diff options
248 files changed, 2741 insertions, 970 deletions
diff --git a/Makefile.common b/Makefile.common index caf1821ce5..1f59bff183 100644 --- a/Makefile.common +++ b/Makefile.common @@ -122,7 +122,7 @@ LIBCOQRUN:=kernel/byterun/lib$(COQRUN).a DLLCOQRUN:=$(dir $(LIBCOQRUN))dll$(COQRUN)$(DLLEXT) BYTERUN:=$(addprefix kernel/byterun/, \ - coq_fix_code.o coq_memory.o coq_values.o coq_interp.o ) + coq_fix_code.o coq_float64.o coq_memory.o coq_values.o coq_interp.o ) # LINK ORDER: # respecting this order is useful for developers that want to load or link diff --git a/checker/checkInductive.ml b/checker/checkInductive.ml index 7bb714aa17..7513564cf0 100644 --- a/checker/checkInductive.ml +++ b/checker/checkInductive.ml @@ -69,6 +69,7 @@ let to_entry (mb:mutual_inductive_body) : Entries.mutual_inductive_entry = in let mind_entry_template = Array.exists check_template mb.mind_packets in let () = if mind_entry_template then assert (Array.for_all check_template mb.mind_packets) in + let mind_entry_variance = Option.map (Array.map (fun v -> Some v)) mb.mind_variance in { mind_entry_record; mind_entry_finite = mb.mind_finite; @@ -76,7 +77,7 @@ let to_entry (mb:mutual_inductive_body) : Entries.mutual_inductive_entry = mind_entry_inds; mind_entry_universes; mind_entry_template; - mind_entry_cumulative= Option.has_some mb.mind_variance; + mind_entry_variance; mind_entry_private = mb.mind_private; } diff --git a/checker/checker.ml b/checker/checker.ml index e2c90e2b93..08d92bb7b3 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -298,7 +298,9 @@ let explain_exn = function | DisallowedSProp -> str"DisallowedSProp" | BadRelevance -> str"BadRelevance" | BadInvert -> str"BadInvert" - | UndeclaredUniverse _ -> str"UndeclaredUniverse")) + | UndeclaredUniverse _ -> str"UndeclaredUniverse" + | BadVariance _ -> str "BadVariance" + )) | InductiveError e -> hov 0 (str "Error related to inductive types") diff --git a/clib/cArray.ml b/clib/cArray.ml index 7249bcada0..95ae48a7ba 100644 --- a/clib/cArray.ml +++ b/clib/cArray.ml @@ -56,6 +56,7 @@ sig (int -> 'a -> 'b -> 'c -> 'd) -> 'a array -> 'b array -> 'c array -> 'd array val map_left : ('a -> 'b) -> 'a array -> 'b array val iter2_i : (int -> 'a -> 'b -> unit) -> 'a array -> 'b array -> unit + val iter3 : ('a -> 'b -> 'c -> unit) -> 'a array -> 'b array -> 'c array -> unit val fold_left_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array val fold_right_map : ('a -> 'c -> 'b * 'c) -> 'a array -> 'c -> 'b array * 'c val fold_left2_map : ('a -> 'b -> 'c -> 'a * 'd) -> 'a -> 'b array -> 'c array -> 'a * 'd array @@ -392,6 +393,13 @@ let iter2_i f v1 v2 = let () = if not (Int.equal len2 len1) then invalid_arg "Array.iter2" in for i = 0 to len1 - 1 do f i (uget v1 i) (uget v2 i) done +let iter3 f v1 v2 v3 = + let len1 = Array.length v1 in + let len2 = Array.length v2 in + let len3 = Array.length v3 in + let () = if not (Int.equal len2 len1) || not (Int.equal len1 len3) then invalid_arg "Array.iter3" in + for i = 0 to len1 - 1 do f (uget v1 i) (uget v2 i) (uget v3 i) done + let map_right f a = let l = length a in if l = 0 then [||] else begin diff --git a/clib/cArray.mli b/clib/cArray.mli index f40ceb56db..664bad4c0a 100644 --- a/clib/cArray.mli +++ b/clib/cArray.mli @@ -92,6 +92,9 @@ sig val iter2_i : (int -> 'a -> 'b -> unit) -> 'a array -> 'b array -> unit (** Iter on two arrays. Raise [Invalid_argument "Array.iter2_i"] if sizes differ. *) + val iter3 : ('a -> 'b -> 'c -> unit) -> 'a array -> 'b array -> 'c array -> unit + (** Iter on three arrays. Raise [Invalid_argument "Array.iter3"] if sizes differ. *) + val fold_left_map : ('a -> 'b -> 'a * 'c) -> 'a -> 'b array -> 'a * 'c array (** [fold_left_map f e_0 [|l_1...l_n|] = e_n,[|k_1...k_n|]] where [(e_i,k_i)=f e_{i-1} l_i]; see also [Smart.fold_left_map] *) diff --git a/configure.ml b/configure.ml index 7fd1acb53e..6a4b1f9a75 100644 --- a/configure.ml +++ b/configure.ml @@ -692,10 +692,13 @@ let operating_system = let check_for_zarith () = let zarith,_ = tryrun camlexec.find ["query";"zarith"] in + let zarith_cmai base = Sys.file_exists (base / "z.cmi") && Sys.file_exists (base / "zarith.cma") in let zarith_version, _ = run camlexec.find ["query"; "zarith"; "-format"; "%v"] in match zarith with | "" -> die "Zarith library not installed, required" + | _ when not (zarith_cmai zarith) -> + die "Zarith library installed but no development files found (try installing the -dev package)" | _ -> let zarith_version_int = List.map int_of_string (numeric_prefix_list zarith_version) in if zarith_version_int >= [1;10;0] then diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index fc8921e63d..6f6b3cd6d2 100755 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -404,8 +404,7 @@ function build_prep { # ------------------------------------------------------------------------------ # Like build_prep, but gets the data from an entry in ci-basic-overlay.sh -# This assumes the following definitions exist in ci-basic-overlay.sh, -# or in a file in the user-overlays folder: +# This assumes the following definitions exist in ci-basic-overlay.sh # $1_CI_REF # $1_CI_ARCHIVEURL # $1_CI_GITURL @@ -432,7 +431,7 @@ function build_prep_overlay { } # ------------------------------------------------------------------------------ -# Load overlay version variables from ci-basic-overlay.sh and user-overlays/*.sh +# Load overlay version variables from ci-basic-overlay.sh # ------------------------------------------------------------------------------ function load_overlay_data { @@ -448,9 +447,6 @@ function load_overlay_data { export CI_PULL_REQUEST="" fi - for overlay in /build/user-overlays/*.sh; do - . "$overlay" - done . /build/ci-basic-overlay.sh } @@ -1441,7 +1437,6 @@ function make_coq { # Copy these files somewhere the plugin builds can find them logn copy-basic-overlays cp dev/ci/ci-basic-overlay.sh /build/ - logn copy-user-overlays cp -r dev/ci/user-overlays /build/ build_post fi diff --git a/dev/ci/ci-perennial.sh b/dev/ci/ci-perennial.sh index f3be66e814..306cbdf63c 100755 --- a/dev/ci/ci-perennial.sh +++ b/dev/ci/ci-perennial.sh @@ -6,7 +6,4 @@ ci_dir="$(dirname "$0")" FORCE_GIT=1 git_download perennial -# required by Perennial's coqc.py build wrapper -export LC_ALL=C.UTF-8 - -( cd "${CI_BUILD_DIR}/perennial" && git submodule update --init --recursive && make TIMED=false ) +( cd "${CI_BUILD_DIR}/perennial" && git submodule update --init --recursive && make TIMED=false lite ) diff --git a/dev/ci/user-overlays/12653-SkySkimmer-cumul-syntax.sh b/dev/ci/user-overlays/12653-SkySkimmer-cumul-syntax.sh new file mode 100644 index 0000000000..1473f6df8b --- /dev/null +++ b/dev/ci/user-overlays/12653-SkySkimmer-cumul-syntax.sh @@ -0,0 +1,15 @@ +if [ "$CI_PULL_REQUEST" = "12653" ] || [ "$CI_BRANCH" = "cumul-syntax" ]; then + + overlay elpi https://github.com/SkySkimmer/coq-elpi cumul-syntax + + overlay equations https://github.com/SkySkimmer/Coq-Equations cumul-syntax + + overlay mtac2 https://github.com/SkySkimmer/Mtac2 cumul-syntax + + overlay paramcoq https://github.com/SkySkimmer/paramcoq cumul-syntax + + overlay rewriter https://github.com/SkySkimmer/rewriter cumul-syntax + + overlay metacoq https://github.com/SkySkimmer/metacoq cumul-syntax + +fi diff --git a/dev/ci/user-overlays/12873-master+minifix-unification-error-reporting-recheck-applications.sh b/dev/ci/user-overlays/12873-master+minifix-unification-error-reporting-recheck-applications.sh new file mode 100644 index 0000000000..7680e8da78 --- /dev/null +++ b/dev/ci/user-overlays/12873-master+minifix-unification-error-reporting-recheck-applications.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "12873" ] || [ "$CI_BRANCH" = "master+minifix-unification-error-reporting-recheck-applications" ]; then + + equations_CI_REF=master+fix12873-better-unification + equations_CI_GITURL=https://github.com/herbelin/Coq-Equations + +fi diff --git a/dev/ci/user-overlays/13312-ejgallego-attributes+bool_single.sh b/dev/ci/user-overlays/13312-ejgallego-attributes+bool_single.sh new file mode 100644 index 0000000000..3bdbcf7d6e --- /dev/null +++ b/dev/ci/user-overlays/13312-ejgallego-attributes+bool_single.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "13312" ] || [ "$CI_BRANCH" = "attributes+bool_single" ]; then + + overlay unicoq https://github.com/ejgallego/unicoq attributes+bool_single + overlay elpi https://github.com/ejgallego/coq-elpi attributes+bool_single + +fi diff --git a/dev/ci/user-overlays/13386-master+fix9971-primproj-canonical-structure-on-evar-type.sh b/dev/ci/user-overlays/13386-master+fix9971-primproj-canonical-structure-on-evar-type.sh new file mode 100644 index 0000000000..95f0de2bd3 --- /dev/null +++ b/dev/ci/user-overlays/13386-master+fix9971-primproj-canonical-structure-on-evar-type.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "13386" ] || [ "$CI_BRANCH" = "master+fix9971-primproj-canonical-structure-on-evar-type" ]; then + + unicoq_CI_REF=master+adapting-coq-pr13386 + unicoq_CI_GITURL=https://github.com/herbelin/unicoq + + elpi_CI_REF=coq-master+adapting-coq-pr13386 + elpi_CI_GITURL=https://github.com/herbelin/coq-elpi + +fi diff --git a/doc/changelog/02-specification-language/12653-cumul-syntax.rst b/doc/changelog/02-specification-language/12653-cumul-syntax.rst new file mode 100644 index 0000000000..ba97f7c796 --- /dev/null +++ b/doc/changelog/02-specification-language/12653-cumul-syntax.rst @@ -0,0 +1,5 @@ +- **Added:** Commands :cmd:`Inductive`, :cmd:`Record` and synonyms now + support syntax `Inductive foo@{=i +j *k l}` to specify variance + information for their universes (in :ref:`Cumulative <cumulative>` + mode) (`#12653 <https://github.com/coq/coq/pull/12653>`_, by Gaëtan + Gilbert). diff --git a/doc/changelog/02-specification-language/13312-attributes+bool_single.rst b/doc/changelog/02-specification-language/13312-attributes+bool_single.rst new file mode 100644 index 0000000000..f069bc616b --- /dev/null +++ b/doc/changelog/02-specification-language/13312-attributes+bool_single.rst @@ -0,0 +1,17 @@ +- **Changed:** + :term:`Boolean attributes <boolean attribute>` are now specified using + key/value pairs, that is to say :n:`@ident__attr{? = {| yes | no } }`. + If the value is missing, the default is :n:`yes`. The old syntax is still + supported, but produces the ``deprecated-attribute-syntax`` warning. + + Deprecated attributes are :attr:`universes(monomorphic)`, + :attr:`universes(notemplate)` and :attr:`universes(noncumulative)`, which are + respectively replaced by :attr:`universes(polymorphic=no) <universes(polymorphic)>`, + :attr:`universes(template=no) <universes(template)>` + and :attr:`universes(cumulative=no) <universes(cumulative)>`. + Attributes :attr:`program` and :attr:`canonical` are also affected, + with the syntax :n:`@ident__attr(false)` being deprecated in favor of + :n:`@ident__attr=no`. + + (`#13312 <https://github.com/coq/coq/pull/13312>`_, + by Emilio Jesus Gallego Arias). diff --git a/doc/changelog/02-specification-language/13386-master+fix9971-primproj-canonical-structure-on-evar-type.rst b/doc/changelog/02-specification-language/13386-master+fix9971-primproj-canonical-structure-on-evar-type.rst new file mode 100644 index 0000000000..4bd214d7be --- /dev/null +++ b/doc/changelog/02-specification-language/13386-master+fix9971-primproj-canonical-structure-on-evar-type.rst @@ -0,0 +1,6 @@ +- **Fixed:** + issue when two expressions involving different projections and one is + primitive need to be unified + (`#13386 <https://github.com/coq/coq/pull/13386>`_, + fixes `#9971 <https://github.com/coq/coq/issues/9971>`_, + by Hugo Herbelin). diff --git a/doc/changelog/03-notations/12765-master+partial-app-in-recursive-notation.rst b/doc/changelog/03-notations/12765-master+partial-app-in-recursive-notation.rst new file mode 100644 index 0000000000..82cbefc60b --- /dev/null +++ b/doc/changelog/03-notations/12765-master+partial-app-in-recursive-notation.rst @@ -0,0 +1,4 @@ +- **Added:** + Added support for encoding notations of the form :g:`x ⪯ y ⪯ .. ⪯ z ⪯ t` + (`#12765 <https://github.com/coq/coq/pull/12765>`_, + by Hugo Herbelin). diff --git a/doc/changelog/03-notations/12984-master+import-notation-make-active-again.rst b/doc/changelog/03-notations/12984-master+import-notation-make-active-again.rst new file mode 100644 index 0000000000..d472e6fdf0 --- /dev/null +++ b/doc/changelog/03-notations/12984-master+import-notation-make-active-again.rst @@ -0,0 +1,12 @@ +- **Changed:** + Redeclaring a notation reactivates also its printing rule; in + particular a second :cmd:`Import` of the same module reactivates the + printing rules declared in this module. In theory, this leads to + changes of behavior for printing. However, this is mitigated in + general by the adoption in `#12986 + <https://github.com/coq/coq/pull/12986>`_ of a priority given to + notations which match a larger part of the term to print + (`#12984 <https://github.com/coq/coq/pull/12984>`_, + fixes `#7443 <https://github.com/coq/coq/issues/7443>`_ + and `#10824 <https://github.com/coq/coq/issues/10824>`_, + by Hugo Herbelin). diff --git a/doc/changelog/03-notations/12986-master+ordering-notation-by-precision.rst b/doc/changelog/03-notations/12986-master+ordering-notation-by-precision.rst new file mode 100644 index 0000000000..8b233972bf --- /dev/null +++ b/doc/changelog/03-notations/12986-master+ordering-notation-by-precision.rst @@ -0,0 +1,5 @@ +- **Changed:** + Use of notations for printing now gives preference + to notations which match a larger part of the term to abbreviate + (`#12986 <https://github.com/coq/coq/pull/12986>`_, + by Hugo Herbelin). diff --git a/doc/changelog/04-tactics/13237-master+fix13235-no-degenerate-in-hyps-clause.rst b/doc/changelog/04-tactics/13237-master+fix13235-no-degenerate-in-hyps-clause.rst new file mode 100644 index 0000000000..bc67fd025a --- /dev/null +++ b/doc/changelog/04-tactics/13237-master+fix13235-no-degenerate-in-hyps-clause.rst @@ -0,0 +1,6 @@ +- **Changed:** + Giving an empty list of occurrences after :n:`in` in tactics is no + longer permitted. Omitting the :n:`in` gives the same behavior + (`#13237 <https://github.com/coq/coq/pull/13236>`_, + fixes `#13235 <https://github.com/coq/coq/issues/13235>`_, + by Hugo Herbelin). diff --git a/doc/changelog/04-tactics/13381-bfs_eauto.rst b/doc/changelog/04-tactics/13381-bfs_eauto.rst index a51f96d0a2..f37fbfe52b 100644 --- a/doc/changelog/04-tactics/13381-bfs_eauto.rst +++ b/doc/changelog/04-tactics/13381-bfs_eauto.rst @@ -1,6 +1,6 @@ - **Deprecated:** Undocumented :n:`eauto @int_or_var @int_or_var` syntax in favor of new ``bfs eauto``. - Also deprecated 2-integer syntax for ``debug eauto`` and ``info_eauto``; - replacement TBD. + Also deprecated 2-integer syntax for ``debug eauto`` and ``info_eauto``. + (Use ``bfs eauto`` with the :flag:`Info Eauto` or :flag:`Debug Eauto` flags instead.) (`#13381 <https://github.com/coq/coq/pull/13381>`_, by Jim Fehrle). diff --git a/doc/changelog/04-tactics/13403-occs_nums_nat.rst b/doc/changelog/04-tactics/13403-occs_nums_nat.rst new file mode 100644 index 0000000000..5dfa90a267 --- /dev/null +++ b/doc/changelog/04-tactics/13403-occs_nums_nat.rst @@ -0,0 +1,7 @@ +- **Removed:** + :n:`at @occs_nums` clauses in tactics such as tacn:`unfold` + no longer allow negative values. A "-" before the + list (for set complement) is still supported. Ex: "at -1 -2" + is no longer supported but "at -1 2" is. + (`#13403 <https://github.com/coq/coq/pull/13403>`_, + by Jim Fehrle). diff --git a/doc/changelog/07-commands-and-options/13040-gc+best_fit.rst b/doc/changelog/07-commands-and-options/13040-gc+best_fit.rst new file mode 100644 index 0000000000..74818f8464 --- /dev/null +++ b/doc/changelog/07-commands-and-options/13040-gc+best_fit.rst @@ -0,0 +1,9 @@ +- **Changed:** + When compiled with OCaml >= 4.10.0, Coq will use the new best-fit GC + policy, which should provide some performance benefits. Coq's policy + is optimized for speed, but could increase memory consumption in + some cases. You are welcome to tune it using the ``OCAMLRUNPARAM`` + variable and report back setting so we could optimize more. + (`#13040 <https://github.com/coq/coq/pull/13040>`_, + fixes `#11277 <https://github.com/coq/coq/issues/11277>`_, + by Emilio Jesus Gallego Arias). diff --git a/doc/changelog/07-commands-and-options/13384-warn-unqualified-hint.rst b/doc/changelog/07-commands-and-options/13384-warn-unqualified-hint.rst new file mode 100644 index 0000000000..8ec7198b72 --- /dev/null +++ b/doc/changelog/07-commands-and-options/13384-warn-unqualified-hint.rst @@ -0,0 +1,8 @@ +- **Deprecated:** + The default value for hint locality is currently :attr:`local` in a section and + :attr:`global` otherwise, but is scheduled to change in a future release. For the + time being, adding hints outside of sections without specifying an explicit + locality is therefore triggering a deprecation warning. It is recommended to + use :attr:`export` whenever possible + (`#13384 <https://github.com/coq/coq/pull/13384>`_, + by Pierre-Marie Pédrot). diff --git a/doc/sphinx/addendum/program.rst b/doc/sphinx/addendum/program.rst index 298ea4b4ab..104f84a253 100644 --- a/doc/sphinx/addendum/program.rst +++ b/doc/sphinx/addendum/program.rst @@ -99,15 +99,15 @@ coercions. Enables the program mode, in which 1) typechecking allows subset coercions and 2) the elaboration of pattern matching of :cmd:`Fixpoint` and - :cmd:`Definition` act as if the :attr:`program` attribute had been + :cmd:`Definition` acts as if the :attr:`program` attribute has been used, generating obligations if there are unresolved holes after typechecking. -.. attr:: program +.. attr:: program{? = {| yes | no } } :name: program; Program - Allows using the Program mode on a specific - definition. An alternative syntax is to use the legacy ``Program`` + This :term:`boolean attribute` allows using or disabling the Program mode on a specific + definition. An alternative and commonly used syntax is to use the legacy ``Program`` prefix (cf. :n:`@legacy_attr`) as it is elsewhere in this chapter. .. _syntactic_control: diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index 2474c784b8..22527dc379 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -320,10 +320,9 @@ Summary of the commands maintained. Like any command declaring a record, this command supports the - :attr:`universes(polymorphic)`, :attr:`universes(monomorphic)`, - :attr:`universes(template)`, :attr:`universes(notemplate)`, - :attr:`universes(cumulative)`, :attr:`universes(noncumulative)` and - :attr:`private(matching)` attributes. + :attr:`universes(polymorphic)`, :attr:`universes(template)`, + :attr:`universes(cumulative)`, and :attr:`private(matching)` + attributes. .. cmd:: Existing Class @qualid diff --git a/doc/sphinx/addendum/universe-polymorphism.rst b/doc/sphinx/addendum/universe-polymorphism.rst index 1fb337b30a..4615a8dfca 100644 --- a/doc/sphinx/addendum/universe-polymorphism.rst +++ b/doc/sphinx/addendum/universe-polymorphism.rst @@ -122,33 +122,37 @@ in a universe strictly higher than :g:`Set`. Polymorphic, Monomorphic ------------------------- -.. attr:: universes(polymorphic) - :name: universes(polymorphic); Polymorphic +.. attr:: universes(polymorphic{? = {| yes | no } }) + :name: universes(polymorphic); Polymorphic; Monomorphic + + This :term:`boolean attribute` can be used to control whether universe + polymorphism is enabled in the definition of an inductive type. + There is also a legacy syntax using the ``Polymorphic`` prefix (see + :n:`@legacy_attr`) which, as shown in the examples, is more + commonly used. + + When ``universes(polymorphic=no)`` is used, global universe constraints + are produced, even when the :flag:`Universe Polymorphism` flag is + on. There is also a legacy syntax using the ``Monomorphic`` prefix + (see :n:`@legacy_attr`). - This attribute can be used to declare universe polymorphic - definitions and inductive types. There is also a legacy syntax - using the ``Polymorphic`` prefix (see :n:`@legacy_attr`) which, as - shown in the examples, is more commonly used. +.. attr:: universes(monomorphic) -.. flag:: Universe Polymorphism + .. deprecated:: 8.13 - This flag is off by default. When it is on, new declarations are - polymorphic unless the :attr:`universes(monomorphic)` attribute is - used. + Use :attr:`universes(polymorphic=no) <universes(polymorphic)>` + instead. -.. attr:: universes(monomorphic) - :name: universes(monomorphic); Monomorphic +.. flag:: Universe Polymorphism - This attribute can be used to declare universe monomorphic - definitions and inductive types (i.e. global universe constraints - are produced), even when the :flag:`Universe Polymorphism` flag is - on. There is also a legacy syntax using the ``Monomorphic`` prefix - (see :n:`@legacy_attr`). + This flag is off by default. When it is on, new declarations are + polymorphic unless the :attr:`universes(polymorphic=no) <universes(polymorphic)>` + attribute is used to override the default. Many other commands can be used to declare universe polymorphic or monomorphic constants depending on whether the :flag:`Universe -Polymorphism` flag is on or the :attr:`universes(polymorphic)` or -:attr:`universes(monomorphic)` attributes are used: +Polymorphism` flag is on or the :attr:`universes(polymorphic)` +attribute is used: - :cmd:`Lemma`, :cmd:`Axiom`, etc. can be used to declare universe polymorphic constants. @@ -171,19 +175,27 @@ Polymorphism` flag is on or the :attr:`universes(polymorphic)` or Cumulative, NonCumulative ------------------------- -.. attr:: universes(cumulative) - :name: universes(cumulative); Cumulative +.. attr:: universes(cumulative{? = {| yes | no } }) + :name: universes(cumulative); Cumulative; NonCumulative Polymorphic inductive types, coinductive types, variants and - records can be declared cumulative using this attribute or the - legacy ``Cumulative`` prefix (see :n:`@legacy_attr`) which, as + records can be declared cumulative using this :term:`boolean attribute` + or the legacy ``Cumulative`` prefix (see :n:`@legacy_attr`) which, as shown in the examples, is more commonly used. This means that two instances of the same inductive type (family) are convertible based on the universe variances; they do not need to be equal. - .. exn:: The cumulative and noncumulative attributes can only be used in a polymorphic context. + When the attribtue is off, the inductive type is non-cumulative + even if the :flag:`Polymorphic Inductive Cumulativity` flag is on. + There is also a legacy syntax using the ``NonCumulative`` prefix + (see :n:`@legacy_attr`). + + This means that two instances of the same inductive type (family) + are convertible only if all the universes are equal. + + .. exn:: The cumulative attribute can only be used in a polymorphic context. Using this attribute requires being in a polymorphic context, i.e. either having the :flag:`Universe Polymorphism` flag on, or @@ -192,26 +204,21 @@ Cumulative, NonCumulative .. note:: - ``#[ universes(polymorphic), universes(cumulative) ]`` can be - abbreviated into ``#[ universes(polymorphic, cumulative) ]``. + :n:`#[ universes(polymorphic{? = yes }), universes(cumulative{? = {| yes | no } }) ]` can be + abbreviated into :n:`#[ universes(polymorphic{? = yes }, cumulative{? = {| yes | no } }) ]`. -.. flag:: Polymorphic Inductive Cumulativity +.. attr:: universes(noncumulative) - When this flag is on (it is off by default), it makes all - subsequent *polymorphic* inductive definitions cumulative, unless - the :attr:`universes(noncumulative)` attribute is used. It has no - effect on *monomorphic* inductive definitions. + .. deprecated:: 8.13 -.. attr:: universes(noncumulative) - :name: universes(noncumulative); NonCumulative + Use :attr:`universes(cumulative=no) <universes(cumulative)>` instead. - Declares the inductive type as non-cumulative even if the - :flag:`Polymorphic Inductive Cumulativity` flag is on. There is - also a legacy syntax using the ``NonCumulative`` prefix (see - :n:`@legacy_attr`). +.. flag:: Polymorphic Inductive Cumulativity - This means that two instances of the same inductive type (family) - are convertible only if all the universes are equal. + When this flag is on (it is off by default), it makes all + subsequent *polymorphic* inductive definitions cumulative, unless + the :attr:`universes(cumulative=no) <universes(cumulative)>` attribute is + used to override the default. It has no effect on *monomorphic* inductive definitions. Consider the examples below. @@ -246,6 +253,7 @@ The following is an example of a record with non-trivial subtyping relation: .. coqtop:: all Polymorphic Cumulative Record packType := {pk : Type}. + About packType. :g:`packType` binds a covariant universe, i.e. @@ -254,6 +262,27 @@ The following is an example of a record with non-trivial subtyping relation: E[Γ] ⊢ \mathsf{packType}@\{i\} =_{βδιζη} \mathsf{packType}@\{j\}~\mbox{ whenever }~i ≤ j +Specifying cumulativity +~~~~~~~~~~~~~~~~~~~~~~~ + +The variance of the universe parameters for a cumulative inductive may be specified by the user. + +For the following type, universe ``a`` has its variance automatically +inferred (it is irrelevant), ``b`` is required to be irrelevant, +``c`` is covariant and ``d`` is invariant. With these annotations +``c`` and ``d`` have less general variances than would be inferred. + +.. coqtop:: all + + Polymorphic Cumulative Inductive Dummy@{a *b +c =d} : Prop := dummy. + About Dummy. + +Insufficiently restrictive variance annotations lead to errors: + +.. coqtop:: all + + Fail Polymorphic Cumulative Record bad@{*a} := {p : Type@{a}}. + An example of a proof using cumulativity ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -280,7 +309,7 @@ An example of a proof using cumulativity End down. Cumulativity Weak Constraints ------------------------------ +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ .. flag:: Cumulativity Weak Constraints @@ -383,6 +412,7 @@ Explicit Universes | _ | @qualid univ_decl ::= @%{ {* @ident } {? + } {? %| {*, @univ_constraint } {? + } } %} + cumul_univ_decl ::= @%{ {* {? {| = | + | * } } @ident } {? + } {? %| {*, @univ_constraint } {? + } } %} univ_constraint ::= @universe_name {| < | = | <= } @universe_name The syntax has been extended to allow users to explicitly bind names diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index de5dbe79cc..24fa71059c 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -147,7 +147,7 @@ Specification language, type inference This makes typeclasses with declared modes more robust with respect to the order of resolution. (`#10858 <https://github.com/coq/coq/pull/10858>`_, - fixes `#9058 <https://github.com/coq/coq/issues/9058>_`, by Matthieu Sozeau). + fixes `#9058 <https://github.com/coq/coq/issues/9058>`_, by Matthieu Sozeau). - **Added:** Warn when manual implicit arguments are used in unexpected positions of a term (e.g. in `Check id (forall {x}, x)`) or when an implicit @@ -533,8 +533,8 @@ Flags, options and attributes - **Removed:** Unqualified ``polymorphic``, ``monomorphic``, ``template``, ``notemplate`` attributes (they were deprecated since Coq 8.10). - Use :attr:`universes(polymorphic)`, :attr:`universes(monomorphic)`, - :attr:`universes(template)` and :attr:`universes(notemplate)` instead + Use :attr:`universes(polymorphic)`, ``universes(monomorphic)``, + :attr:`universes(template)` and ``universes(notemplate)`` instead (`#11663 <https://github.com/coq/coq/pull/11663>`_, by Théo Zimmermann). - **Deprecated:** :flag:`Hide Obligations` flag @@ -545,7 +545,7 @@ Flags, options and attributes <https://github.com/coq/coq/pull/11162>`_, by Enrico Tassi). - **Added:** New attributes supported when defining an inductive type - :attr:`universes(cumulative)`, :attr:`universes(noncumulative)` and + :attr:`universes(cumulative)`, ``universes(noncumulative)`` and :attr:`private(matching)`, which correspond to legacy attributes ``Cumulative``, ``NonCumulative``, and the previously undocumented ``Private`` (`#11665 <https://github.com/coq/coq/pull/11665>`_, by diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py index 75ac2a76cd..af5d1e3a00 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -221,7 +221,8 @@ html_context = { 'versions': [ ("dev", "https://coq.github.io/doc/master/refman/"), ("stable", "https://coq.inria.fr/distrib/current/refman/"), - ("v8.12", "https://coq.github.io/doc/v8.12/refman/"), + ("v8.13", "https://coq.github.io/doc/v8.13/refman/"), + ("8.12", "https://coq.inria.fr/distrib/V8.12.1/refman/"), ("8.11", "https://coq.inria.fr/distrib/V8.11.2/refman/"), ("8.10", "https://coq.inria.fr/distrib/V8.10.2/refman/"), ("8.9", "https://coq.inria.fr/distrib/V8.9.1/refman/"), diff --git a/doc/sphinx/language/core/basic.rst b/doc/sphinx/language/core/basic.rst index 5406da38a1..2b262b89c0 100644 --- a/doc/sphinx/language/core/basic.rst +++ b/doc/sphinx/language/core/basic.rst @@ -369,6 +369,7 @@ this attribute`. attributes ::= {* #[ {*, @attribute } ] } {* @legacy_attr } attribute ::= @ident {? @attr_value } attr_value ::= = @string + | = @ident | ( {*, @attribute } ) legacy_attr ::= {| Local | Global } | {| Polymorphic | Monomorphic } @@ -379,21 +380,22 @@ this attribute`. The order of top-level attributes doesn't affect their meaning. ``#[foo,bar]``, ``#[bar,foo]``, ``#[foo]#[bar]`` and ``#[bar]#[foo]`` are equivalent. +:gdef:`Boolean attributes <boolean attribute>` take the form :n:`@ident__attr{? = {| yes | no } }`. +When the :n:`{| yes | no }` value is omitted, the default is :n:`yes`. + The legacy attributes (:n:`@legacy_attr`) provide an older, alternate syntax for certain attributes. They are equivalent to new attributes as follows: -================ ================================ -Legacy attribute New attribute -================ ================================ -`Local` :attr:`local` -`Global` :attr:`global` -`Polymorphic` :attr:`universes(polymorphic)` -`Monomorphic` :attr:`universes(monomorphic)` -`Cumulative` :attr:`universes(cumulative)` -`NonCumulative` :attr:`universes(noncumulative)` -`Private` :attr:`private(matching)` -`Program` :attr:`program` -================ ================================ +============================= ================================ +Legacy attribute New attribute +============================= ================================ +`Local` :attr:`local` +`Global` :attr:`global` +`Polymorphic`, `Monomorphic` :attr:`universes(polymorphic)` +`Cumulative`, `NonCumulative` :attr:`universes(cumulative)` +`Private` :attr:`private(matching)` +`Program` :attr:`program` +============================= ================================ Attributes appear in the HTML documentation in blue or gray boxes after the label "Attribute". In the pdf, they appear after the diff --git a/doc/sphinx/language/core/coinductive.rst b/doc/sphinx/language/core/coinductive.rst index 3e2ecdc0f0..43bbc8b40d 100644 --- a/doc/sphinx/language/core/coinductive.rst +++ b/doc/sphinx/language/core/coinductive.rst @@ -26,10 +26,8 @@ More information on co-inductive definitions can be found in For co-inductive types, the only elimination principle is case analysis. This command supports the :attr:`universes(polymorphic)`, - :attr:`universes(monomorphic)`, :attr:`universes(template)`, - :attr:`universes(notemplate)`, :attr:`universes(cumulative)`, - :attr:`universes(noncumulative)`, :attr:`private(matching)` - and :attr:`using` attributes. + :attr:`universes(template)`, :attr:`universes(cumulative)`, + :attr:`private(matching)`, and :attr:`using` attributes. .. example:: diff --git a/doc/sphinx/language/core/definitions.rst b/doc/sphinx/language/core/definitions.rst index 79489c85f6..57771c9036 100644 --- a/doc/sphinx/language/core/definitions.rst +++ b/doc/sphinx/language/core/definitions.rst @@ -90,7 +90,7 @@ Section :ref:`typing-rules`. computation on :n:`@term`. These commands also support the :attr:`universes(polymorphic)`, - :attr:`universes(monomorphic)`, :attr:`program` (see :ref:`program_definition`), + :attr:`program` (see :ref:`program_definition`), :attr:`canonical` and :attr:`using` attributes. If :n:`@term` is omitted, :n:`@type` is required and Coq enters proof editing mode. diff --git a/doc/sphinx/language/core/inductive.rst b/doc/sphinx/language/core/inductive.rst index d3bd787587..251b5e4955 100644 --- a/doc/sphinx/language/core/inductive.rst +++ b/doc/sphinx/language/core/inductive.rst @@ -8,13 +8,14 @@ Inductive types .. cmd:: Inductive @inductive_definition {* with @inductive_definition } - .. insertprodn inductive_definition constructor + .. insertprodn inductive_definition cumul_ident_decl .. prodn:: - inductive_definition ::= {? > } @ident_decl {* @binder } {? %| {* @binder } } {? : @type } {? := {? @constructors_or_record } } {? @decl_notations } + inductive_definition ::= {? > } @cumul_ident_decl {* @binder } {? %| {* @binder } } {? : @type } {? := {? @constructors_or_record } } {? @decl_notations } constructors_or_record ::= {? %| } {+| @constructor } | {? @ident } %{ {*; @record_field } {? ; } %} constructor ::= @ident {* @binder } {? @of_type } + cumul_ident_decl ::= @ident {? @cumul_univ_decl } This command defines one or more inductive types and its constructors. Coq generates destructors @@ -31,10 +32,8 @@ Inductive types proposition). This command supports the :attr:`universes(polymorphic)`, - :attr:`universes(monomorphic)`, :attr:`universes(template)`, - :attr:`universes(notemplate)`, :attr:`universes(cumulative)`, - :attr:`universes(noncumulative)` and :attr:`private(matching)` - attributes. + :attr:`universes(template)`, :attr:`universes(cumulative)`, and + :attr:`private(matching)` attributes. Mutually inductive types can be defined by including multiple :n:`@inductive_definition`\s. The :n:`@ident`\s are simultaneously added to the environment before the types of constructors are checked. @@ -1057,7 +1056,7 @@ Conversion is preserved as any (partial) instance :math:`I_j~q_1 … q_r` or at level :math:`\Type` (without annotations or hiding it behind a definition) template polymorphic if possible. - This can be prevented using the :attr:`universes(notemplate)` + This can be prevented using the :attr:`universes(template=no) <universes(template)>` attribute. Template polymorphism and full universe polymorphism (see Chapter @@ -1076,11 +1075,12 @@ Conversion is preserved as any (partial) instance :math:`I_j~q_1 … q_r` or the :attr:`universes(template)` attribute: in this case, the warning is not emitted. -.. attr:: universes(template) +.. attr:: universes(template{? = {| yes | no } }) + :name: universes(template) - This attribute can be used to explicitly declare an inductive type - as template polymorphic, whether the :flag:`Auto Template - Polymorphism` flag is on or off. + This :term:`boolean attribute` can be used to explicitly declare an + inductive type as template polymorphic, whether the :flag:`Auto + Template Polymorphism` flag is on or off. .. exn:: template and polymorphism not compatible @@ -1093,11 +1093,15 @@ Conversion is preserved as any (partial) instance :math:`I_j~q_1 … q_r` or The attribute was used but the inductive definition does not satisfy the criterion to be template polymorphic. + When ``universes(template=no)`` is used, it will prevent an + inductive type to be template polymorphic, even if the :flag:`Auto + Template Polymorphism` flag is on. + .. attr:: universes(notemplate) - This attribute can be used to prevent an inductive type to be - template polymorphic, even if the :flag:`Auto Template - Polymorphism` flag is on. + .. deprecated:: 8.13 + + Use :attr:`universes(template=no) <universes(template)>` instead. In practice, the rule **Ind-Family** is used by Coq only when all the inductive types of the inductive definition are declared with an arity diff --git a/doc/sphinx/language/core/records.rst b/doc/sphinx/language/core/records.rst index e6df3ee9f5..7eedbcd59a 100644 --- a/doc/sphinx/language/core/records.rst +++ b/doc/sphinx/language/core/records.rst @@ -53,10 +53,8 @@ expressions. In this sense, the :cmd:`Record` construction allows defining :cmd:`Record` and :cmd:`Structure` are synonyms. This command supports the :attr:`universes(polymorphic)`, - :attr:`universes(monomorphic)`, :attr:`universes(template)`, - :attr:`universes(notemplate)`, :attr:`universes(cumulative)`, - :attr:`universes(noncumulative)` and :attr:`private(matching)` - attributes. + :attr:`universes(template)`, :attr:`universes(cumulative)`, and + :attr:`private(matching)` attributes. More generally, a record may have explicitly defined (a.k.a. manifest) fields. For instance, we might have: diff --git a/doc/sphinx/language/core/variants.rst b/doc/sphinx/language/core/variants.rst index 645986be9c..6ac6626dbe 100644 --- a/doc/sphinx/language/core/variants.rst +++ b/doc/sphinx/language/core/variants.rst @@ -17,10 +17,8 @@ Variants this variant, unless the :flag:`Nonrecursive Elimination Schemes` flag is on. This command supports the :attr:`universes(polymorphic)`, - :attr:`universes(monomorphic)`, :attr:`universes(template)`, - :attr:`universes(notemplate)`, :attr:`universes(cumulative)`, - :attr:`universes(noncumulative)` and :attr:`private(matching)` - attributes. + :attr:`universes(template)`, :attr:`universes(cumulative)`, and + :attr:`private(matching)` attributes. .. exn:: The @natural th argument of @ident must be @ident in @type. :undocumented: diff --git a/doc/sphinx/language/extensions/canonical.rst b/doc/sphinx/language/extensions/canonical.rst index 48120503af..f7ce7f1c6c 100644 --- a/doc/sphinx/language/extensions/canonical.rst +++ b/doc/sphinx/language/extensions/canonical.rst @@ -87,29 +87,27 @@ in :ref:`canonicalstructures`; here only a simple example is given. If a same field occurs in several canonical structures, then only the structure declared first as canonical is considered. - .. attr:: canonical(false) +.. attr:: canonical{? = {| yes | no } } + :name: canonical - To prevent a field from being involved in the inference of - canonical instances, its declaration can be annotated with the - :attr:`canonical(false)` attribute (cf. the syntax of - :n:`@record_field`). + This boolean attribute can decorate a :cmd:`Definition` or + :cmd:`Let` command. It is equivalent to having a :cmd:`Canonical + Structure` declaration just after the command. - .. example:: + To prevent a field from being involved in the inference of + canonical instances, its declaration can be annotated with + ``canonical=no`` (cf. the syntax of :n:`@record_field`). - For instance, when declaring the :g:`Setoid` structure above, the - :g:`Prf_equiv` field declaration could be written as follows. - - .. coqdoc:: + .. example:: - #[canonical(false)] Prf_equiv : equivalence Carrier Equal + For instance, when declaring the :g:`Setoid` structure above, the + :g:`Prf_equiv` field declaration could be written as follows. - See :ref:`canonicalstructures` for a more realistic example. + .. coqdoc:: -.. attr:: canonical + #[canonical=no] Prf_equiv : equivalence Carrier Equal - This attribute can decorate a :cmd:`Definition` or :cmd:`Let` command. - It is equivalent to having a :cmd:`Canonical Structure` declaration just - after the command. + See :ref:`hierarchy_of_structures` for a more realistic example. .. cmd:: Print Canonical Projections {* @reference } @@ -248,6 +246,8 @@ for each component of the pair. The declaration associates to the key ``*`` relation ``pair_eq`` whenever the type constructor ``*`` is applied to two types being themselves in the ``EQ`` class. +.. _hierarchy_of_structures: + Hierarchy of structures ---------------------------- @@ -331,7 +331,7 @@ We need to define a new class that inherits from both ``EQ`` and ``LE``. LE_class : LE.class T; extra : mixin (EQ.Pack T EQ_class) (LE.cmp T LE_class) }. - Structure type := _Pack { obj : Type; #[canonical(false)] class_of : class obj }. + Structure type := _Pack { obj : Type; #[canonical=no] class_of : class obj }. Arguments Mixin {e le} _. diff --git a/doc/sphinx/practical-tools/utilities.rst b/doc/sphinx/practical-tools/utilities.rst index ec3689bbbe..5d36ec3cf9 100644 --- a/doc/sphinx/practical-tools/utilities.rst +++ b/doc/sphinx/practical-tools/utilities.rst @@ -92,14 +92,54 @@ CoqMakefile is a makefile for ``GNU Make`` with targets to build the project (e.g. generate .vo or .html files from .v or compile .ml* files) and install it in the ``user-contrib`` directory where the Coq - library is installed. Run ``make`` with the ``-f CoqMakefile`` - option to use ``CoqMakefile``. + library is installed. CoqMakefile.conf contains make variables assignments that reflect the contents of the ``_CoqProject`` file as well as the path relevant to Coq. +The recommended approach is to invoke ``CoqMakefile`` from a standard +``Makefile`` of the following form: + +.. example:: + + :: + + # KNOWNTARGETS will not be passed along to CoqMakefile + KNOWNTARGETS := CoqMakefile extra-stuff extra-stuff2 + # KNOWNFILES will not get implicit targets from the final rule, and so + # depending on them won't invoke the submake + # Warning: These files get declared as PHONY, so any targets depending + # on them always get rebuilt + KNOWNFILES := Makefile _CoqProject + + .DEFAULT_GOAL := invoke-coqmakefile + + CoqMakefile: Makefile _CoqProject + $(COQBIN)coq_makefile -f _CoqProject -o CoqMakefile + + invoke-coqmakefile: CoqMakefile + $(MAKE) --no-print-directory -f CoqMakefile $(filter-out $(KNOWNTARGETS),$(MAKECMDGOALS)) + + .PHONY: invoke-coqmakefile $(KNOWNFILES) + + #################################################################### + ## Your targets here ## + #################################################################### + + # This should be the last rule, to handle any targets not declared above + %: invoke-coqmakefile + @true + +The advantage of a wrapper, compared to directly calling the generated +``Makefile``, is that it +provides a target independent of the version of Coq to regenerate a +``Makefile`` specific to the current version of Coq. Additionally, the +master ``Makefile`` can be extended with targets not specific to Coq. +Including the generated makefile with an include directive is +discouraged, since the contents of this file, including variable names and +status of rules, may change in the future. An optional file ``CoqMakefile.local`` can be provided by the user in order to extend ``CoqMakefile``. In particular one can declare custom actions to be @@ -453,50 +493,6 @@ line timing data: This target requires python to build the table. -Reusing/extending the generated Makefile -++++++++++++++++++++++++++++++++++++++++ - -Including the generated makefile with an include directive is -discouraged. The contents of this file, including variable names and -status of rules shall change in the future. Users are advised to -include ``Makefile.conf`` or call a target of the generated Makefile as in -``make -f Makefile target`` from another Makefile. - -One way to get access to all targets of the generated ``CoqMakefile`` is to -have a generic target for invoking unknown targets. - -.. example:: - - :: - - # KNOWNTARGETS will not be passed along to CoqMakefile - KNOWNTARGETS := CoqMakefile extra-stuff extra-stuff2 - # KNOWNFILES will not get implicit targets from the final rule, and so - # depending on them won't invoke the submake - # Warning: These files get declared as PHONY, so any targets depending - # on them always get rebuilt - KNOWNFILES := Makefile _CoqProject - - .DEFAULT_GOAL := invoke-coqmakefile - - CoqMakefile: Makefile _CoqProject - $(COQBIN)coq_makefile -f _CoqProject -o CoqMakefile - - invoke-coqmakefile: CoqMakefile - $(MAKE) --no-print-directory -f CoqMakefile $(filter-out $(KNOWNTARGETS),$(MAKECMDGOALS)) - - .PHONY: invoke-coqmakefile $(KNOWNFILES) - - #################################################################### - ## Your targets here ## - #################################################################### - - # This should be the last rule, to handle any targets not declared above - %: invoke-coqmakefile - @true - - - Building a subset of the targets with ``-j`` ++++++++++++++++++++++++++++++++++++++++++++ diff --git a/doc/sphinx/proofs/automatic-tactics/auto.rst b/doc/sphinx/proofs/automatic-tactics/auto.rst index 485b92342d..cc4ab76502 100644 --- a/doc/sphinx/proofs/automatic-tactics/auto.rst +++ b/doc/sphinx/proofs/automatic-tactics/auto.rst @@ -123,6 +123,10 @@ Programmable proof search .. example:: + .. coqtop:: none + + Set Warnings "-deprecated-hint-without-locality". + .. coqtop:: all Hint Resolve ex_intro : core. @@ -285,6 +289,13 @@ automatically created. + :attr:`global` hints are made available by merely requiring the current module. + .. deprecated:: 8.13 + + The default value for hint locality is scheduled to change in a future + release. For the time being, adding hints outside of sections without + specifying an explicit locality is therefore triggering a deprecation + warning. It is recommended to use :attr:`export` whenever possible + The various possible :production:`hint_definition`\s are given below. .. cmdv:: Hint @hint_definition @@ -405,6 +416,10 @@ automatically created. .. example:: + .. coqtop:: none + + Set Warnings "-deprecated-hint-without-locality". + .. coqtop:: in Hint Extern 4 (~(_ = _)) => discriminate : core. @@ -419,7 +434,11 @@ automatically created. .. example:: - .. coqtop:: reset all + .. coqtop:: reset none + + Set Warnings "-deprecated-hint-without-locality". + + .. coqtop:: all Require Import List. Hint Extern 5 ({?X1 = ?X2} + {?X1 <> ?X2}) => generalize X1, X2; decide equality : eqdec. diff --git a/doc/sphinx/proofs/writing-proofs/rewriting.rst b/doc/sphinx/proofs/writing-proofs/rewriting.rst index f3f69a2fdc..5283f60b11 100644 --- a/doc/sphinx/proofs/writing-proofs/rewriting.rst +++ b/doc/sphinx/proofs/writing-proofs/rewriting.rst @@ -274,9 +274,13 @@ simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. .. exn:: Too few occurrences. :undocumented: - .. tacv:: change @term {? {? at {+ @natural}} with @term} in @ident + .. tacv:: change @term {? {? at {+ @natural}} with @term} in @goal_occurrences - This applies the :tacn:`change` tactic not to the goal but to the hypothesis :n:`@ident`. + In the presence of :n:`with`, this applies :tacn:`change` to the + occurrences specified by :n:`@goal_occurrences`. In the + absence of :n:`with`, :n:`@goal_occurrences` is expected to + only list hypotheses (and optionally the conclusion) without + specifying occurrences (i.e. no :n:`at` clause). .. tacv:: now_show @term @@ -320,7 +324,7 @@ Performing computations ref_or_pattern_occ ::= @reference {? at @occs_nums } | @one_term {? at @occs_nums } occs_nums ::= {+ {| @natural | @ident } } - | - {| @natural | @ident } {* @int_or_var } + | - {+ {| @natural | @ident } } int_or_var ::= @integer | @ident unfold_occ ::= @reference {? at @occs_nums } diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index f36767b207..16c8586a9f 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -214,7 +214,7 @@ have to be observed for notations starting with a symbol, e.g., rules starting with “\ ``{``\ ” or “\ ``(``\ ” should be put at level 0. The list of Coq predefined notations can be found in the chapter on :ref:`thecoqlibrary`. -Displaying symbolic notations +Use of notations for printing ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The command :cmd:`Notation` has an effect both on the Coq parser and on the @@ -323,6 +323,26 @@ at the time of use of the notation. scope. Obviously, expressions printed by means of such extra printing rules will not be reparsed to the same form. +.. note:: + + When several notations can be used to print a given term, the + notations which capture the largest subterm of the term are used + preferentially. Here is an example: + + .. coqtop:: in + + Notation "x < y" := (lt x y) (at level 70). + Notation "x < y < z" := (lt x y /\ lt y z) (at level 70, y at next level). + + Check (0 < 1 /\ 1 < 2). + + When several notations match the same subterm, or incomparable + subterms of the term to print, the notation declared most recently + is selected. Moreover, reimporting a library or module declares the + notations of this library or module again. If the notation is in a + scope (see :ref:`Scopes`), either the scope has to be opened or a + delimiter has to exist in the scope for the notation to be usable. + The Infix command ~~~~~~~~~~~~~~~~~~ @@ -787,20 +807,39 @@ nested iterating pattern, the second placeholder is finally filled with the terminating expression. In the example above, the iterator :math:`φ([~]_E , [~]_I)` is :math:`cons [~]_E\, [~]_I` -and the terminating expression is ``nil``. Here are other examples: +and the terminating expression is ``nil``. + +Here is another example with the pattern associating on the left: .. coqtop:: in Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) (at level 0). +Here is an example with more involved recursive patterns: + +.. coqtop:: in + Notation "[| t * ( x , y , .. , z ) ; ( a , b , .. , c ) * u |]" := (pair (pair .. (pair (pair t x) (pair t y)) .. (pair t z)) (pair .. (pair (pair a u) (pair b u)) .. (pair c u))) (t at level 39). -Notations with recursive patterns can be reserved like standard -notations, they can also be declared within -:ref:`notation scopes <Scopes>`. +To give a flavor of the extent and limits of the mechanism, here is an +example showing a notation for a chain of equalities. It relies on an +artificial expansion of the intended denotation so as to expose a +``φ(x, .. φ(y,t) ..)`` structure, with the drawback that if ever the +beta-redexes are contracted, the notations stops to be used for +printing. + +.. coqtop:: in + + Notation "x ⪯ y ⪯ .. ⪯ z ⪯ t" := + ((fun b A a => a <= b /\ A b) y .. ((fun b A a => a <= b /\ A b) z (fun b => b <= t)) .. x) + (at level 70, y at next level, z at next level, t at next level). + +Note finally that notations with recursive patterns can be reserved like +standard notations, they can also be declared within :ref:`notation +scopes <Scopes>`. .. _RecursiveNotationsWithBinders: diff --git a/doc/tools/docgram/common.edit_mlg b/doc/tools/docgram/common.edit_mlg index 4c1956d172..816acba4c1 100644 --- a/doc/tools/docgram/common.edit_mlg +++ b/doc/tools/docgram/common.edit_mlg @@ -1939,11 +1939,6 @@ tac2rec_fields: [ | LIST1 tac2rec_field SEP ";" OPT ";" TAG Ltac2 ] -(* todo: weird productions, ints only after an initial "-"??: - occs_nums: [ - | LIST1 [ natural | ident ] - | "-" [ natural | ident ] LIST0 int_or_var -*) ltac2_occs_nums: [ | DELETE LIST1 nat_or_anti (* Ltac2 plugin *) | REPLACE "-" nat_or_anti LIST0 nat_or_anti (* Ltac2 plugin *) diff --git a/doc/tools/docgram/fullGrammar b/doc/tools/docgram/fullGrammar index 033ece04de..03a20d621b 100644 --- a/doc/tools/docgram/fullGrammar +++ b/doc/tools/docgram/fullGrammar @@ -480,6 +480,7 @@ opt_hintbases: [ command: [ | "Goal" lconstr | "Proof" +| "Proof" "using" G_vernac.section_subset_expr | "Proof" "Mode" string | "Proof" lconstr | "Abort" @@ -604,7 +605,7 @@ command: [ | "Typeclasses" "Opaque" LIST1 reference | "Typeclasses" "eauto" ":=" debug eauto_search_strategy OPT natural | "Proof" "with" Pltac.tactic OPT [ "using" G_vernac.section_subset_expr ] -| "Proof" "using" G_vernac.section_subset_expr OPT [ "with" Pltac.tactic ] +| "Proof" "using" G_vernac.section_subset_expr "with" Pltac.tactic | "Tactic" "Notation" OPT ltac_tactic_level LIST1 ltac_production_item ":=" tactic | "Print" "Ltac" reference | "Locate" "Ltac" reference @@ -764,6 +765,7 @@ attribute: [ attr_value: [ | "=" string +| "=" IDENT | "(" attribute_list ")" | ] @@ -2327,7 +2329,7 @@ conversion: [ occs_nums: [ | LIST1 nat_or_var -| "-" nat_or_var LIST0 int_or_var +| "-" LIST1 nat_or_var ] occs: [ @@ -2537,6 +2539,7 @@ or_and_intropattern_loc: [ as_or_and_ipat: [ | "as" or_and_intropattern_loc +| "as" equality_intropattern | ] diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index e6fc6188b7..0209cf762a 100644 --- a/doc/tools/docgram/orderedGrammar +++ b/doc/tools/docgram/orderedGrammar @@ -383,6 +383,7 @@ attribute: [ attr_value: [ | "=" string +| "=" ident | "(" LIST0 attribute SEP "," ")" ] @@ -434,6 +435,10 @@ univ_decl: [ | "@{" LIST0 ident OPT "+" OPT [ "|" LIST0 univ_constraint SEP "," OPT "+" ] "}" ] +cumul_univ_decl: [ +| "@{" LIST0 ( OPT [ "=" | "+" | "*" ] ident ) OPT "+" OPT [ "|" LIST0 univ_constraint SEP "," OPT "+" ] "}" +] + univ_constraint: [ | universe_name [ "<" | "=" | "<=" ] universe_name ] @@ -648,7 +653,7 @@ ref_or_pattern_occ: [ occs_nums: [ | LIST1 [ natural | ident ] -| "-" [ natural | ident ] LIST0 int_or_var +| "-" LIST1 [ natural | ident ] ] int_or_var: [ @@ -695,7 +700,7 @@ field_def: [ ] inductive_definition: [ -| OPT ">" ident_decl LIST0 binder OPT [ "|" LIST0 binder ] OPT [ ":" type ] OPT ( ":=" OPT constructors_or_record ) OPT decl_notations +| OPT ">" cumul_ident_decl LIST0 binder OPT [ "|" LIST0 binder ] OPT [ ":" type ] OPT ( ":=" OPT constructors_or_record ) OPT decl_notations ] constructors_or_record: [ @@ -707,6 +712,10 @@ constructor: [ | ident LIST0 binder OPT of_type ] +cumul_ident_decl: [ +| ident OPT cumul_univ_decl +] + filtered_import: [ | qualid OPT [ "(" LIST1 ( qualid OPT [ "(" ".." ")" ] ) SEP "," ")" ] ] @@ -944,6 +953,7 @@ command: [ | "Extract" "Inductive" qualid "=>" [ ident | string ] "[" LIST0 [ ident | string ] "]" OPT string (* extraction plugin *) | "Show" "Extraction" (* extraction plugin *) | "Proof" +| "Proof" "using" section_var_expr | "Proof" "Mode" string | "Proof" term | "Abort" OPT [ "All" | ident ] @@ -1024,7 +1034,7 @@ command: [ | "Typeclasses" "Opaque" LIST1 qualid | "Typeclasses" "eauto" ":=" OPT "debug" OPT ( "(" [ "bfs" | "dfs" ] ")" ) OPT natural | "Proof" "with" ltac_expr OPT [ "using" section_var_expr ] -| "Proof" "using" section_var_expr OPT [ "with" ltac_expr ] +| "Proof" "using" section_var_expr "with" ltac_expr | "Tactic" "Notation" OPT ( "(" "at" "level" natural ")" ) LIST1 ltac_production_item ":=" ltac_expr | "Print" "Rewrite" "HintDb" ident | "Print" "Ltac" qualid @@ -1960,6 +1970,7 @@ or_and_intropattern_loc: [ as_or_and_ipat: [ | "as" or_and_intropattern_loc +| "as" equality_intropattern ] eqn_ipat: [ diff --git a/interp/constrexpr.ml b/interp/constrexpr.ml index 235310660b..977cbbccf2 100644 --- a/interp/constrexpr.ml +++ b/interp/constrexpr.ml @@ -15,8 +15,11 @@ open Libnames (** [constr_expr] is the abstract syntax tree produced by the parser *) type universe_decl_expr = (lident list, Glob_term.glob_constraint list) UState.gen_universe_decl +type cumul_univ_decl_expr = + ((lident * Univ.Variance.t option) list, Glob_term.glob_constraint list) UState.gen_universe_decl type ident_decl = lident * universe_decl_expr option +type cumul_ident_decl = lident * cumul_univ_decl_expr option type name_decl = lname * universe_decl_expr option type notation_with_optional_scope = LastLonelyNotation | NotationInScope of string diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 02c3c047d5..c7ed066f7e 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -534,15 +534,19 @@ let intern_generalized_binder intern_type ntnvars in let na = match na with | Anonymous -> - let name = - let id = - match ty with - | { v = CApp ((_, { v = CRef (qid,_) } ), _) } when qualid_is_ident qid -> - qualid_basename qid - | _ -> default_non_dependent_ident - in Implicit_quantifiers.make_fresh ids' (Global.env ()) id - in Name name - | _ -> na in + let id = + match ty with + | { v = CApp ((_, { v = CRef (qid,_) } ), _) } when qualid_is_ident qid -> + qualid_basename qid + | _ -> default_non_dependent_ident + in + let ids' = List.fold_left (fun ids' lid -> Id.Set.add lid.CAst.v ids') ids' fvs in + let id = + Implicit_quantifiers.make_fresh ids' (Global.env ()) id + in + Name id + | _ -> na + in let impls = impls_type_list 1 ty' in (push_name_env ntnvars impls env' (make ?loc na), (make ?loc (na,b',ty')) :: List.rev bl) @@ -2409,8 +2413,9 @@ let internalize globalenv env pattern_mode (_, ntnvars as lvar) c = and intern_args env subscopes = function | [] -> [] | a::args -> - let (enva,subscopes) = apply_scope_env env subscopes in - (intern_no_implicit enva a) :: (intern_args env subscopes args) + let (enva,subscopes) = apply_scope_env env subscopes in + let a = intern_no_implicit enva a in + a :: (intern_args env subscopes args) in intern env c @@ -2648,13 +2653,34 @@ let interp_univ_decl env decl = let binders : lident list = decl.univdecl_instance in let evd = Evd.from_env ~binders env in let evd, cstrs = interp_univ_constraints env evd decl.univdecl_constraints in - let decl = { univdecl_instance = binders; + let decl = { + univdecl_instance = binders; univdecl_extensible_instance = decl.univdecl_extensible_instance; univdecl_constraints = cstrs; - univdecl_extensible_constraints = decl.univdecl_extensible_constraints } + univdecl_extensible_constraints = decl.univdecl_extensible_constraints; + } in evd, decl +let interp_cumul_univ_decl env decl = + let open UState in + let binders = List.map fst decl.univdecl_instance in + let variances = Array.map_of_list snd decl.univdecl_instance in + let evd = Evd.from_ctx (UState.from_env ~binders env) in + let evd, cstrs = interp_univ_constraints env evd decl.univdecl_constraints in + let decl = { + univdecl_instance = binders; + univdecl_extensible_instance = decl.univdecl_extensible_instance; + univdecl_constraints = cstrs; + univdecl_extensible_constraints = decl.univdecl_extensible_constraints; + } + in + evd, decl, variances + let interp_univ_decl_opt env l = match l with | None -> Evd.from_env env, UState.default_univ_decl | Some decl -> interp_univ_decl env decl + +let interp_cumul_univ_decl_opt env = function + | None -> Evd.from_env env, UState.default_univ_decl, [| |] + | Some decl -> interp_cumul_univ_decl env decl diff --git a/interp/constrintern.mli b/interp/constrintern.mli index 9037ed5414..0de6c3e89d 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -204,3 +204,8 @@ val interp_univ_decl : Environ.env -> universe_decl_expr -> val interp_univ_decl_opt : Environ.env -> universe_decl_expr option -> Evd.evar_map * UState.universe_decl + +val interp_cumul_univ_decl_opt : Environ.env -> cumul_univ_decl_expr option -> + Evd.evar_map * UState.universe_decl * Entries.variance_entry +(** BEWARE the variance entry needs to be adjusted by + [ComInductive.variance_of_entry] if the instance is extensible. *) diff --git a/interp/notation.ml b/interp/notation.ml index 948ebe9640..286ece6cb6 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -345,11 +345,23 @@ let also_cases_notation_rule_eq (also_cases1,rule1) (also_cases2,rule2) = (* No need in principle to compare also_cases as it is inferred *) also_cases1 = also_cases2 && notation_rule_eq rule1 rule2 +let adjust_application c1 c2 = + match c1, c2 with + | NApp (t1, a1), (NList (_,_,NApp (_, a2),_,_) | NApp (_, a2)) when List.length a1 >= List.length a2 -> + NApp (t1, List.firstn (List.length a2) a1) + | NApp (t1, a1), _ -> + t1 + | _ -> c1 + +let strictly_finer_interpretation_than (_,(_,(vars1,c1),_)) (_,(_,(vars2,c2),_)) = + let c1 = adjust_application c1 c2 in + Notation_ops.strictly_finer_notation_constr (List.map fst vars1, List.map fst vars2) c1 c2 + let keymap_add key interp map = let old = try KeyMap.find key map with Not_found -> [] in - (* In case of re-import, no need to keep the previous copy *) - let old = try List.remove_first (also_cases_notation_rule_eq interp) old with Not_found -> old in - KeyMap.add key (interp :: old) map + (* strictly finer interpretation are kept in front *) + let strictly_finer, rest = List.partition (fun c -> strictly_finer_interpretation_than c interp) old in + KeyMap.add key (strictly_finer @ interp :: rest) map let keymap_remove key interp map = let old = try KeyMap.find key map with Not_found -> [] in @@ -391,6 +403,10 @@ let notation_constr_key = function (* Rem: NApp(NRef ref,[]) stands for @ref *) | NBinderList (_,_,NApp (NRef ref,args),_,_) -> RefKey (canonical_gr ref), AppBoundedNotation (List.length args) | NRef ref -> RefKey(canonical_gr ref), NotAppNotation + | NApp (NList (_,_,NApp (NRef ref,args),_,_), args') -> + RefKey (canonical_gr ref), AppBoundedNotation (List.length args + List.length args') + | NApp (NList (_,_,NApp (_,args),_,_), args') -> + Oth, AppBoundedNotation (List.length args + List.length args') | NApp (_,args) -> Oth, AppBoundedNotation (List.length args) | NList (_,_,NApp (NVar x,_),_,_) when x = Notation_ops.ldots_var -> Oth, AppUnboundedNotation | _ -> Oth, NotAppNotation @@ -1415,12 +1431,12 @@ let check_parsing_override (scopt,ntn) data = function | OnlyParsingData (_,old_data) -> let overridden = not (interpretation_eq data.not_interp old_data.not_interp) in warn_override_if_needed (scopt,ntn) overridden data old_data; - None, not overridden + None | ParsingAndPrintingData (_,on_printing,old_data) -> let overridden = not (interpretation_eq data.not_interp old_data.not_interp) in warn_override_if_needed (scopt,ntn) overridden data old_data; - (if on_printing then Some old_data.not_interp else None), not overridden - | NoParsingData -> None, false + if on_printing then Some old_data.not_interp else None + | NoParsingData -> None let check_printing_override (scopt,ntn) data parsingdata printingdata = let parsing_update = match parsingdata with @@ -1449,15 +1465,15 @@ let update_notation_data (scopt,ntn) use data table = try NotationMap.find ntn table with Not_found -> (NoParsingData, []) in match use with | OnlyParsing -> - let printing_update, exists = check_parsing_override (scopt,ntn) data parsingdata in - NotationMap.add ntn (OnlyParsingData (true,data), printingdata) table, printing_update, exists + let printing_update = check_parsing_override (scopt,ntn) data parsingdata in + NotationMap.add ntn (OnlyParsingData (true,data), printingdata) table, printing_update | ParsingAndPrinting -> - let printing_update, exists = check_parsing_override (scopt,ntn) data parsingdata in - NotationMap.add ntn (ParsingAndPrintingData (true,true,data), printingdata) table, printing_update, exists + let printing_update = check_parsing_override (scopt,ntn) data parsingdata in + NotationMap.add ntn (ParsingAndPrintingData (true,true,data), printingdata) table, printing_update | OnlyPrinting -> let parsingdata, exists = check_printing_override (scopt,ntn) data parsingdata printingdata in let printingdata = if exists then printingdata else (true,data) :: printingdata in - NotationMap.add ntn (parsingdata, printingdata) table, None, exists + NotationMap.add ntn (parsingdata, printingdata) table, None let rec find_interpretation ntn find = function | [] -> raise Not_found @@ -1730,23 +1746,22 @@ let declare_notation (scopt,ntn) pat df ~use ~also_in_cases_pattern coe deprecat not_location = df; not_deprecation = deprecation; } in - let notation_update,printing_update, exists = update_notation_data (scopt,ntn) use notdata sc.notations in - if not exists then - let sc = { sc with notations = notation_update } in - scope_map := String.Map.add scope sc !scope_map; + let notation_update,printing_update = update_notation_data (scopt,ntn) use notdata sc.notations in + let sc = { sc with notations = notation_update } in + scope_map := String.Map.add scope sc !scope_map; (* Update the uninterpretation cache *) begin match printing_update with | Some pat -> remove_uninterpretation (NotationRule (scopt,ntn)) also_in_cases_pattern pat | None -> () end; - if not exists && use <> OnlyParsing then declare_uninterpretation ~also_in_cases_pattern (NotationRule (scopt,ntn)) pat; + if use <> OnlyParsing then declare_uninterpretation ~also_in_cases_pattern (NotationRule (scopt,ntn)) pat; (* Register visibility of lonely notations *) - if not exists then begin match scopt with + begin match scopt with | LastLonelyNotation -> scope_stack := LonelyNotationItem ntn :: !scope_stack | NotationInScope _ -> () end; (* Declare a possible coercion *) - if not exists then begin match coe with + begin match coe with | Some (IsEntryCoercion entry) -> let (_,level,_) = level_of_notation ntn in let level = match fst ntn with diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index cfab9d1d98..c4d2a2a496 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -24,82 +24,182 @@ open Notation_term (**********************************************************************) (* Utilities *) -(* helper for NVar, NVar case in eq_notation_constr *) -let get_var_ndx id vs = try Some (List.index Id.equal id vs) with Not_found -> None - -let rec eq_notation_constr (vars1,vars2 as vars) t1 t2 = -(vars1 == vars2 && t1 == t2) || -match t1, t2 with -| NRef gr1, NRef gr2 -> GlobRef.equal gr1 gr2 -| NVar id1, NVar id2 -> ( - match (get_var_ndx id1 vars1,get_var_ndx id2 vars2) with - | Some n,Some m -> Int.equal n m - | None ,None -> Id.equal id1 id2 - | _ -> false) -| NApp (t1, a1), NApp (t2, a2) -> - (eq_notation_constr vars) t1 t2 && List.equal (eq_notation_constr vars) a1 a2 -| NHole (_, _, _), NHole (_, _, _) -> true (* FIXME? *) -| NList (i1, j1, t1, u1, b1), NList (i2, j2, t2, u2, b2) -> - Id.equal i1 i2 && Id.equal j1 j2 && (eq_notation_constr vars) t1 t2 && - (eq_notation_constr vars) u1 u2 && b1 == b2 -| NLambda (na1, t1, u1), NLambda (na2, t2, u2) -> - Name.equal na1 na2 && (eq_notation_constr vars) t1 t2 && (eq_notation_constr vars) u1 u2 -| NProd (na1, t1, u1), NProd (na2, t2, u2) -> - Name.equal na1 na2 && (eq_notation_constr vars) t1 t2 && (eq_notation_constr vars) u1 u2 -| NBinderList (i1, j1, t1, u1, b1), NBinderList (i2, j2, t2, u2, b2) -> - Id.equal i1 i2 && Id.equal j1 j2 && (eq_notation_constr vars) t1 t2 && - (eq_notation_constr vars) u1 u2 && b1 == b2 -| NLetIn (na1, b1, t1, u1), NLetIn (na2, b2, t2, u2) -> - Name.equal na1 na2 && eq_notation_constr vars b1 b2 && - Option.equal (eq_notation_constr vars) t1 t2 && (eq_notation_constr vars) u1 u2 -| NCases (_, o1, r1, p1), NCases (_, o2, r2, p2) -> (* FIXME? *) - let eqpat (p1, t1) (p2, t2) = - List.equal cases_pattern_eq p1 p2 && - (eq_notation_constr vars) t1 t2 - in - let eqf (t1, (na1, o1)) (t2, (na2, o2)) = - let eq (i1, n1) (i2, n2) = Ind.CanOrd.equal i1 i2 && List.equal Name.equal n1 n2 in - (eq_notation_constr vars) t1 t2 && Name.equal na1 na2 && Option.equal eq o1 o2 - in - Option.equal (eq_notation_constr vars) o1 o2 && - List.equal eqf r1 r2 && - List.equal eqpat p1 p2 -| NLetTuple (nas1, (na1, o1), t1, u1), NLetTuple (nas2, (na2, o2), t2, u2) -> - List.equal Name.equal nas1 nas2 && - Name.equal na1 na2 && - Option.equal (eq_notation_constr vars) o1 o2 && - (eq_notation_constr vars) t1 t2 && - (eq_notation_constr vars) u1 u2 -| NIf (t1, (na1, o1), u1, r1), NIf (t2, (na2, o2), u2, r2) -> - (eq_notation_constr vars) t1 t2 && - Name.equal na1 na2 && - Option.equal (eq_notation_constr vars) o1 o2 && - (eq_notation_constr vars) u1 u2 && - (eq_notation_constr vars) r1 r2 -| NRec (_, ids1, ts1, us1, rs1), NRec (_, ids2, ts2, us2, rs2) -> (* FIXME? *) - let eq (na1, o1, t1) (na2, o2, t2) = - Name.equal na1 na2 && - Option.equal (eq_notation_constr vars) o1 o2 && - (eq_notation_constr vars) t1 t2 - in - Array.equal Id.equal ids1 ids2 && - Array.equal (List.equal eq) ts1 ts2 && - Array.equal (eq_notation_constr vars) us1 us2 && - Array.equal (eq_notation_constr vars) rs1 rs2 -| NSort s1, NSort s2 -> - glob_sort_eq s1 s2 -| NCast (t1, c1), NCast (t2, c2) -> - (eq_notation_constr vars) t1 t2 && cast_type_eq (eq_notation_constr vars) c1 c2 -| NInt i1, NInt i2 -> - Uint63.equal i1 i2 -| NFloat f1, NFloat f2 -> - Float64.equal f1 f2 -| NArray(t1,def1,ty1), NArray(t2,def2,ty2) -> - Array.equal (eq_notation_constr vars) t1 t2 && (eq_notation_constr vars) def1 def2 - && eq_notation_constr vars ty1 ty2 -| (NRef _ | NVar _ | NApp _ | NHole _ | NList _ | NLambda _ | NProd _ - | NBinderList _ | NLetIn _ | NCases _ | NLetTuple _ | NIf _ - | NRec _ | NSort _ | NCast _ | NInt _ | NFloat _ | NArray _), _ -> false +let ldots_var = Id.of_string ".." + +let rec alpha_var id1 id2 = function + | (i1,i2)::_ when Id.equal i1 id1 -> Id.equal i2 id2 + | (i1,i2)::_ when Id.equal i2 id2 -> Id.equal i1 id1 + | _::idl -> alpha_var id1 id2 idl + | [] -> Id.equal id1 id2 + +let cast_type_iter2 f t1 t2 = match t1, t2 with + | CastConv t1, CastConv t2 -> f t1 t2 + | CastVM t1, CastVM t2 -> f t1 t2 + | CastCoerce, CastCoerce -> () + | CastNative t1, CastNative t2 -> f t1 t2 + | (CastConv _ | CastVM _ | CastCoerce | CastNative _), _ -> raise Exit + +(* used to update the notation variable with the local variables used + in NList and NBinderList, since the iterator has its own variable *) +let replace_var i j var = j :: List.remove Id.equal i var + +(* When [lt] is [true], tell if [t1] is a strict refinement of [t2] + (this is a partial order, so returning [false] does not mean that + [t2] is finer than [t1]); when [lt] is false, tell if [t1] is the + same pattern as [t2] *) + +let compare_notation_constr lt (vars1,vars2) t1 t2 = + (* this is used to reason up to order of notation variables *) + let alphameta = ref [] in + (* this becomes true when at least one subterm is detected as strictly smaller *) + let strictly_lt = ref false in + (* this is the stack of inner of iter patterns for comparison with a + new iteration or the tail of a recursive pattern *) + let tail = ref [] in + let check_alphameta id1 id2 = + try if not (Id.equal (List.assoc id1 !alphameta) id2) then raise Exit + with Not_found -> + if (List.mem_assoc id1 !alphameta) then raise Exit; + alphameta := (id1,id2) :: !alphameta in + let check_eq_id (vars1,vars2) renaming id1 id2 = + let ismeta1 = List.mem_f Id.equal id1 vars1 in + let ismeta2 = List.mem_f Id.equal id2 vars2 in + match ismeta1, ismeta2 with + | true, true -> check_alphameta id1 id2 + | false, false -> if not (alpha_var id1 id2 renaming) then raise Exit + | false, true -> + if not lt then raise Exit + else + (* a binder which is not bound in the notation can be + considered as strictly more precise since it prevents the + notation variables in its scope to be bound by this binder; + i.e. it is strictly more precise in the sense that it + covers strictly less patterns than a notation where the + same binder is bound in the notation; this is hawever + disputable *) + strictly_lt := true + | true, false -> if not lt then raise Exit in + let check_eq_name vars renaming na1 na2 = + match na1, na2 with + | Name id1, Name id2 -> check_eq_id vars renaming id1 id2; (id1,id2)::renaming + | Anonymous, Anonymous -> renaming + | Anonymous, Name _ when lt -> renaming + | _ -> raise Exit in + let rec aux (vars1,vars2 as vars) renaming t1 t2 = match t1, t2 with + | NVar id1, NVar id2 when id1 = ldots_var && id2 = ldots_var -> () + | _, NVar id2 when lt && id2 = ldots_var -> tail := t1 :: !tail + | NVar id1, _ when lt && id1 = ldots_var -> tail := t2 :: !tail + | NVar id1, NVar id2 -> check_eq_id vars renaming id1 id2 + | NHole _, NVar id2 when lt && List.mem_f Id.equal id2 vars2 -> () + | NVar id1, NHole (_, _, _) when lt && List.mem_f Id.equal id1 vars1 -> () + | _, NVar id2 when lt && List.mem_f Id.equal id2 vars2 -> strictly_lt := true + | NRef gr1, NRef gr2 when GlobRef.equal gr1 gr2 -> () + | NHole (_, _, _), NHole (_, _, _) -> () (* FIXME? *) + | _, NHole (_, _, _) when lt -> strictly_lt := true + | NList (i1, j1, iter1, tail1, b1), NList (i2, j2, iter2, tail2, b2) + | NBinderList (i1, j1, iter1, tail1, b1), NBinderList (i2, j2, iter2, tail2, b2) -> + if b1 <> b2 then raise Exit; + let vars1 = replace_var i1 j1 vars1 in + let vars2 = replace_var i2 j2 vars2 in + check_alphameta i1 i2; aux (vars1,vars2) renaming iter1 iter2; aux vars renaming tail1 tail2; + | NBinderList (i1, j1, iter1, tail1, b1), NList (i2, j2, iter2, tail2, b2) + | NList (i1, j1, iter1, tail1, b1), NBinderList (i2, j2, iter2, tail2, b2) -> + (* They may overlap on a unique iteration of them *) + let vars1 = replace_var i1 j1 vars1 in + let vars2 = replace_var i2 j2 vars2 in + aux (vars1,vars2) renaming iter1 iter2; + aux vars renaming tail1 tail2 + | t1, NList (i2, j2, iter2, tail2, b2) + | t1, NBinderList (i2, j2, iter2, tail2, b2) when lt -> + (* checking if t1 is a finite iteration of the pattern *) + let vars2 = replace_var i2 j2 vars2 in + aux (vars1,vars2) renaming t1 iter2; + let t1 = List.hd !tail in + tail := List.tl !tail; + (* either matching a new iteration, or matching the tail *) + (try aux vars renaming t1 tail2 with Exit -> aux vars renaming t1 t2) + | NList (i1, j1, iter1, tail1, b1), t2 + | NBinderList (i1, j1, iter1, tail1, b1), t2 when lt -> + (* we see the NList as a single iteration *) + let vars1 = replace_var i1 j1 vars1 in + aux (vars1,vars2) renaming iter1 t2; + let t2 = match !tail with + | t::rest -> tail := rest; t + | _ -> (* ".." is in a discarded fine-grained position *) raise Exit in + (* it had to be a single iteration of iter1 *) + aux vars renaming tail1 t2 + | NApp (t1, a1), NApp (t2, a2) -> aux vars renaming t1 t2; List.iter2 (aux vars renaming) a1 a2 + | NLambda (na1, t1, u1), NLambda (na2, t2, u2) + | NProd (na1, t1, u1), NProd (na2, t2, u2) -> + aux vars renaming t1 t2; + let renaming = check_eq_name vars renaming na1 na2 in + aux vars renaming u1 u2 + | NLetIn (na1, b1, t1, u1), NLetIn (na2, b2, t2, u2) -> + aux vars renaming b1 b2; + Option.iter2 (aux vars renaming) t1 t2;(* TODO : subtyping? *) + let renaming = check_eq_name vars renaming na1 na2 in + aux vars renaming u1 u2 + | NCases (_, o1, r1, p1), NCases (_, o2, r2, p2) -> (* FIXME? *) + let check_pat (p1, t1) (p2, t2) = + if not (List.equal cases_pattern_eq p1 p2) then raise Exit; (* TODO: subtyping and renaming *) + aux vars renaming t1 t2 + in + let eqf renaming (t1, (na1, o1)) (t2, (na2, o2)) = + aux vars renaming t1 t2; + let renaming = check_eq_name vars renaming na1 na2 in + let eq renaming (i1, n1) (i2, n2) = + if not (Ind.CanOrd.equal i1 i2) then raise Exit; + List.fold_left2 (check_eq_name vars) renaming n1 n2 in + Option.fold_left2 eq renaming o1 o2 in + let renaming = List.fold_left2 eqf renaming r1 r2 in + Option.iter2 (aux vars renaming) o1 o2; + List.iter2 check_pat p1 p2 + | NLetTuple (nas1, (na1, o1), t1, u1), NLetTuple (nas2, (na2, o2), t2, u2) -> + aux vars renaming t1 t2; + let renaming = check_eq_name vars renaming na1 na2 in + Option.iter2 (aux vars renaming) o1 o2; + let renaming' = List.fold_left2 (check_eq_name vars) renaming nas1 nas2 in + aux vars renaming' u1 u2 + | NIf (t1, (na1, o1), u1, r1), NIf (t2, (na2, o2), u2, r2) -> + aux vars renaming t1 t2; + aux vars renaming u1 u2; + aux vars renaming r1 r2; + let renaming = check_eq_name vars renaming na1 na2 in + Option.iter2 (aux vars renaming) o1 o2 + | NRec (_, ids1, ts1, us1, rs1), NRec (_, ids2, ts2, us2, rs2) -> (* FIXME? *) + let eq renaming (na1, o1, t1) (na2, o2, t2) = + Option.iter2 (aux vars renaming) o1 o2; + aux vars renaming t1 t2; + check_eq_name vars renaming na1 na2 + in + let renaming = Array.fold_left2 (fun r id1 id2 -> check_eq_id vars r id1 id2; (id1,id2)::r) renaming ids1 ids2 in + let renamings = Array.map2 (List.fold_left2 eq renaming) ts1 ts2 in + Array.iter3 (aux vars) renamings us1 us2; + Array.iter3 (aux vars) (Array.map ((@) renaming) renamings) rs1 rs2 + | NSort s1, NSort s2 when glob_sort_eq s1 s2 -> () + | NCast (t1, c1), NCast (t2, c2) -> + aux vars renaming t1 t2; + cast_type_iter2 (aux vars renaming) c1 c2 + | NInt i1, NInt i2 when Uint63.equal i1 i2 -> () + | NFloat f1, NFloat f2 when Float64.equal f1 f2 -> () + | NArray(t1,def1,ty1), NArray(t2,def2,ty2) -> + Array.iter2 (aux vars renaming) t1 t2; + aux vars renaming def1 def2; + aux vars renaming ty1 ty2 + | (NRef _ | NVar _ | NApp _ | NHole _ | NList _ | NLambda _ | NProd _ + | NBinderList _ | NLetIn _ | NCases _ | NLetTuple _ | NIf _ + | NRec _ | NSort _ | NCast _ | NInt _ | NFloat _ | NArray _), _ -> raise Exit in + try + let _ = aux (vars1,vars2) [] t1 t2 in + if not lt then + (* Check that order of notation metavariables does not matter *) + List.iter2 check_alphameta vars1 vars2; + not lt || !strictly_lt + with Exit | (* Option.iter2: *) Option.Heterogeneous | Invalid_argument _ -> false + +let eq_notation_constr vars t1 t2 = t1 == t2 || compare_notation_constr false vars t1 t2 + +let strictly_finer_notation_constr vars t1 t2 = compare_notation_constr true vars t1 t2 (**********************************************************************) (* Re-interpret a notation as a glob_constr, taking care of binders *) @@ -154,8 +254,6 @@ let rec subst_glob_vars l gc = DAst.map (function | _ -> DAst.get (map_glob_constr (subst_glob_vars l) gc) (* assume: id is not binding *) ) gc -let ldots_var = Id.of_string ".." - type 'a binder_status_fun = { no : 'a -> 'a; restart_prod : 'a -> 'a; @@ -275,6 +373,12 @@ type found_variables = { let add_id r id = r := { !r with vars = id :: (!r).vars } let add_name r = function Anonymous -> () | Name id -> add_id r id +let mkNApp1 (g,a) = + match g with + (* Ensure flattening of nested applicative nodes *) + | NApp (g,args') -> NApp (g,args'@[a]) + | _ -> NApp (g,[a]) + let is_gvar id c = match DAst.get c with | GVar id' -> Id.equal id id' | _ -> false @@ -443,7 +547,10 @@ let notation_constr_and_vars_of_glob_constr recvars a = aux' c and aux' x = DAst.with_val (function | GVar id -> if not (Id.equal id ldots_var) then add_id found id; NVar id - | GApp (g,args) -> NApp (aux g, List.map aux args) + | GApp (g,[]) -> NApp (aux g,[]) (* Encoding @foo *) + | GApp (g,args) -> + (* Treat applicative notes as binary nodes *) + let a,args = List.sep_last args in mkNApp1 (aux (DAst.make (GApp (g, args))), aux a) | GLambda (na,bk,ty,c) -> add_name found na; NLambda (na,aux ty,aux c) | GProd (na,bk,ty,c) -> add_name found na; NProd (na,aux ty,aux c) | GLetIn (na,b,t,c) -> add_name found na; NLetIn (na,aux b,Option.map aux t, aux c) @@ -754,12 +861,6 @@ let is_bindinglist_meta id metas = exception No_match -let rec alpha_var id1 id2 = function - | (i1,i2)::_ when Id.equal i1 id1 -> Id.equal i2 id2 - | (i1,i2)::_ when Id.equal i2 id2 -> Id.equal i1 id1 - | _::idl -> alpha_var id1 id2 idl - | [] -> Id.equal id1 id2 - let alpha_rename alpmetas v = if alpmetas == [] then v else try rename_glob_vars alpmetas v with UnsoundRenaming -> raise No_match diff --git a/interp/notation_ops.mli b/interp/notation_ops.mli index 0d4bdf3e85..9d451a5bb9 100644 --- a/interp/notation_ops.mli +++ b/interp/notation_ops.mli @@ -16,6 +16,11 @@ open Glob_term val eq_notation_constr : Id.t list * Id.t list -> notation_constr -> notation_constr -> bool +val strictly_finer_notation_constr : Id.t list * Id.t list -> notation_constr -> notation_constr -> bool +(** Tell if [t1] is a strict refinement of [t2] + (this is a partial order and returning [false] does not mean that + [t2] is finer than [t1]) *) + (** Substitution of kernel names in interpretation data *) val subst_interpretation : diff --git a/kernel/byterun/coq_fix_code.c b/kernel/byterun/coq_fix_code.c index 9118410549..1ba6a8c8fe 100644 --- a/kernel/byterun/coq_fix_code.c +++ b/kernel/byterun/coq_fix_code.c @@ -43,9 +43,7 @@ void init_arity () { arity[CONST0]=arity[CONST1]=arity[CONST2]=arity[CONST3]= arity[PUSHCONST0]=arity[PUSHCONST1]=arity[PUSHCONST2]=arity[PUSHCONST3]= arity[ACCUMULATE]=arity[STOP]=arity[MAKEPROD]= - arity[ADDINT63]=arity[SUBINT63]=arity[LTINT63]=arity[LEINT63]= - arity[LTFLOAT]=arity[LEFLOAT]= - arity[ISINT]=arity[AREINT2]=0; + 0; /* instruction with one operand */ arity[ACC]=arity[PUSHACC]=arity[POP]=arity[ENVACC]=arity[PUSHENVACC]= arity[PUSH_RETADDR]=arity[APPLY]=arity[APPTERM1]=arity[APPTERM2]= @@ -75,9 +73,10 @@ void init_arity () { arity[CHECKNEXTUPFLOAT]=arity[CHECKNEXTDOWNFLOAT]=1; /* instruction with two operands */ arity[APPTERM]=arity[MAKEBLOCK]=arity[CLOSURE]= - arity[ISARRAY_CAML_CALL1]=arity[ISINT_CAML_CALL2]= - arity[ISARRAY_INT_CAML_CALL2]=arity[ISARRAY_INT_CAML_CALL3]= - arity[PROJ]=2; + arity[CHECKCAMLCALL1]=arity[CHECKCAMLCALL2_1]= + arity[CHECKCAMLCALL2]=arity[CHECKCAMLCALL3_1]= + arity[PROJ]= + 2; /* instruction with four operands */ arity[MAKESWITCHBLOCK]=4; /* instruction with arbitrary operands */ diff --git a/kernel/byterun/coq_float64.h b/kernel/byterun/coq_float64.c index 84a3edf1c7..bea47dd47e 100644 --- a/kernel/byterun/coq_float64.h +++ b/kernel/byterun/coq_float64.c @@ -8,19 +8,40 @@ /* * (see LICENSE file for the text of the license) */ /************************************************************************/ -#ifndef _COQ_FLOAT64_ -#define _COQ_FLOAT64_ - #include <math.h> +#include <stdint.h> -#define DECLARE_FREL(name, e) \ - int coq_##name(double x, double y) { \ - return e; \ - } \ - \ - value coq_##name##_byte(value x, value y) { \ - return coq_##name(Double_val(x), Double_val(y)); \ - } +#define CAML_INTERNALS +#include <caml/alloc.h> + +#include "coq_values.h" + +union double_bits { + double d; + uint64_t u; +}; + +static double next_up(double x) { + union double_bits bits; + if (!(x < INFINITY)) return x; // x is +oo or NaN + bits.d = x; + int64_t i = bits.u; + if (i >= 0) ++bits.u; // x >= +0.0, go away from zero + else if (bits.u + bits.u == 0) bits.u = 1; // x is -0.0, should almost never happen + else --bits.u; // x < 0.0, go toward zero + return bits.d; +} + +static double next_down(double x) { + union double_bits bits; + if (!(x > -INFINITY)) return x; // x is -oo or NaN + bits.d = x; + int64_t i = bits.u; + if (i == 0) bits.u = INT64_MIN + 1; // x is +0.0 + else if (i < 0) ++bits.u; // x <= -0.0, go away from zero + else --bits.u; // x > 0.0, go toward zero + return bits.d; +} #define DECLARE_FBINOP(name, e) \ double coq_##name(double x, double y) { \ @@ -40,19 +61,14 @@ return caml_copy_double(coq_##name(Double_val(x))); \ } -DECLARE_FREL(feq, x == y) -DECLARE_FREL(flt, x < y) -DECLARE_FREL(fle, x <= y) DECLARE_FBINOP(fmul, x * y) DECLARE_FBINOP(fadd, x + y) DECLARE_FBINOP(fsub, x - y) DECLARE_FBINOP(fdiv, x / y) DECLARE_FUNOP(fsqrt, sqrt(x)) -DECLARE_FUNOP(next_up, nextafter(x, INFINITY)) -DECLARE_FUNOP(next_down, nextafter(x, -INFINITY)) +DECLARE_FUNOP(next_up, next_up(x)) +DECLARE_FUNOP(next_down, next_down(x)) value coq_is_double(value x) { return Val_long(Is_double(x)); } - -#endif /* _COQ_FLOAT64_ */ diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index 1b6da7dd6f..8990743de2 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -28,7 +28,6 @@ #include "coq_fix_code.h" #include "coq_memory.h" #include "coq_values.h" -#include "coq_float64.h" #if OCAML_VERSION < 41000 extern void caml_minor_collection(void); @@ -113,7 +112,7 @@ if (sp - num_args < coq_stack_threshold) { \ #define Setup_for_gc { sp -= 2; sp[0] = accu; sp[1] = coq_env; coq_sp = sp; } #define Restore_after_gc { accu = sp[0]; coq_env = sp[1]; sp += 2; } #define Setup_for_caml_call { *--sp = coq_env; coq_sp = sp; } -#define Restore_after_caml_call { sp = coq_sp; coq_env = *sp++; } +#define Restore_after_caml_call coq_env = *sp++; /* Register optimization. Some compilers underestimate the use of the local variables representing @@ -193,7 +192,9 @@ if (sp - num_args < coq_stack_threshold) { \ #endif #endif -#define Is_accu(v) (Is_block(v) && Tag_val(v) == Closure_tag && Code_val(v) == accumulate) +/* We should also check "Code_val(v) == accumulate" to be sure, + but Is_accu is only used in places where closures cannot occur. */ +#define Is_accu(v) (Is_block(v) && Tag_val(v) == Closure_tag) #define CheckPrimArgs(cond, apply_lbl) do{ \ if (cond) pc++; \ @@ -237,6 +238,9 @@ extern intnat volatile caml_pending_signals[]; extern void caml_process_pending_signals(void); #endif +extern double coq_next_up(double); +extern double coq_next_down(double); + /* The interpreter itself */ value coq_interprete @@ -1271,11 +1275,8 @@ value coq_interprete Instruct(CHECKADDINT63){ print_instr("CHECKADDINT63"); CheckInt2(); - } - Instruct(ADDINT63) { /* Adds the integer in the accumulator with the one ontop of the stack (which is poped)*/ - print_instr("ADDINT63"); Uint63_add(accu, *sp++); Next; } @@ -1309,9 +1310,6 @@ value coq_interprete Instruct (CHECKSUBINT63) { print_instr("CHECKSUBINT63"); CheckInt2(); - } - Instruct (SUBINT63) { - print_instr("SUBINT63"); /* returns the subtraction */ Uint63_sub(accu, *sp++); Next; @@ -1517,9 +1515,6 @@ value coq_interprete Instruct (CHECKLTINT63) { print_instr("CHECKLTINT63"); CheckInt2(); - } - Instruct (LTINT63) { - print_instr("LTINT63"); int b; Uint63_lt(b,accu,*sp++); accu = b ? coq_true : coq_false; @@ -1529,9 +1524,6 @@ value coq_interprete Instruct (CHECKLEINT63) { print_instr("CHECKLEINT63"); CheckInt2(); - } - Instruct (LEINT63) { - print_instr("LEINT63"); int b; Uint63_leq(b,accu,*sp++); accu = b ? coq_true : coq_false; @@ -1570,20 +1562,6 @@ value coq_interprete Next; } - Instruct (ISINT){ - print_instr("ISINT"); - accu = (Is_uint63(accu)) ? coq_true : coq_false; - Next; - } - - Instruct (AREINT2){ - print_instr("AREINT2"); - accu = (Is_uint63(accu) && Is_uint63(sp[0])) ? coq_true : coq_false; - sp++; - Next; - } - - Instruct (CHECKOPPFLOAT) { print_instr("CHECKOPPFLOAT"); CheckFloat1(); @@ -1601,27 +1579,21 @@ value coq_interprete Instruct (CHECKEQFLOAT) { print_instr("CHECKEQFLOAT"); CheckFloat2(); - accu = coq_feq(Double_val(accu), Double_val(*sp++)) ? coq_true : coq_false; + accu = Double_val(accu) == Double_val(*sp++) ? coq_true : coq_false; Next; } Instruct (CHECKLTFLOAT) { print_instr("CHECKLTFLOAT"); CheckFloat2(); - } - Instruct (LTFLOAT) { - print_instr("LTFLOAT"); - accu = coq_flt(Double_val(accu), Double_val(*sp++)) ? coq_true : coq_false; + accu = Double_val(accu) < Double_val(*sp++) ? coq_true : coq_false; Next; } Instruct (CHECKLEFLOAT) { print_instr("CHECKLEFLOAT"); CheckFloat2(); - } - Instruct (LEFLOAT) { - print_instr("LEFLOAT"); - accu = coq_fle(Double_val(accu), Double_val(*sp++)) ? coq_true : coq_false; + accu = Double_val(accu) <= Double_val(*sp++) ? coq_true : coq_false; Next; } @@ -1674,35 +1646,35 @@ value coq_interprete Instruct (CHECKADDFLOAT) { print_instr("CHECKADDFLOAT"); CheckFloat2(); - Coq_copy_double(coq_fadd(Double_val(accu), Double_val(*sp++))); + Coq_copy_double(Double_val(accu) + Double_val(*sp++)); Next; } Instruct (CHECKSUBFLOAT) { print_instr("CHECKSUBFLOAT"); CheckFloat2(); - Coq_copy_double(coq_fsub(Double_val(accu), Double_val(*sp++))); + Coq_copy_double(Double_val(accu) - Double_val(*sp++)); Next; } Instruct (CHECKMULFLOAT) { print_instr("CHECKMULFLOAT"); CheckFloat2(); - Coq_copy_double(coq_fmul(Double_val(accu), Double_val(*sp++))); + Coq_copy_double(Double_val(accu) * Double_val(*sp++)); Next; } Instruct (CHECKDIVFLOAT) { print_instr("CHECKDIVFLOAT"); CheckFloat2(); - Coq_copy_double(coq_fdiv(Double_val(accu), Double_val(*sp++))); + Coq_copy_double(Double_val(accu) / Double_val(*sp++)); Next; } Instruct (CHECKSQRTFLOAT) { print_instr("CHECKSQRTFLOAT"); CheckFloat1(); - Coq_copy_double(coq_fsqrt(Double_val(accu))); + Coq_copy_double(sqrt(Double_val(accu))); Next; } @@ -1784,11 +1756,25 @@ value coq_interprete Next; } + Instruct (CHECKNEXTUPFLOATINPLACE) { + print_instr("CHECKNEXTUPFLOATINPLACE"); + CheckFloat1(); + Store_double_val(accu, coq_next_up(Double_val(accu))); + Next; + } + + Instruct (CHECKNEXTDOWNFLOATINPLACE) { + print_instr("CHECKNEXTDOWNFLOATINPLACE"); + CheckFloat1(); + Store_double_val(accu, coq_next_down(Double_val(accu))); + Next; + } - Instruct(ISINT_CAML_CALL2) { + Instruct(CHECKCAMLCALL2_1) { + // arity-2 callback, the last argument can be an accumulator value arg; - print_instr("ISINT_CAML_CALL2"); - if (Is_uint63(accu)) { + print_instr("CHECKCAMLCALL2_1"); + if (!Is_accu(accu)) { pc++; print_int(*pc); arg = sp[0]; @@ -1801,47 +1787,50 @@ value coq_interprete Next; } - Instruct(ISARRAY_CAML_CALL1) { - print_instr("ISARRAY_CAML_CALL1"); - if (Is_coq_array(accu)) { - pc++; - Setup_for_caml_call; - print_int(*pc); - accu = caml_callback(Field(coq_global_data, *pc),accu); - Restore_after_caml_call; - pc++; - } - else pc += *pc; - Next; + Instruct(CHECKCAMLCALL1) { + // arity-1 callback, no argument can be an accumulator + print_instr("CHECKCAMLCALL1"); + if (!Is_accu(accu)) { + pc++; + Setup_for_caml_call; + print_int(*pc); + accu = caml_callback(Field(coq_global_data, *pc), accu); + Restore_after_caml_call; + pc++; + } + else pc += *pc; + Next; } - Instruct(ISARRAY_INT_CAML_CALL2) { + Instruct(CHECKCAMLCALL2) { + // arity-2 callback, no argument can be an accumulator value arg; - print_instr("ISARRAY_INT_CAML_CALL2"); - if (Is_coq_array(accu) && Is_uint63(sp[0])) { - pc++; - arg = sp[0]; - Setup_for_caml_call; - print_int(*pc); - accu = caml_callback2(Field(coq_global_data, *pc), accu, arg); - Restore_after_caml_call; - sp += 1; - pc++; - } else pc += *pc; - Next; + print_instr("CHECKCAMLCALL2"); + if (!Is_accu(accu) && !Is_accu(sp[0])) { + pc++; + arg = sp[0]; + Setup_for_caml_call; + print_int(*pc); + accu = caml_callback2(Field(coq_global_data, *pc), accu, arg); + Restore_after_caml_call; + sp += 1; + pc++; + } else pc += *pc; + Next; } - Instruct(ISARRAY_INT_CAML_CALL3) { + Instruct(CHECKCAMLCALL3_1) { + // arity-3 callback, the last argument can be an accumulator value arg1; value arg2; - print_instr("ISARRAY_INT_CAML_CALL3"); - if (Is_coq_array(accu) && Is_uint63(sp[0])) { + print_instr("CHECKCAMLCALL3_1"); + if (!Is_accu(accu) && !Is_accu(sp[0])) { pc++; arg1 = sp[0]; arg2 = sp[1]; Setup_for_caml_call; print_int(*pc); - accu = caml_callback3(Field(coq_global_data, *pc),accu, arg1, arg2); + accu = caml_callback3(Field(coq_global_data, *pc), accu, arg1, arg2); Restore_after_caml_call; sp += 2; pc++; diff --git a/kernel/byterun/coq_memory.c b/kernel/byterun/coq_memory.c index ae5251c252..fe076f8f04 100644 --- a/kernel/byterun/coq_memory.c +++ b/kernel/byterun/coq_memory.c @@ -65,9 +65,10 @@ static void coq_scan_roots(scanning_action action) register value * i; /* Scan the stack */ for (i = coq_sp; i < coq_stack_high; i++) { + if (!Is_block(*i)) continue; #ifdef NO_NAKED_POINTERS /* The VM stack may contain C-allocated bytecode */ - if (Is_block(*i) && !Is_in_heap_or_young(*i)) continue; + if (!Is_in_heap_or_young(*i)) continue; #endif (*action) (*i, i); }; diff --git a/kernel/byterun/coq_values.h b/kernel/byterun/coq_values.h index f07018711b..0cdef34050 100644 --- a/kernel/byterun/coq_values.h +++ b/kernel/byterun/coq_values.h @@ -30,9 +30,6 @@ #define Is_double(v) (Tag_val(v) == Double_tag) #define Is_tailrec_switch(v) (Field(v,1) == Val_true) -/* coq array */ -#define Is_coq_array(v) (Is_block(v) && (Wosize_val(v) == 1)) - /* coq values for primitive operations */ #define coq_tag_C1 2 #define coq_tag_C0 1 diff --git a/kernel/byterun/dune b/kernel/byterun/dune index 2998178be2..d3e2a2fa7f 100644 --- a/kernel/byterun/dune +++ b/kernel/byterun/dune @@ -4,7 +4,7 @@ (public_name coq.vm) (foreign_stubs (language c) - (names coq_fix_code coq_memory coq_values coq_interp) + (names coq_fix_code coq_float64 coq_memory coq_values coq_interp) (flags (:include %{project_root}/config/dune.c_flags)))) (rule diff --git a/kernel/context.ml b/kernel/context.ml index 6a99f201f3..ab66898b59 100644 --- a/kernel/context.ml +++ b/kernel/context.ml @@ -365,6 +365,15 @@ struct let ty' = f ty in if v == v' && ty == ty' then decl else LocalDef (id, v', ty') + let map_constr_het f = function + | LocalAssum (id, ty) -> + let ty' = f ty in + LocalAssum (id, ty') + | LocalDef (id, v, ty) -> + let v' = f v in + let ty' = f ty in + LocalDef (id, v', ty') + (** Perform a given action on all terms in a given declaration. *) let iter_constr f = function | LocalAssum (_, ty) -> f ty diff --git a/kernel/context.mli b/kernel/context.mli index 76c4461760..29309daf34 100644 --- a/kernel/context.mli +++ b/kernel/context.mli @@ -231,6 +231,9 @@ sig (** Map all terms in a given declaration. *) val map_constr : ('c -> 'c) -> ('c, 'c) pt -> ('c, 'c) pt + (** Map all terms, with an heterogeneous function. *) + val map_constr_het : ('a -> 'b) -> ('a, 'a) pt -> ('b, 'b) pt + (** Perform a given action on all terms in a given declaration. *) val iter_constr : ('c -> unit) -> ('c, 'c) pt -> unit diff --git a/kernel/entries.ml b/kernel/entries.ml index ae64112e33..1bfc740017 100644 --- a/kernel/entries.ml +++ b/kernel/entries.ml @@ -20,6 +20,8 @@ type universes_entry = | Monomorphic_entry of Univ.ContextSet.t | Polymorphic_entry of Name.t array * Univ.UContext.t +type variance_entry = Univ.Variance.t option array + type 'a in_universes_entry = 'a * universes_entry (** {6 Declaration of inductive types. } *) @@ -50,9 +52,10 @@ type mutual_inductive_entry = { mind_entry_inds : one_inductive_entry list; mind_entry_universes : universes_entry; mind_entry_template : bool; (* Use template polymorphism *) - mind_entry_cumulative : bool; - (* universe constraints and the constraints for subtyping of - inductive types in the block. *) + mind_entry_variance : variance_entry option; + (* [None] if non-cumulative, otherwise associates each universe of + the entry to [None] if to be inferred or [Some v] if to be + checked. *) mind_entry_private : bool option; } diff --git a/kernel/genOpcodeFiles.ml b/kernel/genOpcodeFiles.ml index f052e03cde..dc2cd349ce 100644 --- a/kernel/genOpcodeFiles.ml +++ b/kernel/genOpcodeFiles.ml @@ -104,11 +104,9 @@ let opcodes = "MAKEPROD"; "BRANCH"; "CHECKADDINT63"; - "ADDINT63"; "CHECKADDCINT63"; "CHECKADDCARRYCINT63"; "CHECKSUBINT63"; - "SUBINT63"; "CHECKSUBCINT63"; "CHECKSUBCARRYCINT63"; "CHECKMULINT63"; @@ -127,21 +125,15 @@ let opcodes = "CHECKLSRINT63CONST1"; "CHECKEQINT63"; "CHECKLTINT63"; - "LTINT63"; "CHECKLEINT63"; - "LEINT63"; "CHECKCOMPAREINT63"; "CHECKHEAD0INT63"; "CHECKTAIL0INT63"; - "ISINT"; - "AREINT2"; "CHECKOPPFLOAT"; "CHECKABSFLOAT"; "CHECKEQFLOAT"; "CHECKLTFLOAT"; - "LTFLOAT"; "CHECKLEFLOAT"; - "LEFLOAT"; "CHECKCOMPAREFLOAT"; "CHECKCLASSIFYFLOAT"; "CHECKADDFLOAT"; @@ -155,10 +147,12 @@ let opcodes = "CHECKLDSHIFTEXP"; "CHECKNEXTUPFLOAT"; "CHECKNEXTDOWNFLOAT"; - "ISINT_CAML_CALL2"; - "ISARRAY_CAML_CALL1"; - "ISARRAY_INT_CAML_CALL2"; - "ISARRAY_INT_CAML_CALL3"; + "CHECKNEXTUPFLOATINPLACE"; + "CHECKNEXTDOWNFLOATINPLACE"; + "CHECKCAMLCALL2_1"; + "CHECKCAMLCALL1"; + "CHECKCAMLCALL2"; + "CHECKCAMLCALL3_1"; "STOP" |] diff --git a/kernel/indTyping.ml b/kernel/indTyping.ml index b2520b780f..33ee8c325a 100644 --- a/kernel/indTyping.ml +++ b/kernel/indTyping.ml @@ -369,15 +369,20 @@ let typecheck_inductive env ~sec_univs (mie:mutual_inductive_entry) = data, Some None in - let variance = if not mie.mind_entry_cumulative then None - else match mie.mind_entry_universes with + let variance = match mie.mind_entry_variance with + | None -> None + | Some variances -> + match mie.mind_entry_universes with | Monomorphic_entry _ -> CErrors.user_err Pp.(str "Inductive cannot be both monomorphic and universe cumulative.") | Polymorphic_entry (_,uctx) -> let univs = Instance.to_array @@ UContext.instance uctx in + let univs = Array.map2 (fun a b -> a,b) univs variances in let univs = match sec_univs with | None -> univs - | Some sec_univs -> Array.append sec_univs univs + | Some sec_univs -> + let sec_univs = Array.map (fun u -> u, None) sec_univs in + Array.append sec_univs univs in let variances = InferCumulativity.infer_inductive ~env_params univs mie.mind_entry_inds in Some variances diff --git a/kernel/inferCumulativity.ml b/kernel/inferCumulativity.ml index 8191a5b0f3..d02f92ef26 100644 --- a/kernel/inferCumulativity.ml +++ b/kernel/inferCumulativity.ml @@ -15,30 +15,82 @@ open Univ open Variance open Util -type inferred = IrrelevantI | CovariantI - -(** Throughout this module we modify a map [variances] from local - universes to [inferred]. It starts as a trivial mapping to - [Irrelevant] and every time we encounter a local universe we - restrict it accordingly. - [Invariant] universes are removed from the map. -*) exception TrivialVariance -let maybe_trivial variances = - if LMap.is_empty variances then raise TrivialVariance - else variances +(** Not the same as Type_errors.BadVariance because we don't have the env where we raise. *) +exception BadVariance of Level.t * Variance.t * Variance.t +(* some ocaml bug is triggered if we make this an inline record *) -let infer_level_eq u variances = - maybe_trivial (LMap.remove u variances) +module Inf : sig + type variances + val infer_level_eq : Level.t -> variances -> variances + val infer_level_leq : Level.t -> variances -> variances + val start : (Level.t * Variance.t option) array -> variances + val finish : variances -> Variance.t array +end = struct + type inferred = IrrelevantI | CovariantI + type mode = Check | Infer -let infer_level_leq u variances = - (* can only set Irrelevant -> Covariant so nontrivial *) - LMap.update u (function - | None -> None - | Some CovariantI as x -> x - | Some IrrelevantI -> Some CovariantI) - variances + (** + Each local universe is either in the [univs] map or is Invariant. + + If [univs] is empty all universes are Invariant and there is nothing more to do, + so we stop by raising [TrivialVariance]. The [soft] check comes before that. + *) + type variances = { + orig_array : (Level.t * Variance.t option) array; + univs : (mode * inferred) LMap.t; + } + + let to_variance = function + | IrrelevantI -> Irrelevant + | CovariantI -> Covariant + + let to_variance_opt o = Option.cata to_variance Invariant o + + let infer_level_eq u variances = + match LMap.find_opt u variances.univs with + | None -> variances + | Some (Check, expected) -> + let expected = to_variance expected in + raise (BadVariance (u, expected, Invariant)) + | Some (Infer, _) -> + let univs = LMap.remove u variances.univs in + if LMap.is_empty univs then raise TrivialVariance; + {variances with univs} + + let infer_level_leq u variances = + (* can only set Irrelevant -> Covariant so no TrivialVariance *) + let univs = + LMap.update u (function + | None -> None + | Some (_,CovariantI) as x -> x + | Some (Infer,IrrelevantI) -> Some (Infer,CovariantI) + | Some (Check,IrrelevantI) -> + raise (BadVariance (u, Irrelevant, Covariant))) + variances.univs + in + if univs == variances.univs then variances else {variances with univs} + + let start us = + let univs = Array.fold_left (fun univs (u,variance) -> + match variance with + | None -> LMap.add u (Infer,IrrelevantI) univs + | Some Invariant -> univs + | Some Covariant -> LMap.add u (Check,CovariantI) univs + | Some Irrelevant -> LMap.add u (Check,IrrelevantI) univs) + LMap.empty us + in + if LMap.is_empty univs then raise TrivialVariance; + {univs; orig_array=us} + + let finish variances = + Array.map + (fun (u,_check) -> to_variance_opt (Option.map snd (LMap.find_opt u variances.univs))) + variances.orig_array + +end +open Inf let infer_generic_instance_eq variances u = Array.fold_left (fun variances u -> infer_level_eq u variances) @@ -204,11 +256,7 @@ let infer_arity_constructor is_arity env variances arcn = open Entries let infer_inductive_core env univs entries = - if Array.is_empty univs then raise TrivialVariance; - let variances = - Array.fold_left (fun variances u -> LMap.add u IrrelevantI variances) - LMap.empty univs - in + let variances = Inf.start univs in let variances = List.fold_left (fun variances entry -> let variances = infer_arity_constructor true env variances entry.mind_entry_arity @@ -218,12 +266,11 @@ let infer_inductive_core env univs entries = variances entries in - Array.map (fun u -> match LMap.find u variances with - | exception Not_found -> Invariant - | IrrelevantI -> Irrelevant - | CovariantI -> Covariant) - univs + Inf.finish variances let infer_inductive ~env_params univs entries = try infer_inductive_core env_params univs entries - with TrivialVariance -> Array.make (Array.length univs) Invariant + with + | TrivialVariance -> Array.make (Array.length univs) Invariant + | BadVariance (lev, expected, actual) -> + Type_errors.error_bad_variance env_params ~lev ~expected ~actual diff --git a/kernel/inferCumulativity.mli b/kernel/inferCumulativity.mli index db5539a0ff..99d8f0c98d 100644 --- a/kernel/inferCumulativity.mli +++ b/kernel/inferCumulativity.mli @@ -12,8 +12,8 @@ val infer_inductive : env_params:Environ.env (** Environment containing the polymorphic universes and the parameters. *) - -> Univ.Level.t array - (** Universes whose cumulativity we want to infer. *) + -> (Univ.Level.t * Univ.Variance.t option) array + (** Universes whose cumulativity we want to infer or check. *) -> Entries.one_inductive_entry list (** The inductive block data we want to infer cumulativity for. NB: we ignore the template bool and the names, only the terms diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml index ae5c4b6880..bcb7aa88ca 100644 --- a/kernel/type_errors.ml +++ b/kernel/type_errors.ml @@ -69,6 +69,7 @@ type ('constr, 'types) ptype_error = | DisallowedSProp | BadRelevance | BadInvert + | BadVariance of { lev : Level.t; expected : Variance.t; actual : Variance.t } type type_error = (constr, types) ptype_error @@ -163,6 +164,9 @@ let error_bad_relevance env = let error_bad_invert env = raise (TypeError (env, BadInvert)) +let error_bad_variance env ~lev ~expected ~actual = + raise (TypeError (env, BadVariance {lev;expected;actual})) + let map_pguard_error f = function | NotEnoughAbstractionInFixBody -> NotEnoughAbstractionInFixBody | RecursionNotOnInductiveType c -> RecursionNotOnInductiveType (f c) @@ -207,3 +211,4 @@ let map_ptype_error f = function | DisallowedSProp -> DisallowedSProp | BadRelevance -> BadRelevance | BadInvert -> BadInvert +| BadVariance u -> BadVariance u diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli index b1f7eb8a34..bcdcab9db7 100644 --- a/kernel/type_errors.mli +++ b/kernel/type_errors.mli @@ -70,6 +70,7 @@ type ('constr, 'types) ptype_error = | DisallowedSProp | BadRelevance | BadInvert + | BadVariance of { lev : Level.t; expected : Variance.t; actual : Variance.t } type type_error = (constr, types) ptype_error @@ -146,5 +147,7 @@ val error_bad_relevance : env -> 'a val error_bad_invert : env -> 'a +val error_bad_variance : env -> lev:Level.t -> expected:Variance.t -> actual:Variance.t -> 'a + val map_pguard_error : ('c -> 'd) -> 'c pguard_error -> 'd pguard_error val map_ptype_error : ('c -> 'd) -> ('c, 'c) ptype_error -> ('d, 'd) ptype_error diff --git a/kernel/vmbytecodes.ml b/kernel/vmbytecodes.ml index c156a21c86..4977aec00a 100644 --- a/kernel/vmbytecodes.ml +++ b/kernel/vmbytecodes.ml @@ -56,13 +56,12 @@ type instruction = | Kfield of int | Ksetfield of int | Kstop - | Ksequence of bytecodes * bytecodes + | Ksequence of bytecodes | Kproj of Projection.Repr.t | Kensurestackcapacity of int | Kbranch of Label.t (* jump to label *) - | Kprim of CPrimitives.t * pconstant option + | Kprim of CPrimitives.t * pconstant | Kcamlprim of CPrimitives.t * Label.t - | Kareint of int and bytecodes = instruction list @@ -146,21 +145,19 @@ let rec pp_instr i = | Kensurestackcapacity size -> str "growstack " ++ int size | Kprim (op, id) -> str (CPrimitives.to_string op) ++ str " " ++ - (match id with Some (id,_u) -> Constant.print id | None -> str "") + (Constant.print (fst id)) | Kcamlprim (op, lbl) -> str "camlcall " ++ str (CPrimitives.to_string op) ++ spc () ++ pp_lbl lbl - | Kareint n -> str "areint " ++ int n - and pp_bytecodes c = match c with | [] -> str "" | Klabel lbl :: c -> str "L" ++ int lbl ++ str ":" ++ fnl () ++ pp_bytecodes c - | Ksequence (l1, l2) :: c -> - pp_bytecodes l1 ++ pp_bytecodes l2 ++ pp_bytecodes c + | Ksequence l :: c -> + pp_bytecodes l ++ pp_bytecodes c | i :: c -> pp_instr i ++ fnl () ++ pp_bytecodes c diff --git a/kernel/vmbytecodes.mli b/kernel/vmbytecodes.mli index b703058fb7..003a77ab78 100644 --- a/kernel/vmbytecodes.mli +++ b/kernel/vmbytecodes.mli @@ -54,14 +54,13 @@ type instruction = | Kfield of int (** accu = accu[n] *) | Ksetfield of int (** accu[n] = sp[0] ; sp = pop sp *) | Kstop - | Ksequence of bytecodes * bytecodes + | Ksequence of bytecodes | Kproj of Projection.Repr.t | Kensurestackcapacity of int | Kbranch of Label.t (** jump to label, is it needed ? *) - | Kprim of CPrimitives.t * pconstant option + | Kprim of CPrimitives.t * pconstant | Kcamlprim of CPrimitives.t * Label.t - | Kareint of int and bytecodes = instruction list diff --git a/kernel/vmbytegen.ml b/kernel/vmbytegen.ml index 16a0f42664..70c92fd8f0 100644 --- a/kernel/vmbytegen.ml +++ b/kernel/vmbytegen.ml @@ -315,12 +315,10 @@ let pos_evar evk r = (* non-terminating instruction (branch, raise, return, appterm) *) (* in front of it. *) -let discard_dead_code cont = cont -(*function - [] -> [] +let rec discard_dead_code = function + | [] -> [] | (Klabel _ | Krestart ) :: _ as cont -> cont | _ :: cont -> discard_dead_code cont -*) (* Return a label to the beginning of the given continuation. *) (* If the sequence starts with a branch, use the target of that branch *) @@ -581,7 +579,7 @@ let rec compile_lam env cenv lam sz cont = let cont_fun = ensure_stack_capacity (compile_lam env r_fun body arity) [Kreturn arity] in - fun_code := [Ksequence(add_grab arity lbl_fun cont_fun,!fun_code)]; + fun_code := Ksequence (add_grab arity lbl_fun cont_fun) :: !fun_code; let fv = fv r_fun in compile_fv cenv fv.fv_rev sz (Kclosure(lbl_fun,fv.size) :: cont) @@ -604,7 +602,7 @@ let rec compile_lam env cenv lam sz cont = in let lbl,fcode = label_code fcode in lbl_types.(i) <- lbl; - fun_code := [Ksequence(fcode,!fun_code)] + fun_code := Ksequence fcode :: !fun_code done; (* Compiling bodies *) for i = 0 to ndef - 1 do @@ -617,7 +615,7 @@ let rec compile_lam env cenv lam sz cont = let lbl = Label.create () in lbl_bodies.(i) <- lbl; let fcode = add_grabrec rec_args.(i) arity lbl cont1 in - fun_code := [Ksequence(fcode,!fun_code)] + fun_code := Ksequence fcode :: !fun_code done; let fv = !rfv in compile_fv cenv fv.fv_rev sz @@ -637,7 +635,7 @@ let rec compile_lam env cenv lam sz cont = in let lbl,fcode = label_code fcode in lbl_types.(i) <- lbl; - fun_code := [Ksequence(fcode,!fun_code)] + fun_code := Ksequence fcode :: !fun_code done; (* Compiling bodies *) for i = 0 to ndef - 1 do @@ -652,25 +650,13 @@ let rec compile_lam env cenv lam sz cont = in let cont = ensure_stack_capacity comp arity in lbl_bodies.(i) <- lbl; - fun_code := [Ksequence(add_grab (arity+1) lbl cont,!fun_code)]; + fun_code := Ksequence (add_grab (arity+1) lbl cont) :: !fun_code; done; let fv = !rfv in set_max_stack_size (sz + fv.size + ndef + 2); compile_fv cenv fv.fv_rev sz (Kclosurecofix(fv.size, init, lbl_types, lbl_bodies) :: cont) - | Lif(t, bt, bf) -> - let branch, cont = make_branch cont in - let lbl_true = Label.create() in - let lbl_false = Label.create() in - compile_lam env cenv t sz - (Kswitch([|lbl_true;lbl_false|],[||]) :: - Klabel lbl_false :: - compile_lam env cenv bf sz - (branch :: - Klabel lbl_true :: - compile_lam env cenv bt sz cont)) - | Lcase(ci,rtbl,t,a,branches) -> let ind = ci.ci_ind in let mib = lookup_mind (fst ind) env in @@ -688,7 +674,7 @@ let rec compile_lam env cenv lam sz cont = ensure_stack_capacity (compile_lam env cenv t sz) [Kpop sz; Kstop] in let lbl_typ,fcode = label_code fcode in - fun_code := [Ksequence(fcode,!fun_code)]; + fun_code := Ksequence fcode :: !fun_code; (* Compilation of the branches *) let lbl_sw = Label.create () in let sz_b,branch,is_tailcall = @@ -700,6 +686,7 @@ let rec compile_lam env cenv lam sz cont = | _ -> assert false in + let cont = discard_dead_code cont in let c = ref cont in (* Perform the extra match if needed (too many block constructors) *) if neblock <> 0 then begin @@ -770,7 +757,7 @@ let rec compile_lam env cenv lam sz cont = let cont = code_makeblock ~stack_size:(sz+arity-1) ~arity ~tag cont in comp_args (compile_lam env) cenv args sz cont - | Lprim (Some (kn,u), op, args) when is_caml_prim op -> + | Lprim ((kn,u), op, args) when is_caml_prim op -> let arity = CPrimitives.arity op in let nparams = CPrimitives.nparams op in let nargs = arity - nparams in @@ -788,7 +775,7 @@ let rec compile_lam env cenv lam sz cont = if Int.equal nparams 0 then cont else comp_args (compile_lam env) cenv (Array.sub args 0 nparams) (sz + nargs) (Kpush::cont) in - fun_code := [Ksequence(default, !fun_code)]; + fun_code := Ksequence default :: !fun_code; comp_args (compile_lam env) cenv (Array.sub args nparams nargs) sz (Kcamlprim (op, lbl_default) :: cont) | Lprim (kn, op, args) -> @@ -878,7 +865,7 @@ let compile ~fail_on_error ?universes:(universes=0) env c = ensure_stack_capacity (compile_lam env r_fun body full_arity) [Kreturn full_arity] in - fun_code := [Ksequence(add_grab full_arity lbl_fun cont_fun,!fun_code)]; + fun_code := Ksequence (add_grab full_arity lbl_fun cont_fun) :: !fun_code; let fv = fv r_fun in let init_code = ensure_stack_capacity (compile_fv cenv fv.fv_rev 0) diff --git a/kernel/vmemitcodes.ml b/kernel/vmemitcodes.ml index babc57794b..c1d8fcb855 100644 --- a/kernel/vmemitcodes.ml +++ b/kernel/vmemitcodes.ml @@ -208,14 +208,6 @@ let slot_for_caml_prim env op = (* Emission of one instruction *) -let nocheck_prim_op = function - | Int63add -> opADDINT63 - | Int63sub -> opSUBINT63 - | Int63lt -> opLTINT63 - | Int63le -> opLEINT63 - | _ -> assert false - - let check_prim_op = function | Int63head0 -> opCHECKHEAD0INT63 | Int63tail0 -> opCHECKTAIL0INT63 @@ -259,11 +251,20 @@ let check_prim_op = function | Float64ldshiftexp -> opCHECKLDSHIFTEXP | Float64next_up -> opCHECKNEXTUPFLOAT | Float64next_down -> opCHECKNEXTDOWNFLOAT - | Arraymake -> opISINT_CAML_CALL2 - | Arrayget -> opISARRAY_INT_CAML_CALL2 - | Arrayset -> opISARRAY_INT_CAML_CALL3 + | Arraymake -> opCHECKCAMLCALL2_1 + | Arrayget -> opCHECKCAMLCALL2 + | Arrayset -> opCHECKCAMLCALL3_1 | Arraydefault | Arraycopy | Arraylength -> - opISARRAY_CAML_CALL1 + opCHECKCAMLCALL1 + +let inplace_prim_op = function + | Float64next_up | Float64next_down -> true + | _ -> false + +let check_prim_op_inplace = function + | Float64next_up -> opCHECKNEXTUPFLOATINPLACE + | Float64next_down -> opCHECKNEXTDOWNFLOATINPLACE + | _ -> assert false let emit_instr env = function | Klabel lbl -> define_label env lbl @@ -354,10 +355,7 @@ let emit_instr env = function | Kproj p -> out env opPROJ; out_int env (Projection.Repr.arg p); slot_for_proj_name env p | Kensurestackcapacity size -> out env opENSURESTACKCAPACITY; out_int env size | Kbranch lbl -> out env opBRANCH; out_label env lbl - | Kprim (op,None) -> - out env (nocheck_prim_op op) - - | Kprim(op,Some (q,_u)) -> + | Kprim (op, (q,_u)) -> out env (check_prim_op op); slot_for_getglobal env q @@ -366,13 +364,8 @@ let emit_instr env = function out_label env lbl; slot_for_caml_prim env op - | Kareint 1 -> out env opISINT - | Kareint 2 -> out env opAREINT2; - | Kstop -> out env opSTOP - | Kareint _ -> assert false - (* Emission of a current list and remaining lists of instructions. Include some peephole optimization. *) let rec emit env insns remaining = match insns with @@ -406,8 +399,14 @@ let rec emit env insns remaining = match insns with emit env c remaining | Kpop n :: Kjump :: c -> out env opRETURN; out_int env n; emit env c remaining - | Ksequence(c1,c2)::c -> - emit env c1 (c2::c::remaining) + | Ksequence c1 :: c -> + emit env c1 (c :: remaining) + | Kprim (op1, (q1, _)) :: Kprim (op2, (q2, _)) :: c when inplace_prim_op op2 -> + out env (check_prim_op op1); + slot_for_getglobal env q1; + out env (check_prim_op_inplace op2); + slot_for_getglobal env q2; + emit env c remaining (* Default case *) | instr :: c -> emit_instr env instr; emit env c remaining diff --git a/kernel/vmlambda.ml b/kernel/vmlambda.ml index 332a331a7a..9cca204e8c 100644 --- a/kernel/vmlambda.ml +++ b/kernel/vmlambda.ml @@ -19,10 +19,8 @@ type lambda = | Llet of Name.t Context.binder_annot * lambda * lambda | Lapp of lambda * lambda array | Lconst of pconstant - | Lprim of pconstant option * CPrimitives.t * lambda array - (* No check if None *) + | Lprim of pconstant * CPrimitives.t * lambda array | Lcase of case_info * reloc_table * lambda * lambda * lam_branches - | Lif of lambda * lambda * lambda | Lfix of (int array * int) * fix_decl | Lcofix of int * fix_decl | Lint of int @@ -112,10 +110,6 @@ let rec pp_lam lam = pp_names ids ++ str " => " ++ pp_lam c) (Array.to_list branches.nonconstant_branches))) ++ cut() ++ str "end") - | Lif (t, bt, bf) -> - v 0 (str "(if " ++ pp_lam t ++ - cut () ++ str "then " ++ pp_lam bt ++ - cut() ++ str "else " ++ pp_lam bf ++ str ")") | Lfix((t,i),(lna,tl,bl)) -> let fixl = Array.mapi (fun i id -> (id,t.(i),tl.(i),bl.(i))) lna in hov 1 @@ -148,16 +142,11 @@ let rec pp_lam lam = | Lval _ -> str "values" | Lsort s -> pp_sort s | Lind ((mind,i), _) -> MutInd.print mind ++ str"#" ++ int i - | Lprim(Some (kn,_u),_op,args) -> + | Lprim ((kn,_u),_op,args) -> hov 1 (str "(PRIM " ++ pr_con kn ++ spc() ++ prlist_with_sep spc pp_lam (Array.to_list args) ++ str")") - | Lprim(None,op,args) -> - hov 1 - (str "(PRIM_NC " ++ str (CPrimitives.to_string op) ++ spc() ++ - prlist_with_sep spc pp_lam (Array.to_list args) ++ - str")") | Lproj(p,arg) -> hov 1 (str "(proj " ++ Projection.Repr.print p ++ str "(" ++ pp_lam arg @@ -237,11 +226,6 @@ let map_lam_with_binders g f n lam = in if t == t' && a == a' && branches == branches' then lam else Lcase(ci,rtbl,t',a',branches') - | Lif(t,bt,bf) -> - let t' = f n t in - let bt' = f n bt in - let bf' = f n bf in - if t == t' && bt == bt' && bf == bf' then lam else Lif(t',bt',bf') | Lfix(init,(ids,ltypes,lbodies)) -> let ltypes' = Array.Smart.map (f n) ltypes in let lbodies' = Array.Smart.map (f (g (Array.length ids) n)) lbodies in @@ -312,28 +296,6 @@ let can_subst lam = | Lval _ | Lsort _ | Lind _ -> true | _ -> false - -let can_merge_if bt bf = - match bt, bf with - | Llam(_idst,_), Llam(_idsf,_) -> true - | _ -> false - -let merge_if t bt bf = - let (idst,bodyt) = decompose_Llam bt in - let (idsf,bodyf) = decompose_Llam bf in - let nt = Array.length idst in - let nf = Array.length idsf in - let common,idst,idsf = - if nt = nf then idst, [||], [||] - else - if nt < nf then idst,[||], Array.sub idsf nt (nf - nt) - else idsf, Array.sub idst nf (nt - nf), [||] in - Llam(common, - Lif(lam_lift (Array.length common) t, - mkLlam idst bodyt, - mkLlam idsf bodyf)) - - let rec simplify subst lam = match lam with | Lrel(id,i) -> lam_subst_rel lam id i subst @@ -352,14 +314,6 @@ let rec simplify subst lam = | lam' -> lam' end - | Lif(t,bt,bf) -> - let t' = simplify subst t in - let bt' = simplify subst bt in - let bf' = simplify subst bf in - if can_merge_if bt' bf' then merge_if t' bt' bf' - else - if t == t' && bt == bt' && bf == bf' then lam - else Lif(t',bt',bf') | _ -> map_lam_with_binders liftn simplify subst lam and simplify_app substf f substa args = @@ -442,9 +396,6 @@ let rec occurrence k kind lam = in Array.iter on_b branches.nonconstant_branches; !r - | Lif (t, bt, bf) -> - let kind = occurrence k kind t in - kind && occurrence k kind bt && occurrence k kind bf | Lfix(_,(ids,ltypes,lbodies)) | Lcofix(_,(ids,ltypes,lbodies)) -> let kind = occurrence_args k kind ltypes in @@ -566,7 +517,7 @@ let rec get_alias env kn = (* Compilation of primitive *) let prim kn p args = - Lprim(Some kn, p, args) + Lprim (kn, p, args) let expand_prim kn op arity = (* primitives are always Relevant *) diff --git a/kernel/vmlambda.mli b/kernel/vmlambda.mli index bd11c2667f..ad5f81638f 100644 --- a/kernel/vmlambda.mli +++ b/kernel/vmlambda.mli @@ -12,10 +12,8 @@ type lambda = | Llet of Name.t Context.binder_annot * lambda * lambda | Lapp of lambda * lambda array | Lconst of pconstant - | Lprim of pconstant option * CPrimitives.t * lambda array - (* No check if None *) + | Lprim of pconstant * CPrimitives.t * lambda array | Lcase of case_info * reloc_table * lambda * lambda * lam_branches - | Lif of lambda * lambda * lambda | Lfix of (int array * int) * fix_decl | Lcofix of int * fix_decl | Lint of int diff --git a/kernel/vmvalues.ml b/kernel/vmvalues.ml index 7b4101b9d0..9944458d6b 100644 --- a/kernel/vmvalues.ml +++ b/kernel/vmvalues.ml @@ -381,7 +381,15 @@ let rec whd_accu a stk = CErrors.anomaly Pp.(strbrk "Failed to parse VM value. Tag = " ++ int tg ++ str ".") -external kind_of_closure : Obj.t -> int = "coq_kind_of_closure" +[@@@warning "-37"] +type vm_closure_kind = + | VCfun (** closure, or fixpoint applied past the recursive argument *) + | VCfix (** unapplied fixpoint *) + | VCfix_partial (** partially applied fixpoint, but not sufficiently for recursion *) + | VCaccu (** accumulator *) +[@@@warning "+37"] + +external kind_of_closure : Obj.t -> vm_closure_kind = "coq_kind_of_closure" external is_accumulate : tcode -> bool = "coq_is_accumulate_code" external int_tcode : tcode -> int -> int = "coq_int_tcode" external accumulate : unit -> tcode = "accumulate_code" @@ -400,12 +408,11 @@ let whd_val (v: values) = else if Int.equal tag Obj.closure_tag && is_accumulate (fun_code o) then whd_accu o [] else if Int.equal tag Obj.closure_tag || Int.equal tag Obj.infix_tag then - (match kind_of_closure o with - | 0 -> Vfun(Obj.obj o) - | 1 -> Vfix(Obj.obj o, None) - | 2 -> Vfix(Obj.obj (Obj.field o 2), Some (Obj.obj o)) - | 3 -> Vatom_stk(Aid(RelKey(int_tcode (fun_code o) 1)), []) - | _ -> CErrors.anomaly ~label:"Vm.whd " (Pp.str "kind_of_closure does not work.")) + match kind_of_closure o with + | VCfun -> Vfun (Obj.obj o) + | VCfix -> Vfix (Obj.obj o, None) + | VCfix_partial -> Vfix (Obj.obj (Obj.field o 2), Some (Obj.obj o)) + | VCaccu -> Vatom_stk (Aid (RelKey (int_tcode (fun_code o) 1)), []) else if Int.equal tag Obj.custom_tag then Vint64 (Obj.magic v) else if Int.equal tag Obj.double_tag then Vfloat64 (Obj.magic v) else diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index ecfe6c1664..072206c39c 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -234,9 +234,7 @@ GRAMMAR EXTEND Gram ; occs_nums: [ [ nl = LIST1 nat_or_var -> { OnlyOccurrences nl } - | "-"; n = nat_or_var; nl = LIST0 int_or_var -> - (* have used int_or_var instead of nat_or_var for compatibility *) - { AllOccurrencesBut (List.map (Locusops.or_var_map abs) (n::nl)) } ] ] + | "-"; nl = LIST1 nat_or_var -> { AllOccurrencesBut nl } ] ] ; occs: [ [ "at"; occs = occs_nums -> { occs } | -> { AllOccurrences } ] ] @@ -379,9 +377,11 @@ GRAMMAR EXTEND Gram { {onhyps=None; concl_occs=occs} } | "*"; "|-"; occs=concl_occ -> { {onhyps=None; concl_occs=occs} } - | hl=LIST0 hypident_occ SEP","; "|-"; occs=concl_occ -> + | "|-"; occs=concl_occ -> + { {onhyps=Some []; concl_occs=occs} } + | hl = LIST1 hypident_occ SEP ","; "|-"; occs=concl_occ -> { {onhyps=Some hl; concl_occs=occs} } - | hl=LIST0 hypident_occ SEP"," -> + | hl = LIST1 hypident_occ SEP "," -> { {onhyps=Some hl; concl_occs=NoOccurrences} } ] ] ; clause_dft_concl: @@ -450,6 +450,11 @@ GRAMMAR EXTEND Gram ; as_or_and_ipat: [ [ "as"; ipat = or_and_intropattern_loc -> { Some ipat } + | "as"; ipat = equality_intropattern -> + { match ipat with + | IntroRewrite _ -> user_err Pp.(str "Disjunctive/conjunctive pattern expected.") + | IntroInjection _ -> user_err Pp.(strbrk "Found an injection pattern while a disjunctive/conjunctive pattern was expected; use " ++ str "\"injection as pattern\"" ++ strbrk " instead.") + | _ -> assert false } | -> { None } ] ] ; eqn_ipat: diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 26e2b18a02..77162ce89a 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -13,7 +13,6 @@ open CErrors open Util open Names open Nameops -open Namegen open Constr open Context open EConstr @@ -485,7 +484,7 @@ let rec decompose_app_rel env evd t = let (f', argl, argr) = decompose_app_rel env evd arg in let ty = Retyping.get_type_of env evd argl in let r = Retyping.relevance_of_type env evd ty in - let f'' = mkLambda (make_annot (Name default_dependent_ident) r, ty, + let f'' = mkLambda (make_annot (Name Namegen.default_dependent_ident) r, ty, mkLambda (make_annot (Name (Id.of_string "y")) r, lift 1 ty, mkApp (lift 2 f, [| mkApp (lift 2 f', [| mkRel 2; mkRel 1 |]) |]))) in (f'', argl, argr) @@ -1119,7 +1118,14 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = *) | Lambda (n, t, b) when flags.under_lambdas -> - let n' = map_annot (Nameops.Name.map (fun id -> Tactics.fresh_id_in_env unfresh id env)) n in + let unfresh, n' = + let id = match n.binder_name with + | Anonymous -> Namegen.default_dependent_ident + | Name id -> id + in + let id = Tactics.fresh_id_in_env unfresh id env in + Id.Set.add id unfresh, {n with binder_name = Name id} + in let unfresh = match n'.binder_name with | Anonymous -> unfresh | Name id -> Id.Set.add id unfresh @@ -1542,7 +1548,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = (* For compatibility *) let beta = Tactics.reduct_in_concl ~check:false (Reductionops.nf_betaiota, DEFAULTcast) in let beta_hyp id = Tactics.reduct_in_hyp ~check:false ~reorder:false Reductionops.nf_betaiota (id, InHyp) in - let treat sigma res = + let treat sigma res state = match res with | None -> newfail 0 (str "Nothing to rewrite") | Some None -> @@ -1553,7 +1559,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = let (undef, prf, newt) = res in let fold ev _ accu = if Evd.mem sigma ev then accu else ev :: accu in let gls = List.rev (Evd.fold_undefined fold undef []) in - let gls = List.map Proofview.with_empty_state gls in + let gls = List.map (fun gl -> Proofview.goal_with_state gl state) gls in match clause, prf with | Some id, Some p -> let tac = tclTHENLIST [ @@ -1583,6 +1589,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = Proofview.Goal.enter begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in + let state = Proofview.Goal.state gl in let sigma = Tacmach.New.project gl in let ty = match clause with | None -> concl @@ -1602,7 +1609,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = cl_rewrite_clause_aux ?abs strat env Id.Set.empty sigma ty clause in let sigma = match origsigma with None -> sigma | Some sigma -> sigma in - treat sigma res <*> + treat sigma res state <*> (* For compatibility *) beta <*> Proofview.shelve_unifiable with diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml index 3360a9a51c..21178a64a5 100644 --- a/plugins/micromega/persistent_cache.ml +++ b/plugins/micromega/persistent_cache.ml @@ -36,10 +36,8 @@ module PHashtable (Key : HashedType) : PHashtable with type key = Key.t = struct module Table = Hashtbl.Make (Key) exception InvalidTableFormat - exception UnboundTable - type mode = Closed | Open - type 'a t = {outch : out_channel; mutable status : mode; htbl : 'a Table.t} + type 'a t = {outch : out_channel; htbl : 'a Table.t} (* XXX: Move to Fun.protect once in Ocaml 4.08 *) let fun_protect ~(finally : unit -> unit) work = @@ -118,7 +116,6 @@ module PHashtable (Key : HashedType) : PHashtable with type key = Key.t = struct close_in_noerr inch; { outch = out_channel_of_descr (openfile f [O_WRONLY; O_APPEND; O_CREAT] 0o666) - ; status = Open ; htbl } with InvalidTableFormat -> (* The file is corrupted *) @@ -131,24 +128,20 @@ module PHashtable (Key : HashedType) : PHashtable with type key = Key.t = struct (fun k e -> Marshal.to_channel outch (k, e) [Marshal.No_sharing]) htbl; flush outch); - {outch; status = Open; htbl} + {outch; htbl} let add t k e = - let {outch; status; htbl = tbl} = t in - if status == Closed then raise UnboundTable - else - let fd = descr_of_out_channel outch in - Table.add tbl k e; - do_under_lock Write fd (fun _ -> - Marshal.to_channel outch (k, e) [Marshal.No_sharing]; - flush outch) + let {outch; htbl = tbl} = t in + let fd = descr_of_out_channel outch in + Table.add tbl k e; + do_under_lock Write fd (fun _ -> + Marshal.to_channel outch (k, e) [Marshal.No_sharing]; + flush outch) let find t k = - let {outch; status; htbl = tbl} = t in - if status == Closed then raise UnboundTable - else - let res = Table.find tbl k in - res + let {outch; htbl = tbl} = t in + let res = Table.find tbl k in + res let memo cache f = let tbl = lazy (try Some (open_in cache) with _ -> None) in diff --git a/plugins/ring/ring.ml b/plugins/ring/ring.ml index 9c75175889..292fbefb84 100644 --- a/plugins/ring/ring.ml +++ b/plugins/ring/ring.ml @@ -71,7 +71,7 @@ let add_map s m = protect_maps := String.Map.add s m !protect_maps let lookup_map map = try String.Map.find map !protect_maps with Not_found -> - CErrors.user_err ~hdr:"lookup_map" (str"map "++qs map++str"not found") + CErrors.user_err ~hdr:"lookup_map" (str"Map "++qs map++str"not found") let protect_red map env sigma c0 = let evars ev = Evarutil.safe_evar_value sigma ev in @@ -135,15 +135,11 @@ let _ = add_tacdef false ((Loc.ghost,Id.of_string"ring_closed_term" (****************************************************************************) -let ic c = - let env = Global.env() in - let sigma = Evd.from_env env in +let ic env sigma c = let c, uctx = Constrintern.interp_constr env sigma c in (Evd.from_ctx uctx, c) -let ic_unsafe c = (*FIXME remove *) - let env = Global.env() in - let sigma = Evd.from_env env in +let ic_unsafe env sigma c = (*FIXME remove *) fst (Constrintern.interp_constr env sigma c) let decl_constant name univs c = @@ -170,8 +166,8 @@ let dummy_goal env sigma = Goal.V82.mk_goal sigma (named_context_val env) EConstr.mkProp in {Evd.it = gl; Evd.sigma = sigma} -let constr_of evd v = match Value.to_constr v with - | Some c -> EConstr.to_constr evd c +let constr_of sigma v = match Value.to_constr v with + | Some c -> EConstr.to_constr sigma c | None -> failwith "Ring.exec_tactic: anomaly" let tactic_res = ref [||] @@ -189,7 +185,7 @@ let get_res = Tacenv.register_ml_tactic name [| tac |]; entry -let exec_tactic env evd n f args = +let exec_tactic env sigma n f args = let fold arg (i, vars, lfun) = let id = Id.of_string ("x" ^ string_of_int i) in let x = Reference (ArgVar CAst.(make id)) in @@ -203,11 +199,11 @@ let exec_tactic env evd n f args = let get_res = TacML (CAst.make (get_res, [TacGeneric (None, n)])) in let getter = Tacexp (TacFun (List.map (fun n -> Name n) lid, get_res)) in (* Evaluate the whole result *) - let gl = dummy_goal env evd in + let gl = dummy_goal env sigma in let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic_ist ist (ltac_call f (args@[getter]))) gl in - let evd = Evd.minimize_universes gls.Evd.sigma in - let nf c = constr_of evd c in - Array.map nf !tactic_res, Evd.universe_context_set evd + let sigma = Evd.minimize_universes gls.Evd.sigma in + let nf c = constr_of sigma c in + Array.map nf !tactic_res, Evd.universe_context_set sigma let gen_constant n = lazy (EConstr.of_constr (UnivGen.constr_of_monomorphic_global (Coqlib.lib_ref n))) let gen_reference n = lazy (Coqlib.lib_ref n) @@ -222,10 +218,9 @@ let coq_nil = gen_reference "core.list.nil" let lapp f args = mkApp(Lazy.force f,args) -let plapp evdref f args = - let evd, fc = Evarutil.new_global !evdref (Lazy.force f) in - evdref := evd; - mkApp(fc,args) +let plapp sigma f args = + let sigma, fc = Evarutil.new_global sigma (Lazy.force f) in + sigma, mkApp(fc,args) let dest_rel0 sigma t = match EConstr.kind sigma t with @@ -351,14 +346,14 @@ let find_ring_structure env sigma l = let ty' = Retyping.get_type_of env sigma c in if not (Reductionops.is_conv env sigma ty ty') then CErrors.user_err ~hdr:"ring" - (str"arguments of ring_simplify do not have all the same type") + (str"Arguments of ring_simplify do not have all the same type.") in List.iter check cl'; (try ring_for_carrier (EConstr.to_constr sigma ty) with Not_found -> CErrors.user_err ~hdr:"ring" - (str"cannot find a declared ring structure over"++ - spc() ++ str"\"" ++ pr_econstr_env env sigma ty ++ str"\"")) + (str"Cannot find a declared ring structure over"++ + spc() ++ str"\"" ++ pr_econstr_env env sigma ty ++ str"\".")) | [] -> assert false let add_entry e = @@ -411,16 +406,14 @@ let theory_to_obj : ring_info -> obj = ~cache:cache_th ~subst:(Some subst_th) -let setoid_of_relation env evd a r = +let setoid_of_relation env sigma a r = try - let evm = !evd in - let evm, refl = Rewrite.get_reflexive_proof env evm a r in - let evm, sym = Rewrite.get_symmetric_proof env evm a r in - let evm, trans = Rewrite.get_transitive_proof env evm a r in - evd := evm; - lapp coq_mk_Setoid [|a ; r ; refl; sym; trans |] + let sigma, refl = Rewrite.get_reflexive_proof env sigma a r in + let sigma, sym = Rewrite.get_symmetric_proof env sigma a r in + let sigma, trans = Rewrite.get_transitive_proof env sigma a r in + sigma, lapp coq_mk_Setoid [|a ; r ; refl; sym; trans |] with Not_found -> - error "cannot find setoid relation" + CErrors.user_err (str "Cannot find a setoid structure for relation " ++ pr_econstr_env env sigma r ++ str ".") let op_morph r add mul opp req m1 m2 m3 = lapp coq_mk_reqe [| r; add; mul; opp; req; m1; m2; m3 |] @@ -428,61 +421,59 @@ let op_morph r add mul opp req m1 m2 m3 = let op_smorph r add mul req m1 m2 = lapp coq_mk_seqe [| r; add; mul; req; m1; m2 |] -let ring_equality env evd (r,add,mul,opp,req) = - match EConstr.kind !evd req with - | App (f, [| _ |]) when eq_constr_nounivs !evd f (Lazy.force coq_eq) -> - let setoid = plapp evd coq_eq_setoid [|r|] in - let op_morph = +let ring_equality env sigma (r,add,mul,opp,req) = + match EConstr.kind sigma req with + | App (f, [| _ |]) when eq_constr_nounivs sigma f (Lazy.force coq_eq) -> + let sigma, setoid = plapp sigma coq_eq_setoid [|r|] in + let sigma, op_morph = match opp with - Some opp -> plapp evd coq_eq_morph [|r;add;mul;opp|] - | None -> plapp evd coq_eq_smorph [|r;add;mul|] in - let sigma = !evd in + Some opp -> plapp sigma coq_eq_morph [|r;add;mul;opp|] + | None -> plapp sigma coq_eq_smorph [|r;add;mul|] in let sigma, setoid = Typing.solve_evars env sigma setoid in let sigma, op_morph = Typing.solve_evars env sigma op_morph in - evd := sigma; (setoid,op_morph) | _ -> - let setoid = setoid_of_relation (Global.env ()) evd r req in + let sigma, setoid = setoid_of_relation env sigma r req in let signature = [Some (r,Some req);Some (r,Some req)],Some(r,Some req) in let add_m, add_m_lem = try Rewrite.default_morphism signature add with Not_found -> - error "ring addition should be declared as a morphism" in + CErrors.user_err (str "Ring addition " ++ pr_econstr_env env sigma add ++ str " should be declared as a morphism.") in let mul_m, mul_m_lem = try Rewrite.default_morphism signature mul with Not_found -> - error "ring multiplication should be declared as a morphism" in + CErrors.user_err (str "Ring multiplication " ++ pr_econstr_env env sigma mul ++ str " should be declared as a morphism.") in let op_morph = match opp with | Some opp -> (let opp_m,opp_m_lem = try Rewrite.default_morphism ([Some(r,Some req)],Some(r,Some req)) opp with Not_found -> - error "ring opposite should be declared as a morphism" in + CErrors.user_err (str "Ring opposite " ++ pr_econstr_env env sigma opp ++ str " should be declared as a morphism.") in let op_morph = op_morph r add mul opp req add_m_lem mul_m_lem opp_m_lem in Flags.if_verbose Feedback.msg_info - (str"Using setoid \""++ pr_econstr_env env !evd req++str"\""++spc()++ - str"and morphisms \""++pr_econstr_env env !evd add_m_lem ++ - str"\","++spc()++ str"\""++pr_econstr_env env !evd mul_m_lem++ - str"\""++spc()++str"and \""++pr_econstr_env env !evd opp_m_lem++ + (str"Using setoid \""++ pr_econstr_env env sigma req++str"\""++spc()++ + str"and morphisms \""++pr_econstr_env env sigma add_m ++ + str"\","++spc()++ str"\""++pr_econstr_env env sigma mul_m++ + str"\""++spc()++str"and \""++pr_econstr_env env sigma opp_m++ str"\""); op_morph) | None -> (Flags.if_verbose Feedback.msg_info - (str"Using setoid \""++pr_econstr_env env !evd req ++str"\"" ++ spc() ++ - str"and morphisms \""++pr_econstr_env env !evd add_m_lem ++ + (str"Using setoid \""++pr_econstr_env env sigma req ++str"\"" ++ spc() ++ + str"and morphisms \""++pr_econstr_env env sigma add_m ++ str"\""++spc()++str"and \""++ - pr_econstr_env env !evd mul_m_lem++str"\""); + pr_econstr_env env sigma mul_m++str"\""); op_smorph r add mul req add_m_lem mul_m_lem) in (setoid,op_morph) -let build_setoid_params env evd r add mul opp req eqth = +let build_setoid_params env sigma r add mul opp req eqth = match eqth with Some th -> th - | None -> ring_equality env evd (r,add,mul,opp,req) + | None -> ring_equality env sigma (r,add,mul,opp,req) let dest_ring env sigma th_spec = let th_typ = Retyping.get_type_of env sigma th_spec in @@ -515,71 +506,69 @@ let interp_cst_tac env sigma rk kind (zero,one,add,mul,opp) cst_tac = let t = ArgArg(Loc.tag @@ Lazy.force ltac_inv_morph_nothing) in TacArg(CAst.make (TacCall(CAst.make (t,[])))) -let make_hyp env evd c = - let t = Retyping.get_type_of env !evd c in - plapp evd coq_mkhypo [|t;c|] +let make_hyp env sigma c = + let t = Retyping.get_type_of env sigma c in + plapp sigma coq_mkhypo [|t;c|] -let make_hyp_list env evdref lH = - let evd, carrier = Evarutil.new_global !evdref (Lazy.force coq_hypo) in - evdref := evd; - let l = +let make_hyp_list env sigma lH = + let sigma, carrier = Evarutil.new_global sigma (Lazy.force coq_hypo) in + let sigma, l = List.fold_right - (fun c l -> plapp evdref coq_cons [|carrier; (make_hyp env evdref c); l|]) lH - (plapp evdref coq_nil [|carrier|]) + (fun c (sigma,l) -> + let sigma, c = make_hyp env sigma c in + plapp sigma coq_cons [|carrier; c; l|]) lH + (plapp sigma coq_nil [|carrier|]) in - let sigma, l' = Typing.solve_evars env !evdref l in - evdref := sigma; + let sigma, l' = Typing.solve_evars env sigma l in let l' = EConstr.Unsafe.to_constr l' in - Evarutil.nf_evars_universes !evdref l' + sigma, Evarutil.nf_evars_universes sigma l' -let interp_power env evdref pow = - let evd, carrier = Evarutil.new_global !evdref (Lazy.force coq_hypo) in - evdref := evd; +let interp_power env sigma pow = + let sigma, carrier = Evarutil.new_global sigma (Lazy.force coq_hypo) in match pow with | None -> let t = ArgArg(Loc.tag (Lazy.force ltac_inv_morph_nothing)) in - (TacArg(CAst.make (TacCall(CAst.make (t,[])))), plapp evdref coq_None [|carrier|]) + let sigma, c = plapp sigma coq_None [|carrier|] in + sigma, (TacArg(CAst.make (TacCall(CAst.make (t,[])))), c) | Some (tac, spec) -> let tac = match tac with | CstTac t -> Tacintern.glob_tactic t | Closed lc -> closed_term_ast (List.map Smartlocate.global_with_alias lc) in - let spec = make_hyp env evdref (ic_unsafe spec) in - (tac, plapp evdref coq_Some [|carrier; spec|]) + let spec = ic_unsafe env sigma spec in + let sigma, spec = make_hyp env sigma spec in + let sigma, pow = plapp sigma coq_Some [|carrier; spec|] in + sigma, (tac, pow) -let interp_sign env evdref sign = - let evd, carrier = Evarutil.new_global !evdref (Lazy.force coq_hypo) in - evdref := evd; +let interp_sign env sigma sign = + let sigma, carrier = Evarutil.new_global sigma (Lazy.force coq_hypo) in match sign with - | None -> plapp evdref coq_None [|carrier|] + | None -> plapp sigma coq_None [|carrier|] | Some spec -> - let spec = make_hyp env evdref (ic_unsafe spec) in - plapp evdref coq_Some [|carrier;spec|] + let sigma, spec = make_hyp env sigma (ic_unsafe env sigma spec) in + plapp sigma coq_Some [|carrier;spec|] (* Same remark on ill-typed terms ... *) -let interp_div env evdref div = - let evd, carrier = Evarutil.new_global !evdref (Lazy.force coq_hypo) in - evdref := evd; +let interp_div env sigma div = + let sigma, carrier = Evarutil.new_global sigma (Lazy.force coq_hypo) in match div with - | None -> plapp evdref coq_None [|carrier|] + | None -> plapp sigma coq_None [|carrier|] | Some spec -> - let spec = make_hyp env evdref (ic_unsafe spec) in - plapp evdref coq_Some [|carrier;spec|] + let sigma, spec = make_hyp env sigma (ic_unsafe env sigma spec) in + plapp sigma coq_Some [|carrier;spec|] (* Same remark on ill-typed terms ... *) -let add_theory0 name (sigma, rth) eqth morphth cst_tac (pre,post) power sign div = +let add_theory0 env sigma name rth eqth morphth cst_tac (pre,post) power sign div = check_required_library (cdir@["Ring_base"]); - let env = Global.env() in let (kind,r,zero,one,add,mul,sub,opp,req) = dest_ring env sigma rth in - let evd = ref sigma in - let (sth,ext) = build_setoid_params env evd r add mul opp req eqth in - let (pow_tac, pspec) = interp_power env evd power in - let sspec = interp_sign env evd sign in - let dspec = interp_div env evd div in + let (sth,ext) = build_setoid_params env sigma r add mul opp req eqth in + let sigma, (pow_tac, pspec) = interp_power env sigma power in + let sigma, sspec = interp_sign env sigma sign in + let sigma, dspec = interp_div env sigma div in let rk = reflect_coeff morphth in let params,ctx = - exec_tactic env !evd 5 (zltac "ring_lemmas") + exec_tactic env sigma 5 (zltac "ring_lemmas") [sth;ext;rth;pspec;sspec;dspec;rk] in let lemma1 = params.(3) in let lemma2 = params.(4) in @@ -619,16 +608,16 @@ let add_theory0 name (sigma, rth) eqth morphth cst_tac (pre,post) power sign div ring_post_tac = posttac }) in () -let ic_coeff_spec = function - | Computational t -> Computational (ic_unsafe t) - | Morphism t -> Morphism (ic_unsafe t) +let ic_coeff_spec env sigma = function + | Computational t -> Computational (ic_unsafe env sigma t) + | Morphism t -> Morphism (ic_unsafe env sigma t) | Abstract -> Abstract let set_once s r v = if Option.is_empty !r then r := Some v else error (s^" cannot be set twice") -let process_ring_mods l = +let process_ring_mods env sigma l = let kind = ref None in let set = ref None in let cst_tac = ref None in @@ -638,11 +627,11 @@ let process_ring_mods l = let power = ref None in let div = ref None in List.iter(function - Ring_kind k -> set_once "ring kind" kind (ic_coeff_spec k) + Ring_kind k -> set_once "ring kind" kind (ic_coeff_spec env sigma k) | Const_tac t -> set_once "tactic recognizing constants" cst_tac t | Pre_tac t -> set_once "preprocess tactic" pre t | Post_tac t -> set_once "postprocess tactic" post t - | Setoid(sth,ext) -> set_once "setoid" set (ic_unsafe sth,ic_unsafe ext) + | Setoid(sth,ext) -> set_once "setoid" set (ic_unsafe env sigma sth,ic_unsafe env sigma ext) | Pow_spec(t,spec) -> set_once "power" power (t,spec) | Sign_spec t -> set_once "sign" sign t | Div_spec t -> set_once "div" div t) l; @@ -650,9 +639,11 @@ let process_ring_mods l = (k, !set, !cst_tac, !pre, !post, !power, !sign, !div) let add_theory id rth l = - let (sigma, rth) = ic rth in - let (k,set,cst,pre,post,power,sign, div) = process_ring_mods l in - add_theory0 id (sigma, rth) set k cst (pre,post) power sign div + let env = Global.env () in + let sigma = Evd.from_env env in + let sigma, rth = ic env sigma rth in + let (k,set,cst,pre,post,power,sign, div) = process_ring_mods env sigma l in + add_theory0 env sigma id rth set k cst (pre,post) power sign div (*****************************************************************************) (* The tactics consist then only in a lookup in the ring database and @@ -663,13 +654,12 @@ let make_args_list sigma rl t = | [] -> let (_,t1,t2) = dest_rel0 sigma t in [t1;t2] | _ -> rl -let make_term_list env evd carrier rl = - let l = List.fold_right - (fun x l -> plapp evd coq_cons [|carrier;x;l|]) rl - (plapp evd coq_nil [|carrier|]) +let make_term_list env sigma carrier rl = + let sigma, l = List.fold_right + (fun x (sigma,l) -> plapp sigma coq_cons [|carrier;x;l|]) rl + (plapp sigma coq_nil [|carrier|]) in - let sigma, l = Typing.solve_evars env !evd l in - evd := sigma; l + Typing.solve_evars env sigma l let carg c = Tacinterp.Value.of_constr (EConstr.of_constr c) let tacarg expr = @@ -695,12 +685,13 @@ let ring_lookup (f : Value.t) lH rl t = let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in 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 sigma, l = make_term_list env sigma (EConstr.of_constr e.ring_carrier) rl in + let rl = Value.of_constr l in + let sigma, l = make_hyp_list env sigma lH in + let lH = carg l in let ring = ltac_ring_structure e in - Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (Value.apply f (ring@[lH;rl])) + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Value.apply f (ring@[lH;rl])) end (***********************************************************************) @@ -758,23 +749,23 @@ let sfield_theory = my_reference "semi_field_theory" let af_ar = my_reference"AF_AR" let f_r = my_reference"F_R" let sf_sr = my_reference"SF_SR" -let dest_field env evd th_spec = - let th_typ = Retyping.get_type_of env !evd th_spec in - match EConstr.kind !evd th_typ with +let dest_field env sigma th_spec = + let th_typ = Retyping.get_type_of env sigma th_spec in + match EConstr.kind sigma th_typ with | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|]) - when isRefX !evd (Lazy.force afield_theory) f -> - let rth = plapp evd af_ar + when isRefX sigma (Lazy.force afield_theory) f -> + let sigma, rth = plapp sigma af_ar [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in (None,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth) | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|]) - when isRefX !evd (Lazy.force field_theory) f -> - let rth = - plapp evd f_r + when isRefX sigma (Lazy.force field_theory) f -> + let sigma, rth = + plapp sigma f_r [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in (Some false,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth) | App(f,[|r;zero;one;add;mul;div;inv;req|]) - when isRefX !evd (Lazy.force sfield_theory) f -> - let rth = plapp evd sf_sr + when isRefX sigma (Lazy.force sfield_theory) f -> + let sigma, rth = plapp sigma sf_sr [|r;zero;one;add;mul;div;inv;req;th_spec|] in (Some true,r,zero,one,add,mul,None,None,div,inv,req,rth) | _ -> error "bad field structure" @@ -804,14 +795,14 @@ let find_field_structure env sigma l = let ty' = Retyping.get_type_of env sigma c in if not (Reductionops.is_conv env sigma ty ty') then CErrors.user_err ~hdr:"field" - (str"arguments of field_simplify do not have all the same type") + (str"Arguments of field_simplify do not have all the same type.") in List.iter check cl'; (try field_for_carrier (EConstr.to_constr sigma ty) with Not_found -> CErrors.user_err ~hdr:"field" - (str"cannot find a declared field structure over"++ - spc()++str"\""++pr_econstr_env env sigma ty++str"\"")) + (str"Cannot find a declared field structure over"++ + spc()++str"\""++pr_econstr_env env sigma ty++str"\".")) | [] -> assert false let add_field_entry e = @@ -860,14 +851,14 @@ let ftheory_to_obj : field_info -> obj = ~cache:cache_th ~subst:(Some subst_th) -let field_equality evd r inv req = - match EConstr.kind !evd req with - | App (f, [| _ |]) when eq_constr_nounivs !evd f (Lazy.force coq_eq) -> +let field_equality env sigma r inv req = + match EConstr.kind sigma req with + | App (f, [| _ |]) when eq_constr_nounivs sigma f (Lazy.force coq_eq) -> let c = UnivGen.constr_of_monomorphic_global Coqlib.(lib_ref "core.eq.congr") in let c = EConstr.of_constr c in mkApp(c,[|r;r;inv|]) | _ -> - let _setoid = setoid_of_relation (Global.env ()) evd r req in + let _setoid = setoid_of_relation env sigma r req in let signature = [Some (r,Some req)],Some(r,Some req) in let inv_m, inv_m_lem = try Rewrite.default_morphism signature inv @@ -875,24 +866,22 @@ let field_equality evd r inv req = error "field inverse should be declared as a morphism" in inv_m_lem -let add_field_theory0 name fth eqth morphth cst_tac inj (pre,post) power sign odiv = +let add_field_theory0 env sigma name fth eqth morphth cst_tac inj (pre,post) power sign odiv = let open Constr in check_required_library (cdir@["Field_tac"]); - let (sigma,fth) = ic fth in - let env = Global.env() in - let evd = ref sigma in + let (sigma,fth) = ic env sigma fth in let (kind,r,zero,one,add,mul,sub,opp,div,inv,req,rth) = - dest_field env evd fth in - let (sth,ext) = build_setoid_params env evd r add mul opp req eqth in + dest_field env sigma fth in + let (sth,ext) = build_setoid_params env sigma r add mul opp req eqth in let eqth = Some(sth,ext) in - let _ = add_theory0 name (!evd,rth) eqth morphth cst_tac (None,None) power sign odiv in - let (pow_tac, pspec) = interp_power env evd power in - let sspec = interp_sign env evd sign in - let dspec = interp_div env evd odiv in - let inv_m = field_equality evd r inv req in + let _ = add_theory0 env sigma name rth eqth morphth cst_tac (None,None) power sign odiv in + let sigma, (pow_tac, pspec) = interp_power env sigma power in + let sigma, sspec = interp_sign env sigma sign in + let sigma, dspec = interp_div env sigma odiv in + let inv_m = field_equality env sigma r inv req in let rk = reflect_coeff morphth in let params,ctx = - exec_tactic env !evd 9 (field_ltac"field_lemmas") + exec_tactic env sigma 9 (field_ltac"field_lemmas") [sth;ext;inv_m;fth;pspec;sspec;dspec;rk] in let lemma1 = params.(3) in let lemma2 = params.(4) in @@ -940,7 +929,7 @@ let add_field_theory0 name fth eqth morphth cst_tac inj (pre,post) power sign od field_pre_tac = pretac; field_post_tac = posttac }) in () -let process_field_mods l = +let process_field_mods env sigma l = let kind = ref None in let set = ref None in let cst_tac = ref None in @@ -951,22 +940,24 @@ let process_field_mods l = let power = ref None in let div = ref None in List.iter(function - Ring_mod(Ring_kind k) -> set_once "field kind" kind (ic_coeff_spec k) + Ring_mod(Ring_kind k) -> set_once "field kind" kind (ic_coeff_spec env sigma k) | Ring_mod(Const_tac t) -> set_once "tactic recognizing constants" cst_tac t | Ring_mod(Pre_tac t) -> set_once "preprocess tactic" pre t | Ring_mod(Post_tac t) -> set_once "postprocess tactic" post t - | Ring_mod(Setoid(sth,ext)) -> set_once "setoid" set (ic_unsafe sth,ic_unsafe ext) + | Ring_mod(Setoid(sth,ext)) -> set_once "setoid" set (ic_unsafe env sigma sth,ic_unsafe env sigma ext) | Ring_mod(Pow_spec(t,spec)) -> set_once "power" power (t,spec) | Ring_mod(Sign_spec t) -> set_once "sign" sign t | Ring_mod(Div_spec t) -> set_once "div" div t - | Inject i -> set_once "infinite property" inj (ic_unsafe i)) l; + | Inject i -> set_once "infinite property" inj (ic_unsafe env sigma i)) l; let k = match !kind with Some k -> k | None -> Abstract in - (k, !set, !inj, !cst_tac, !pre, !post, !power, !sign, !div) + (env, sigma, k, !set, !inj, !cst_tac, !pre, !post, !power, !sign, !div) let add_field_theory id t mods = - let (k,set,inj,cst_tac,pre,post,power,sign,div) = process_field_mods mods in - add_field_theory0 id t set k cst_tac inj (pre,post) power sign div + let env = Global.env () in + let sigma = Evd.from_env env in + let (env,sigma,k,set,inj,cst_tac,pre,post,power,sign,div) = process_field_mods env sigma mods in + add_field_theory0 env sigma id t set k cst_tac inj (pre,post) power sign div let ltac_field_structure e = let req = carg e.field_req in @@ -987,10 +978,11 @@ let field_lookup (f : Value.t) lH rl t = let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in 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 sigma, c = make_term_list env sigma (EConstr.of_constr e.field_carrier) rl in + let rl = Value.of_constr c in + let sigma, l = make_hyp_list env sigma lH in + let lH = carg l in let field = ltac_field_structure e in - Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (Value.apply f (field@[lH;rl])) + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Value.apply f (field@[lH;rl])) end diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index bd514f15d5..a4aa08300d 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -454,7 +454,7 @@ let ungen_upat lhs (sigma, uc, t) u = let nb_cs_proj_args pc f u = let na k = - List.length (snd (lookup_canonical_conversion (GlobRef.ConstRef pc, k))).o_TCOMPS in + List.length (snd (lookup_canonical_conversion (Global.env()) (GlobRef.ConstRef pc, k))).o_TCOMPS in let nargs_of_proj t = match kind t with | App(_,args) -> Array.length args | Proj _ -> 0 (* if splay_app calls expand_projection, this has to be diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 00d4c7b3d8..cdf2922516 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -244,24 +244,20 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = Prod (_,a,b) -> (* assert (l2=[]); *) let _, a, b = destProd sigma t2 in if noccurn sigma 1 b then - lookup_canonical_conversion (proji, Prod_cs), + lookup_canonical_conversion env (proji, Prod_cs), (Stack.append_app [|a;pop b|] Stack.empty) else raise Not_found | Sort s -> let s = ESorts.kind sigma s in - lookup_canonical_conversion + lookup_canonical_conversion env (proji, Sort_cs (Sorts.family s)),[] | Proj (p, c) -> - let c2 = GlobRef.ConstRef (Projection.constant p) in - let c = Retyping.expand_projection env sigma p c [] in - let _, args = destApp sigma c in - let sk2 = Stack.append_app args sk2 in - lookup_canonical_conversion (proji, Const_cs c2), sk2 + lookup_canonical_conversion env (proji, Proj_cs (Projection.repr p)), Stack.append_app [|c|] sk2 | _ -> let (c2, _) = try destRef sigma t2 with DestKO -> raise Not_found in - lookup_canonical_conversion (proji, Const_cs c2),sk2 + lookup_canonical_conversion env (proji, Const_cs c2),sk2 with Not_found -> - let (c, cs) = lookup_canonical_conversion (proji,Default_cs) in + let (c, cs) = lookup_canonical_conversion env (proji,Default_cs) in (c,cs),[] in let t', { o_DEF = c; o_CTX = ctx; o_INJ=n; o_TABS = bs; @@ -273,6 +269,7 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = | Some c -> (* A primitive projection applied to c *) let ty = Retyping.get_type_of ~lax:true env sigma c in let (i,u), ind_args = + (* Are we sure that ty is not an evar? *) try Inductiveops.find_mrectype env sigma ty with _ -> raise Not_found in Stack.append_app_list ind_args Stack.empty, c, sk1 diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index c58ebe1bbd..44414aa6a0 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -227,8 +227,7 @@ let recheck_applications unify flags env evdref t = (match unify flags TypeUnification env !evdref Reduction.CUMUL argsty.(i) dom with | Success evd -> evdref := evd; aux (succ i) (subst1 args.(i) codom) - | UnifFailure (evd, reason) -> - Pretype_errors.error_cannot_unify env evd ~reason (argsty.(i), dom)) + | UnifFailure (evd, reason) -> raise (IllTypedInstance (env, ty, argsty.(i)))) | _ -> raise (IllTypedInstance (env, ty, argsty.(i))) else () in aux 0 fty @@ -936,13 +935,6 @@ let project_with_effects aliases sigma t subst = in filter_solution (Int.Map.fold is_projectable subst []) -open Context.Named.Declaration -let rec find_solution_type evarenv = function - | (id,ProjectVar)::l -> get_type (lookup_named id evarenv) - | [id,ProjectEvar _] -> (* bugged *) get_type (lookup_named id evarenv) - | (id,ProjectEvar _)::l -> find_solution_type evarenv l - | [] -> assert false - (* In case the solution to a projection problem requires the instantiation of * subsidiary evars, [do_projection_effects] performs them; it * also try to instantiate the type of those subsidiary evars if their @@ -1553,10 +1545,10 @@ let rec invert_definition unify flags choose imitate_defs raise (NotEnoughInformationToProgress sols); (* No unique projection but still restrict to where it is possible *) (* materializing is necessary, but is restricting useful? *) - let ty = find_solution_type (evar_filtered_env env evi) sols in - let ty' = instantiate_evar_array evi ty argsv in + let t' = of_alias t in + let ty = Retyping.get_type_of env !evdref t' in let (evd,evar,(evk',argsv' as ev')) = - materialize_evar (evar_define unify flags ~choose) env !evdref 0 ev ty' in + materialize_evar (evar_define unify flags ~choose) env !evdref 0 ev ty in let ts = expansions_of_var evd aliases t in let test c = isEvar evd c || List.exists (is_alias evd c) ts in let filter = restrict_upon_filter evd evk test argsv' in @@ -1565,7 +1557,7 @@ let rec invert_definition unify flags choose imitate_defs let evd = match candidates with | NoUpdate -> let evd, ev'' = restrict_applied_evar evd ev' filter NoUpdate in - add_conv_oriented_pb ~tail:false (None,env,mkEvar ev'',of_alias t) evd + add_conv_oriented_pb ~tail:false (None,env,mkEvar ev'',t') evd | UpdateWith _ -> restrict_evar evd evk' filter candidates in diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index e6e5ad8dd4..b6e44265ae 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -144,19 +144,21 @@ type obj_typ = { type cs_pattern = Const_cs of GlobRef.t + | Proj_cs of Projection.Repr.t | Prod_cs | Sort_cs of Sorts.family | Default_cs -let eq_cs_pattern p1 p2 = match p1, p2 with -| Const_cs gr1, Const_cs gr2 -> GlobRef.equal gr1 gr2 +let eq_cs_pattern env p1 p2 = match p1, p2 with +| Const_cs gr1, Const_cs gr2 -> Environ.QGlobRef.equal env gr1 gr2 +| Proj_cs p1, Proj_cs p2 -> Environ.QProjection.Repr.equal env p1 p2 | Prod_cs, Prod_cs -> true | Sort_cs s1, Sort_cs s2 -> Sorts.family_equal s1 s2 | Default_cs, Default_cs -> true | _ -> false -let rec assoc_pat a = function - | ((pat, t), e) :: xs -> if eq_cs_pattern pat a then (t, e) else assoc_pat a xs +let rec assoc_pat env a = function + | ((pat, t), e) :: xs -> if eq_cs_pattern env pat a then (t, e) else assoc_pat env a xs | [] -> raise Not_found @@ -179,10 +181,7 @@ let rec cs_pattern_of_constr env t = patt, n, args @ Array.to_list vargs | Rel n -> Default_cs, Some n, [] | Prod (_,a,b) when Vars.noccurn 1 b -> Prod_cs, None, [a; Vars.lift (-1) b] - | Proj (p, c) -> - let ty = Retyping.get_type_of_constr env c in - let _, params = Inductive.find_rectype env ty in - Const_cs (GlobRef.ConstRef (Projection.constant p)), None, params @ [c] + | Proj (p, c) -> Proj_cs (Projection.repr p), None, [c] | Sort s -> Sort_cs (Sorts.family s), None, [] | _ -> Const_cs (fst @@ destRef t) , None, [] @@ -238,6 +237,7 @@ let compute_canonical_projections env ~warn (gref,ind) = let pr_cs_pattern = function Const_cs c -> Nametab.pr_global_env Id.Set.empty c + | Proj_cs p -> Nametab.pr_global_env Id.Set.empty (GlobRef.ConstRef (Projection.Repr.constant p)) | Prod_cs -> str "_ -> _" | Default_cs -> str "_" | Sort_cs s -> Sorts.pr_sort_family s @@ -253,7 +253,7 @@ let register_canonical_structure ~warn env sigma o = compute_canonical_projections env ~warn o |> List.iter (fun ((proj, (cs_pat, _ as pat)), s) -> let l = try GlobRef.Map.find proj !object_table with Not_found -> [] in - match assoc_pat cs_pat l with + match assoc_pat env cs_pat l with | exception Not_found -> object_table := GlobRef.Map.add proj ((pat, s) :: l) !object_table | _, cs -> @@ -320,8 +320,8 @@ let check_and_decompose_canonical_structure env sigma ref = error_not_structure ref (str "Got too few arguments to the record or structure constructor."); (ref,indsp) -let lookup_canonical_conversion (proj,pat) = - assoc_pat pat (GlobRef.Map.find proj !object_table) +let lookup_canonical_conversion env (proj,pat) = + assoc_pat env pat (GlobRef.Map.find proj !object_table) let decompose_projection sigma c args = match EConstr.kind sigma c with diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index 3be60d5e62..5b8dc8184a 100644 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -67,6 +67,7 @@ val find_primitive_projection : Constant.t -> Projection.Repr.t option (** A cs_pattern characterizes the form of a component of canonical structure *) type cs_pattern = Const_cs of GlobRef.t + | Proj_cs of Projection.Repr.t | Prod_cs | Sort_cs of Sorts.family | Default_cs @@ -88,7 +89,7 @@ val pr_cs_pattern : cs_pattern -> Pp.t type cs = GlobRef.t * inductive -val lookup_canonical_conversion : (GlobRef.t * cs_pattern) -> constr * obj_typ +val lookup_canonical_conversion : Environ.env -> (GlobRef.t * cs_pattern) -> constr * obj_typ val register_canonical_structure : warn:bool -> Environ.env -> Evd.evar_map -> cs -> unit val subst_canonical_structure : Mod_subst.substitution -> cs -> cs diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 4bd22e76cb..34bcd0982c 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -67,6 +67,14 @@ let get_type_from_constraints env sigma t = | _ -> raise Not_found else raise Not_found +let sort_of_arity_with_constraints env sigma t = + try Reductionops.sort_of_arity env sigma t + with Reduction.NotArity -> + try + let t = get_type_from_constraints env sigma t in + Reductionops.sort_of_arity env sigma t + with Not_found | Reduction.NotArity -> retype_error NotAnArity + let rec subst_type env sigma typ = function | [] -> typ | h::rest -> @@ -187,9 +195,7 @@ let retype ?(polyprop=true) sigma = let mip = lookup_mind_specif env ind in let paramtyps = Array.map_to_list (fun arg () -> let t = type_of env arg in - let s = try Reductionops.sort_of_arity env sigma t - with Reduction.NotArity -> retype_error NotAnArity - in + let s = sort_of_arity_with_constraints env sigma t in Sorts.univ_of_sort (ESorts.kind sigma s)) args in diff --git a/stm/stm.ml b/stm/stm.ml index df7e35beb5..f7d66b7b53 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1003,9 +1003,9 @@ end = struct (* {{{ *) end (* }}} *) (* Wrapper for the proof-closing special path for Qed *) -let stm_qed_delay_proof ?route ~proof ~pinfo ~id ~st ~loc ~control pending : Vernacstate.t = +let stm_qed_delay_proof ?route ~proof ~id ~st ~loc ~control pending : Vernacstate.t = set_id_for_feedback ?route dummy_doc id; - Vernacinterp.interp_qed_delayed_proof ~proof ~pinfo ~st ~control (CAst.make ?loc pending) + Vernacinterp.interp_qed_delayed_proof ~proof ~st ~control (CAst.make ?loc pending) (* Wrapper for Vernacentries.interp to set the feedback id *) (* It is currently called 19 times, this number should be certainly @@ -1470,16 +1470,15 @@ end = struct (* {{{ *) (* Unfortunately close_future_proof and friends are not pure so we need to set the state manually here *) State.unfreeze st; - let pobject, _info = + let pobject = PG_compat.close_future_proof ~feedback_id:stop (Future.from_val proof) in let st = Vernacstate.freeze_interp_state ~marshallable:false in let opaque = Opaque in try let _pstate = - let pinfo = Declare.Proof.Proof_info.default () in stm_qed_delay_proof ~st ~id:stop - ~proof:pobject ~pinfo ~loc ~control:[] (Proved (opaque,None)) in + ~proof:pobject ~loc ~control:[] (Proved (opaque,None)) in () with exn -> (* If [stm_qed_delay_proof] fails above we need to use the @@ -1621,12 +1620,9 @@ end = struct (* {{{ *) else begin let opaque = Opaque in - (* The original terminator, a hook, has not been saved in the .vio*) - let proof, _info = + let proof = PG_compat.close_proof ~opaque ~keep_body_ucst_separate:true in - let pinfo = Declare.Proof.Proof_info.default () in - (* We jump at the beginning since the kernel handles side effects by also * looking at the ones that happen to be present in the current env *) @@ -1638,7 +1634,7 @@ end = struct (* {{{ *) *) (* STATE We use the state resulting from reaching start. *) let st = Vernacstate.freeze_interp_state ~marshallable:false in - ignore(stm_qed_delay_proof ~id:stop ~st ~proof ~pinfo ~loc ~control:[] (Proved (opaque,None))); + ignore(stm_qed_delay_proof ~id:stop ~st ~proof ~loc ~control:[] (Proved (opaque,None))); (* Is this name the same than the one in scope? *) let name = Declare.Proof.get_po_name proof in `OK name @@ -2219,13 +2215,13 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = | VtKeepDefined -> CErrors.anomaly (Pp.str "Cannot delegate transparent proofs, this is a bug in the STM.") in - let proof, pinfo = + let proof = PG_compat.close_future_proof ~feedback_id:id fp in if not delegate then ignore(Future.compute fp); reach view.next; let st = Vernacstate.freeze_interp_state ~marshallable:false in let control, pe = extract_pe x in - ignore(stm_qed_delay_proof ~id ~st ~proof ~pinfo ~loc ~control pe); + ignore(stm_qed_delay_proof ~id ~st ~proof ~loc ~control pe); feedback ~id:id Incomplete | { VCS.kind = `Master }, _ -> assert false end; @@ -2264,9 +2260,9 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = let st = Vernacstate.freeze_interp_state ~marshallable:false in let _st = match proof with | None -> stm_vernac_interp id st x - | Some (proof, pinfo) -> + | Some proof -> let control, pe = extract_pe x in - stm_qed_delay_proof ~id ~st ~proof ~pinfo ~loc ~control pe + stm_qed_delay_proof ~id ~st ~proof ~loc ~control pe in let wall_clock3 = Unix.gettimeofday () in Aux_file.record_in_aux_at ?loc:x.expr.CAst.loc "proof_check_time" diff --git a/test-suite/bugs/closed/bug_13246.v b/test-suite/bugs/closed/bug_13246.v new file mode 100644 index 0000000000..11f5baaaf4 --- /dev/null +++ b/test-suite/bugs/closed/bug_13246.v @@ -0,0 +1,69 @@ +Axiom _0: Prop. + +From Coq Require Export Morphisms Setoid Utf8. + +Class Equiv A := equiv: relation A. + +Reserved Notation "P ⊢ Q" (at level 99, Q at level 200, right associativity). +Reserved Notation "P ⊣⊢ Q" (at level 95, no associativity). +Reserved Notation "■ P" (at level 20, right associativity). + +(** Define the scope *) +Declare Scope bi_scope. +Delimit Scope bi_scope with I. + +Structure bi := + Bi { bi_car :> Type; + bi_entails : bi_car → bi_car → Prop; + bi_impl : bi_car → bi_car → bi_car; + bi_forall : ∀ A, (A → bi_car) → bi_car; }. + +Declare Instance bi_equiv `{PROP:bi} : Equiv (bi_car PROP). + +Arguments bi_car : simpl never. +Arguments bi_entails {PROP} _%I _%I : simpl never, rename. +Arguments bi_impl {PROP} _%I _%I : simpl never, rename. +Arguments bi_forall {PROP _} _%I : simpl never, rename. + +Notation "P ⊢ Q" := (bi_entails P%I Q%I) . +Notation "P ⊣⊢ Q" := (equiv (A:=bi_car _) P%I Q%I) . + +Infix "→" := bi_impl : bi_scope. +Notation "∀ x .. y , P" := + (bi_forall (λ x, .. (bi_forall (λ y, P)) ..)%I) : bi_scope. + +(* bug disappears if definitional class *) +Class Plainly (PROP : bi) := { plainly : PROP -> PROP; }. +Notation "■ P" := (plainly P) : bi_scope. + +Section S. + Context {I : Type} {PROP : bi} `(Plainly PROP). + + Lemma plainly_forall `{Plainly PROP} {A} (Ψ : A → PROP) : (∀ a, ■ (Ψ a)) ⊣⊢ ■ (∀ a, Ψ a). + Proof. Admitted. + + Global Instance entails_proper : + Proper (equiv ==> equiv ==> iff) (bi_entails : relation PROP). + Proof. Admitted. + + Global Instance impl_proper : + Proper (equiv ==> equiv ==> equiv) (@bi_impl PROP). + Proof. Admitted. + + Global Instance forall_proper A : + Proper (pointwise_relation _ equiv ==> equiv) (@bi_forall PROP A). + Proof. Admitted. + + Declare Instance PROP_Equivalence: Equivalence (@equiv PROP _). + + Set Mangle Names. + Lemma foo (P : I -> PROP) K: + K ⊢ ∀ (j : I) + (_ : Prop) (* bug disappears if this is removed *) + , (∀ i0, ■ P i0) → P j. + Proof. + setoid_rewrite plainly_forall. + (* retype in case the tactic did some nonsense *) + match goal with |- ?T => let _ := type of T in idtac end. + Abort. +End S. diff --git a/test-suite/bugs/closed/bug_13249.v b/test-suite/bugs/closed/bug_13249.v new file mode 100644 index 0000000000..06f7ddbd3a --- /dev/null +++ b/test-suite/bugs/closed/bug_13249.v @@ -0,0 +1,9 @@ +Global Generalizable All Variables. + +Section test. + Context {A : Type}. + Context `{!foo A}. + + Goal foo A. + Proof. assumption. Defined. +End test. diff --git a/test-suite/bugs/closed/bug_13300.v b/test-suite/bugs/closed/bug_13300.v new file mode 100644 index 0000000000..e4fcd6dacc --- /dev/null +++ b/test-suite/bugs/closed/bug_13300.v @@ -0,0 +1,7 @@ +Polymorphic Definition type := Type. + +Inductive bad : type := . + +Fail Check bad : Prop. +Check bad : Set. +(* lowered as much as possible *) diff --git a/test-suite/bugs/closed/bug_13366.v b/test-suite/bugs/closed/bug_13366.v new file mode 100644 index 0000000000..06918a9266 --- /dev/null +++ b/test-suite/bugs/closed/bug_13366.v @@ -0,0 +1,5 @@ +Class Functor (F : Type -> Type) : Type := + fmap : F nat. + +Fail Definition blah := sum fmap. +(* used to be anomaly not an arity *) diff --git a/test-suite/bugs/closed/bug_9809.v b/test-suite/bugs/closed/bug_9809.v new file mode 100644 index 0000000000..4a7d2c7fac --- /dev/null +++ b/test-suite/bugs/closed/bug_9809.v @@ -0,0 +1,30 @@ +Section FreeMonad. + + Variable S : Type. + Variable P : S -> Type. + + Inductive FreeF A : Type := + | retFree : A -> FreeF A + | opr : forall s, (P s -> FreeF A) -> FreeF A. + +End FreeMonad. + +Section Fibonnacci. + + Inductive gen_op := call_op : nat -> gen_op. + Definition gen_ty (op : gen_op) := + match op with + | call_op _ => nat + end. + + Fail Definition fib0 (n:nat) : FreeF gen_op gen_ty nat := + match n with + | 0 + | 1 => retFree _ _ _ 1 + | S (S k) => + opr _ _ _ (call_op (S k)) + (fun r1 => opr _ _ _ (call_op k) + (fun r0 => retFree (* _ _ _ *) (r1 + r0))) + end. + +End Fibonnacci. diff --git a/test-suite/bugs/closed/bug_9971.v b/test-suite/bugs/closed/bug_9971.v new file mode 100644 index 0000000000..ef526dcd7d --- /dev/null +++ b/test-suite/bugs/closed/bug_9971.v @@ -0,0 +1,27 @@ +(* Test that it raises a normal error and not an anomaly *) +Set Primitive Projections. +Record prod A B := pair { fst : A ; snd : B }. +Arguments fst {A B} _. +Arguments snd {A B} _. +Arguments pair {A B} _ _. +Record piis := { dep_types : Type; indep_args : dep_types -> Type }. +Import EqNotations. +Goal forall (id : Set) (V : id) (piiio : id -> piis) + (Z : {ridc : id & prod (dep_types (piiio ridc)) True}) + (P : dep_types (piiio V) -> Type) (W : {x : dep_types (piiio V) & P x}), + let ida := fun (x : id) (y : dep_types (piiio x)) => indep_args (piiio x) y in + prod True (ida V (projT1 W)) -> + Z = existT _ V (pair (projT1 W) I) -> + ida (projT1 Z) (fst (projT2 Z)). + intros. + refine (rew <- [fun k' => ida (projT1 k') (fst (projT2 k'))] + H in + let v := I in + _); + refine (snd X). + Undo. +Fail refine (rew <- [fun k' => ida (projT1 k') (fst (projT2 k'))] + H in + let v := I in + snd X). +Abort. diff --git a/test-suite/output/Notations3.out b/test-suite/output/Notations3.out index bd22d45059..a9bed49922 100644 --- a/test-suite/output/Notations3.out +++ b/test-suite/output/Notations3.out @@ -120,14 +120,14 @@ where letpair x [1] = {0}; return (1, 2, 3, 4) : nat * nat * nat * nat -{{ 1 | 1 // 1 }} - : nat -!!! _ _ : nat, True - : (nat -> Prop) * ((nat -> Prop) * Prop) ((*1).2).3 : nat *(1.2) : nat +{{ 1 | 1 // 1 }} + : nat +!!! _ _ : nat, True + : (nat -> Prop) * ((nat -> Prop) * Prop) ! '{{x, y}}, x.y = 0 : Prop exists x : nat, @@ -249,3 +249,5 @@ myfoo01 tt : nat myfoo01 tt : nat +1 ⪯ 2 ⪯ 3 ⪯ 4 + : Prop diff --git a/test-suite/output/Notations3.v b/test-suite/output/Notations3.v index 839df99ea7..04a91c14d9 100644 --- a/test-suite/output/Notations3.v +++ b/test-suite/output/Notations3.v @@ -181,6 +181,13 @@ Notation "'letpair' x [1] = { a } ; 'return' ( b0 , b1 , .. , b2 )" := (let x:=a in ( .. (b0,b1) .., b2)). Check letpair x [1] = {0}; return (1,2,3,4). +(* Allow level for leftmost nonterminal when printing-only, BZ#5739 *) + +Notation "* x" := (id x) (only printing, at level 15, format "* x"). +Notation "x . y" := (x + y) (only printing, at level 20, x at level 14, left associativity, format "x . y"). +Check (((id 1) + 2) + 3). +Check (id (1 + 2)). + (* Test spacing in #5569 *) Notation "{ { xL | xR // xcut } }" := (xL+xR+xcut) @@ -191,13 +198,6 @@ Check 1+1+1. Notation "!!! x .. y , b" := ((fun x => b), .. ((fun y => b), True) ..) (at level 200, x binder). Check !!! (x y:nat), True. -(* Allow level for leftmost nonterminal when printing-only, BZ#5739 *) - -Notation "* x" := (id x) (only printing, at level 15, format "* x"). -Notation "x . y" := (x + y) (only printing, at level 20, x at level 14, left associativity, format "x . y"). -Check (((id 1) + 2) + 3). -Check (id (1 + 2)). - (* Test contraction of "forall x, let 'pat := x in ..." into "forall 'pat, ..." *) (* for isolated "forall" (was not working already in 8.6) *) Notation "! x .. y , A" := (id (forall x, .. (id (forall y, A)) .. )) (at level 200, x binder). @@ -410,3 +410,13 @@ Check myfoo0 1 tt. (* was printing [myfoo0 1 HI], but should print [myfoo01 HI] Check myfoo01 tt. (* was printing [myfoo0 1 HI], but should print [myfoo01 HI] *) End Issue8126. + +Module RecursiveNotationPartialApp. + +(* Discussed on Coq Club, 28 July 2020 *) +Notation "x ⪯ y ⪯ .. ⪯ z ⪯ t" := + ((fun b A a => a <= b /\ A b) y .. ((fun b A a => a <= b /\ A b) z (fun b => b <= t)) .. x) + (at level 70, y at next level, z at next level, t at next level). +Check 1 ⪯ 2 ⪯ 3 ⪯ 4. + +End RecursiveNotationPartialApp. diff --git a/test-suite/output/Notations4.out b/test-suite/output/Notations4.out index a6fd39c29b..86c4b3cccc 100644 --- a/test-suite/output/Notations4.out +++ b/test-suite/output/Notations4.out @@ -179,3 +179,21 @@ Found an inductive type while a pattern was expected. : Prop !!!! (nat, id), nat = true /\ id = false : Prop +∀ x : nat, x = 0 + : Prop +∀₁ x, x = 0 + : Prop +∀₁ x, x = 0 + : Prop +∀₂ x y, x + y = 0 + : Prop +((1, 2)) + : nat * nat +%% [x == 1] + : Prop +%%% [1] + : Prop +[[2]] + : nat * nat +%%% + : Type diff --git a/test-suite/output/Notations4.v b/test-suite/output/Notations4.v index 0731819bba..6af192ea82 100644 --- a/test-suite/output/Notations4.v +++ b/test-suite/output/Notations4.v @@ -414,3 +414,76 @@ Module P. End NotationBinderNotMixedWithTerms. End P. + +Module MorePrecise1. + +(* A notation with limited iteration is strictly more precise than a + notation with unlimited iteration *) + +Notation "∀ x .. y , P" := (forall x, .. (forall y, P) ..) + (at level 200, x binder, y binder, right associativity, + format "'[ ' '[ ' ∀ x .. y ']' , '/' P ']'") : type_scope. + +Check forall x, x = 0. + +Notation "∀₁ z , P" := (forall z, P) + (at level 200, right associativity) : type_scope. + +Check forall x, x = 0. + +Notation "∀₂ y x , P" := (forall y x, P) + (at level 200, right associativity) : type_scope. + +Check forall x, x = 0. +Check forall x y, x + y = 0. + +Notation "(( x , y ))" := (x,y) : core_scope. + +Check ((1,2)). + +End MorePrecise1. + +Module MorePrecise2. + +(* Case of a bound binder *) +Notation "%% [ x == y ]" := (forall x, S x = y) (at level 0, x pattern, y at level 60). + +(* Case of an internal binder *) +Notation "%%% [ y ]" := (forall x : nat, x = y) (at level 0). + +(* Check that the two previous notations are indeed finer *) +Notation "∀ x .. y , P" := (forall x, .. (forall y, P) ..) + (at level 200, x binder, y binder, right associativity, + format "'[ ' '[ ' ∀ x .. y ']' , '/' P ']'"). +Notation "∀' x .. y , P" := (forall y, .. (forall x, P) ..) + (at level 200, x binder, y binder, right associativity, + format "'[ ' '[ ' ∀' x .. y ']' , '/' P ']'"). + +Check %% [x == 1]. +Check %%% [1]. + +Notation "[[ x ]]" := (pair 1 x). + +Notation "( x ; y ; .. ; z )" := (pair .. (pair x y) .. z). +Notation "[ x ; y ; .. ; z ]" := (pair .. (pair x z) .. y). + +(* Check which is finer *) +Check [[ 2 ]]. + +End MorePrecise2. + +Module MorePrecise3. + +(* This is about a binder not bound in a notation being strictly more + precise than a binder bound in the notation (since the notation + applies - a priori - stricly less often) *) + +Notation "%%%" := (forall x, x) (at level 0). + +Notation "∀ x .. y , P" := (forall x, .. (forall y, P) ..) + (at level 200, x binder, y binder, right associativity, + format "'[ ' '[ ' ∀ x .. y ']' , '/' P ']'"). + +Check %%%. + +End MorePrecise3. diff --git a/test-suite/output/TypeclassDebug.v b/test-suite/output/TypeclassDebug.v index 2e4008ae56..0bd3d5fa40 100644 --- a/test-suite/output/TypeclassDebug.v +++ b/test-suite/output/TypeclassDebug.v @@ -2,6 +2,7 @@ Parameter foo : Prop. Axiom H : foo -> foo. +#[global] Hint Resolve H : foo. Goal foo. Typeclasses eauto := debug. diff --git a/test-suite/output/UnboundRef.out b/test-suite/output/UnboundRef.out new file mode 100644 index 0000000000..a574e97e0f --- /dev/null +++ b/test-suite/output/UnboundRef.out @@ -0,0 +1,3 @@ +File "stdin", line 1, characters 11-12: +Error: The reference a was not found in the current environment. + diff --git a/test-suite/output/UnboundRef.v b/test-suite/output/UnboundRef.v new file mode 100644 index 0000000000..fd08ae0c5c --- /dev/null +++ b/test-suite/output/UnboundRef.v @@ -0,0 +1,2 @@ +Check Prop a b. +(* Prop is because we need a real head for the application *) diff --git a/test-suite/output/attributes.out b/test-suite/output/attributes.out new file mode 100644 index 0000000000..25572ee2aa --- /dev/null +++ b/test-suite/output/attributes.out @@ -0,0 +1,11 @@ +The command has indeed failed with message: +Attribute for canonical specified twice. +The command has indeed failed with message: +key 'polymorphic' has been already set. +The command has indeed failed with message: +Invalid value 'foo' for key polymorphic +use one of {yes, no} +The command has indeed failed with message: +Invalid syntax polymorphic(foo), try polymorphic={yes, no} instead. +The command has indeed failed with message: +Invalid syntax polymorphic(foo, bar), try polymorphic={yes, no} instead. diff --git a/test-suite/output/attributes.v b/test-suite/output/attributes.v new file mode 100644 index 0000000000..aef05e6cd4 --- /dev/null +++ b/test-suite/output/attributes.v @@ -0,0 +1,9 @@ +Fail #[canonical=yes, canonical=no] Definition a := 3. + +Fail #[universes(polymorphic=yes,polymorphic=no)] Definition a := 3. + +Fail #[universes(polymorphic=foo)] Definition a := 3. + +Fail #[universes(polymorphic(foo))] Definition a := 3. + +Fail #[universes(polymorphic(foo,bar))] Definition a := 3. diff --git a/test-suite/output/bug_10824.out b/test-suite/output/bug_10824.out new file mode 100644 index 0000000000..4bc5aafbca --- /dev/null +++ b/test-suite/output/bug_10824.out @@ -0,0 +1,4 @@ +!! + : Prop +!! + : Prop diff --git a/test-suite/output/bug_10824.v b/test-suite/output/bug_10824.v new file mode 100644 index 0000000000..01271f7d61 --- /dev/null +++ b/test-suite/output/bug_10824.v @@ -0,0 +1,12 @@ +Module A. +Notation F := False. +Notation "!!" := False (at level 100). +Check False. +End A. + +Module B. +Notation "!!" := False (at level 100). +Notation F := False. +Notation "!!" := False (at level 100). +Check False. +End B. diff --git a/test-suite/output/bug_7443.out b/test-suite/output/bug_7443.out new file mode 100644 index 0000000000..446ec6a1ad --- /dev/null +++ b/test-suite/output/bug_7443.out @@ -0,0 +1,13 @@ +Literal 1 + : Type +[1] + : Type +Literal 1 + : Type +[1] + : Type +The command has indeed failed with message: +The term "1" has type "Datatypes.nat" while it is expected to have type + "denote ?t". +Literal 1 + : Type diff --git a/test-suite/output/bug_7443.v b/test-suite/output/bug_7443.v new file mode 100644 index 0000000000..33f76dbcfa --- /dev/null +++ b/test-suite/output/bug_7443.v @@ -0,0 +1,37 @@ +Inductive type := nat | bool. +Definition denote (t : type) + := match t with + | nat => Datatypes.nat + | bool => Datatypes.bool + end. +Ltac reify t := + lazymatch eval cbv beta in t with + | Datatypes.nat => nat + | Datatypes.bool => bool + end. +Notation reify t := (ltac:(let rt := reify t in exact rt)) (only parsing). +Notation reify_type_of e := (reify ((fun t (_ : t) => t) _ e)) (only parsing). +Axiom Literal : forall {t}, denote t -> Type. +Declare Scope foo_scope. +Delimit Scope foo_scope with foo. +Open Scope foo_scope. +Section A. + Notation "[ x ]" := (Literal (t:=reify_type_of x) x) (only parsing) : foo_scope. + Check [1]. (* Literal 1 : Type *) (* as expected *) + Notation "[ x ]" := (Literal x) : foo_scope. + Check @Literal nat 1. (* Incorred: gives Literal 1 : Type when it should give [1]. Fixed by #12950 *) + Notation "[ x ]" := (Literal (t:=reify_type_of x) x) (only parsing) : foo_scope. + Check [1]. (* Incorrect: gives Literal 1 : Type when it should give [1]. This is disputable: + #12950 considers that giving an only parsing a previous both-parsing-and-printing notation *) +End A. +Section B. + Notation "[ x ]" := (Literal x) : foo_scope. + Check @Literal nat 1. (* [1] : Type *) + Fail Check [1]. (* As expected: The command has indeed failed with message: + The term "1" has type "Datatypes.nat" while it is expected to have type + "denote ?t". *) + Notation "[ x ]" := (Literal (t:=reify_type_of x) x) (only parsing) : foo_scope. + Check [1]. (* Should succeed, but instead fails with: Error: + The term "1" has type "Datatypes.nat" while it is expected to have type + "denote ?t". Fixed by #12950, but previous declaration is cancelled by #12950. *) +End B. diff --git a/test-suite/primitive/float/next_up_down.v b/test-suite/primitive/float/next_up_down.v index 4f8427dc5b..ea45fb3983 100644 --- a/test-suite/primitive/float/next_up_down.v +++ b/test-suite/primitive/float/next_up_down.v @@ -120,3 +120,46 @@ Check (eq_refl (SF64succ (Prim2SF f14)) <<: Prim2SF (next_up f14) = SF64succ (Pr Check (eq_refl (SF64pred (Prim2SF f14)) <<: Prim2SF (next_down f14) = SF64pred (Prim2SF f14)). Check (eq_refl (SF64succ (Prim2SF f15)) <<: Prim2SF (next_up f15) = SF64succ (Prim2SF f15)). Check (eq_refl (SF64pred (Prim2SF f15)) <<: Prim2SF (next_down f15) = SF64pred (Prim2SF f15)). + +Check (eq_refl : next_up nan = nan). +Check (eq_refl : next_down nan = nan). +Check (eq_refl : next_up neg_infinity = -0x1.fffffffffffffp+1023). +Check (eq_refl : next_down neg_infinity = neg_infinity). +Check (eq_refl : next_up (-0x1.fffffffffffffp+1023) = -0x1.ffffffffffffep+1023). +Check (eq_refl : next_down (-0x1.fffffffffffffp+1023) = neg_infinity). +Check (eq_refl : next_up (-0x1.ffffffffffffap+1023) = -0x1.ffffffffffff9p+1023). +Check (eq_refl : next_down (-0x1.ffffffffffffap+1023) = -0x1.ffffffffffffbp+1023). +Check (eq_refl : next_up (-0x1.fffffffffffff) = -0x1.ffffffffffffe). +Check (eq_refl : next_down (-0x1.fffffffffffff) = -0x1p+1). +Check (eq_refl : next_up (-0x1p1) = -0x1.fffffffffffff). +Check (eq_refl : next_down (-0x1p1) = -0x1.0000000000001p+1). +Check (eq_refl : next_up (-0x1p-1022) = -0x0.fffffffffffffp-1022). +Check (eq_refl : next_down (-0x1p-1022) = -0x1.0000000000001p-1022). +Check (eq_refl : next_up (-0x0.fffffffffffffp-1022) = -0x0.ffffffffffffep-1022). +Check (eq_refl : next_down (-0x0.fffffffffffffp-1022) = -0x1p-1022). +Check (eq_refl : next_up (-0x0.01p-1022) = -0x0.00fffffffffffp-1022). +Check (eq_refl : next_down (-0x0.01p-1022) = -0x0.0100000000001p-1022). +Check (eq_refl : next_up (-0x0.0000000000001p-1022) = -0). +Check (eq_refl : next_down (-0x0.0000000000001p-1022) = -0x0.0000000000002p-1022). +Check (eq_refl : next_up (-0) = 0x0.0000000000001p-1022). +Check (eq_refl : next_down (-0) = -0x0.0000000000001p-1022). +Check (eq_refl : next_up 0 = 0x0.0000000000001p-1022). +Check (eq_refl : next_down 0 = -0x0.0000000000001p-1022). +Check (eq_refl : next_up 0x0.0000000000001p-1022 = 0x0.0000000000002p-1022). +Check (eq_refl : next_down 0x0.0000000000001p-1022 = 0). +Check (eq_refl : next_up 0x0.01p-1022 = 0x0.0100000000001p-1022). +Check (eq_refl : next_down 0x0.01p-1022 = 0x0.00fffffffffffp-1022). +Check (eq_refl : next_up 0x0.fffffffffffffp-1022 = 0x1p-1022). +Check (eq_refl : next_down 0x0.fffffffffffffp-1022 = 0x0.ffffffffffffep-1022). +Check (eq_refl : next_up 0x1p-1022 = 0x1.0000000000001p-1022). +Check (eq_refl : next_down 0x1p-1022 = 0x0.fffffffffffffp-1022). +Check (eq_refl : next_up 0x1p1 = 0x1.0000000000001p+1). +Check (eq_refl : next_down 0x1p1 = 0x1.fffffffffffff). +Check (eq_refl : next_up 0x1.fffffffffffff = 0x1p+1). +Check (eq_refl : next_down 0x1.fffffffffffff = 0x1.ffffffffffffe). +Check (eq_refl : next_up 0x1.ffffffffffffap+1023 = 0x1.ffffffffffffbp+1023). +Check (eq_refl : next_down 0x1.ffffffffffffap+1023 = 0x1.ffffffffffff9p+1023). +Check (eq_refl : next_up 0x1.fffffffffffffp+1023 = infinity). +Check (eq_refl : next_down 0x1.fffffffffffffp+1023 = 0x1.ffffffffffffep+1023). +Check (eq_refl : next_up infinity = infinity). +Check (eq_refl : next_down infinity = 0x1.fffffffffffffp+1023). diff --git a/test-suite/success/CumulInd.v b/test-suite/success/CumulInd.v new file mode 100644 index 0000000000..f24d13b8af --- /dev/null +++ b/test-suite/success/CumulInd.v @@ -0,0 +1,20 @@ + +(* variances other than Invariant are forbidden for non-cumul inductives *) +Fail Inductive foo@{+u} : Prop := . +Fail Polymorphic Inductive foo@{*u} : Prop := . +Inductive foo@{=u} : Prop := . + +Set Universe Polymorphism. +Set Polymorphic Inductive Cumulativity. + +Inductive force_invariant@{=u} : Prop := . +Fail Definition lift@{u v | u < v} (x:force_invariant@{u}) : force_invariant@{v} := x. + +Inductive force_covariant@{+u} : Prop := . +Fail Definition lift@{u v | v < u} (x:force_covariant@{u}) : force_covariant@{v} := x. +Definition lift@{u v | u < v} (x:force_covariant@{u}) : force_covariant@{v} := x. + +Fail Inductive not_irrelevant@{*u} : Prop := nirr (_ : Type@{u}). +Inductive check_covariant@{+u} : Prop := cov (_ : Type@{u}). + +Fail Inductive not_covariant@{+u} : Prop := ncov (_ : Type@{u} -> nat). diff --git a/test-suite/success/Template.v b/test-suite/success/Template.v index 656362b8fc..d11ae20b8d 100644 --- a/test-suite/success/Template.v +++ b/test-suite/success/Template.v @@ -37,7 +37,7 @@ Module Yes. End Yes. Module No. - #[universes(notemplate)] + #[universes(template=no)] Inductive Box (A:Type) : Type := box : A -> Box A. About Box. diff --git a/test-suite/success/attribute_syntax.v b/test-suite/success/attribute_syntax.v index b403fc120c..b866c4b074 100644 --- a/test-suite/success/attribute_syntax.v +++ b/test-suite/success/attribute_syntax.v @@ -16,11 +16,16 @@ Definition ι T (x: T) := x. Check ι _ ι. +#[universes(polymorphic=no)] +Definition ιι T (x: T) := x. + +Fail Check ιι _ ιι. + #[program] Fixpoint f (n: nat) {wf lt n} : nat := _. Reset f. -#[program(true)] +#[program=yes] Fixpoint f (n: nat) {wf lt n} : nat := _. Reset f. @@ -43,3 +48,14 @@ Export Set Foo. Fail #[ export ] Export Foo. (* Attribute for Locality specified twice *) + +(* Tests for deprecated attribute syntax *) +Set Warnings "-deprecated-attribute-syntax". + +#[program(true)] +Fixpoint f (n: nat) {wf lt n} : nat := _. +Reset f. + +#[universes(monomorphic)] +Definition ιιι T (x: T) := x. +Fail Check ιιι _ ιιι. diff --git a/theories/Arith/Between.v b/theories/Arith/Between.v index 74d1e391c4..71c8f10755 100644 --- a/theories/Arith/Between.v +++ b/theories/Arith/Between.v @@ -24,6 +24,7 @@ Section Between. | bet_emp : between k k | bet_S : forall l, between k l -> P l -> between k (S l). + #[local] Hint Constructors between: arith. Lemma bet_eq : forall k l, l = k -> between k l. @@ -31,18 +32,21 @@ Section Between. intros * ->; auto with arith. Qed. + #[local] Hint Resolve bet_eq: arith. Lemma between_le : forall k l, between k l -> k <= l. Proof. induction 1; auto with arith. Qed. + #[local] Hint Immediate between_le: arith. Lemma between_Sk_l : forall k l, between k l -> S k <= l -> between (S k) l. Proof. induction 1 as [|* [|]]; auto with arith. Qed. + #[local] Hint Resolve between_Sk_l: arith. Lemma between_restr : @@ -57,6 +61,7 @@ Section Between. | exists_S : forall l, exists_between k l -> exists_between k (S l) | exists_le : forall l, k <= l -> Q l -> exists_between k (S l). + #[local] Hint Constructors exists_between: arith. Lemma exists_le_S : forall k l, exists_between k l -> S k <= l. @@ -66,12 +71,14 @@ Section Between. Lemma exists_lt : forall k l, exists_between k l -> k < l. Proof exists_le_S. + #[local] Hint Immediate exists_le_S exists_lt: arith. Lemma exists_S_le : forall k l, exists_between k (S l) -> k <= l. Proof. intros; apply le_S_n; auto with arith. Qed. + #[local] Hint Immediate exists_S_le: arith. Definition in_int p q r := p <= r /\ r < q. @@ -80,6 +87,7 @@ Section Between. Proof. split; assumption. Qed. + #[local] Hint Resolve in_int_intro: arith. Lemma in_int_lt : forall p q r, in_int p q r -> p < q. @@ -99,12 +107,14 @@ Section Between. Proof. intros * []; auto with arith. Qed. + #[local] Hint Resolve in_int_S: arith. Lemma in_int_Sp_q : forall p q r, in_int (S p) q r -> in_int p q r. Proof. intros * []; auto with arith. Qed. + #[local] Hint Immediate in_int_Sp_q: arith. Lemma between_in_int : @@ -188,6 +198,8 @@ Section Between. End Between. +#[global] Hint Resolve nth_O bet_S bet_emp bet_eq between_Sk_l exists_S exists_le in_int_S in_int_intro: arith. +#[global] Hint Immediate in_int_Sp_q exists_le_S exists_S_le: arith. diff --git a/theories/Arith/Div2.v b/theories/Arith/Div2.v index 2d34412908..c52edf9994 100644 --- a/theories/Arith/Div2.v +++ b/theories/Arith/Div2.v @@ -42,6 +42,7 @@ Qed. Lemma lt_div2 n : 0 < n -> div2 n < n. Proof. apply Nat.lt_div2. Qed. +#[global] Hint Resolve lt_div2: arith. (** Properties related to the parity *) @@ -73,6 +74,7 @@ Proof. symmetry in Ev'. elim (n_Sn _ Ev'). Qed. +#[global] Hint Resolve even_div2 div2_even odd_div2 div2_odd: arith. Lemma even_odd_div2 n : @@ -88,6 +90,7 @@ Qed. Notation double := Nat.double (only parsing). +#[global] Hint Unfold double Nat.double: arith. Lemma double_S n : double (S n) = S (S (double n)). @@ -100,6 +103,7 @@ Proof. apply Nat.add_shuffle1. Qed. +#[global] Hint Resolve double_S: arith. Lemma even_odd_double n : @@ -133,6 +137,7 @@ Proof proj1 (proj2 (even_odd_double n)). Lemma double_odd n : n = S (double (div2 n)) -> odd n. Proof proj2 (proj2 (even_odd_double n)). +#[global] Hint Resolve even_double double_even odd_double double_odd: arith. (** Application: diff --git a/theories/Arith/EqNat.v b/theories/Arith/EqNat.v index 593d8c5934..66678b24f8 100644 --- a/theories/Arith/EqNat.v +++ b/theories/Arith/EqNat.v @@ -27,6 +27,7 @@ Theorem eq_nat_refl n : eq_nat n n. Proof. induction n; simpl; auto. Qed. +#[global] Hint Resolve eq_nat_refl: arith. (** [eq] restricted to [nat] and [eq_nat] are equivalent *) @@ -48,6 +49,7 @@ Proof. apply eq_nat_is_eq. Qed. +#[global] Hint Immediate eq_eq_nat eq_nat_eq: arith. Theorem eq_nat_elim : diff --git a/theories/Arith/Even.v b/theories/Arith/Even.v index 3422596818..87d6a6ee64 100644 --- a/theories/Arith/Even.v +++ b/theories/Arith/Even.v @@ -31,7 +31,9 @@ Inductive even : nat -> Prop := with odd : nat -> Prop := odd_S : forall n, even n -> odd (S n). +#[global] Hint Constructors even: arith. +#[global] Hint Constructors odd: arith. (** * Equivalence with predicates [Nat.Even] and [Nat.odd] *) @@ -178,6 +180,7 @@ Proof. parity_binop. Qed. Lemma odd_mult_inv_r n m : odd (n * m) -> odd m. Proof. parity_binop. Qed. +#[global] Hint Resolve even_even_plus odd_even_plus odd_plus_l odd_plus_r even_mult_l even_mult_r even_mult_l even_mult_r odd_mult : arith. diff --git a/theories/Arith/Gt.v b/theories/Arith/Gt.v index 05d585b9a2..492aeba66b 100644 --- a/theories/Arith/Gt.v +++ b/theories/Arith/Gt.v @@ -135,13 +135,21 @@ Qed. (** * Hints *) +#[global] Hint Resolve gt_Sn_O gt_Sn_n gt_n_S : arith. +#[global] Hint Immediate gt_S_n gt_pred : arith. +#[global] Hint Resolve gt_irrefl gt_asym : arith. +#[global] Hint Resolve le_not_gt gt_not_le : arith. +#[global] Hint Immediate le_S_gt gt_S_le : arith. +#[global] Hint Resolve gt_le_S le_gt_S : arith. +#[global] Hint Resolve gt_trans_S le_gt_trans gt_le_trans: arith. +#[global] Hint Resolve plus_gt_compat_l: arith. (* begin hide *) diff --git a/theories/Arith/Le.v b/theories/Arith/Le.v index 4e71465452..3d176fb644 100644 --- a/theories/Arith/Le.v +++ b/theories/Arith/Le.v @@ -32,7 +32,9 @@ Notation le_refl := Nat.le_refl (only parsing). Notation le_trans := Nat.le_trans (only parsing). Notation le_antisym := Nat.le_antisymm (only parsing). +#[global] Hint Resolve le_trans: arith. +#[global] Hint Immediate le_antisym: arith. (** * Properties of [le] w.r.t 0 *) @@ -61,8 +63,11 @@ Notation le_Sn_n := Nat.nle_succ_diag_l (only parsing). (* ~ S n <= n *) Theorem le_Sn_le : forall n m, S n <= m -> n <= m. Proof Nat.lt_le_incl. +#[global] Hint Resolve le_0_n le_Sn_0: arith. +#[global] Hint Resolve le_n_S le_n_Sn le_Sn_n : arith. +#[global] Hint Immediate le_n_0_eq le_Sn_le le_S_n : arith. (** * Properties of [le] w.r.t predecessor *) @@ -70,6 +75,7 @@ Hint Immediate le_n_0_eq le_Sn_le le_S_n : arith. Notation le_pred_n := Nat.le_pred_l (only parsing). (* pred n <= n *) Notation le_pred := Nat.pred_le_mono (only parsing). (* n<=m -> pred n <= pred m *) +#[global] Hint Resolve le_pred_n: arith. (** * A different elimination principle for the order on natural numbers *) diff --git a/theories/Arith/Lt.v b/theories/Arith/Lt.v index 60cc361e35..467420afb3 100644 --- a/theories/Arith/Lt.v +++ b/theories/Arith/Lt.v @@ -27,6 +27,7 @@ Local Open Scope nat_scope. Notation lt_irrefl := Nat.lt_irrefl (only parsing). (* ~ x < x *) +#[global] Hint Resolve lt_irrefl: arith. (** * Relationship between [le] and [lt] *) @@ -50,8 +51,11 @@ Qed. Register le_lt_n_Sm as num.nat.le_lt_n_Sm. +#[global] Hint Immediate lt_le_S: arith. +#[global] Hint Immediate lt_n_Sm_le: arith. +#[global] Hint Immediate le_lt_n_Sm: arith. Theorem le_not_lt n m : n <= m -> ~ m < n. @@ -64,6 +68,7 @@ Proof. apply Nat.lt_nge. Qed. +#[global] Hint Immediate le_not_lt lt_not_le: arith. (** * Asymmetry *) @@ -85,7 +90,9 @@ Proof. intros. now apply Nat.neq_sym, Nat.neq_0_lt_0. Qed. +#[global] Hint Resolve lt_0_Sn lt_n_0 : arith. +#[global] Hint Immediate neq_0_lt lt_0_neq: arith. (** * Order and successor *) @@ -105,7 +112,9 @@ Qed. Register lt_S_n as num.nat.lt_S_n. +#[global] Hint Resolve lt_n_Sn lt_S lt_n_S : arith. +#[global] Hint Immediate lt_S_n : arith. (** * Predecessor *) @@ -130,7 +139,9 @@ Proof. intros. now apply Nat.lt_pred_l, Nat.neq_0_lt_0. Qed. +#[global] Hint Immediate lt_pred: arith. +#[global] Hint Resolve lt_pred_n_n: arith. (** * Transitivity properties *) @@ -141,6 +152,7 @@ Notation le_lt_trans := Nat.le_lt_trans (only parsing). Register le_lt_trans as num.nat.le_lt_trans. +#[global] Hint Resolve lt_trans lt_le_trans le_lt_trans: arith. (** * Large = strict or equal *) @@ -154,6 +166,7 @@ Qed. Notation lt_le_weak := Nat.lt_le_incl (only parsing). +#[global] Hint Immediate lt_le_weak: arith. (** * Dichotomy *) diff --git a/theories/Arith/Max.v b/theories/Arith/Max.v index 28fe51f9af..863b02ef2e 100644 --- a/theories/Arith/Max.v +++ b/theories/Arith/Max.v @@ -43,8 +43,10 @@ Notation max_case2 := max_case (only parsing). Notation max_SS := Nat.succ_max_distr (only parsing). (* end hide *) +#[global] Hint Resolve Nat.max_l Nat.max_r Nat.le_max_l Nat.le_max_r : arith. +#[global] Hint Resolve Nat.min_l Nat.min_r Nat.le_min_l Nat.le_min_r : arith. diff --git a/theories/Arith/Minus.v b/theories/Arith/Minus.v index b8c7ac147a..6cbba63e1a 100644 --- a/theories/Arith/Minus.v +++ b/theories/Arith/Minus.v @@ -111,13 +111,23 @@ Qed. (** * Hints *) +#[global] Hint Resolve minus_n_O: arith. +#[global] Hint Resolve minus_Sn_m: arith. +#[global] Hint Resolve minus_diag_reverse: arith. +#[global] Hint Resolve minus_plus_simpl_l_reverse: arith. +#[global] Hint Immediate plus_minus: arith. +#[global] Hint Resolve minus_plus: arith. +#[global] Hint Resolve le_plus_minus: arith. +#[global] Hint Resolve le_plus_minus_r: arith. +#[global] Hint Resolve lt_minus: arith. +#[global] Hint Immediate lt_O_minus_lt: arith. diff --git a/theories/Arith/Mult.v b/theories/Arith/Mult.v index d7f703e6e4..584b282f4d 100644 --- a/theories/Arith/Mult.v +++ b/theories/Arith/Mult.v @@ -33,12 +33,14 @@ Notation mult_0_r := Nat.mul_0_r (only parsing). (* n * 0 = 0 *) Notation mult_1_l := Nat.mul_1_l (only parsing). (* 1 * n = n *) Notation mult_1_r := Nat.mul_1_r (only parsing). (* n * 1 = n *) +#[global] Hint Resolve mult_1_l mult_1_r: arith. (** ** Commutativity *) Notation mult_comm := Nat.mul_comm (only parsing). (* n * m = m * n *) +#[global] Hint Resolve mult_comm: arith. (** ** Distributivity *) @@ -55,8 +57,11 @@ Notation mult_minus_distr_r := Notation mult_minus_distr_l := Nat.mul_sub_distr_l (only parsing). (* n*(m-p) = n*m - n*p *) +#[global] Hint Resolve mult_plus_distr_r: arith. +#[global] Hint Resolve mult_minus_distr_r: arith. +#[global] Hint Resolve mult_minus_distr_l: arith. (** ** Associativity *) @@ -68,7 +73,9 @@ Proof. symmetry. apply Nat.mul_assoc. Qed. +#[global] Hint Resolve mult_assoc_reverse: arith. +#[global] Hint Resolve mult_assoc: arith. (** ** Inversion lemmas *) @@ -94,12 +101,14 @@ Lemma mult_O_le n m : m = 0 \/ n <= m * n. Proof. destruct m; [left|right]; simpl; trivial using Nat.le_add_r. Qed. +#[global] Hint Resolve mult_O_le: arith. Lemma mult_le_compat_l n m p : n <= m -> p * n <= p * m. Proof. apply Nat.mul_le_mono_nonneg_l, Nat.le_0_l. (* TODO : get rid of 0<=n hyp *) Qed. +#[global] Hint Resolve mult_le_compat_l: arith. Lemma mult_le_compat_r n m p : n <= m -> n * p <= m * p. @@ -117,6 +126,7 @@ Proof. apply Nat.mul_lt_mono_pos_l, Nat.lt_0_succ. Qed. +#[global] Hint Resolve mult_S_lt_compat_l: arith. Lemma mult_lt_compat_l n m p : n < m -> 0 < p -> p * n < p * m. diff --git a/theories/Arith/PeanoNat.v b/theories/Arith/PeanoNat.v index 37704704a0..8d3b1b318a 100644 --- a/theories/Arith/PeanoNat.v +++ b/theories/Arith/PeanoNat.v @@ -765,7 +765,9 @@ Infix "?=" := Nat.compare (at level 70) : nat_scope. Infix "/" := Nat.div : nat_scope. Infix "mod" := Nat.modulo (at level 40, no associativity) : nat_scope. +#[global] Hint Unfold Nat.le : core. +#[global] Hint Unfold Nat.lt : core. Register Nat.le_trans as num.nat.le_trans. diff --git a/theories/Arith/Peano_dec.v b/theories/Arith/Peano_dec.v index 9a7a397023..2fc44ba592 100644 --- a/theories/Arith/Peano_dec.v +++ b/theories/Arith/Peano_dec.v @@ -23,6 +23,7 @@ Defined. Notation eq_nat_dec := Nat.eq_dec (only parsing). +#[global] Hint Resolve O_or_S eq_nat_dec: arith. Theorem dec_eq_nat n m : decidable (n = m). diff --git a/theories/Arith/Plus.v b/theories/Arith/Plus.v index 5da7738adc..49e242276e 100644 --- a/theories/Arith/Plus.v +++ b/theories/Arith/Plus.v @@ -179,11 +179,17 @@ Proof (succ_plus_discr n 3). (** * Compatibility Hints *) +#[global] Hint Immediate plus_comm : arith. +#[global] Hint Resolve plus_assoc plus_assoc_reverse : arith. +#[global] Hint Resolve plus_le_compat_l plus_le_compat_r : arith. +#[global] Hint Resolve le_plus_l le_plus_r le_plus_trans : arith. +#[global] Hint Immediate lt_plus_trans : arith. +#[global] Hint Resolve plus_lt_compat_l plus_lt_compat_r : arith. (** For compatibility, we "Require" the same files as before *) diff --git a/theories/Arith/Wf_nat.v b/theories/Arith/Wf_nat.v index ebd909c1dc..a87eeba9b1 100644 --- a/theories/Arith/Wf_nat.v +++ b/theories/Arith/Wf_nat.v @@ -197,7 +197,9 @@ Proof. intros n H q; pattern q; apply lt_wf_ind; auto with arith. Qed. +#[global] Hint Resolve lt_wf: arith. +#[global] Hint Resolve well_founded_lt_compat: arith. Section LT_WF_REL. diff --git a/theories/Bool/Bool.v b/theories/Bool/Bool.v index 0f62db42cf..8039c96efe 100644 --- a/theories/Bool/Bool.v +++ b/theories/Bool/Bool.v @@ -44,13 +44,16 @@ Lemma diff_true_false : true <> false. Proof. discriminate. Qed. +#[global] Hint Resolve diff_true_false : bool. Lemma diff_false_true : false <> true. Proof. discriminate. Qed. +#[global] Hint Resolve diff_false_true : bool. +#[global] Hint Extern 1 (false <> true) => exact diff_false_true : core. Lemma eq_true_false_abs : forall b:bool, b = true -> b = false -> False. @@ -87,6 +90,7 @@ Qed. | true => b2 = true | false => True end. +#[global] Hint Unfold le: bool. Lemma le_implb : forall b1 b2, le b1 b2 <-> implb b1 b2 = true. @@ -104,6 +108,7 @@ Notation leb_implb := le_implb (only parsing). | true => False | false => b2 = true end. +#[global] Hint Unfold lt: bool. #[ local ] Definition compare (b1 b2 : bool) := @@ -271,6 +276,7 @@ Lemma orb_true_intro : Proof. intros; apply orb_true_iff; trivial. Qed. +#[global] Hint Resolve orb_true_intro: bool. Lemma orb_false_intro : @@ -278,6 +284,7 @@ Lemma orb_false_intro : Proof. intros. subst. reflexivity. Qed. +#[global] Hint Resolve orb_false_intro: bool. Lemma orb_false_elim : @@ -297,6 +304,7 @@ Lemma orb_true_r : forall b:bool, b || true = true. Proof. destr_bool. Qed. +#[global] Hint Resolve orb_true_r: bool. Lemma orb_true_l : forall b:bool, true || b = true. @@ -313,12 +321,14 @@ Lemma orb_false_r : forall b:bool, b || false = b. Proof. destr_bool. Qed. +#[global] Hint Resolve orb_false_r: bool. Lemma orb_false_l : forall b:bool, false || b = b. Proof. destr_bool. Qed. +#[global] Hint Resolve orb_false_l: bool. Notation orb_b_false := orb_false_r (only parsing). @@ -330,6 +340,7 @@ Lemma orb_negb_r : forall b:bool, b || negb b = true. Proof. destr_bool. Qed. +#[global] Hint Resolve orb_negb_r: bool. Lemma orb_negb_l : forall b:bool, negb b || b = true. @@ -352,6 +363,7 @@ Lemma orb_assoc : forall b1 b2 b3:bool, b1 || (b2 || b3) = b1 || b2 || b3. Proof. destr_bool. Qed. +#[global] Hint Resolve orb_comm orb_assoc: bool. (***************************) @@ -426,6 +438,7 @@ Lemma andb_false_elim : Proof. intro b1; destruct b1; simpl; auto. Defined. +#[global] Hint Resolve andb_false_elim: bool. (** Complementation *) @@ -434,6 +447,7 @@ Lemma andb_negb_r : forall b:bool, b && negb b = false. Proof. destr_bool. Qed. +#[global] Hint Resolve andb_negb_r: bool. Lemma andb_negb_l : forall b:bool, negb b && b = false. @@ -457,6 +471,7 @@ Proof. destr_bool. Qed. +#[global] Hint Resolve andb_comm andb_assoc: bool. (*****************************************) @@ -722,6 +737,7 @@ Qed. Notation bool_6 := eq_true_not_negb (only parsing). (* Compatibility *) +#[global] Hint Resolve eq_true_not_negb : bool. (* An interesting lemma for auto but too strong to keep compatibility *) @@ -737,6 +753,7 @@ Lemma absurd_eq_true : forall b, False -> b = true. Proof. contradiction. Qed. +#[global] Hint Resolve absurd_eq_true : core. (* A specific instance of eq_trans that preserves compatibility with @@ -746,6 +763,7 @@ Lemma trans_eq_bool : forall x y z:bool, x = y -> y = z -> x = z. Proof. apply eq_trans. Qed. +#[global] Hint Resolve trans_eq_bool : core. (***************************************) @@ -754,6 +772,7 @@ Hint Resolve trans_eq_bool : core. (** [Is_true] and equality *) +#[global] Hint Unfold Is_true: bool. Lemma Is_true_eq_true : forall x:bool, Is_true x -> x = true. @@ -773,6 +792,7 @@ Qed. Notation Is_true_eq_true2 := Is_true_eq_right (only parsing). +#[global] Hint Immediate Is_true_eq_right Is_true_eq_left: bool. Lemma eqb_refl : forall x:bool, Is_true (eqb x x). @@ -806,6 +826,7 @@ Lemma andb_prop_intro : Proof. destr_bool; tauto. Qed. +#[global] Hint Resolve andb_prop_intro: bool. Notation andb_true_intro2 := @@ -817,6 +838,7 @@ Lemma andb_prop_elim : Proof. destr_bool; auto. Qed. +#[global] Hint Resolve andb_prop_elim: bool. Notation andb_prop2 := andb_prop_elim (only parsing). @@ -901,6 +923,7 @@ Qed. Inductive reflect (P : Prop) : bool -> Set := | ReflectT : P -> reflect P true | ReflectF : ~ P -> reflect P false. +#[global] Hint Constructors reflect : bool. (** Interest: a case on a reflect lemma or hyp performs clever diff --git a/theories/Bool/IfProp.v b/theories/Bool/IfProp.v index 1a41eb6bb5..7e9087c377 100644 --- a/theories/Bool/IfProp.v +++ b/theories/Bool/IfProp.v @@ -14,6 +14,7 @@ Inductive IfProp (A B:Prop) : bool -> Prop := | Iftrue : A -> IfProp A B true | Iffalse : B -> IfProp A B false. +#[global] Hint Resolve Iftrue Iffalse: bool. Lemma Iftrue_inv : forall (A B:Prop) (b:bool), IfProp A B b -> b = true -> A. diff --git a/theories/Bool/Sumbool.v b/theories/Bool/Sumbool.v index 52605a4667..49feda15ea 100644 --- a/theories/Bool/Sumbool.v +++ b/theories/Bool/Sumbool.v @@ -19,6 +19,7 @@ Definition sumbool_of_bool : forall b:bool, {b = true} + {b = false}. intros b; destruct b; auto. Defined. +#[global] Hint Resolve sumbool_of_bool: bool. Definition bool_eq_rec : @@ -57,7 +58,9 @@ Section connectives. End connectives. +#[global] Hint Resolve sumbool_and sumbool_or: core. +#[global] Hint Immediate sumbool_not : core. (** Any decidability function in type [sumbool] can be turned into a function diff --git a/theories/Bool/Zerob.v b/theories/Bool/Zerob.v index 3665a8c78d..aff5008410 100644 --- a/theories/Bool/Zerob.v +++ b/theories/Bool/Zerob.v @@ -23,6 +23,7 @@ Lemma zerob_true_intro : forall n:nat, n = 0 -> zerob n = true. Proof. destruct n; [ trivial with bool | inversion 1 ]. Qed. +#[global] Hint Resolve zerob_true_intro: bool. Lemma zerob_true_elim : forall n:nat, zerob n = true -> n = 0. @@ -34,6 +35,7 @@ Lemma zerob_false_intro : forall n:nat, n <> 0 -> zerob n = false. Proof. destruct n; [ destruct 1; auto with bool | trivial with bool ]. Qed. +#[global] Hint Resolve zerob_false_intro: bool. Lemma zerob_false_elim : forall n:nat, zerob n = false -> n <> 0. diff --git a/theories/Classes/CMorphisms.v b/theories/Classes/CMorphisms.v index aae24e0e0a..9ff18ebe2c 100644 --- a/theories/Classes/CMorphisms.v +++ b/theories/Classes/CMorphisms.v @@ -80,9 +80,11 @@ End Proper. (** We favor the use of Leibniz equality or a declared reflexive crelation when resolving [ProperProxy], otherwise, if the crelation is given (not an evar), we fall back to [Proper]. *) +#[global] Hint Extern 1 (ProperProxy _ _) => class_apply @eq_proper_proxy || class_apply @reflexive_proper_proxy : typeclass_instances. +#[global] Hint Extern 2 (ProperProxy ?R _) => not_evar R; class_apply @proper_proper_proxy : typeclass_instances. @@ -215,8 +217,11 @@ Typeclasses Opaque respectful pointwise_relation forall_relation. Arguments forall_relation {A P}%type sig%signature _ _. Arguments pointwise_relation A%type {B}%type R%signature _ _. +#[global] Hint Unfold Reflexive : core. +#[global] Hint Unfold Symmetric : core. +#[global] Hint Unfold Transitive : core. (** Resolution with subrelation: favor decomposing products over applying reflexivity @@ -225,6 +230,7 @@ Ltac subrelation_tac T U := (is_ground T ; is_ground U ; class_apply @subrelation_refl) || class_apply @subrelation_respectful || class_apply @subrelation_refl. +#[global] Hint Extern 3 (@subrelation _ ?T ?U) => subrelation_tac T U : typeclass_instances. CoInductive apply_subrelation : Prop := do_subrelation. @@ -234,6 +240,7 @@ Ltac proper_subrelation := [ H : apply_subrelation |- _ ] => clear H ; class_apply @subrelation_proper end. +#[global] Hint Extern 5 (@Proper _ ?H _) => proper_subrelation : typeclass_instances. (** Essential subrelation instances for [iff], [impl] and [pointwise_relation]. *) @@ -254,6 +261,7 @@ Proof. firstorder. Qed. (** We use an extern hint to help unification. *) +#[global] Hint Extern 4 (subrelation (@forall_relation ?A ?B ?R) (@forall_relation _ _ ?S)) => apply (@forall_subrelation A B R S) ; intro : typeclass_instances. @@ -526,17 +534,23 @@ Ltac proper_reflexive := end. +#[global] Hint Extern 1 (subrelation (flip _) _) => class_apply @flip1 : typeclass_instances. +#[global] Hint Extern 1 (subrelation _ (flip _)) => class_apply @flip2 : typeclass_instances. (* Hint Extern 1 (Proper _ (complement _)) => apply @complement_proper *) (* : typeclass_instances. *) +#[global] Hint Extern 1 (Proper _ (flip _)) => apply @flip_proper : typeclass_instances. +#[global] Hint Extern 2 (@Proper _ (flip _) _) => class_apply @proper_flip_proper : typeclass_instances. +#[global] Hint Extern 4 (@Proper _ _ _) => partial_application_tactic : typeclass_instances. +#[global] Hint Extern 7 (@Proper _ _ _) => proper_reflexive : typeclass_instances. @@ -586,7 +600,9 @@ Ltac proper_normalization := set(H:=did_normalization) ; class_apply @proper_normalizes_proper end. +#[global] Hint Extern 1 (Normalizes _ _ _) => normalizes : typeclass_instances. +#[global] Hint Extern 6 (@Proper _ _ _) => proper_normalization : typeclass_instances. @@ -690,6 +706,7 @@ split. + right. transitivity y; auto. Qed. +#[global] Hint Extern 4 (PreOrder (relation_disjunction _ _)) => class_apply StrictOrder_PreOrder : typeclass_instances. @@ -702,8 +719,10 @@ elim (StrictOrder_Irreflexive x). transitivity y; auto. Qed. +#[global] Hint Extern 4 (StrictOrder (relation_conjunction _ _)) => class_apply PartialOrder_StrictOrder : typeclass_instances. +#[global] Hint Extern 4 (PartialOrder _ (relation_disjunction _ _)) => class_apply StrictOrder_PartialOrder : typeclass_instances. diff --git a/theories/Classes/CRelationClasses.v b/theories/Classes/CRelationClasses.v index 72a196ca7a..236d35b68e 100644 --- a/theories/Classes/CRelationClasses.v +++ b/theories/Classes/CRelationClasses.v @@ -203,22 +203,35 @@ Defined. (** Hints to drive the typeclass resolution avoiding loops due to the use of full unification. *) +#[global] Hint Extern 1 (Reflexive (complement _)) => class_apply @irreflexivity : typeclass_instances. +#[global] Hint Extern 3 (Symmetric (complement _)) => class_apply complement_Symmetric : typeclass_instances. +#[global] Hint Extern 3 (Irreflexive (complement _)) => class_apply complement_Irreflexive : typeclass_instances. +#[global] Hint Extern 3 (Reflexive (flip _)) => apply flip_Reflexive : typeclass_instances. +#[global] Hint Extern 3 (Irreflexive (flip _)) => class_apply flip_Irreflexive : typeclass_instances. +#[global] Hint Extern 3 (Symmetric (flip _)) => class_apply flip_Symmetric : typeclass_instances. +#[global] Hint Extern 3 (Asymmetric (flip _)) => class_apply flip_Asymmetric : typeclass_instances. +#[global] Hint Extern 3 (Antisymmetric (flip _)) => class_apply flip_Antisymmetric : typeclass_instances. +#[global] Hint Extern 3 (Transitive (flip _)) => class_apply flip_Transitive : typeclass_instances. +#[global] Hint Extern 3 (StrictOrder (flip _)) => class_apply flip_StrictOrder : typeclass_instances. +#[global] Hint Extern 3 (PreOrder (flip _)) => class_apply flip_PreOrder : typeclass_instances. +#[global] Hint Extern 4 (subrelation (flip _) _) => class_apply @subrelation_symmetric : typeclass_instances. +#[global] Hint Resolve irreflexivity : ord. Unset Implicit Arguments. @@ -231,6 +244,7 @@ Ltac solve_crelation := | [ H : ?R ?x ?y |- ?R ?y ?x ] => symmetry ; exact H end. +#[global] Hint Extern 4 => solve_crelation : crelations. (** We can already dualize all these properties. *) @@ -351,6 +365,7 @@ Section Binary. Qed. End Binary. +#[global] Hint Extern 3 (PartialOrder (flip _)) => class_apply PartialOrder_inverse : typeclass_instances. (** The partial order defined by subrelation and crelation equivalence. *) diff --git a/theories/Classes/Init.v b/theories/Classes/Init.v index 394f5dc4de..9ca465bbfd 100644 --- a/theories/Classes/Init.v +++ b/theories/Classes/Init.v @@ -36,4 +36,5 @@ Ltac unconvertible := | |- _ => exact tt end. +#[global] Hint Extern 0 (@Unconvertible _ _ _) => unconvertible : typeclass_instances. diff --git a/theories/Classes/Morphisms.v b/theories/Classes/Morphisms.v index 867d9cb9b3..87abc4a08f 100644 --- a/theories/Classes/Morphisms.v +++ b/theories/Classes/Morphisms.v @@ -81,9 +81,11 @@ End Proper. (** We favor the use of Leibniz equality or a declared reflexive relation when resolving [ProperProxy], otherwise, if the relation is given (not an evar), we fall back to [Proper]. *) +#[global] Hint Extern 1 (ProperProxy _ _) => class_apply @eq_proper_proxy || class_apply @reflexive_proper_proxy : typeclass_instances. +#[global] Hint Extern 2 (ProperProxy ?R _) => not_evar R; class_apply @proper_proper_proxy : typeclass_instances. @@ -213,8 +215,11 @@ Typeclasses Opaque respectful pointwise_relation forall_relation. Arguments forall_relation {A P}%type sig%signature _ _. Arguments pointwise_relation A%type {B}%type R%signature _ _. +#[global] Hint Unfold Reflexive : core. +#[global] Hint Unfold Symmetric : core. +#[global] Hint Unfold Transitive : core. (** Resolution with subrelation: favor decomposing products over applying reflexivity @@ -223,6 +228,7 @@ Ltac subrelation_tac T U := (is_ground T ; is_ground U ; class_apply @subrelation_refl) || class_apply @subrelation_respectful || class_apply @subrelation_refl. +#[global] Hint Extern 3 (@subrelation _ ?T ?U) => subrelation_tac T U : typeclass_instances. CoInductive apply_subrelation : Prop := do_subrelation. @@ -232,6 +238,7 @@ Ltac proper_subrelation := [ H : apply_subrelation |- _ ] => clear H ; class_apply @subrelation_proper end. +#[global] Hint Extern 5 (@Proper _ ?H _) => proper_subrelation : typeclass_instances. (** Essential subrelation instances for [iff], [impl] and [pointwise_relation]. *) @@ -244,6 +251,7 @@ Proof. firstorder. Qed. (** We use an extern hint to help unification. *) +#[global] Hint Extern 4 (subrelation (@forall_relation ?A ?B ?R) (@forall_relation _ _ ?S)) => apply (@forall_subrelation A B R S) ; intro : typeclass_instances. @@ -538,17 +546,24 @@ Ltac proper_reflexive := end. +#[global] Hint Extern 1 (subrelation (flip _) _) => class_apply @flip1 : typeclass_instances. +#[global] Hint Extern 1 (subrelation _ (flip _)) => class_apply @flip2 : typeclass_instances. +#[global] Hint Extern 1 (Proper _ (complement _)) => apply @complement_proper : typeclass_instances. +#[global] Hint Extern 1 (Proper _ (flip _)) => apply @flip_proper : typeclass_instances. +#[global] Hint Extern 2 (@Proper _ (flip _) _) => class_apply @proper_flip_proper : typeclass_instances. +#[global] Hint Extern 4 (@Proper _ _ _) => partial_application_tactic : typeclass_instances. +#[global] Hint Extern 7 (@Proper _ _ _) => proper_reflexive : typeclass_instances. @@ -603,7 +618,9 @@ Ltac proper_normalization := set(H:=did_normalization) ; class_apply @proper_normalizes_proper end. +#[global] Hint Extern 1 (Normalizes _ _ _) => normalizes : typeclass_instances. +#[global] Hint Extern 6 (@Proper _ _ _) => proper_normalization : typeclass_instances. @@ -693,6 +710,7 @@ split. + right. transitivity y; auto. Qed. +#[global] Hint Extern 4 (PreOrder (relation_disjunction _ _)) => class_apply StrictOrder_PreOrder : typeclass_instances. @@ -705,8 +723,10 @@ elim (StrictOrder_Irreflexive x). transitivity y; auto. Qed. +#[global] Hint Extern 4 (StrictOrder (relation_conjunction _ _)) => class_apply PartialOrder_StrictOrder : typeclass_instances. +#[global] Hint Extern 4 (PartialOrder _ (relation_disjunction _ _)) => class_apply StrictOrder_PartialOrder : typeclass_instances. diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v index 401d7007e2..54ee06343a 100644 --- a/theories/Classes/RelationClasses.v +++ b/theories/Classes/RelationClasses.v @@ -196,19 +196,31 @@ Defined. (** Hints to drive the typeclass resolution avoiding loops due to the use of full unification. *) +#[global] Hint Extern 1 (Reflexive (complement _)) => class_apply @irreflexivity : typeclass_instances. +#[global] Hint Extern 3 (Symmetric (complement _)) => class_apply complement_Symmetric : typeclass_instances. +#[global] Hint Extern 3 (Irreflexive (complement _)) => class_apply complement_Irreflexive : typeclass_instances. +#[global] Hint Extern 3 (Reflexive (flip _)) => apply flip_Reflexive : typeclass_instances. +#[global] Hint Extern 3 (Irreflexive (flip _)) => class_apply flip_Irreflexive : typeclass_instances. +#[global] Hint Extern 3 (Symmetric (flip _)) => class_apply flip_Symmetric : typeclass_instances. +#[global] Hint Extern 3 (Asymmetric (flip _)) => class_apply flip_Asymmetric : typeclass_instances. +#[global] Hint Extern 3 (Antisymmetric (flip _)) => class_apply flip_Antisymmetric : typeclass_instances. +#[global] Hint Extern 3 (Transitive (flip _)) => class_apply flip_Transitive : typeclass_instances. +#[global] Hint Extern 3 (StrictOrder (flip _)) => class_apply flip_StrictOrder : typeclass_instances. +#[global] Hint Extern 3 (PreOrder (flip _)) => class_apply flip_PreOrder : typeclass_instances. +#[global] Hint Extern 4 (subrelation (flip _) _) => class_apply @subrelation_symmetric : typeclass_instances. @@ -218,6 +230,7 @@ Arguments asymmetry {A} {R} {_} [x] [y] _ _. Arguments transitivity {A} {R} {_} [x] [y] [z] _ _. Arguments Antisymmetric A eqA {_} _. +#[global] Hint Resolve irreflexivity : ord. Unset Implicit Arguments. @@ -230,6 +243,7 @@ Ltac solve_relation := | [ H : ?R ?x ?y |- ?R ?y ?x ] => symmetry ; exact H end. +#[global] Hint Extern 4 => solve_relation : relations. (** We can already dualize all these properties. *) @@ -476,6 +490,7 @@ Section Binary. Proof. firstorder. Qed. End Binary. +#[global] Hint Extern 3 (PartialOrder (flip _)) => class_apply PartialOrder_inverse : typeclass_instances. (** The partial order defined by subrelation and relation equivalence. *) diff --git a/theories/Classes/RelationPairs.v b/theories/Classes/RelationPairs.v index 09c25b38a6..87e66a25dd 100644 --- a/theories/Classes/RelationPairs.v +++ b/theories/Classes/RelationPairs.v @@ -158,6 +158,8 @@ Section RelProd_Instances. Proof. unfold RelCompFun; firstorder. Qed. End RelProd_Instances. +#[global] Hint Unfold RelProd RelCompFun : core. +#[global] Hint Extern 2 (RelProd _ _ _ _) => split : core. diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v index ad0124db6d..bfa50d7fae 100644 --- a/theories/FSets/FMapAVL.v +++ b/theories/FSets/FMapAVL.v @@ -41,6 +41,7 @@ Local Open Scope Int_scope. Local Notation int := I.t. Definition key := X.t. +#[global] Hint Transparent key : core. (** * Trees *) @@ -495,7 +496,9 @@ Functional Scheme map2_opt_ind := Induction for map2_opt Sort Prop. (** * Automation and dedicated tactics. *) +#[global] Hint Constructors tree MapsTo In bst : core. +#[global] Hint Unfold lt_tree gt_tree : core. Tactic Notation "factornode" ident(l) ident(x) ident(d) ident(r) ident(h) @@ -576,6 +579,7 @@ Lemma MapsTo_In : forall k e m, MapsTo k e m -> In k m. Proof. induction 1; auto. Qed. +#[local] Hint Resolve MapsTo_In : core. Lemma In_MapsTo : forall k m, In k m -> exists e, MapsTo k e m. @@ -595,6 +599,7 @@ Lemma MapsTo_1 : Proof. induction m; simpl; intuition_in; eauto with ordered_type. Qed. +#[local] Hint Immediate MapsTo_1 : core. Lemma In_1 : @@ -634,6 +639,7 @@ Proof. unfold gt_tree in *; intuition_in; order. Qed. +#[local] Hint Resolve lt_leaf gt_leaf lt_tree_node gt_tree_node : core. Lemma lt_left : forall x y l r e h, @@ -660,6 +666,7 @@ Proof. intuition_in. Qed. +#[local] Hint Resolve lt_left lt_right gt_left gt_right : core. Lemma lt_tree_not_in : @@ -686,6 +693,7 @@ Proof. eauto with ordered_type. Qed. +#[local] Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans : core. (** * Empty map *) @@ -818,6 +826,7 @@ Lemma create_bst : Proof. unfold create; auto. Qed. +#[local] Hint Resolve create_bst : core. Lemma create_in : @@ -835,6 +844,7 @@ Proof. (apply lt_tree_node || apply gt_tree_node); auto with ordered_type; (eapply lt_tree_trans || eapply gt_tree_trans); eauto with ordered_type. Qed. +#[local] Hint Resolve bal_bst : core. Lemma bal_in : forall l x e r y, @@ -876,6 +886,7 @@ Proof. apply MX.eq_lt with x; auto. apply MX.lt_eq with x; auto with ordered_type. Qed. +#[local] Hint Resolve add_bst : core. Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m). @@ -956,6 +967,7 @@ Proof. destruct 1. apply H2; intuition. Qed. +#[local] Hint Resolve remove_min_bst : core. Lemma remove_min_gt_tree : forall l x e r h, @@ -975,6 +987,7 @@ Proof. assert (X.lt m#1 x) by order. decompose [or] H; order. Qed. +#[local] Hint Resolve remove_min_gt_tree : core. Lemma remove_min_find : forall l x e r h y, @@ -1127,6 +1140,7 @@ Proof. intuition; [ apply MX.lt_eq with x | ]; eauto with ordered_type. intuition; [ apply MX.eq_lt with x | ]; eauto with ordered_type. Qed. +#[local] Hint Resolve join_bst : core. Lemma join_find : forall l x d r y, @@ -1263,6 +1277,7 @@ Proof. rewrite remove_min_in, e1; simpl; auto with ordered_type. change (gt_tree (m2',xd)#2#1 (m2',xd)#1). rewrite <-e1; eauto. Qed. +#[local] Hint Resolve concat_bst : core. Lemma concat_find : forall m1 m2 y, bst m1 -> bst m2 -> @@ -1351,6 +1366,7 @@ Proof. intros; unfold elements; apply elements_aux_sort; auto. intros; inversion H0. Qed. +#[local] Hint Resolve elements_sort : core. Lemma elements_nodup : forall s : t elt, bst s -> NoDupA eqk (elements s). @@ -1620,6 +1636,7 @@ destruct (map_option_2 H) as (d0 & ? & ?). destruct (map_option_2 H') as (d0' & ? & ?). eapply X.lt_trans with x; eauto using MapsTo_In. Qed. +#[local] Hint Resolve map_option_bst : core. Ltac nonify e := @@ -1719,6 +1736,7 @@ apply X.lt_trans with x1. destruct (map2_opt_2 H1 H6 Hy); intuition. destruct (map2_opt_2 H2 H7 Hy'); intuition. Qed. +#[local] Hint Resolve map2_opt_bst : core. Ltac map2_aux := @@ -2075,6 +2093,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Proof. destruct c; simpl; intros; P.MX.elim_comp; auto with ordered_type. Qed. + #[global] Hint Resolve cons_Cmp : core. Lemma compare_end_Cmp : diff --git a/theories/FSets/FMapFacts.v b/theories/FSets/FMapFacts.v index 2001201ec3..bb52166ca7 100644 --- a/theories/FSets/FMapFacts.v +++ b/theories/FSets/FMapFacts.v @@ -20,6 +20,7 @@ Require Export FMapInterface. Set Implicit Arguments. Unset Strict Implicit. +#[global] Hint Extern 1 (Equivalence _) => constructor; congruence : core. (** * Facts about weak maps *) @@ -371,6 +372,7 @@ Proof. intros. rewrite eq_option_alt. intro e'. rewrite <- 2 find_mapsto_iff. apply add_neq_mapsto_iff; auto. Qed. +#[local] Hint Resolve add_neq_o : map. Lemma add_o : forall m x y e, @@ -404,6 +406,7 @@ Proof. intros. rewrite eq_option_alt. intro e. rewrite <- find_mapsto_iff, remove_mapsto_iff; now intuition. Qed. +#[local] Hint Resolve remove_eq_o : map. Lemma remove_neq_o : forall m x y, @@ -412,6 +415,7 @@ Proof. intros. rewrite eq_option_alt. intro e. rewrite <- find_mapsto_iff, remove_neq_mapsto_iff; now intuition. Qed. +#[local] Hint Resolve remove_neq_o : map. Lemma remove_o : forall m x y, @@ -1100,6 +1104,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). contradict Hnotin; rewrite <- Hnotin; exists e0; auto. Qed. + #[local] Hint Resolve NoDupA_eqk_eqke NoDupA_rev elements_3w : map. Lemma fold_Equal : forall m1 m2 i, Equal m1 m2 -> @@ -1232,6 +1237,7 @@ Module WProperties_fun (E:DecidableType)(M:WSfun E). Proof. intros; rewrite cardinal_Empty; auto. Qed. + #[local] Hint Resolve cardinal_inv_1 : map. Lemma cardinal_inv_2 : @@ -1846,6 +1852,7 @@ Module OrdProperties (M:S). unfold leb; f_equal; apply gtb_compat; auto. Qed. + #[local] Hint Resolve gtb_compat leb_compat elements_3 : map. Lemma elements_split : forall p m, diff --git a/theories/FSets/FMapFullAVL.v b/theories/FSets/FMapFullAVL.v index 03e8d270e9..d26510ab9d 100644 --- a/theories/FSets/FMapFullAVL.v +++ b/theories/FSets/FMapFullAVL.v @@ -63,6 +63,7 @@ Inductive avl : t elt -> Prop := (** * Automation and dedicated tactics about [avl]. *) +#[local] Hint Constructors avl : core. Lemma height_non_negative : forall (s : t elt), avl s -> @@ -100,6 +101,7 @@ Lemma avl_node : forall x e l r, avl l -> avl r -> Proof. intros; auto. Qed. +#[local] Hint Resolve avl_node : core. (** Results about [height] *) @@ -193,6 +195,7 @@ Lemma add_avl : forall m x e, avl m -> avl (add x e m). Proof. intros; generalize (add_avl_1 x e H); intuition. Qed. +#[local] Hint Resolve add_avl : core. (** * Extraction of minimum binding *) @@ -274,6 +277,7 @@ Lemma remove_avl : forall m x, avl m -> avl (remove x m). Proof. intros; generalize (remove_avl_1 x H); intuition. Qed. +#[local] Hint Resolve remove_avl : core. @@ -331,6 +335,7 @@ Lemma join_avl : forall l x d r, avl l -> avl r -> avl (join l x d r). Proof. intros; destruct (join_avl_1 x d H H0); auto. Qed. +#[local] Hint Resolve join_avl : core. (** concat *) @@ -341,6 +346,7 @@ Proof. intros; apply join_avl; auto. generalize (remove_min_avl H0); rewrite e1; simpl; auto. Qed. +#[local] Hint Resolve concat_avl : core. (** split *) @@ -355,6 +361,7 @@ Proof. Qed. End Elt. +#[global] Hint Constructors avl : core. Section Map. @@ -714,6 +721,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: Proof. destruct c; simpl; intros; MX.elim_comp; auto with ordered_type. Qed. + #[global] Hint Resolve cons_Cmp : core. Lemma compare_aux_Cmp : forall e, diff --git a/theories/FSets/FMapInterface.v b/theories/FSets/FMapInterface.v index ab87ba9722..77ce76721e 100644 --- a/theories/FSets/FMapInterface.v +++ b/theories/FSets/FMapInterface.v @@ -58,6 +58,7 @@ Definition Cmp (elt:Type)(cmp:elt->elt->bool) e1 e2 := cmp e1 e2 = true. Module Type WSfun (E : DecidableType). Definition key := E.t. + #[global] Hint Transparent key : core. Parameter t : Type -> Type. @@ -243,9 +244,11 @@ Module Type WSfun (E : DecidableType). (x:key)(f:option elt->option elt'->option elt''), In x (map2 f m m') -> In x m \/ In x m'. + #[global] Hint Immediate MapsTo_1 mem_2 is_empty_2 map_2 mapi_2 add_3 remove_3 find_2 : map. + #[global] Hint Resolve mem_1 is_empty_1 is_empty_2 add_1 add_2 remove_1 remove_2 find_1 fold_1 map_1 mapi_1 mapi_2 : map. diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v index a5c00189c4..204e8d0199 100644 --- a/theories/FSets/FMapList.v +++ b/theories/FSets/FMapList.v @@ -51,6 +51,7 @@ Proof. intro abs. inversion abs. Qed. +#[local] Hint Resolve empty_1 : core. Lemma empty_sorted : Sort empty. @@ -216,6 +217,7 @@ Proof. compute in H0,H1. simpl; case (X.compare x x''); intuition. Qed. +#[local] Hint Resolve add_Inf : core. Lemma add_sorted : forall m (Hm:Sort m) x e, Sort (add x e m). @@ -302,6 +304,7 @@ Proof. inversion_clear Hm. apply Inf_lt with (x'',e''); auto. Qed. +#[local] Hint Resolve remove_Inf : core. Lemma remove_sorted : forall m (Hm:Sort m) x, Sort (remove x m). @@ -586,6 +589,7 @@ Proof. inversion_clear H; auto. Qed. +#[local] Hint Resolve map_lelistA : core. Lemma map_sorted : forall (m: t elt)(Hm : sort (@ltk elt) m)(f:elt -> elt'), @@ -655,6 +659,7 @@ Proof. inversion_clear H; auto. Qed. +#[local] Hint Resolve mapi_lelistA : core. Lemma mapi_sorted : forall m (Hm : sort (@ltk elt) m)(f: key ->elt -> elt'), @@ -782,6 +787,7 @@ Proof. inversion_clear H; auto. inversion_clear H0; auto. Qed. +#[local] Hint Resolve combine_lelistA : core. Lemma combine_sorted : diff --git a/theories/FSets/FMapWeakList.v b/theories/FSets/FMapWeakList.v index c4bb67a52c..78e7ab69d8 100644 --- a/theories/FSets/FMapWeakList.v +++ b/theories/FSets/FMapWeakList.v @@ -49,6 +49,7 @@ Proof. inversion abs. Qed. +#[local] Hint Resolve empty_1 : core. Lemma empty_NoDup : NoDupA empty. @@ -621,6 +622,7 @@ Proof. inversion_clear 1. intros; apply add_NoDup; auto. Qed. +#[local] Hint Resolve fold_right_pair_NoDup : core. Lemma combine_NoDup : diff --git a/theories/FSets/FSetBridge.v b/theories/FSets/FSetBridge.v index 73021a84a3..4917fcb5fd 100644 --- a/theories/FSets/FSetBridge.v +++ b/theories/FSets/FSetBridge.v @@ -137,6 +137,7 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. generalize (E.eq_sym H0); case (Pdec x); case (Pdec y); firstorder. Qed. + #[global] Hint Resolve compat_P_aux : core. Definition filter : @@ -467,6 +468,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. Proof. intros; unfold elements; case (M.elements s); firstorder. Qed. + #[global] Hint Resolve elements_3 : core. Lemma elements_3w : forall s : t, NoDupA E.eq (elements s). @@ -666,6 +668,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. rewrite <- H1; firstorder. Qed. + #[global] Hint Resolve compat_P_aux : core. Definition filter (f : elt -> bool) (s : t) : t := diff --git a/theories/FSets/FSetDecide.v b/theories/FSets/FSetDecide.v index 8a217a752a..d597c0404a 100644 --- a/theories/FSets/FSetDecide.v +++ b/theories/FSets/FSetDecide.v @@ -466,6 +466,7 @@ the above form: (** Here is the tactic that will throw away hypotheses that are not useful (for the intended scope of the [fsetdec] tactic). *) + #[global] Hint Constructors FSet_elt_Prop FSet_Prop : FSet_Prop. Ltac discard_nonFSet := repeat ( @@ -518,6 +519,7 @@ the above form: (** The hint database [FSet_decidability] will be given to the [push_neg] tactic from the module [Negation]. *) + #[global] Hint Resolve dec_In dec_eq : FSet_decidability. (** ** Normalizing Propositions About Equality diff --git a/theories/FSets/FSetEqProperties.v b/theories/FSets/FSetEqProperties.v index ac08351ad9..7618880bd2 100644 --- a/theories/FSets/FSetEqProperties.v +++ b/theories/FSets/FSetEqProperties.v @@ -460,9 +460,11 @@ Qed. End BasicProperties. +#[global] Hint Immediate empty_mem is_empty_equal_empty add_mem_1 remove_mem_1 singleton_equal_add union_mem inter_mem diff_mem equal_sym add_remove remove_add : set. +#[global] Hint Resolve equal_mem_1 subset_mem_1 choose_mem_1 choose_mem_2 add_mem_2 remove_mem_2 equal_refl equal_equal subset_refl subset_equal subset_antisym diff --git a/theories/FSets/FSetInterface.v b/theories/FSets/FSetInterface.v index dfe22b7831..848c27cba1 100644 --- a/theories/FSets/FSetInterface.v +++ b/theories/FSets/FSetInterface.v @@ -253,13 +253,16 @@ Module Type WSfun (E : DecidableType). End Spec. + #[global] Hint Transparent elt : core. + #[global] Hint Resolve mem_1 equal_1 subset_1 empty_1 is_empty_1 choose_1 choose_2 add_1 add_2 remove_1 remove_2 singleton_2 union_1 union_2 union_3 inter_3 diff_3 fold_1 filter_3 for_all_1 exists_1 partition_1 partition_2 elements_1 elements_3w : set. + #[global] Hint Immediate In_1 mem_2 equal_2 subset_2 is_empty_2 add_3 remove_3 singleton_1 inter_1 inter_2 diff_1 diff_2 filter_1 filter_2 for_all_2 exists_2 elements_2 @@ -336,7 +339,9 @@ Module Type Sfun (E : OrderedType). End Spec. + #[global] Hint Resolve elements_3 : set. + #[global] Hint Immediate min_elt_1 min_elt_2 min_elt_3 max_elt_1 max_elt_2 max_elt_3 : set. diff --git a/theories/FSets/FSetProperties.v b/theories/FSets/FSetProperties.v index 98b445580b..af034bbdd5 100644 --- a/theories/FSets/FSetProperties.v +++ b/theories/FSets/FSetProperties.v @@ -21,7 +21,9 @@ Require Import DecidableTypeEx FSetFacts FSetDecide. Set Implicit Arguments. Unset Strict Implicit. +#[global] Hint Unfold transpose compat_op Proper respectful : fset. +#[global] Hint Extern 1 (Equivalence _) => constructor; congruence : fset. (** First, a functor for Weak Sets in functorial version. *) @@ -269,7 +271,9 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). End BasicProperties. + #[global] Hint Immediate equal_sym add_remove remove_add union_sym inter_sym: set. + #[global] Hint Resolve equal_refl equal_trans subset_refl subset_equal subset_antisym subset_trans subset_empty subset_remove_3 subset_diff subset_add_3 subset_add_2 in_subset empty_is_empty_1 empty_is_empty_2 add_equal @@ -732,6 +736,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). Proof. intros; rewrite cardinal_Empty; auto. Qed. + #[global] Hint Resolve cardinal_inv_1 : fset. Lemma cardinal_inv_2 : @@ -769,6 +774,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). exact Equal_cardinal. Qed. + #[global] Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal : fset. (** ** Cardinal and set operators *) @@ -778,6 +784,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). rewrite cardinal_fold; apply fold_1; auto with set fset. Qed. + #[global] Hint Immediate empty_cardinal cardinal_1 : set. Lemma singleton_cardinal : forall x, cardinal (singleton x) = 1. @@ -788,6 +795,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). apply cardinal_2 with x; auto with set. Qed. + #[global] Hint Resolve singleton_cardinal: set. Lemma diff_inter_cardinal : @@ -887,6 +895,7 @@ Module WProperties_fun (Import E : DecidableType)(M : WSfun E). auto with set fset. Qed. + #[global] Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2 : fset. End WProperties_fun. @@ -952,6 +961,7 @@ Module OrdProperties (M:S). red; intros x a b H; unfold leb. f_equal; apply gtb_compat; auto. Qed. + #[global] Hint Resolve gtb_compat leb_compat : fset. Lemma elements_split : forall x s, diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index 9984bff0c2..f013c857ea 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -83,6 +83,7 @@ Lemma andb_prop (a b:bool) : andb a b = true -> a = true /\ b = true. Proof. destruct a, b; repeat split; assumption. Qed. +#[global] Hint Resolve andb_prop: bool. Register andb_prop as core.bool.andb_prop. @@ -92,6 +93,7 @@ Lemma andb_true_intro (b1 b2:bool) : Proof. destruct b1; destruct b2; simpl; intros [? ?]; assumption. Qed. +#[global] Hint Resolve andb_true_intro: bool. Register andb_true_intro as core.bool.andb_true_intro. @@ -100,6 +102,7 @@ Register andb_true_intro as core.bool.andb_true_intro. Inductive eq_true : bool -> Prop := is_eq_true : eq_true true. +#[global] Hint Constructors eq_true : eq_true. Register eq_true as core.eq_true.type. @@ -142,6 +145,7 @@ Defined. Inductive BoolSpec (P Q : Prop) : bool -> Prop := | BoolSpecT : P -> BoolSpec P Q true | BoolSpecF : Q -> BoolSpec P Q false. +#[global] Hint Constructors BoolSpec : core. Register BoolSpec as core.BoolSpec.type. @@ -243,6 +247,7 @@ Section projections. End projections. +#[global] Hint Resolve pair inl inr: core. Lemma surjective_pairing (A B:Type) (p:A * B) : p = (fst p, snd p). @@ -380,6 +385,7 @@ Inductive CompareSpec (Peq Plt Pgt : Prop) : comparison -> Prop := | CompEq : Peq -> CompareSpec Peq Plt Pgt Eq | CompLt : Plt -> CompareSpec Peq Plt Pgt Lt | CompGt : Pgt -> CompareSpec Peq Plt Pgt Gt. +#[global] Hint Constructors CompareSpec : core. Register CompareSpec as core.CompareSpec.type. @@ -395,6 +401,7 @@ Inductive CompareSpecT (Peq Plt Pgt : Prop) : comparison -> Type := | CompEqT : Peq -> CompareSpecT Peq Plt Pgt Eq | CompLtT : Plt -> CompareSpecT Peq Plt Pgt Lt | CompGtT : Pgt -> CompareSpecT Peq Plt Pgt Gt. +#[global] Hint Constructors CompareSpecT : core. Register CompareSpecT as core.CompareSpecT.type. @@ -417,6 +424,7 @@ Definition CompSpec {A} (eq lt : A->A->Prop)(x y:A) : comparison -> Prop := Definition CompSpecT {A} (eq lt : A->A->Prop)(x y:A) : comparison -> Type := CompareSpecT (eq x y) (lt x y) (lt y x). +#[global] Hint Unfold CompSpec CompSpecT : core. Lemma CompSpec2Type : forall A (eq lt:A->A->Prop) x y c, @@ -435,6 +443,7 @@ Proof. intros. apply CompareSpec2Type; assumption. Defined. Inductive identity (A:Type) (a:A) : A -> Type := identity_refl : identity a a. +#[global] Hint Resolve identity_refl: core. Arguments identity_ind [A] a P f y i. diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index 8012235143..023705e169 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -41,9 +41,12 @@ Register not as core.not.type. variables and constants explicitly. *) Create HintDb core. +#[global] Hint Variables Opaque : core. +#[global] Hint Constants Opaque : core. +#[global] Hint Unfold not: core. (** [and A B], written [A /\ B], is the conjunction of [A] and [B] @@ -119,6 +122,7 @@ Theorem iff_sym : forall A B:Prop, (A <-> B) -> (B <-> A). End Equivalence. +#[global] Hint Unfold iff: extcore. (** Backward direction of the equivalences above does not need assumptions *) @@ -364,8 +368,11 @@ Notation "x = y" := (eq x y) : type_scope. Notation "x <> y :> T" := (~ x = y :>T) : type_scope. Notation "x <> y" := (~ (x = y)) : type_scope. +#[global] Hint Resolve I conj or_introl or_intror : core. +#[global] Hint Resolve eq_refl: core. +#[global] Hint Resolve ex_intro ex_intro2: core. Register eq as core.eq.type. @@ -733,6 +740,7 @@ Notation sym_equal := eq_sym (only parsing). Notation trans_equal := eq_trans (only parsing). Notation sym_not_equal := not_eq_sym (only parsing). +#[global] Hint Immediate eq_sym not_eq_sym: core. (** Basic definitions about relations and properties *) @@ -801,6 +809,7 @@ Qed. Inductive inhabited (A:Type) : Prop := inhabits : A -> inhabited A. +#[global] Hint Resolve inhabits: core. Lemma exists_inhabited : forall (A:Type) (P:A->Prop), diff --git a/theories/Init/Logic_Type.v b/theories/Init/Logic_Type.v index 3d9937ae89..f8869615cd 100644 --- a/theories/Init/Logic_Type.v +++ b/theories/Init/Logic_Type.v @@ -72,6 +72,7 @@ Definition identity_rect_r : intros A x P H y H0; case identity_sym with (1 := H0); trivial. Defined. +#[global] Hint Immediate identity_sym not_identity_sym: core. Notation refl_id := identity_refl (only parsing). diff --git a/theories/Init/Peano.v b/theories/Init/Peano.v index 98fd52f351..fb2a7a57fe 100644 --- a/theories/Init/Peano.v +++ b/theories/Init/Peano.v @@ -37,6 +37,7 @@ Local Notation "0" := O. Definition eq_S := f_equal S. Definition f_equal_nat := f_equal (A:=nat). +#[global] Hint Resolve f_equal_nat: core. (** The predecessor function *) @@ -53,12 +54,14 @@ Qed. (** Injectivity of successor *) Definition eq_add_S n m (H: S n = S m): n = m := f_equal pred H. +#[global] Hint Immediate eq_add_S: core. Theorem not_eq_S : forall n m:nat, n <> m -> S n <> S m. Proof. red; auto. Qed. +#[global] Hint Resolve not_eq_S: core. Definition IsSucc (n:nat) : Prop := @@ -73,12 +76,14 @@ Theorem O_S : forall n:nat, 0 <> S n. Proof. discriminate. Qed. +#[global] Hint Resolve O_S: core. Theorem n_Sn : forall n:nat, n <> S n. Proof. intro n; induction n; auto. Qed. +#[global] Hint Resolve n_Sn: core. (** Addition *) @@ -88,6 +93,7 @@ Infix "+" := Nat.add : nat_scope. Definition f_equal2_plus := f_equal2 plus. Definition f_equal2_nat := f_equal2 (A1:=nat) (A2:=nat). +#[global] Hint Resolve f_equal2_nat: core. Lemma plus_n_O : forall n:nat, n = n + 0. @@ -95,7 +101,9 @@ Proof. intro n; induction n; simpl; auto. Qed. +#[global] Remove Hints eq_refl : core. +#[global] Hint Resolve plus_n_O eq_refl: core. (* We want eq_refl to have higher priority than plus_n_O *) Lemma plus_O_n : forall n:nat, 0 + n = n. @@ -107,6 +115,7 @@ Lemma plus_n_Sm : forall n m:nat, S (n + m) = n + S m. Proof. intros n m; induction n; simpl; auto. Qed. +#[global] Hint Resolve plus_n_Sm: core. Lemma plus_Sn_m : forall n m:nat, S n + m = S (n + m). @@ -125,12 +134,14 @@ Notation mult := Nat.mul (only parsing). Infix "*" := Nat.mul : nat_scope. Definition f_equal2_mult := f_equal2 mult. +#[global] Hint Resolve f_equal2_mult: core. Lemma mult_n_O : forall n:nat, 0 = n * 0. Proof. intro n; induction n; simpl; auto. Qed. +#[global] Hint Resolve mult_n_O: core. Lemma mult_n_Sm : forall n m:nat, n * m + n = n * S m. @@ -139,6 +150,7 @@ Proof. destruct H; rewrite <- plus_n_Sm; apply eq_S. pattern m at 1 3; elim m; simpl; auto. Qed. +#[global] Hint Resolve mult_n_Sm: core. (** Standard associated names *) @@ -162,20 +174,24 @@ where "n <= m" := (le n m) : nat_scope. Register le_n as num.nat.le_n. +#[global] Hint Constructors le: core. (*i equivalent to : "Hints Resolve le_n le_S : core." i*) Definition lt (n m:nat) := S n <= m. +#[global] Hint Unfold lt: core. Infix "<" := lt : nat_scope. Definition ge (n m:nat) := m <= n. +#[global] Hint Unfold ge: core. Infix ">=" := ge : nat_scope. Definition gt (n m:nat) := m < n. +#[global] Hint Unfold gt: core. Infix ">" := gt : nat_scope. diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v index 1fb6dabe6f..5d759f3234 100644 --- a/theories/Init/Specif.v +++ b/theories/Init/Specif.v @@ -797,5 +797,7 @@ Proof. apply (h2 h1). Defined. +#[global] Hint Resolve left right inleft inright: core. +#[global] Hint Resolve exist exist2 existT existT2: core. diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v index 35bab1021e..8721b7c797 100644 --- a/theories/Init/Tactics.v +++ b/theories/Init/Tactics.v @@ -339,5 +339,6 @@ Tactic Notation "assert_fails" tactic3(tac) := assert_fails tac. Create HintDb rewrite discriminated. +#[global] Hint Variables Opaque : rewrite. Create HintDb typeclass_instances discriminated. diff --git a/theories/Lists/List.v b/theories/Lists/List.v index 4cc3597029..115c7cb365 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -163,6 +163,7 @@ Section Facts. Proof. auto using app_assoc. Qed. + #[local] Hint Resolve app_assoc_reverse : core. (* end hide *) @@ -385,10 +386,15 @@ Section Facts. End Facts. +#[global] Hint Resolve app_assoc app_assoc_reverse: datatypes. +#[global] Hint Resolve app_comm_cons app_cons_not_nil: datatypes. +#[global] Hint Immediate app_eq_nil: datatypes. +#[global] Hint Resolve app_eq_unit app_inj_tail: datatypes. +#[global] Hint Resolve in_eq in_cons in_inv in_nil in_app_or in_or_app: datatypes. @@ -1928,6 +1934,7 @@ Section length_order. Qed. End length_order. +#[global] Hint Resolve lel_refl lel_cons_cons lel_cons lel_nil lel_nil nil_cons: datatypes. @@ -1941,6 +1948,7 @@ Section SetIncl. Variable A : Type. Definition incl (l m:list A) := forall a:A, In a l -> In a m. + #[local] Hint Unfold incl : core. Lemma incl_nil_l : forall l, incl nil l. @@ -1959,12 +1967,14 @@ Section SetIncl. Proof. auto. Qed. + #[local] Hint Resolve incl_refl : core. Lemma incl_tl : forall (a:A) (l m:list A), incl l m -> incl l (a :: m). Proof. auto with datatypes. Qed. + #[local] Hint Immediate incl_tl : core. Lemma incl_tran : forall l m n:list A, incl l m -> incl m n -> incl l n. @@ -1976,12 +1986,14 @@ Section SetIncl. Proof. auto with datatypes. Qed. + #[local] Hint Immediate incl_appl : core. Lemma incl_appr : forall l m n:list A, incl l n -> incl l (m ++ n). Proof. auto with datatypes. Qed. + #[local] Hint Immediate incl_appr : core. Lemma incl_cons : @@ -1997,6 +2009,7 @@ Section SetIncl. now_show (In a0 l -> In a0 m). auto. Qed. + #[local] Hint Resolve incl_cons : core. Lemma incl_cons_inv : forall (a:A) (l m:list A), @@ -2012,6 +2025,7 @@ Section SetIncl. now_show (In a n). elim (in_app_or _ _ _ H1); auto. Qed. + #[local] Hint Resolve incl_app : core. Lemma incl_app_app : forall l1 l2 m1 m2:list A, @@ -2054,6 +2068,7 @@ Proof. apply in_map; intuition. Qed. +#[global] Hint Resolve incl_refl incl_tl incl_tran incl_appl incl_appr incl_cons incl_app incl_map: datatypes. @@ -2738,6 +2753,7 @@ Section Exists_Forall. | Exists_cons_hd : forall x l, P x -> Exists (x::l) | Exists_cons_tl : forall x l, Exists l -> Exists (x::l). + #[local] Hint Constructors Exists : core. Lemma Exists_exists (l:list A) : @@ -2815,6 +2831,7 @@ Section Exists_Forall. | Forall_nil : Forall nil | Forall_cons : forall x l, P x -> Forall l -> Forall (x::l). + #[local] Hint Constructors Forall : core. Lemma Forall_forall (l:list A): @@ -2999,7 +3016,9 @@ Section Exists_Forall. End Exists_Forall. +#[global] Hint Constructors Exists : core. +#[global] Hint Constructors Forall : core. Lemma exists_Forall A B : forall (P : A -> B -> Prop) l, @@ -3064,6 +3083,7 @@ Section Forall2. | Forall2_cons : forall x y l l', R x y -> Forall2 l l' -> Forall2 (x::l) (y::l'). + #[local] Hint Constructors Forall2 : core. Theorem Forall2_refl : Forall2 [] []. @@ -3098,6 +3118,7 @@ Section Forall2. Qed. End Forall2. +#[global] Hint Constructors Forall2 : core. Section ForallPairs. @@ -3119,6 +3140,7 @@ Section ForallPairs. | FOP_cons : forall a l, Forall (R a) l -> ForallOrdPairs l -> ForallOrdPairs (a::l). + #[local] Hint Constructors ForallOrdPairs : core. Lemma ForallOrdPairs_In : forall l, @@ -3344,6 +3366,7 @@ Notation rev_acc := rev_append (only parsing). Notation rev_acc_rev := rev_append_rev (only parsing). Notation AllS := Forall (only parsing). (* was formerly in TheoryList *) +#[global] Hint Resolve app_nil_end : datatypes. (* end hide *) diff --git a/theories/Lists/ListSet.v b/theories/Lists/ListSet.v index 7f5148d0dd..458d08ccb9 100644 --- a/theories/Lists/ListSet.v +++ b/theories/Lists/ListSet.v @@ -193,6 +193,7 @@ Section first_definitions. | auto with datatypes ]. Qed. + #[local] Hint Resolve set_add_intro1 set_add_intro2 : core. Lemma set_add_intro : @@ -224,6 +225,7 @@ Section first_definitions. case H1; trivial. Qed. + #[local] Hint Resolve set_add_intro set_add_elim set_add_elim2 : core. Lemma set_add_not_empty : forall (a:A) (x:set), set_add a x <> empty_set. @@ -310,6 +312,7 @@ Section first_definitions. intros; elim H0; auto with datatypes. Qed. + #[local] Hint Resolve set_union_intro2 set_union_intro1 : core. Lemma set_union_intro : @@ -393,6 +396,7 @@ Section first_definitions. eauto with datatypes. Qed. + #[local] Hint Resolve set_inter_elim1 set_inter_elim2 : core. Lemma set_inter_elim : @@ -471,6 +475,7 @@ Section first_definitions. apply (set_diff_elim1 _ _ _ H). Qed. +#[local] Hint Resolve set_diff_intro set_diff_trivial : core. diff --git a/theories/Lists/SetoidList.v b/theories/Lists/SetoidList.v index 48e9f992fd..826815410a 100644 --- a/theories/Lists/SetoidList.v +++ b/theories/Lists/SetoidList.v @@ -30,6 +30,7 @@ Inductive InA (x : A) : list A -> Prop := | InA_cons_hd : forall y l, eqA x y -> InA x (y :: l) | InA_cons_tl : forall y l, InA x l -> InA x (y :: l). +#[local] Hint Constructors InA : core. (** TODO: it would be nice to have a generic definition instead @@ -62,6 +63,7 @@ Inductive NoDupA : list A -> Prop := | NoDupA_nil : NoDupA nil | NoDupA_cons : forall x l, ~ InA x l -> NoDupA l -> NoDupA (x::l). +#[local] Hint Constructors NoDupA : core. (** An alternative definition of [NoDupA] based on [ForallOrdPairs] *) @@ -84,6 +86,7 @@ Definition equivlistA l l' := forall x, InA x l <-> InA x l'. Lemma incl_nil l : inclA nil l. Proof. intro. intros. inversion H. Qed. +#[local] Hint Resolve incl_nil : list. (** lists with same elements modulo [eqA] at the same place *) @@ -93,6 +96,7 @@ Inductive eqlistA : list A -> list A -> Prop := | eqlistA_cons : forall x x' l l', eqA x x' -> eqlistA l l' -> eqlistA (x::l) (x'::l'). +#[local] Hint Constructors eqlistA : core. (** We could also have written [eqlistA = Forall2 eqA]. *) @@ -107,7 +111,9 @@ Definition eqarefl := (@Equivalence_Reflexive _ _ eqA_equiv). Definition eqatrans := (@Equivalence_Transitive _ _ eqA_equiv). Definition eqasym := (@Equivalence_Symmetric _ _ eqA_equiv). +#[local] Hint Resolve eqarefl eqatrans : core. +#[local] Hint Immediate eqasym : core. Ltac inv := invlist InA; invlist sort; invlist lelistA; invlist NoDupA. @@ -154,6 +160,7 @@ Lemma InA_eqA : forall l x y, eqA x y -> InA x l -> InA y l. Proof. intros l x y H H'. rewrite <- H. auto. Qed. +#[local] Hint Immediate InA_eqA : core. Lemma In_InA : forall l x, In x l -> InA x l. @@ -161,6 +168,7 @@ Proof. simple induction l; simpl; intuition. subst; auto. Qed. +#[local] Hint Resolve In_InA : core. Lemma InA_split : forall l x, InA x l -> @@ -786,11 +794,13 @@ Hypothesis ltA_compat : Proper (eqA==>eqA==>iff) ltA. Let sotrans := (@StrictOrder_Transitive _ _ ltA_strorder). +#[local] Hint Resolve sotrans : core. Notation InfA:=(lelistA ltA). Notation SortA:=(sort ltA). +#[local] Hint Constructors lelistA sort : core. Lemma InfA_ltA : @@ -814,6 +824,7 @@ Lemma InfA_eqA l x y : eqA x y -> InfA y l -> InfA x l. Proof using eqA_equiv ltA_compat. intros H; now rewrite H. Qed. +#[local] Hint Immediate InfA_ltA InfA_eqA : core. Lemma SortA_InfA_InA : @@ -1005,6 +1016,7 @@ Qed. End Filter. End Type_with_equality. +#[global] Hint Constructors InA eqlistA NoDupA sort lelistA : core. Arguments equivlistA_cons_nil {A} eqA {eqA_equiv} x l _. diff --git a/theories/Lists/Streams.v b/theories/Lists/Streams.v index 7a275a8231..f16d70a4c2 100644 --- a/theories/Lists/Streams.v +++ b/theories/Lists/Streams.v @@ -54,6 +54,7 @@ Lemma tl_nth_tl : Proof. simple induction n; simpl; auto. Qed. +#[local] Hint Resolve tl_nth_tl: datatypes. Lemma Str_nth_tl_plus : diff --git a/theories/Logic/Classical_Prop.v b/theories/Logic/Classical_Prop.v index e5d364297d..b2b5985ff1 100644 --- a/theories/Logic/Classical_Prop.v +++ b/theories/Logic/Classical_Prop.v @@ -16,6 +16,7 @@ Require Import ClassicalFacts. +#[global] Hint Unfold not: core. Axiom classic : forall P:Prop, P \/ ~ P. diff --git a/theories/Logic/Decidable.v b/theories/Logic/Decidable.v index 998497f13e..5fb6bb3907 100644 --- a/theories/Logic/Decidable.v +++ b/theories/Logic/Decidable.v @@ -206,6 +206,7 @@ Qed. (** With the following hint database, we can leverage [auto] to check decidability of propositions. *) +#[global] Hint Resolve dec_True dec_False dec_or dec_and dec_imp dec_not dec_iff : decidable_prop. diff --git a/theories/Logic/Eqdep.v b/theories/Logic/Eqdep.v index f2e15c9abb..934806de93 100644 --- a/theories/Logic/Eqdep.v +++ b/theories/Logic/Eqdep.v @@ -35,5 +35,7 @@ Export EqdepTheory. (** Exported hints *) +#[global] Hint Resolve eq_dep_eq: eqdep. +#[global] Hint Resolve inj_pair2 inj_pairT2: eqdep. diff --git a/theories/Logic/EqdepFacts.v b/theories/Logic/EqdepFacts.v index a918d1ecd7..6589e75289 100644 --- a/theories/Logic/EqdepFacts.v +++ b/theories/Logic/EqdepFacts.v @@ -65,6 +65,7 @@ Section Dependent_Equality. Inductive eq_dep (p:U) (x:P p) : forall q:U, P q -> Prop := eq_dep_intro : eq_dep p x p x. + #[local] Hint Constructors eq_dep: core. Lemma eq_dep_refl : forall (p:U) (x:P p), eq_dep p x p x. @@ -75,6 +76,7 @@ Section Dependent_Equality. Proof. destruct 1; auto. Qed. + #[local] Hint Immediate eq_dep_sym: core. Lemma eq_dep_trans : @@ -221,7 +223,9 @@ Unset Implicit Arguments. (** Exported hints *) +#[global] Hint Resolve eq_dep_intro: core. +#[global] Hint Immediate eq_dep_sym: core. (************************************************************************) diff --git a/theories/Logic/JMeq.v b/theories/Logic/JMeq.v index ccd7db177c..7ee3a99d60 100644 --- a/theories/Logic/JMeq.v +++ b/theories/Logic/JMeq.v @@ -31,6 +31,7 @@ Arguments JMeq_refl {A x} , [A] x. Register JMeq as core.JMeq.type. Register JMeq_refl as core.JMeq.refl. +#[global] Hint Resolve JMeq_refl : core. Definition JMeq_hom {A : Type} (x y : A) := JMeq x y. @@ -42,6 +43,7 @@ Proof. intros; destruct H; trivial. Qed. +#[global] Hint Immediate JMeq_sym : core. Register JMeq_sym as core.JMeq.sym. diff --git a/theories/MSets/MSetDecide.v b/theories/MSets/MSetDecide.v index 0f62a9419b..aa0c419f0e 100644 --- a/theories/MSets/MSetDecide.v +++ b/theories/MSets/MSetDecide.v @@ -466,6 +466,7 @@ the above form: (** Here is the tactic that will throw away hypotheses that are not useful (for the intended scope of the [fsetdec] tactic). *) + #[global] Hint Constructors MSet_elt_Prop MSet_Prop : MSet_Prop. Ltac discard_nonMSet := repeat ( @@ -518,6 +519,7 @@ the above form: (** The hint database [MSet_decidability] will be given to the [push_neg] tactic from the module [Negation]. *) + #[global] Hint Resolve dec_In dec_eq : MSet_decidability. (** ** Normalizing Propositions About Equality diff --git a/theories/MSets/MSetEqProperties.v b/theories/MSets/MSetEqProperties.v index dc22af4948..b439be9b3f 100644 --- a/theories/MSets/MSetEqProperties.v +++ b/theories/MSets/MSetEqProperties.v @@ -462,9 +462,11 @@ Qed. End BasicProperties. +#[global] Hint Immediate empty_mem is_empty_equal_empty add_mem_1 remove_mem_1 singleton_equal_add union_mem inter_mem diff_mem equal_sym add_remove remove_add : set. +#[global] Hint Resolve equal_mem_1 subset_mem_1 choose_mem_1 choose_mem_2 add_mem_2 remove_mem_2 equal_refl equal_equal subset_refl subset_equal subset_antisym diff --git a/theories/MSets/MSetFacts.v b/theories/MSets/MSetFacts.v index 7dbb658e46..ea86c7a4d7 100644 --- a/theories/MSets/MSetFacts.v +++ b/theories/MSets/MSetFacts.v @@ -139,12 +139,14 @@ Notation choose_1 := choose_spec1 (only parsing). Notation choose_2 := choose_spec2 (only parsing). Notation elements_3w := elements_spec2w (only parsing). +#[global] Hint Resolve mem_1 equal_1 subset_1 empty_1 is_empty_1 choose_1 choose_2 add_1 add_2 remove_1 remove_2 singleton_2 union_1 union_2 union_3 inter_3 diff_3 fold_1 filter_3 for_all_1 exists_1 partition_1 partition_2 elements_1 elements_3w : set. +#[global] Hint Immediate In_1 mem_2 equal_2 subset_2 is_empty_2 add_3 remove_3 singleton_1 inter_1 inter_2 diff_1 diff_2 filter_1 filter_2 for_all_2 exists_2 elements_2 diff --git a/theories/MSets/MSetGenTree.v b/theories/MSets/MSetGenTree.v index 58656b666e..37d20bffad 100644 --- a/theories/MSets/MSetGenTree.v +++ b/theories/MSets/MSetGenTree.v @@ -46,6 +46,7 @@ End InfoTyp. Module Type Ops (X:OrderedType)(Info:InfoTyp). Definition elt := X.t. +#[global] Hint Transparent elt : core. Inductive tree : Type := diff --git a/theories/MSets/MSetInterface.v b/theories/MSets/MSetInterface.v index fe5d721ffa..c0567f9ef1 100644 --- a/theories/MSets/MSetInterface.v +++ b/theories/MSets/MSetInterface.v @@ -442,6 +442,7 @@ Module WRaw2SetsOn (E:DecidableType)(M:WRawSets E) <: WSetsOn E. Record t_ := Mkt {this :> M.t; is_ok : M.Ok this}. Definition t := t_. Arguments Mkt this {is_ok}. + #[global] Hint Resolve is_ok : typeclass_instances. Definition In (x : elt)(s : t) := M.In x (this s). @@ -884,9 +885,11 @@ Module MakeListOrdering (O:OrderedType). O.lt x y -> lt_list (x :: s) (y :: s') | lt_cons_eq : forall x y s s', O.eq x y -> lt_list s s' -> lt_list (x :: s) (y :: s'). + #[global] Hint Constructors lt_list : core. Definition lt := lt_list. + #[global] Hint Unfold lt : core. Instance lt_strorder : StrictOrder lt. @@ -933,6 +936,7 @@ Module MakeListOrdering (O:OrderedType). left; MO.order. right; rewrite <- E12; auto. left; MO.order. right; rewrite E12; auto. Qed. + #[global] Hint Resolve eq_cons : core. Lemma cons_CompSpec : forall c x1 x2 l1 l2, O.eq x1 x2 -> @@ -940,6 +944,7 @@ Module MakeListOrdering (O:OrderedType). Proof. destruct c; simpl; inversion_clear 2; auto with relations. Qed. + #[global] Hint Resolve cons_CompSpec : core. End MakeListOrdering. diff --git a/theories/MSets/MSetList.v b/theories/MSets/MSetList.v index d2878b4710..84cf620474 100644 --- a/theories/MSets/MSetList.v +++ b/theories/MSets/MSetList.v @@ -231,13 +231,16 @@ Module MakeRaw (X: OrderedType) <: RawSets X. Notation In := (InA X.eq). Existing Instance X.eq_equiv. + #[local] Hint Extern 20 => solve [order] : core. Definition IsOk s := Sort s. Class Ok (s:t) : Prop := ok : Sort s. + #[local] Hint Resolve ok : core. + #[local] Hint Unfold Ok : core. Instance Sort_Ok s `(Hs : Sort s) : Ok s := { ok := Hs }. @@ -276,6 +279,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X. destruct H; constructor; tauto. Qed. + #[local] Hint Extern 1 (Ok _) => rewrite <- isok_iff : core. Ltac inv_ok := match goal with @@ -326,6 +330,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X. intuition. intros; elim_compare x a; inv; intuition. Qed. + #[local] Hint Resolve add_inf : core. Global Instance add_ok s x : forall `(Ok s), Ok (add x s). @@ -353,6 +358,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X. intros; elim_compare x a; inv; auto. apply Inf_lt with a; auto. Qed. + #[local] Hint Resolve remove_inf : core. Global Instance remove_ok s x : forall `(Ok s), Ok (remove x s). @@ -396,6 +402,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X. Proof. induction2. Qed. + #[local] Hint Resolve union_inf : core. Global Instance union_ok s s' : forall `(Ok s, Ok s'), Ok (union s s'). @@ -422,6 +429,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X. apply Hrec'; auto. apply Inf_lt with x'; auto. Qed. + #[local] Hint Resolve inter_inf : core. Global Instance inter_ok s s' : forall `(Ok s, Ok s'), Ok (inter s s'). @@ -452,6 +460,7 @@ Module MakeRaw (X: OrderedType) <: RawSets X. apply Hrec'; auto. apply Inf_lt with x'; auto. Qed. + #[local] Hint Resolve diff_inf : core. Global Instance diff_ok s s' : forall `(Ok s, Ok s'), Ok (diff s s'). diff --git a/theories/MSets/MSetProperties.v b/theories/MSets/MSetProperties.v index 51807e5cda..b49a91ed14 100644 --- a/theories/MSets/MSetProperties.v +++ b/theories/MSets/MSetProperties.v @@ -21,6 +21,7 @@ Require Import DecidableTypeEx OrdersLists MSetFacts MSetDecide. Set Implicit Arguments. Unset Strict Implicit. +#[global] Hint Unfold transpose : core. (** First, a functor for Weak Sets in functorial version. *) @@ -268,7 +269,9 @@ Module WPropertiesOn (Import E : DecidableType)(M : WSetsOn E). End BasicProperties. + #[global] Hint Immediate equal_sym add_remove remove_add union_sym inter_sym: set. + #[global] Hint Resolve equal_refl equal_trans subset_refl subset_equal subset_antisym subset_trans subset_empty subset_remove_3 subset_diff subset_add_3 subset_add_2 in_subset empty_is_empty_1 empty_is_empty_2 add_equal @@ -735,6 +738,7 @@ Module WPropertiesOn (Import E : DecidableType)(M : WSetsOn E). Proof. intros; rewrite cardinal_Empty; auto. Qed. + #[global] Hint Resolve cardinal_inv_1 : core. Lemma cardinal_inv_2 : @@ -774,6 +778,7 @@ Module WPropertiesOn (Import E : DecidableType)(M : WSetsOn E). exact Equal_cardinal. Qed. + #[global] Hint Resolve Add_add Add_remove Equal_remove cardinal_inv_1 Equal_cardinal : core. (** ** Cardinal and set operators *) @@ -783,6 +788,7 @@ Module WPropertiesOn (Import E : DecidableType)(M : WSetsOn E). rewrite cardinal_fold; apply fold_1; auto with *. Qed. + #[global] Hint Immediate empty_cardinal cardinal_1 : set. Lemma singleton_cardinal : forall x, cardinal (singleton x) = 1. @@ -793,6 +799,7 @@ Module WPropertiesOn (Import E : DecidableType)(M : WSetsOn E). apply cardinal_2 with x; auto with set. Qed. + #[global] Hint Resolve singleton_cardinal: set. Lemma diff_inter_cardinal : @@ -898,6 +905,7 @@ Module WPropertiesOn (Import E : DecidableType)(M : WSetsOn E). auto with set. Qed. + #[global] Hint Resolve subset_cardinal union_cardinal add_cardinal_1 add_cardinal_2 : core. End WPropertiesOn. @@ -922,7 +930,9 @@ Module OrdProperties (M:Sets). Import M.E. Import M. + #[global] Hint Resolve elements_spec2 : core. + #[global] Hint Immediate min_elt_spec1 min_elt_spec2 min_elt_spec3 max_elt_spec1 max_elt_spec2 max_elt_spec3 : set. @@ -961,6 +971,7 @@ Module OrdProperties (M:Sets). Proof. intros a b H; unfold leb. rewrite H; auto. Qed. + #[global] Hint Resolve gtb_compat leb_compat : core. Lemma elements_split : forall x s, diff --git a/theories/MSets/MSetWeakList.v b/theories/MSets/MSetWeakList.v index 2498d82889..8a5ba2d80f 100644 --- a/theories/MSets/MSetWeakList.v +++ b/theories/MSets/MSetWeakList.v @@ -123,14 +123,18 @@ Module MakeRaw (X:DecidableType) <: WRawSets X. Let eqr:= (@Equivalence_Reflexive _ _ X.eq_equiv). Let eqsym:= (@Equivalence_Symmetric _ _ X.eq_equiv). Let eqtrans:= (@Equivalence_Transitive _ _ X.eq_equiv). + #[local] Hint Resolve eqr eqtrans : core. + #[local] Hint Immediate eqsym : core. Definition IsOk := NoDup. Class Ok (s:t) : Prop := ok : NoDup s. + #[local] Hint Unfold Ok : core. + #[local] Hint Resolve ok : core. Instance NoDup_Ok s (nd : NoDup s) : Ok s := { ok := nd }. diff --git a/theories/Numbers/Cyclic/Int31/Cyclic31.v b/theories/Numbers/Cyclic/Int31/Cyclic31.v index f6b2544b6e..c5c75fc17a 100644 --- a/theories/Numbers/Cyclic/Int31/Cyclic31.v +++ b/theories/Numbers/Cyclic/Int31/Cyclic31.v @@ -467,6 +467,7 @@ Section Basics. apply phibis_aux_pos. Qed. + #[local] Hint Resolve phi_nonneg : zarith. Lemma phi_bounded : forall x, (0 <= phi x < 2 ^ (Z.of_nat size))%Z. diff --git a/theories/Numbers/Cyclic/Int63/Int63.v b/theories/Numbers/Cyclic/Int63/Int63.v index 383c0aff3a..dbca2f0947 100644 --- a/theories/Numbers/Cyclic/Int63/Int63.v +++ b/theories/Numbers/Cyclic/Int63/Int63.v @@ -290,6 +290,7 @@ Proof. intros h; apply Z.lt_gt, Zpower_gt_0; lia. Qed. Lemma pow2_nz n : 0 <= n → 2 ^ n ≠ 0. Proof. intros h; generalize (pow2_pos _ h); lia. Qed. +#[global] Hint Resolve pow2_pos pow2_nz : zarith. (* =================================================== *) diff --git a/theories/Numbers/Cyclic/ZModulo/ZModulo.v b/theories/Numbers/Cyclic/ZModulo/ZModulo.v index 5e486333b2..6aad65899a 100644 --- a/theories/Numbers/Cyclic/ZModulo/ZModulo.v +++ b/theories/Numbers/Cyclic/ZModulo/ZModulo.v @@ -61,6 +61,7 @@ Section ZModulo. apply Z.lt_gt. unfold wB, base; auto with zarith. Qed. + #[local] Hint Resolve wB_pos : core. Lemma spec_to_Z_1 : forall x, 0 <= [|x|]. @@ -72,6 +73,7 @@ Section ZModulo. Proof. unfold to_Z; intros; destruct (Z_mod_lt x wB wB_pos); auto. Qed. + #[local] Hint Resolve spec_to_Z_1 spec_to_Z_2 : core. Lemma spec_to_Z : forall x, 0 <= [|x|] < wB. @@ -706,6 +708,7 @@ Section ZModulo. Proof. induction p; simpl; auto with zarith. Qed. + #[local] Hint Resolve Ptail_pos : core. Lemma Ptail_bounded : forall p d, Zpos p < 2^(Zpos d) -> Ptail p < Zpos d. diff --git a/theories/Numbers/Natural/Abstract/NDefOps.v b/theories/Numbers/Natural/Abstract/NDefOps.v index 019b138b4d..2f8fcc7290 100644 --- a/theories/Numbers/Natural/Abstract/NDefOps.v +++ b/theories/Numbers/Natural/Abstract/NDefOps.v @@ -383,6 +383,7 @@ f_equiv. apply E, half_decrease. rewrite two_succ, <- not_true_iff_false, ltb_lt, nlt_ge, le_succ_l in H. order'. Qed. +#[global] Hint Resolve log_good_step : core. Theorem log_init : forall n, n < 2 -> log n == 0. diff --git a/theories/Program/Basics.v b/theories/Program/Basics.v index 3e282f696a..3ecb5a5a61 100644 --- a/theories/Program/Basics.v +++ b/theories/Program/Basics.v @@ -26,6 +26,7 @@ Arguments id {A} x. Definition compose {A B C} (g : B -> C) (f : A -> B) := fun x : A => g (f x). +#[global] Hint Unfold compose : core. Declare Scope program_scope. diff --git a/theories/Program/Equality.v b/theories/Program/Equality.v index 5862a08838..25af2d5ffb 100644 --- a/theories/Program/Equality.v +++ b/theories/Program/Equality.v @@ -21,6 +21,7 @@ Ltac is_ground_goal := (** Try to find a contradiction. *) +#[global] Hint Extern 10 => is_ground_goal ; progress exfalso : exfalso. (** We will use the [block] definition to separate the goal from the @@ -308,6 +309,7 @@ Proof. intros. rewrite (UIP_refl A). assumption. Defined. (** This hint database and the following tactic can be used with [autounfold] to unfold everything to [eq_rect]s. *) +#[global] Hint Unfold solution_left solution_right deletion simplification_heq simplification_existT1 simplification_existT2 simplification_K eq_rect_r eq_rec eq_ind : dep_elim. diff --git a/theories/Program/Wf.v b/theories/Program/Wf.v index 688db8b812..d1be8812e9 100644 --- a/theories/Program/Wf.v +++ b/theories/Program/Wf.v @@ -108,6 +108,7 @@ Section Measure_well_founded. End Measure_well_founded. +#[global] Hint Resolve measure_wf : core. Section Fix_rects. diff --git a/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v index fa4f9134cc..b008c6c2aa 100644 --- a/theories/QArith/QArith_base.v +++ b/theories/QArith/QArith_base.v @@ -95,7 +95,9 @@ Proof. symmetry. apply Z.ge_le_iff. Qed. +#[global] Hint Unfold Qeq Qlt Qle : qarith. +#[global] Hint Extern 5 (?X1 <> ?X2) => intro; discriminate: qarith. Lemma Qcompare_antisym x y : CompOpp (x ?= y) = (y ?= x). @@ -127,7 +129,9 @@ apply Z.mul_reg_r with (QDen y); [auto with qarith|]. now rewrite Z.mul_shuffle0, XY, Z.mul_shuffle0, YZ, Z.mul_shuffle0. Qed. +#[global] Hint Immediate Qeq_sym : qarith. +#[global] Hint Resolve Qeq_refl Qeq_trans : qarith. (** In a word, [Qeq] is a setoid equality. *) @@ -203,6 +207,7 @@ Proof. rewrite !Qeq_bool_iff; apply Qeq_trans. Qed. +#[global] Hint Resolve Qnot_eq_sym : qarith. (** * Addition, multiplication and opposite *) @@ -783,6 +788,7 @@ Proof. Close Scope Z_scope. Qed. +#[global] Hint Resolve Qle_trans : qarith. Lemma Qlt_irrefl x : ~x<x. @@ -863,6 +869,7 @@ Proof. unfold Qle, Qlt, Qeq; intros; now apply Z.lt_eq_cases. Qed. +#[global] Hint Resolve Qle_not_lt Qlt_not_le Qnot_le_lt Qnot_lt_le Qlt_le_weak Qlt_not_eq Qle_antisym Qle_refl: qarith. @@ -904,6 +911,7 @@ Proof. Qed. +#[global] Hint Resolve Qopp_le_compat : qarith. Lemma Qle_minus_iff : forall p q, p <= q <-> 0 <= q+-p. diff --git a/theories/QArith/Qabs.v b/theories/QArith/Qabs.v index 13e88fc093..d1ff1fc794 100644 --- a/theories/QArith/Qabs.v +++ b/theories/QArith/Qabs.v @@ -11,6 +11,7 @@ Require Export QArith. Require Export Qreduction. +#[global] Hint Resolve Qlt_le_weak : qarith. Definition Qabs (x:Q) := let (n,d):=x in (Z.abs n#d). diff --git a/theories/QArith/Qcanon.v b/theories/QArith/Qcanon.v index 63b0a5afb7..bd43f901bb 100644 --- a/theories/QArith/Qcanon.v +++ b/theories/QArith/Qcanon.v @@ -66,6 +66,7 @@ Proof. rewrite hq, hq' in H'. subst q'. f_equal. apply eq_proofs_unicity. intros. repeat decide equality. Qed. +#[global] Hint Resolve Qc_is_canon : core. Theorem Qc_decomp: forall q q': Qc, (q:Q) = q' -> q = q'. diff --git a/theories/QArith/Qreals.v b/theories/QArith/Qreals.v index 20b5cb236b..5a23a20811 100644 --- a/theories/QArith/Qreals.v +++ b/theories/QArith/Qreals.v @@ -19,6 +19,7 @@ intros. now apply not_O_IZR. Qed. +#[global] Hint Resolve IZR_nz Rmult_integral_contrapositive : core. Lemma eqR_Qeq : forall x y : Q, Q2R x = Q2R y -> x==y. diff --git a/theories/QArith/Qround.v b/theories/QArith/Qround.v index 8fd342ab15..06f4ca02d1 100644 --- a/theories/QArith/Qround.v +++ b/theories/QArith/Qround.v @@ -18,6 +18,7 @@ rewrite !Z.mul_opp_l. apply Z.opp_lt_mono. Qed. +#[global] Hint Resolve Qopp_lt_compat : qarith. (************) @@ -54,6 +55,7 @@ rewrite Z.mul_comm. now apply Z.mul_div_le. Qed. +#[global] Hint Resolve Qfloor_le : qarith. Lemma Qle_ceiling : forall x, x <= Qceiling x. @@ -66,6 +68,7 @@ change (Qceiling x:Q) with (-(Qfloor(-x))). auto with *. Qed. +#[global] Hint Resolve Qle_ceiling : qarith. Lemma Qle_floor_ceiling : forall x, Qfloor x <= Qceiling x. @@ -88,6 +91,7 @@ rewrite <- Z.lt_add_lt_sub_r. destruct (Z_mod_lt n (Zpos d)); auto with *. Qed. +#[global] Hint Resolve Qlt_floor : qarith. Lemma Qceiling_lt : forall x, (Qceiling x-1)%Z < x. @@ -101,6 +105,7 @@ rewrite Qopp_involutive. auto with *. Qed. +#[global] Hint Resolve Qceiling_lt : qarith. Lemma Qfloor_resp_le : forall x y, x <= y -> (Qfloor x <= Qfloor y)%Z. @@ -114,6 +119,7 @@ rewrite (Z.mul_comm (Zpos yd) (Zpos xd)). apply Z_div_le; auto with *. Qed. +#[global] Hint Resolve Qfloor_resp_le : qarith. Lemma Qceiling_resp_le : forall x y, x <= y -> (Qceiling x <= Qceiling y)%Z. @@ -123,6 +129,7 @@ unfold Qceiling. rewrite <- Z.opp_le_mono; auto with qarith. Qed. +#[global] Hint Resolve Qceiling_resp_le : qarith. Add Morphism Qfloor with signature Qeq ==> eq as Qfloor_comp. diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v index 993b7b3ec4..fd8acf481a 100644 --- a/theories/Reals/RIneq.v +++ b/theories/Reals/RIneq.v @@ -37,10 +37,12 @@ Lemma Rle_refl : forall r, r <= r. Proof. intro; right; reflexivity. Qed. +#[global] Hint Immediate Rle_refl: rorders. Lemma Rge_refl : forall r, r <= r. Proof. exact Rle_refl. Qed. +#[global] Hint Immediate Rge_refl: rorders. (** Irreflexivity of the strict order *) @@ -49,6 +51,7 @@ Lemma Rlt_irrefl : forall r, ~ r < r. Proof. intros r H; eapply Rlt_asym; eauto. Qed. +#[global] Hint Resolve Rlt_irrefl: real. Lemma Rgt_irrefl : forall r, ~ r > r. @@ -72,6 +75,7 @@ Proof. - apply Rlt_not_eq in H1. eauto. - apply Rgt_not_eq in H1. eauto. Qed. +#[global] Hint Resolve Rlt_dichotomy_converse: real. (** Reasoning by case on equality and order *) @@ -82,6 +86,7 @@ Proof. intros; generalize (total_order_T r1 r2) Rlt_dichotomy_converse; unfold not; intuition eauto 3. Qed. +#[global] Hint Resolve Req_dec: real. (**********) @@ -110,6 +115,7 @@ Lemma Rlt_le : forall r1 r2, r1 < r2 -> r1 <= r2. Proof. intros; red; tauto. Qed. +#[global] Hint Resolve Rlt_le: real. Lemma Rgt_ge : forall r1 r2, r1 > r2 -> r1 >= r2. @@ -122,14 +128,18 @@ Lemma Rle_ge : forall r1 r2, r1 <= r2 -> r2 >= r1. Proof. destruct 1; red; auto with real. Qed. +#[global] Hint Immediate Rle_ge: real. +#[global] Hint Resolve Rle_ge: rorders. Lemma Rge_le : forall r1 r2, r1 >= r2 -> r2 <= r1. Proof. destruct 1; red; auto with real. Qed. +#[global] Hint Resolve Rge_le: real. +#[global] Hint Immediate Rge_le: rorders. (**********) @@ -137,12 +147,14 @@ Lemma Rlt_gt : forall r1 r2, r1 < r2 -> r2 > r1. Proof. trivial. Qed. +#[global] Hint Resolve Rlt_gt: rorders. Lemma Rgt_lt : forall r1 r2, r1 > r2 -> r2 < r1. Proof. trivial. Qed. +#[global] Hint Immediate Rgt_lt: rorders. (**********) @@ -151,6 +163,7 @@ Lemma Rnot_le_lt : forall r1 r2, ~ r1 <= r2 -> r2 < r1. Proof. intros r1 r2; generalize (Rtotal_order r1 r2); unfold Rle; tauto. Qed. +#[global] Hint Immediate Rnot_le_lt: real. Lemma Rnot_ge_gt : forall r1 r2, ~ r1 >= r2 -> r2 > r1. @@ -183,6 +196,7 @@ Proof. generalize Rlt_asym Rlt_dichotomy_converse; unfold Rle. unfold not; intuition eauto 3. Qed. +#[global] Hint Immediate Rlt_not_le: real. Lemma Rgt_not_le : forall r1 r2, r1 > r2 -> ~ r1 <= r2. @@ -190,6 +204,7 @@ Proof. exact Rlt_not_le. Qed. Lemma Rlt_not_ge : forall r1 r2, r1 < r2 -> ~ r1 >= r2. Proof. red; intros; eapply Rlt_not_le; eauto with real. Qed. +#[global] Hint Immediate Rlt_not_ge: real. Lemma Rgt_not_ge : forall r1 r2, r2 > r1 -> ~ r1 >= r2. @@ -215,24 +230,28 @@ Lemma Req_le : forall r1 r2, r1 = r2 -> r1 <= r2. Proof. unfold Rle; tauto. Qed. +#[global] Hint Immediate Req_le: real. Lemma Req_ge : forall r1 r2, r1 = r2 -> r1 >= r2. Proof. unfold Rge; tauto. Qed. +#[global] Hint Immediate Req_ge: real. Lemma Req_le_sym : forall r1 r2, r2 = r1 -> r1 <= r2. Proof. unfold Rle; auto. Qed. +#[global] Hint Immediate Req_le_sym: real. Lemma Req_ge_sym : forall r1 r2, r2 = r1 -> r1 >= r2. Proof. unfold Rge; auto. Qed. +#[global] Hint Immediate Req_ge_sym: real. (** *** Asymmetry *) @@ -248,6 +267,7 @@ Lemma Rle_antisym : forall r1 r2, r1 <= r2 -> r2 <= r1 -> r1 = r2. Proof. intros r1 r2; generalize (Rlt_asym r1 r2); unfold Rle; intuition. Qed. +#[global] Hint Resolve Rle_antisym: real. Lemma Rge_antisym : forall r1 r2, r1 >= r2 -> r2 >= r1 -> r1 = r2. @@ -387,12 +407,14 @@ Lemma Rplus_0_r : forall r, r + 0 = r. Proof. intro; ring. Qed. +#[global] Hint Resolve Rplus_0_r: real. Lemma Rplus_ne : forall r, r + 0 = r /\ 0 + r = r. Proof. split; ring. Qed. +#[global] Hint Resolve Rplus_ne: real. (**********) @@ -403,6 +425,7 @@ Lemma Rplus_opp_l : forall r, - r + r = 0. Proof. intro; ring. Qed. +#[global] Hint Resolve Rplus_opp_l: real. (**********) @@ -415,6 +438,7 @@ Qed. Definition f_equal_R := (f_equal (A:=R)). +#[global] Hint Resolve f_equal_R : real. Lemma Rplus_eq_compat_l : forall r r1 r2, r1 = r2 -> r + r1 = r + r2. @@ -439,6 +463,7 @@ Proof. repeat rewrite Rplus_assoc; rewrite <- H; reflexivity. ring. Qed. +#[global] Hint Resolve Rplus_eq_reg_l: real. Lemma Rplus_eq_reg_r : forall r r1 r2, r1 + r = r2 + r -> r1 = r2. @@ -485,18 +510,21 @@ Lemma Rinv_r : forall r, r <> 0 -> r * / r = 1. Proof. intros; field; trivial. Qed. +#[global] Hint Resolve Rinv_r: real. Lemma Rinv_l_sym : forall r, r <> 0 -> 1 = / r * r. Proof. intros; field; trivial. Qed. +#[global] Hint Resolve Rinv_l_sym: real. Lemma Rinv_r_sym : forall r, r <> 0 -> 1 = r * / r. Proof. intros; field; trivial. Qed. +#[global] Hint Resolve Rinv_r_sym: real. (**********) @@ -504,6 +532,7 @@ Lemma Rmult_0_r : forall r, r * 0 = 0. Proof. intro; ring. Qed. +#[global] Hint Resolve Rmult_0_r: real. (**********) @@ -511,6 +540,7 @@ Lemma Rmult_0_l : forall r, 0 * r = 0. Proof. intro; ring. Qed. +#[global] Hint Resolve Rmult_0_l: real. (**********) @@ -518,6 +548,7 @@ Lemma Rmult_ne : forall r, r * 1 = r /\ 1 * r = r. Proof. intro; split; ring. Qed. +#[global] Hint Resolve Rmult_ne: real. (**********) @@ -525,6 +556,7 @@ Lemma Rmult_1_r : forall r, r * 1 = r. Proof. intro; ring. Qed. +#[global] Hint Resolve Rmult_1_r: real. (**********) @@ -572,6 +604,7 @@ Proof. intros r1 r2 [H| H]; rewrite H; auto with real. Qed. +#[global] Hint Resolve Rmult_eq_0_compat: real. (**********) @@ -599,6 +632,7 @@ Proof. red; intros r1 r2 [H1 H2] H. case (Rmult_integral r1 r2); auto with real. Qed. +#[global] Hint Resolve Rmult_integral_contrapositive: real. Lemma Rmult_integral_contrapositive_currified : @@ -640,6 +674,7 @@ Lemma Ropp_eq_compat : forall r1 r2, r1 = r2 -> - r1 = - r2. Proof. auto with real. Qed. +#[global] Hint Resolve Ropp_eq_compat: real. (**********) @@ -647,6 +682,7 @@ Lemma Ropp_0 : -0 = 0. Proof. ring. Qed. +#[global] Hint Resolve Ropp_0: real. (**********) @@ -654,6 +690,7 @@ Lemma Ropp_eq_0_compat : forall r, r = 0 -> - r = 0. Proof. intros; rewrite H; auto with real. Qed. +#[global] Hint Resolve Ropp_eq_0_compat: real. (**********) @@ -661,6 +698,7 @@ Lemma Ropp_involutive : forall r, - - r = r. Proof. intro; ring. Qed. +#[global] Hint Resolve Ropp_involutive: real. (*********) @@ -670,6 +708,7 @@ Proof. apply H. transitivity (- - r); auto with real. Qed. +#[global] Hint Resolve Ropp_neq_0_compat: real. (**********) @@ -677,6 +716,7 @@ Lemma Ropp_plus_distr : forall r1 r2, - (r1 + r2) = - r1 + - r2. Proof. intros; ring. Qed. +#[global] Hint Resolve Ropp_plus_distr: real. (*********************************************************) @@ -692,6 +732,7 @@ Lemma Ropp_mult_distr_l_reverse : forall r1 r2, - r1 * r2 = - (r1 * r2). Proof. intros; ring. Qed. +#[global] Hint Resolve Ropp_mult_distr_l_reverse: real. (**********) @@ -699,6 +740,7 @@ Lemma Rmult_opp_opp : forall r1 r2, - r1 * - r2 = r1 * r2. Proof. intros; ring. Qed. +#[global] Hint Resolve Rmult_opp_opp: real. Lemma Ropp_mult_distr_r : forall r1 r2, - (r1 * r2) = r1 * - r2. @@ -719,12 +761,14 @@ Lemma Rminus_0_r : forall r, r - 0 = r. Proof. intro; ring. Qed. +#[global] Hint Resolve Rminus_0_r: real. Lemma Rminus_0_l : forall r, 0 - r = - r. Proof. intro; ring. Qed. +#[global] Hint Resolve Rminus_0_l: real. (**********) @@ -732,6 +776,7 @@ Lemma Ropp_minus_distr : forall r1 r2, - (r1 - r2) = r2 - r1. Proof. intros; ring. Qed. +#[global] Hint Resolve Ropp_minus_distr: real. Lemma Ropp_minus_distr' : forall r1 r2, - (r2 - r1) = r1 - r2. @@ -744,6 +789,7 @@ Lemma Rminus_diag_eq : forall r1 r2, r1 = r2 -> r1 - r2 = 0. Proof. intros; rewrite H; ring. Qed. +#[global] Hint Resolve Rminus_diag_eq: real. Lemma Rminus_eq_0 x : x - x = 0. @@ -755,6 +801,7 @@ Proof. intros r1 r2; unfold Rminus; rewrite Rplus_comm; intro. rewrite <- (Ropp_involutive r2); apply (Rplus_opp_r_uniq (- r2) r1 H). Qed. +#[global] Hint Immediate Rminus_diag_uniq: real. Lemma Rminus_diag_uniq_sym : forall r1 r2, r2 - r1 = 0 -> r1 = r2. @@ -762,12 +809,14 @@ Proof. intros; generalize (Rminus_diag_uniq r2 r1 H); clear H; intro H; rewrite H; ring. Qed. +#[global] Hint Immediate Rminus_diag_uniq_sym: real. Lemma Rplus_minus : forall r1 r2, r1 + (r2 - r1) = r2. Proof. intros; ring. Qed. +#[global] Hint Resolve Rplus_minus: real. (**********) @@ -776,18 +825,21 @@ Proof. red; intros r1 r2 H H0. apply H; auto with real. Qed. +#[global] Hint Resolve Rminus_eq_contra: real. Lemma Rminus_not_eq : forall r1 r2, r1 - r2 <> 0 -> r1 <> r2. Proof. red; intros; elim H; apply Rminus_diag_eq; auto. Qed. +#[global] Hint Resolve Rminus_not_eq: real. Lemma Rminus_not_eq_right : forall r1 r2, r2 - r1 <> 0 -> r1 <> r2. Proof. red; intros; elim H; rewrite H0; ring. Qed. +#[global] Hint Resolve Rminus_not_eq_right: real. (**********) @@ -809,6 +861,7 @@ Lemma Rinv_1 : / 1 = 1. Proof. field. Qed. +#[global] Hint Resolve Rinv_1: real. (*********) @@ -817,6 +870,7 @@ Proof. red; intros; apply R1_neq_R0. replace 1 with (/ r * r); auto with real. Qed. +#[global] Hint Resolve Rinv_neq_0_compat: real. (*********) @@ -824,6 +878,7 @@ Lemma Rinv_involutive : forall r, r <> 0 -> / / r = r. Proof. intros; field; trivial. Qed. +#[global] Hint Resolve Rinv_involutive: real. (*********) @@ -857,6 +912,7 @@ Proof. transitivity (r2 * (r1 * / r1)); auto with real. ring. Qed. +#[global] Hint Resolve Rinv_r_simpl_l Rinv_r_simpl_r Rinv_r_simpl_m: real. (*********) @@ -878,6 +934,7 @@ Qed. Lemma Rplus_gt_compat_l : forall r r1 r2, r1 > r2 -> r + r1 > r + r2. Proof. eauto using Rplus_lt_compat_l with rorders. Qed. +#[global] Hint Resolve Rplus_gt_compat_l: real. (**********) @@ -886,6 +943,7 @@ Proof. intros. rewrite (Rplus_comm r1 r); rewrite (Rplus_comm r2 r); auto with real. Qed. +#[global] Hint Resolve Rplus_lt_compat_r: real. Lemma Rplus_gt_compat_r : forall r r1 r2, r1 > r2 -> r1 + r > r2 + r. @@ -901,6 +959,7 @@ Qed. Lemma Rplus_ge_compat_l : forall r r1 r2, r1 >= r2 -> r + r1 >= r + r2. Proof. auto using Rplus_le_compat_l with rorders. Qed. +#[global] Hint Resolve Rplus_ge_compat_l: real. (**********) @@ -911,6 +970,7 @@ Proof. right; rewrite <- H0; auto with real. Qed. +#[global] Hint Resolve Rplus_le_compat_l Rplus_le_compat_r: real. Lemma Rplus_ge_compat_r : forall r r1 r2, r1 >= r2 -> r1 + r >= r2 + r. @@ -922,6 +982,7 @@ Lemma Rplus_lt_compat : Proof. intros; apply Rlt_trans with (r2 + r3); auto with real. Qed. +#[global] Hint Immediate Rplus_lt_compat: real. Lemma Rplus_le_compat : @@ -929,6 +990,7 @@ Lemma Rplus_le_compat : Proof. intros; apply Rle_trans with (r2 + r3); auto with real. Qed. +#[global] Hint Immediate Rplus_le_compat: real. Lemma Rplus_gt_compat : @@ -952,6 +1014,7 @@ Proof. intros; apply Rle_lt_trans with (r2 + r3); auto with real. Qed. +#[global] Hint Immediate Rplus_lt_le_compat Rplus_le_lt_compat: real. Lemma Rplus_gt_ge_compat : @@ -1091,6 +1154,7 @@ Proof. apply CReal_opp_gt_lt_contravar. unfold Rgt in H. rewrite Rlt_def in H. apply CRealLtEpsilon. exact H. Qed. +#[global] Hint Resolve Ropp_gt_lt_contravar : core. Lemma Ropp_lt_gt_contravar : forall r1 r2, r1 < r2 -> - r1 > - r2. @@ -1100,6 +1164,7 @@ Proof. apply CReal_opp_gt_lt_contravar. rewrite Rlt_def in H. apply CRealLtEpsilon. exact H. Qed. +#[global] Hint Resolve Ropp_lt_gt_contravar: real. (**********) @@ -1107,6 +1172,7 @@ Lemma Ropp_lt_contravar : forall r1 r2, r2 < r1 -> - r1 < - r2. Proof. auto with real. Qed. +#[global] Hint Resolve Ropp_lt_contravar: real. Lemma Ropp_gt_contravar : forall r1 r2, r2 > r1 -> - r1 > - r2. @@ -1117,12 +1183,14 @@ Lemma Ropp_le_ge_contravar : forall r1 r2, r1 <= r2 -> - r1 >= - r2. Proof. unfold Rge; intros r1 r2 [H| H]; auto with real. Qed. +#[global] Hint Resolve Ropp_le_ge_contravar: real. Lemma Ropp_ge_le_contravar : forall r1 r2, r1 >= r2 -> - r1 <= - r2. Proof. unfold Rle; intros r1 r2 [H| H]; auto with real. Qed. +#[global] Hint Resolve Ropp_ge_le_contravar: real. (**********) @@ -1130,6 +1198,7 @@ Lemma Ropp_le_contravar : forall r1 r2, r2 <= r1 -> - r1 <= - r2. Proof. intros r1 r2 H; elim H; auto with real. Qed. +#[global] Hint Resolve Ropp_le_contravar: real. Lemma Ropp_ge_contravar : forall r1 r2, r2 >= r1 -> - r1 >= - r2. @@ -1140,12 +1209,14 @@ Lemma Ropp_0_lt_gt_contravar : forall r, 0 < r -> 0 > - r. Proof. intros; replace 0 with (-0); auto with real. Qed. +#[global] Hint Resolve Ropp_0_lt_gt_contravar: real. Lemma Ropp_0_gt_lt_contravar : forall r, 0 > r -> 0 < - r. Proof. intros; replace 0 with (-0); auto with real. Qed. +#[global] Hint Resolve Ropp_0_gt_lt_contravar: real. (**********) @@ -1153,12 +1224,14 @@ Lemma Ropp_lt_gt_0_contravar : forall r, r > 0 -> - r < 0. Proof. intros; rewrite <- Ropp_0; auto with real. Qed. +#[global] Hint Resolve Ropp_lt_gt_0_contravar: real. Lemma Ropp_gt_lt_0_contravar : forall r, r < 0 -> - r > 0. Proof. intros; rewrite <- Ropp_0; auto with real. Qed. +#[global] Hint Resolve Ropp_gt_lt_0_contravar: real. (**********) @@ -1166,12 +1239,14 @@ Lemma Ropp_0_le_ge_contravar : forall r, 0 <= r -> 0 >= - r. Proof. intros; replace 0 with (-0); auto with real. Qed. +#[global] Hint Resolve Ropp_0_le_ge_contravar: real. Lemma Ropp_0_ge_le_contravar : forall r, 0 >= r -> 0 <= - r. Proof. intros; replace 0 with (-0); auto with real. Qed. +#[global] Hint Resolve Ropp_0_ge_le_contravar: real. (** *** Cancellation *) @@ -1182,6 +1257,7 @@ Proof. rewrite <- (Ropp_involutive x); rewrite <- (Ropp_involutive y); auto with real. Qed. +#[global] Hint Immediate Ropp_lt_cancel: real. Lemma Ropp_gt_cancel : forall r1 r2, - r2 > - r1 -> r1 > r2. @@ -1194,6 +1270,7 @@ Proof. intro H1; rewrite <- (Ropp_involutive x); rewrite <- (Ropp_involutive y); rewrite H1; auto with real. Qed. +#[global] Hint Immediate Ropp_le_cancel: real. Lemma Ropp_ge_cancel : forall r1 r2, - r2 >= - r1 -> r1 >= r2. @@ -1211,6 +1288,7 @@ Lemma Rmult_lt_compat_r : forall r r1 r2, 0 < r -> r1 < r2 -> r1 * r < r2 * r. Proof. intros; rewrite (Rmult_comm r1 r); rewrite (Rmult_comm r2 r); auto with real. Qed. +#[global] Hint Resolve Rmult_lt_compat_r : core. Lemma Rmult_gt_compat_r : forall r r1 r2, r > 0 -> r1 > r2 -> r1 * r > r2 * r. @@ -1227,6 +1305,7 @@ Proof. auto with real. right; rewrite <- H; do 2 rewrite Rmult_0_l; reflexivity. Qed. +#[global] Hint Resolve Rmult_le_compat_l: real. Lemma Rmult_le_compat_r : @@ -1235,6 +1314,7 @@ Proof. intros r r1 r2 H; rewrite (Rmult_comm r1 r); rewrite (Rmult_comm r2 r); auto with real. Qed. +#[global] Hint Resolve Rmult_le_compat_r: real. Lemma Rmult_ge_compat_l : @@ -1256,6 +1336,7 @@ Proof. apply Rmult_le_compat_l; auto. apply Rle_trans with z; auto. Qed. +#[global] Hint Resolve Rmult_le_compat: real. Lemma Rmult_ge_compat : @@ -1297,6 +1378,7 @@ Proof. do 2 rewrite (Ropp_mult_distr_l_reverse (- r)). apply Ropp_le_contravar; auto with real. Qed. +#[global] Hint Resolve Rmult_le_compat_neg_l: real. Lemma Rmult_le_ge_compat_neg_l : @@ -1304,6 +1386,7 @@ Lemma Rmult_le_ge_compat_neg_l : Proof. intros; apply Rle_ge; auto with real. Qed. +#[global] Hint Resolve Rmult_le_ge_compat_neg_l: real. Lemma Rmult_lt_gt_compat_neg_l : @@ -1368,6 +1451,7 @@ Proof. replace (r2 + (r1 - r2)) with r1 by ring. now rewrite Rplus_0_r. Qed. +#[global] Hint Resolve Rlt_minus: real. Lemma Rgt_minus : forall r1 r2, r1 > r2 -> r1 - r2 > 0. @@ -1436,6 +1520,7 @@ Proof. intros; apply not_eq_sym; apply Rlt_not_eq. rewrite Rplus_comm; replace 0 with (0 + 0); auto with real. Qed. +#[global] Hint Immediate tech_Rplus: real. (*********************************************************) @@ -1458,6 +1543,7 @@ Proof. replace 0 with (- r * 0); auto with real. replace 0 with (0 * r); auto with real. Qed. +#[global] Hint Resolve Rle_0_sqr Rlt_0_sqr: real. (***********) @@ -1485,6 +1571,7 @@ Proof. replace 1 with (Rsqr 1); auto with real. unfold Rsqr; auto with real. Qed. +#[global] Hint Resolve Rlt_0_1: real. Lemma Rle_0_1 : 0 <= 1. @@ -1504,6 +1591,7 @@ Proof. replace 1 with (r * / r); auto with real. replace 0 with (r * 0); auto with real. Qed. +#[global] Hint Resolve Rinv_0_lt_compat: real. (*********) @@ -1514,6 +1602,7 @@ Proof. replace 1 with (r * / r); auto with real. replace 0 with (r * 0); auto with real. Qed. +#[global] Hint Resolve Rinv_lt_0_compat: real. (*********) @@ -1543,6 +1632,7 @@ Proof. apply Rlt_dichotomy_converse; right. red; apply Rlt_trans with (r2 := x); auto with real. Qed. +#[global] Hint Resolve Rinv_1_lt_contravar: real. (*********************************************************) @@ -1556,6 +1646,7 @@ Proof. apply Rlt_le_trans with 1; auto with real. pattern 1 at 1; replace 1 with (0 + 1); auto with real. Qed. +#[global] Hint Resolve Rle_lt_0_plus_1: real. (**********) @@ -1564,6 +1655,7 @@ Proof. intros. pattern r at 1; replace r with (r + 0); auto with real. Qed. +#[global] Hint Resolve Rlt_plus_1: real. (**********) @@ -1598,6 +1690,7 @@ Proof. repeat rewrite S_INR. rewrite Hrecn; ring. Qed. +#[global] Hint Resolve plus_INR: real. (**********) @@ -1608,6 +1701,7 @@ Proof. intros; repeat rewrite S_INR; simpl. rewrite H0; ring. Qed. +#[global] Hint Resolve minus_INR: real. (*********) @@ -1618,6 +1712,7 @@ Proof. intros; repeat rewrite S_INR; simpl. rewrite plus_INR; rewrite Hrecn; ring. Qed. +#[global] Hint Resolve mult_INR: real. Lemma pow_INR (m n: nat) : INR (m ^ n) = pow (INR m) n. @@ -1629,6 +1724,7 @@ Proof. simple induction 1; intros; auto with real. rewrite S_INR; auto with real. Qed. +#[global] Hint Resolve lt_0_INR: real. Lemma lt_INR : forall n m:nat, (n < m)%nat -> INR n < INR m. @@ -1637,12 +1733,14 @@ Proof. rewrite S_INR; auto with real. rewrite S_INR; apply Rlt_trans with (INR m0); auto with real. Qed. +#[global] Hint Resolve lt_INR: real. Lemma lt_1_INR : forall n:nat, (1 < n)%nat -> 1 < INR n. Proof. apply lt_INR. Qed. +#[global] Hint Resolve lt_1_INR: real. (**********) @@ -1652,6 +1750,7 @@ Proof. simpl; auto with real. apply Pos2Nat.is_pos. Qed. +#[global] Hint Resolve pos_INR_nat_of_P: real. (**********) @@ -1661,6 +1760,7 @@ Proof. simpl; auto with real. auto with arith real. Qed. +#[global] Hint Resolve pos_INR: real. Lemma INR_lt : forall n m:nat, INR n < INR m -> (n < m)%nat. @@ -1676,6 +1776,7 @@ Proof. rewrite 2!S_INR in H. apply Rplus_lt_reg_r with (1 := H). Qed. +#[global] Hint Resolve INR_lt: real. (*********) @@ -1685,6 +1786,7 @@ Proof. rewrite S_INR. apply Rle_trans with (INR m0); auto with real. Qed. +#[global] Hint Resolve le_INR: real. (**********) @@ -1694,6 +1796,7 @@ Proof. apply H. rewrite H1; trivial. Qed. +#[global] Hint Immediate INR_not_0: real. (**********) @@ -1704,6 +1807,7 @@ Proof. intros; rewrite S_INR. apply Rgt_not_eq; red; auto with real. Qed. +#[global] Hint Resolve not_0_INR: real. Lemma not_INR : forall n m:nat, n <> m -> INR n <> INR m. @@ -1714,6 +1818,7 @@ Proof. exfalso; auto. apply not_eq_sym; apply Rlt_dichotomy_converse; auto with real. Qed. +#[global] Hint Resolve not_INR: real. Lemma INR_eq : forall n m:nat, INR n = INR m -> n = m. @@ -1730,6 +1835,7 @@ Proof. generalize (INR_lt n m H0); intro; auto with arith. generalize (INR_eq n m H0); intro; rewrite H1; auto. Qed. +#[global] Hint Resolve INR_le: real. Lemma not_1_INR : forall n:nat, n <> 1%nat -> INR n <> 1. @@ -1737,6 +1843,7 @@ Proof. intros n. apply not_INR. Qed. +#[global] Hint Resolve not_1_INR: real. (*********************************************************) @@ -1967,10 +2074,15 @@ Proof. intros; red; intro; elim H; apply eq_IZR; assumption. Qed. +#[global] Hint Extern 0 (IZR _ <= IZR _) => apply IZR_le, Zle_bool_imp_le, eq_refl : real. +#[global] Hint Extern 0 (IZR _ >= IZR _) => apply Rle_ge, IZR_le, Zle_bool_imp_le, eq_refl : real. +#[global] Hint Extern 0 (IZR _ < IZR _) => apply IZR_lt, eq_refl : real. +#[global] Hint Extern 0 (IZR _ > IZR _) => apply IZR_lt, eq_refl : real. +#[global] Hint Extern 0 (IZR _ <> IZR _) => apply IZR_neq, Zeq_bool_neq, eq_refl : real. Lemma one_IZR_lt1 : forall n:Z, -1 < IZR n < 1 -> n = 0%Z. diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v index 338c939a06..f1c9eb8eee 100644 --- a/theories/Reals/Raxioms.v +++ b/theories/Reals/Raxioms.v @@ -119,6 +119,7 @@ Lemma Rplus_comm : forall r1 r2:R, r1 + r2 = r2 + r1. Proof. intros. apply Rquot1. do 2 rewrite Rrepr_plus. apply CReal_plus_comm. Qed. +#[global] Hint Resolve Rplus_comm: real. (**********) @@ -127,6 +128,7 @@ Proof. intros. apply Rquot1. repeat rewrite Rrepr_plus. apply CReal_plus_assoc. Qed. +#[global] Hint Resolve Rplus_assoc: real. (**********) @@ -135,6 +137,7 @@ Proof. intros. apply Rquot1. rewrite Rrepr_plus, Rrepr_opp, Rrepr_0. apply CReal_plus_opp_r. Qed. +#[global] Hint Resolve Rplus_opp_r: real. (**********) @@ -143,6 +146,7 @@ Proof. intros. apply Rquot1. rewrite Rrepr_plus, Rrepr_0. apply CReal_plus_0_l. Qed. +#[global] Hint Resolve Rplus_0_l: real. (***********************************************************) @@ -154,6 +158,7 @@ Lemma Rmult_comm : forall r1 r2:R, r1 * r2 = r2 * r1. Proof. intros. apply Rquot1. do 2 rewrite Rrepr_mult. apply CReal_mult_comm. Qed. +#[global] Hint Resolve Rmult_comm: real. (**********) @@ -162,6 +167,7 @@ Proof. intros. apply Rquot1. repeat rewrite Rrepr_mult. apply CReal_mult_assoc. Qed. +#[global] Hint Resolve Rmult_assoc: real. (**********) @@ -171,6 +177,7 @@ Proof. - contradiction. - apply Rquot1. rewrite Rrepr_mult, Rquot2, Rrepr_1. apply CReal_inv_l. Qed. +#[global] Hint Resolve Rinv_l: real. (**********) @@ -179,6 +186,7 @@ Proof. intros. apply Rquot1. rewrite Rrepr_mult, Rrepr_1. apply CReal_mult_1_l. Qed. +#[global] Hint Resolve Rmult_1_l: real. (**********) @@ -197,6 +205,7 @@ Proof. pose proof (CRealLt_morph 0%CReal 0%CReal (CRealEq_refl _) 1%CReal 0%CReal H). apply (CRealLt_irrefl 0%CReal). apply H0. apply CRealLt_0_1. Qed. +#[global] Hint Resolve R1_neq_R0: real. (*********************************************************) @@ -211,6 +220,7 @@ Proof. rewrite Rrepr_mult, Rrepr_plus, Rrepr_plus, Rrepr_mult, Rrepr_mult. apply CReal_mult_plus_distr_l. Qed. +#[global] Hint Resolve Rmult_plus_distr_l: real. (*********************************************************) @@ -256,6 +266,7 @@ Proof. rewrite RbaseSymbolsImpl.Rlt_def in H0. apply CRealLtEpsilon. exact H0. Qed. +#[global] Hint Resolve Rlt_asym Rplus_lt_compat_l Rmult_lt_compat_l: real. (**********************************************************) diff --git a/theories/Reals/Rfunctions.v b/theories/Reals/Rfunctions.v index d64e635d0f..4aa6edb2c4 100644 --- a/theories/Reals/Rfunctions.v +++ b/theories/Reals/Rfunctions.v @@ -102,6 +102,7 @@ Proof. apply H; assumption. Qed. +#[global] Hint Resolve pow_O pow_1 pow_add pow_nonzero: real. Lemma pow_RN_plus : @@ -117,6 +118,7 @@ Proof. intros x n; elim n; simpl; auto with real. intros n0 H' H'0; replace 0 with (x * 0); auto with real. Qed. +#[global] Hint Resolve pow_lt: real. Lemma Rlt_pow_R1 : forall (x:R) (n:nat), 1 < x -> (0 < n)%nat -> 1 < x ^ n. @@ -132,6 +134,7 @@ Proof. apply Rlt_trans with (r2 := 1); auto with real. apply H'; auto with arith. Qed. +#[global] Hint Resolve Rlt_pow_R1: real. Lemma Rlt_pow : forall (x:R) (n m:nat), 1 < x -> (n < m)%nat -> x ^ n < x ^ m. @@ -153,6 +156,7 @@ Proof. rewrite le_plus_minus_r; auto with arith; rewrite <- plus_n_O; auto. rewrite plus_comm; auto with arith. Qed. +#[global] Hint Resolve Rlt_pow: real. (*********) @@ -628,6 +632,7 @@ Proof. rewrite pow_add; auto with real. apply Rinv_mult_distr; apply pow_nonzero; auto. Qed. +#[local] Hint Resolve powerRZ_O powerRZ_1 powerRZ_NOR powerRZ_add: real. Lemma Zpower_nat_powerRZ : @@ -661,12 +666,14 @@ Lemma powerRZ_lt : forall (x:R) (z:Z), 0 < x -> 0 < x ^Z z. Proof. intros x z; case z; simpl; auto with real. Qed. +#[local] Hint Resolve powerRZ_lt: real. Lemma powerRZ_le : forall (x:R) (z:Z), 0 < x -> 0 <= x ^Z z. Proof. intros x z H'; apply Rlt_le; auto with real. Qed. +#[local] Hint Resolve powerRZ_le: real. Lemma Zpower_nat_powerRZ_absolu : diff --git a/theories/Relations/Relation_Definitions.v b/theories/Relations/Relation_Definitions.v index 7d0dffdd00..d0d633a0c4 100644 --- a/theories/Relations/Relation_Definitions.v +++ b/theories/Relations/Relation_Definitions.v @@ -68,10 +68,13 @@ Section Relation_Definition. End Relation_Definition. +#[global] Hint Unfold reflexive transitive antisymmetric symmetric: sets. +#[global] Hint Resolve Build_preorder Build_order Build_equivalence Build_PER preord_refl preord_trans ord_refl ord_trans ord_antisym equiv_refl equiv_trans equiv_sym per_sym per_trans: sets. +#[global] Hint Unfold inclusion same_relation commut: sets. diff --git a/theories/Relations/Relation_Operators.v b/theories/Relations/Relation_Operators.v index f0f36149d1..520333332a 100644 --- a/theories/Relations/Relation_Operators.v +++ b/theories/Relations/Relation_Operators.v @@ -228,8 +228,11 @@ Section Lexicographic_Exponentiation. End Lexicographic_Exponentiation. +#[global] Hint Unfold transp union: sets. +#[global] Hint Resolve t_step rt_step rt_refl rst_step rst_refl: sets. +#[global] Hint Immediate rst_sym: sets. (* begin hide *) diff --git a/theories/Sets/Classical_sets.v b/theories/Sets/Classical_sets.v index 68d200e189..430f35eecb 100644 --- a/theories/Sets/Classical_sets.v +++ b/theories/Sets/Classical_sets.v @@ -77,6 +77,7 @@ Section Ensembles_classical. Proof. unfold Subtract at 1; auto with sets. Qed. + #[local] Hint Resolve Subtract_intro : sets. Lemma Subtract_inv : @@ -123,5 +124,6 @@ Section Ensembles_classical. End Ensembles_classical. + #[global] Hint Resolve Strict_super_set_contains_new_element Subtract_intro not_SIncl_empty: sets. diff --git a/theories/Sets/Constructive_sets.v b/theories/Sets/Constructive_sets.v index 5027679266..ae7cdc9a0f 100644 --- a/theories/Sets/Constructive_sets.v +++ b/theories/Sets/Constructive_sets.v @@ -140,6 +140,7 @@ Section Ensembles_facts. End Ensembles_facts. +#[global] Hint Resolve Singleton_inv Singleton_intro Add_intro1 Add_intro2 Intersection_inv Couple_inv Setminus_intro Strict_Included_intro Strict_Included_strict Noone_in_empty Inhabited_not_empty Add_not_Empty diff --git a/theories/Sets/Cpo.v b/theories/Sets/Cpo.v index face010746..581c16778d 100644 --- a/theories/Sets/Cpo.v +++ b/theories/Sets/Cpo.v @@ -92,6 +92,7 @@ Section Bounds. exists bsup : _, Lub X bsup) -> Conditionally_complete. End Bounds. +#[global] Hint Resolve Totally_ordered_definition Upper_Bound_definition Lower_Bound_definition Lub_definition Glb_definition Bottom_definition Definition_of_Complete Definition_of_Complete diff --git a/theories/Sets/Ensembles.v b/theories/Sets/Ensembles.v index fb33f7834c..96fb070071 100644 --- a/theories/Sets/Ensembles.v +++ b/theories/Sets/Ensembles.v @@ -92,8 +92,10 @@ Section Ensembles. End Ensembles. +#[global] Hint Unfold In Included Same_set Strict_Included Add Setminus Subtract: sets. +#[global] Hint Resolve Union_introl Union_intror Intersection_intro In_singleton Couple_l Couple_r Triple_l Triple_m Triple_r Disjoint_intro Extensionality_Ensembles: sets. diff --git a/theories/Sets/Finite_sets.v b/theories/Sets/Finite_sets.v index e8e2a66e98..683979be74 100644 --- a/theories/Sets/Finite_sets.v +++ b/theories/Sets/Finite_sets.v @@ -45,7 +45,9 @@ Section Ensembles_finis. End Ensembles_finis. +#[global] Hint Resolve Empty_is_finite Union_is_finite: sets. +#[global] Hint Resolve card_empty card_add: sets. Require Import Constructive_sets. diff --git a/theories/Sets/Image.v b/theories/Sets/Image.v index 023eeaac9d..e83ff223f3 100644 --- a/theories/Sets/Image.v +++ b/theories/Sets/Image.v @@ -202,4 +202,5 @@ Section Image. End Image. +#[global] Hint Resolve Im_def image_empty finite_image: sets. diff --git a/theories/Sets/Infinite_sets.v b/theories/Sets/Infinite_sets.v index b3d7ed0b7b..766f62af45 100644 --- a/theories/Sets/Infinite_sets.v +++ b/theories/Sets/Infinite_sets.v @@ -46,6 +46,7 @@ Section Approx. Defn_of_Approximant : Finite U X -> Included U X A -> Approximant A X. End Approx. +#[global] Hint Resolve Defn_of_Approximant : core. Section Infinite_sets. diff --git a/theories/Sets/Multiset.v b/theories/Sets/Multiset.v index 4d0cd1174c..3f3cade37d 100644 --- a/theories/Sets/Multiset.v +++ b/theories/Sets/Multiset.v @@ -187,7 +187,10 @@ End multiset_defs. Unset Implicit Arguments. +#[global] Hint Unfold meq multiplicity: datatypes. +#[global] Hint Resolve munion_empty_right munion_comm munion_ass meq_left meq_right munion_empty_left: datatypes. +#[global] Hint Immediate meq_sym: datatypes. diff --git a/theories/Sets/Partial_Order.v b/theories/Sets/Partial_Order.v index 875afe3f44..879a7df608 100644 --- a/theories/Sets/Partial_Order.v +++ b/theories/Sets/Partial_Order.v @@ -53,7 +53,9 @@ Section Partial_orders. End Partial_orders. +#[global] Hint Unfold Carrier_of Rel_of Strict_Rel_of: sets. +#[global] Hint Resolve Definition_of_covers: sets. diff --git a/theories/Sets/Powerset.v b/theories/Sets/Powerset.v index 96d04100b9..617836225c 100644 --- a/theories/Sets/Powerset.v +++ b/theories/Sets/Powerset.v @@ -38,12 +38,14 @@ Variable U : Type. Inductive Power_set (A:Ensemble U) : Ensemble (Ensemble U) := Definition_of_Power_set : forall X:Ensemble U, Included U X A -> In (Ensemble U) (Power_set A) X. +#[local] Hint Resolve Definition_of_Power_set : core. Theorem Empty_set_minimal : forall X:Ensemble U, Included U (Empty_set U) X. intro X; red. intros x H'; elim H'. Qed. +#[local] Hint Resolve Empty_set_minimal : core. Theorem Power_set_Inhabited : @@ -51,22 +53,26 @@ Theorem Power_set_Inhabited : intro X. apply Inhabited_intro with (Empty_set U); auto with sets. Qed. +#[local] Hint Resolve Power_set_Inhabited : core. Theorem Inclusion_is_an_order : Order (Ensemble U) (Included U). auto 6 with sets. Qed. +#[local] Hint Resolve Inclusion_is_an_order : core. Theorem Inclusion_is_transitive : Transitive (Ensemble U) (Included U). elim Inclusion_is_an_order; auto with sets. Qed. +#[local] Hint Resolve Inclusion_is_transitive : core. Definition Power_set_PO : Ensemble U -> PO (Ensemble U). intro A; try assumption. apply Definition_of_PO with (Power_set A) (Included U); auto with sets. Defined. +#[local] Hint Unfold Power_set_PO : core. Theorem Strict_Rel_is_Strict_Included : @@ -74,6 +80,7 @@ Theorem Strict_Rel_is_Strict_Included : (Strict_Rel_of (Ensemble U) (Power_set_PO (Full_set U))). auto with sets. Qed. +#[local] Hint Resolve Strict_Rel_Transitive Strict_Rel_is_Strict_Included : core. Lemma Strict_inclusion_is_transitive_with_inclusion : @@ -109,6 +116,7 @@ Theorem Empty_set_is_Bottom : forall A:Ensemble U, Bottom (Ensemble U) (Power_set_PO A) (Empty_set U). intro A; apply Bottom_definition; simpl; auto with sets. Qed. +#[local] Hint Resolve Empty_set_is_Bottom : core. Theorem Union_minimal : @@ -117,6 +125,7 @@ Theorem Union_minimal : intros a b X H' H'0; red. intros x H'1; elim H'1; auto with sets. Qed. +#[local] Hint Resolve Union_minimal : core. Theorem Intersection_maximal : @@ -144,6 +153,7 @@ Theorem Intersection_decreases_r : intros a b; red. intros x H'; elim H'; auto with sets. Qed. +#[local] Hint Resolve Union_increases_l Union_increases_r Intersection_decreases_l Intersection_decreases_r : core. @@ -177,14 +187,25 @@ Qed. End The_power_set_partial_order. +#[global] Hint Resolve Empty_set_minimal: sets. +#[global] Hint Resolve Power_set_Inhabited: sets. +#[global] Hint Resolve Inclusion_is_an_order: sets. +#[global] Hint Resolve Inclusion_is_transitive: sets. +#[global] Hint Resolve Union_minimal: sets. +#[global] Hint Resolve Union_increases_l: sets. +#[global] Hint Resolve Union_increases_r: sets. +#[global] Hint Resolve Intersection_decreases_l: sets. +#[global] Hint Resolve Intersection_decreases_r: sets. +#[global] Hint Resolve Empty_set_is_Bottom: sets. +#[global] Hint Resolve Strict_inclusion_is_transitive: sets. diff --git a/theories/Sets/Powerset_Classical_facts.v b/theories/Sets/Powerset_Classical_facts.v index b83485bbf3..0fe63c5b66 100644 --- a/theories/Sets/Powerset_Classical_facts.v +++ b/theories/Sets/Powerset_Classical_facts.v @@ -92,6 +92,7 @@ Section Sets_as_an_algebra. apply Subtract_intro; auto with sets. red; intro H'1; apply H'; rewrite H'1; auto with sets. Qed. + #[local] Hint Resolve incl_soustr_add_r: sets. Lemma add_soustr_2 : @@ -330,9 +331,15 @@ Section Sets_as_an_algebra. End Sets_as_an_algebra. +#[global] Hint Resolve incl_soustr_in: sets. +#[global] Hint Resolve incl_soustr: sets. +#[global] Hint Resolve incl_soustr_add_l: sets. +#[global] Hint Resolve incl_soustr_add_r: sets. +#[global] Hint Resolve add_soustr_1 add_soustr_2: sets. +#[global] Hint Resolve add_soustr_xy: sets. diff --git a/theories/Sets/Powerset_facts.v b/theories/Sets/Powerset_facts.v index 69b28f14e4..b21c48d305 100644 --- a/theories/Sets/Powerset_facts.v +++ b/theories/Sets/Powerset_facts.v @@ -348,6 +348,7 @@ Section Sets_as_an_algebra. End Sets_as_an_algebra. +#[global] Hint Resolve Empty_set_zero Empty_set_zero' Union_associative Union_add singlx incl_add: sets. diff --git a/theories/Sets/Relations_1.v b/theories/Sets/Relations_1.v index 42755b551f..1167ad36bf 100644 --- a/theories/Sets/Relations_1.v +++ b/theories/Sets/Relations_1.v @@ -61,7 +61,9 @@ Section Relations_1. Definition_of_PER : Symmetric -> Transitive -> PER. End Relations_1. +#[global] Hint Unfold Reflexive Transitive Antisymmetric Symmetric contains same_relation: sets. +#[global] Hint Resolve Definition_of_preorder Definition_of_order Definition_of_equivalence Definition_of_PER: sets. diff --git a/theories/Sets/Relations_1_facts.v b/theories/Sets/Relations_1_facts.v index 21fc7ceaf2..6d7b837b63 100644 --- a/theories/Sets/Relations_1_facts.v +++ b/theories/Sets/Relations_1_facts.v @@ -52,6 +52,7 @@ apply Definition_of_equivalence. split; apply H'1 with y; auto 10 with sets. - red; intros x y h; elim h; intros H'3 H'4; auto 10 with sets. Qed. +#[global] Hint Resolve Equiv_from_preorder : core. Theorem Equiv_from_order : @@ -60,6 +61,7 @@ Theorem Equiv_from_order : Proof. intros U R H'; elim H'; auto 10 with sets. Qed. +#[global] Hint Resolve Equiv_from_order : core. Theorem contains_is_preorder : @@ -67,6 +69,7 @@ Theorem contains_is_preorder : Proof. auto 10 with sets. Qed. +#[global] Hint Resolve contains_is_preorder : core. Theorem same_relation_is_equivalence : @@ -74,6 +77,7 @@ Theorem same_relation_is_equivalence : Proof. unfold same_relation at 1; auto 10 with sets. Qed. +#[global] Hint Resolve same_relation_is_equivalence : core. Theorem cong_reflexive_same_relation : diff --git a/theories/Sets/Relations_2.v b/theories/Sets/Relations_2.v index 5e3206dd9b..e180798d1f 100644 --- a/theories/Sets/Relations_2.v +++ b/theories/Sets/Relations_2.v @@ -50,7 +50,11 @@ Definition Strongly_confluent : Prop := End Relations_2. +#[global] Hint Resolve Rstar_0: sets. +#[global] Hint Resolve Rstar1_0: sets. +#[global] Hint Resolve Rstar1_1: sets. +#[global] Hint Resolve Rplus_0: sets. diff --git a/theories/Sets/Relations_3.v b/theories/Sets/Relations_3.v index 9ebbba485c..d5c4040033 100644 --- a/theories/Sets/Relations_3.v +++ b/theories/Sets/Relations_3.v @@ -53,10 +53,16 @@ Section Relations_3. Definition Noetherian : Prop := forall x:U, noetherian x. End Relations_3. +#[global] Hint Unfold coherent: sets. +#[global] Hint Unfold locally_confluent: sets. +#[global] Hint Unfold confluent: sets. +#[global] Hint Unfold Confluent: sets. +#[global] Hint Resolve definition_of_noetherian: sets. +#[global] Hint Unfold Noetherian: sets. diff --git a/theories/Sets/Relations_3_facts.v b/theories/Sets/Relations_3_facts.v index db51186ef1..9f4869a625 100644 --- a/theories/Sets/Relations_3_facts.v +++ b/theories/Sets/Relations_3_facts.v @@ -38,6 +38,7 @@ Proof. intros U R x y H'; red. exists y; auto with sets. Qed. +#[global] Hint Resolve Rstar_imp_coherent : core. Theorem coherent_symmetric : diff --git a/theories/Sets/Uniset.v b/theories/Sets/Uniset.v index 474b417e8e..d8fe7f6dbe 100644 --- a/theories/Sets/Uniset.v +++ b/theories/Sets/Uniset.v @@ -41,20 +41,24 @@ Definition Singleton (a:A) := end). Definition In (s:uniset) (a:A) : Prop := charac s a = true. +#[local] Hint Unfold In : core. (** uniset inclusion *) Definition incl (s1 s2:uniset) := forall a:A, Bool.le (charac s1 a) (charac s2 a). +#[local] Hint Unfold incl : core. (** uniset equality *) Definition seq (s1 s2:uniset) := forall a:A, charac s1 a = charac s2 a. +#[local] Hint Unfold seq : core. Lemma le_refl : forall b, Bool.le b b. Proof. destruct b; simpl; auto. Qed. +#[local] Hint Resolve le_refl : core. Lemma incl_left : forall s1 s2:uniset, seq s1 s2 -> incl s1 s2. @@ -71,6 +75,7 @@ Lemma seq_refl : forall x:uniset, seq x x. Proof. destruct x; unfold seq; auto. Qed. +#[local] Hint Resolve seq_refl : core. Lemma seq_trans : forall x y z:uniset, seq x y -> seq y z -> seq x z. @@ -94,6 +99,7 @@ Lemma union_empty_left : forall x:uniset, seq x (union Emptyset x). Proof. unfold seq; unfold union; simpl; auto. Qed. +#[local] Hint Resolve union_empty_left : core. Lemma union_empty_right : forall x:uniset, seq x (union x Emptyset). @@ -101,6 +107,7 @@ Proof. unfold seq; unfold union; simpl. intros x a; rewrite (orb_b_false (charac x a)); auto. Qed. +#[local] Hint Resolve union_empty_right : core. Lemma union_comm : forall x y:uniset, seq (union x y) (union y x). @@ -108,6 +115,7 @@ Proof. unfold seq; unfold charac; unfold union. destruct x; destruct y; auto with bool. Qed. +#[local] Hint Resolve union_comm : core. Lemma union_ass : @@ -116,6 +124,7 @@ Proof. unfold seq; unfold union; unfold charac. destruct x; destruct y; destruct z; auto with bool. Qed. +#[local] Hint Resolve union_ass : core. Lemma seq_left : forall x y z:uniset, seq x y -> seq (union x z) (union y z). @@ -124,6 +133,7 @@ unfold seq; unfold union; unfold charac. destruct x; destruct y; destruct z. intros; elim H; auto. Qed. +#[local] Hint Resolve seq_left : core. Lemma seq_right : forall x y z:uniset, seq x y -> seq (union z x) (union z y). @@ -132,6 +142,7 @@ unfold seq; unfold union; unfold charac. destruct x; destruct y; destruct z. intros; elim H; auto. Qed. +#[local] Hint Resolve seq_right : core. diff --git a/theories/Sorting/CPermutation.v b/theories/Sorting/CPermutation.v index 31d9f7f0ed..cebb0c808c 100644 --- a/theories/Sorting/CPermutation.v +++ b/theories/Sorting/CPermutation.v @@ -96,6 +96,7 @@ Qed. End CPermutation. +#[global] Hint Resolve CPermutation_refl : core. (* These hints do not reduce the size of the problem to solve and they diff --git a/theories/Sorting/Heap.v b/theories/Sorting/Heap.v index 1130c9dd76..05a21620b7 100644 --- a/theories/Sorting/Heap.v +++ b/theories/Sorting/Heap.v @@ -36,7 +36,9 @@ Section defs. Hypothesis leA_trans : forall x y z:A, leA x y -> leA y z -> leA x z. Hypothesis leA_antisym : forall x y:A, leA x y -> leA y x -> eqA x y. + #[local] Hint Resolve leA_refl : core. + #[local] Hint Immediate eqA_dec leA_dec leA_antisym : core. Let emptyBag := EmptyBag A. diff --git a/theories/Sorting/Permutation.v b/theories/Sorting/Permutation.v index 2f445c341a..45fb48ad5d 100644 --- a/theories/Sorting/Permutation.v +++ b/theories/Sorting/Permutation.v @@ -76,6 +76,7 @@ Qed. End Permutation. +#[global] Hint Resolve Permutation_refl perm_nil perm_skip : core. (* These hints do not reduce the size of the problem to solve and they diff --git a/theories/Sorting/Sorted.v b/theories/Sorting/Sorted.v index 8cba461082..206eb606d2 100644 --- a/theories/Sorting/Sorted.v +++ b/theories/Sorting/Sorted.v @@ -137,7 +137,9 @@ Section defs. End defs. +#[global] Hint Constructors HdRel : core. +#[global] Hint Constructors Sorted : core. (* begin hide *) diff --git a/theories/Structures/DecidableType.v b/theories/Structures/DecidableType.v index 0c3bd9393b..c923b503a7 100644 --- a/theories/Structures/DecidableType.v +++ b/theories/Structures/DecidableType.v @@ -38,7 +38,9 @@ Module KeyDecidableType(D:DecidableType). Definition eqke (p p':key*elt) := eq (fst p) (fst p') /\ (snd p) = (snd p'). + #[local] Hint Unfold eqk eqke : core. + #[local] Hint Extern 2 (eqke ?a ?b) => split : core. (* eqke is stricter than eqk *) @@ -70,7 +72,9 @@ Module KeyDecidableType(D:DecidableType). unfold eqke; intuition; [ eauto | congruence ]. Qed. + #[local] Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : core. + #[local] Hint Immediate eqk_sym eqke_sym : core. Global Instance eqk_equiv : Equivalence eqk. @@ -84,6 +88,7 @@ Module KeyDecidableType(D:DecidableType). Proof. unfold eqke; induction 1; intuition. Qed. + #[local] Hint Resolve InA_eqke_eqk : core. Lemma InA_eqk : forall p q m, eqk p q -> InA eqk p m -> InA eqk q m. @@ -94,6 +99,7 @@ Module KeyDecidableType(D:DecidableType). Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). Definition In k m := exists e:elt, MapsTo k e m. + #[local] Hint Unfold MapsTo In : core. (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *) @@ -140,12 +146,19 @@ Module KeyDecidableType(D:DecidableType). End Elt. + #[global] Hint Unfold eqk eqke : core. + #[global] Hint Extern 2 (eqke ?a ?b) => split : core. + #[global] Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : core. + #[global] Hint Immediate eqk_sym eqke_sym : core. + #[global] Hint Resolve InA_eqke_eqk : core. + #[global] Hint Unfold MapsTo In : core. + #[global] Hint Resolve In_inv_2 In_inv_3 : core. End KeyDecidableType. diff --git a/theories/Structures/Equalities.v b/theories/Structures/Equalities.v index 914361d718..7cd5943a3f 100644 --- a/theories/Structures/Equalities.v +++ b/theories/Structures/Equalities.v @@ -53,7 +53,9 @@ Module Type IsEqOrig (Import E:Eq'). Axiom eq_refl : forall x : t, x==x. Axiom eq_sym : forall x y : t, x==y -> y==x. Axiom eq_trans : forall x y z : t, x==y -> y==z -> x==z. + #[global] Hint Immediate eq_sym : core. + #[global] Hint Resolve eq_refl eq_trans : core. End IsEqOrig. diff --git a/theories/Structures/EqualitiesFacts.v b/theories/Structures/EqualitiesFacts.v index fe9794de8a..523240065d 100644 --- a/theories/Structures/EqualitiesFacts.v +++ b/theories/Structures/EqualitiesFacts.v @@ -22,6 +22,7 @@ Module KeyDecidableType(D:DecidableType). Definition eqk {elt} : relation (key*elt) := D.eq @@1. Definition eqke {elt} : relation (key*elt) := D.eq * Logic.eq. + #[global] Hint Unfold eqk eqke : core. (** eqk, eqke are equalities *) @@ -60,6 +61,7 @@ Module KeyDecidableType(D:DecidableType). Lemma eqk_1 {elt} k k' (e e':elt) : eqk (k,e) (k',e') -> D.eq k k'. Proof. trivial. Qed. + #[global] Hint Resolve eqke_1 eqke_2 eqk_1 : core. (* Additional facts *) @@ -69,6 +71,7 @@ Module KeyDecidableType(D:DecidableType). Proof. induction 1; firstorder. Qed. + #[global] Hint Resolve InA_eqke_eqk : core. Lemma InA_eqk_eqke {elt} p (m:list (key*elt)) : @@ -86,6 +89,7 @@ Module KeyDecidableType(D:DecidableType). Definition MapsTo {elt} (k:key)(e:elt):= InA eqke (k,e). Definition In {elt} k m := exists e:elt, MapsTo k e m. + #[global] Hint Unfold MapsTo In : core. (* Alternative formulations for [In k l] *) @@ -167,8 +171,11 @@ Module KeyDecidableType(D:DecidableType). eauto with *. Qed. + #[global] Hint Extern 2 (eqke ?a ?b) => split : core. + #[global] Hint Resolve InA_eqke_eqk : core. + #[global] Hint Resolve In_inv_2 In_inv_3 : core. End KeyDecidableType. diff --git a/theories/Structures/OrderedType.v b/theories/Structures/OrderedType.v index ecf0706a4f..dc7a48cd6b 100644 --- a/theories/Structures/OrderedType.v +++ b/theories/Structures/OrderedType.v @@ -44,7 +44,9 @@ Module Type MiniOrderedType. Parameter compare : forall x y : t, Compare lt eq x y. + #[global] Hint Immediate eq_sym : ordered_type. + #[global] Hint Resolve eq_refl eq_trans lt_not_eq lt_trans : ordered_type. End MiniOrderedType. @@ -144,8 +146,11 @@ Module OrderedTypeFacts (Import O: OrderedType). Lemma eq_not_gt x y : eq x y -> ~ lt y x. Proof. order. Qed. Lemma lt_not_gt x y : lt x y -> ~ lt y x. Proof. order. Qed. + #[global] Hint Resolve gt_not_eq eq_not_lt : ordered_type. + #[global] Hint Immediate eq_lt lt_eq le_eq eq_le neq_eq eq_neq : ordered_type. + #[global] Hint Resolve eq_not_gt lt_antirefl lt_not_gt : ordered_type. Lemma elim_compare_eq : @@ -248,7 +253,9 @@ Proof. exact (SortA_NoDupA eq_equiv lt_strorder lt_compat). Qed. End ForNotations. +#[global] Hint Resolve ListIn_In Sort_NoDup Inf_lt : ordered_type. +#[global] Hint Immediate In_eq Inf_lt : ordered_type. End OrderedTypeFacts. @@ -267,7 +274,9 @@ Module KeyOrderedType(O:OrderedType). eq (fst p) (fst p') /\ (snd p) = (snd p'). Definition ltk (p p':key*elt) := lt (fst p) (fst p'). + #[local] Hint Unfold eqk eqke ltk : ordered_type. + #[local] Hint Extern 2 (eqke ?a ?b) => split : ordered_type. (* eqke is stricter than eqk *) @@ -284,6 +293,7 @@ Module KeyOrderedType(O:OrderedType). Lemma ltk_right_l : forall x k e e', ltk (k,e) x -> ltk (k,e') x. Proof. auto. Qed. + #[local] Hint Immediate ltk_right_r ltk_right_l : ordered_type. (* eqk, eqke are equalities, ltk is a strict order *) @@ -320,8 +330,11 @@ Module KeyOrderedType(O:OrderedType). exact (lt_not_eq H H1). Qed. + #[local] Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : ordered_type. + #[local] Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke : ordered_type. + #[local] Hint Immediate eqk_sym eqke_sym : ordered_type. Global Instance eqk_equiv : Equivalence eqk. @@ -360,7 +373,9 @@ Module KeyOrderedType(O:OrderedType). intros (k,e) (k',e') (k'',e''). unfold ltk, eqk; simpl; eauto with ordered_type. Qed. + #[local] Hint Resolve eqk_not_ltk : ordered_type. + #[local] Hint Immediate ltk_eqk eqk_ltk : ordered_type. Lemma InA_eqke_eqk : @@ -368,6 +383,7 @@ Module KeyOrderedType(O:OrderedType). Proof. unfold eqke; induction 1; intuition. Qed. + #[local] Hint Resolve InA_eqke_eqk : ordered_type. Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). @@ -375,6 +391,7 @@ Module KeyOrderedType(O:OrderedType). Notation Sort := (sort ltk). Notation Inf := (lelistA ltk). + #[local] Hint Unfold MapsTo In : ordered_type. (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *) @@ -406,7 +423,9 @@ Module KeyOrderedType(O:OrderedType). Lemma Inf_lt : forall l x x', ltk x x' -> Inf x' l -> Inf x l. Proof. exact (InfA_ltA ltk_strorder). Qed. + #[local] Hint Immediate Inf_eq : ordered_type. + #[local] Hint Resolve Inf_lt : ordered_type. Lemma Sort_Inf_In : @@ -470,18 +489,31 @@ Module KeyOrderedType(O:OrderedType). End Elt. + #[global] Hint Unfold eqk eqke ltk : ordered_type. + #[global] Hint Extern 2 (eqke ?a ?b) => split : ordered_type. + #[global] Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : ordered_type. + #[global] Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke : ordered_type. + #[global] Hint Immediate eqk_sym eqke_sym : ordered_type. + #[global] Hint Resolve eqk_not_ltk : ordered_type. + #[global] Hint Immediate ltk_eqk eqk_ltk : ordered_type. + #[global] Hint Resolve InA_eqke_eqk : ordered_type. + #[global] Hint Unfold MapsTo In : ordered_type. + #[global] Hint Immediate Inf_eq : ordered_type. + #[global] Hint Resolve Inf_lt : ordered_type. + #[global] Hint Resolve Sort_Inf_NotIn : ordered_type. + #[global] Hint Resolve In_inv_2 In_inv_3 : ordered_type. End KeyOrderedType. diff --git a/theories/Structures/Orders.v b/theories/Structures/Orders.v index b3e3b6e853..b4ddd0b262 100644 --- a/theories/Structures/Orders.v +++ b/theories/Structures/Orders.v @@ -181,6 +181,7 @@ Module OTF_to_TotalOrder (O:OrderedTypeFull) <: TotalOrder we coerce [bool] into [Prop]. *) Local Coercion is_true : bool >-> Sortclass. +#[global] Hint Unfold is_true : core. Module Type HasLeb (Import T:Typ). diff --git a/theories/Structures/OrdersLists.v b/theories/Structures/OrdersLists.v index 3a5dbc2f88..bace70cbee 100644 --- a/theories/Structures/OrdersLists.v +++ b/theories/Structures/OrdersLists.v @@ -50,7 +50,9 @@ Proof. exact (InfA_alt O.eq_equiv O.lt_strorder O.lt_compat). Qed. Lemma Sort_NoDup : forall l, Sort l -> NoDup l. Proof. exact (SortA_NoDupA O.eq_equiv O.lt_strorder O.lt_compat) . Qed. +#[global] Hint Resolve ListIn_In Sort_NoDup Inf_lt : core. +#[global] Hint Immediate In_eq Inf_lt : core. End OrderedTypeLists. @@ -66,6 +68,7 @@ Module KeyOrderedType(O:OrderedType). Definition ltk {elt} : relation (key*elt) := O.lt @@1. + #[global] Hint Unfold ltk : core. (* ltk is a strict order *) @@ -109,7 +112,9 @@ Module KeyOrderedType(O:OrderedType). Lemma Inf_lt l x x' : ltk x x' -> Inf x' l -> Inf x l. Proof. apply InfA_ltA; auto with *. Qed. + #[local] Hint Immediate Inf_eq : core. + #[local] Hint Resolve Inf_lt : core. Lemma Sort_Inf_In l p q : Sort l -> Inf q l -> InA eqk p l -> ltk q p. @@ -148,9 +153,13 @@ Module KeyOrderedType(O:OrderedType). End Elt. + #[global] Hint Resolve ltk_not_eqk ltk_not_eqke : core. + #[global] Hint Immediate Inf_eq : core. + #[global] Hint Resolve Inf_lt : core. + #[global] Hint Resolve Sort_Inf_NotIn : core. End KeyOrderedType. diff --git a/theories/Vectors/VectorDef.v b/theories/Vectors/VectorDef.v index a154a2b269..3799ffaca9 100644 --- a/theories/Vectors/VectorDef.v +++ b/theories/Vectors/VectorDef.v @@ -279,27 +279,32 @@ Section SCANNING. Inductive Forall {A} (P: A -> Prop): forall {n} (v: t A n), Prop := |Forall_nil: Forall P [] |Forall_cons {n} x (v: t A n): P x -> Forall P v -> Forall P (x::v). +#[local] Hint Constructors Forall : core. Inductive Exists {A} (P:A->Prop): forall {n}, t A n -> Prop := |Exists_cons_hd {m} x (v: t A m): P x -> Exists P (x::v) |Exists_cons_tl {m} x (v: t A m): Exists P v -> Exists P (x::v). +#[local] Hint Constructors Exists : core. Inductive In {A} (a:A): forall {n}, t A n -> Prop := |In_cons_hd {m} (v: t A m): In a (a::v) |In_cons_tl {m} x (v: t A m): In a v -> In a (x::v). +#[local] Hint Constructors In : core. Inductive Forall2 {A B} (P:A->B->Prop): forall {n}, t A n -> t B n -> Prop := |Forall2_nil: Forall2 P [] [] |Forall2_cons {m} x1 x2 (v1:t A m) v2: P x1 x2 -> Forall2 P v1 v2 -> Forall2 P (x1::v1) (x2::v2). +#[local] Hint Constructors Forall2 : core. Inductive Exists2 {A B} (P:A->B->Prop): forall {n}, t A n -> t B n -> Prop := |Exists2_cons_hd {m} x1 x2 (v1: t A m) (v2: t B m): P x1 x2 -> Exists2 P (x1::v1) (x2::v2) |Exists2_cons_tl {m} x1 x2 (v1:t A m) v2: Exists2 P v1 v2 -> Exists2 P (x1::v1) (x2::v2). +#[local] Hint Constructors Exists2 : core. End SCANNING. diff --git a/theories/Wellfounded/Inclusion.v b/theories/Wellfounded/Inclusion.v index 474836d53d..cafa849b1b 100644 --- a/theories/Wellfounded/Inclusion.v +++ b/theories/Wellfounded/Inclusion.v @@ -22,6 +22,7 @@ Section WfInclusion. apply Acc_intro; auto with sets. Qed. + #[local] Hint Resolve Acc_incl : core. Theorem wf_incl : inclusion A R1 R2 -> well_founded R2 -> well_founded R1. diff --git a/theories/Wellfounded/Transitive_Closure.v b/theories/Wellfounded/Transitive_Closure.v index 2d139504f3..49c2dd8602 100644 --- a/theories/Wellfounded/Transitive_Closure.v +++ b/theories/Wellfounded/Transitive_Closure.v @@ -31,6 +31,7 @@ Section Wf_Transitive_Closure. apply Acc_inv with y; auto with sets. Defined. + #[local] Hint Resolve Acc_clos_trans : core. Lemma Acc_inv_trans : forall x y:A, trans_clos y x -> Acc R x -> Acc R y. diff --git a/theories/ZArith/BinInt.v b/theories/ZArith/BinInt.v index 52998c8b95..47137414dc 100644 --- a/theories/ZArith/BinInt.v +++ b/theories/ZArith/BinInt.v @@ -1754,6 +1754,7 @@ Proof. congruence. Qed. Lemma Zpos_eq_iff : forall p q, p = q <-> Z.pos p = Z.pos q. Proof (fun p q => iff_sym (Pos2Z.inj_iff p q)). +#[global] Hint Immediate Zsucc_pred: zarith. (* Not kept : diff --git a/theories/ZArith/ZArith_base.v b/theories/ZArith/ZArith_base.v index 26cd3e1e4d..cae918b4b6 100644 --- a/theories/ZArith/ZArith_base.v +++ b/theories/ZArith/ZArith_base.v @@ -30,6 +30,7 @@ Require Export Zbool. Require Export Zmisc. Require Export Wf_Z. +#[global] Hint Resolve Z.le_refl Z.add_comm Z.add_assoc Z.mul_comm Z.mul_assoc Z.add_0_l Z.add_0_r Z.mul_1_l Z.add_opp_diag_l Z.add_opp_diag_r Z.mul_add_distr_l Z.mul_add_distr_r: zarith. diff --git a/theories/ZArith/Zdiv.v b/theories/ZArith/Zdiv.v index 2039dc0bee..13adda412d 100644 --- a/theories/ZArith/Zdiv.v +++ b/theories/ZArith/Zdiv.v @@ -75,6 +75,7 @@ Proof. + apply Pos2Z.neg_is_nonpos. Qed. +#[global] Hint Unfold Remainder : core. (** Now comes the fully general result about Euclidean division. *) @@ -203,6 +204,7 @@ Proof. intros a. zero_or_not a. apply Z.mod_1_r. Qed. Lemma Zdiv_1_r: forall a, a/1 = a. Proof. intros a. zero_or_not a. apply Z.div_1_r. Qed. +#[global] Hint Resolve Zmod_0_l Zmod_0_r Zdiv_0_l Zdiv_0_r Zdiv_1_r Zmod_1_r : zarith. diff --git a/theories/ZArith/Zeven.v b/theories/ZArith/Zeven.v index 0448bcf41b..d3a9d7baac 100644 --- a/theories/ZArith/Zeven.v +++ b/theories/ZArith/Zeven.v @@ -130,6 +130,7 @@ Proof. boolify_even_odd. now rewrite Z.odd_pred. Qed. +#[global] Hint Unfold Zeven Zodd: zarith. Notation Zeven_bool_succ := Z.even_succ (only parsing). diff --git a/theories/ZArith/Zhints.v b/theories/ZArith/Zhints.v index 95266186eb..80073bdbdf 100644 --- a/theories/ZArith/Zhints.v +++ b/theories/ZArith/Zhints.v @@ -40,6 +40,7 @@ Require Import Wf_Z. (** No subgoal or smaller subgoals *) +#[global] Hint Resolve (** ** Reversible simplification lemmas (no loss of information) *) (** Should clearly be declared as hints *) diff --git a/theories/ZArith/Znumtheory.v b/theories/ZArith/Znumtheory.v index cad9454906..861c204ab8 100644 --- a/theories/ZArith/Znumtheory.v +++ b/theories/ZArith/Znumtheory.v @@ -65,8 +65,11 @@ Proof. apply Z.divide_abs_l. Qed. Theorem Zdivide_Zabs_inv_l a b : (a | b) -> (Z.abs a | b). Proof. apply Z.divide_abs_l. Qed. +#[global] Hint Resolve Z.divide_refl Z.divide_1_l Z.divide_0_r: zarith. +#[global] Hint Resolve Z.mul_divide_mono_l Z.mul_divide_mono_r: zarith. +#[global] Hint Resolve Z.divide_add_r Zdivide_opp_r Zdivide_opp_r_rev Zdivide_opp_l Zdivide_opp_l_rev Z.divide_sub_r Z.divide_mul_l Z.divide_mul_r Z.divide_factor_l Z.divide_factor_r: zarith. @@ -236,6 +239,7 @@ Proof. intros; apply Zis_gcd_opp; apply Zis_gcd_0; auto. Qed. +#[global] Hint Resolve Zis_gcd_sym Zis_gcd_0 Zis_gcd_minus Zis_gcd_opp: zarith. Theorem Zis_gcd_unique: forall a b c d : Z, @@ -646,6 +650,7 @@ Proof. - absurd (p | a); intuition. Qed. +#[global] Hint Resolve prime_rel_prime: zarith. (** As a consequence, a prime number is relatively prime with smaller numbers *) @@ -866,6 +871,7 @@ Notation Zgcd_Zabs := Z.gcd_abs_l (only parsing). Notation Zgcd_0 := Z.gcd_0_r (only parsing). Notation Zgcd_1 := Z.gcd_1_r (only parsing). +#[global] Hint Resolve Z.gcd_0_r Z.gcd_1_r : zarith. Theorem Zgcd_1_rel_prime : forall a b, diff --git a/theories/ZArith/Zorder.v b/theories/ZArith/Zorder.v index 949a01860f..4c533ac458 100644 --- a/theories/ZArith/Zorder.v +++ b/theories/ZArith/Zorder.v @@ -132,6 +132,7 @@ Register not_Zne as plugins.omega.not_Zne. Notation Zeq_le := Z.eq_le_incl (only parsing). +#[global] Hint Resolve Z.le_refl: zarith. (** Antisymmetry *) @@ -196,6 +197,7 @@ Proof. Z.swap_greater. Z.order. Qed. +#[global] Hint Resolve Z.le_trans: zarith. (** * Compatibility of order and operations on Z *) @@ -219,6 +221,7 @@ Proof. Z.swap_greater. apply Z.succ_lt_mono. Qed. +#[global] Hint Resolve Zsucc_le_compat: zarith. (** Simplification of successor wrt to order *) @@ -302,7 +305,9 @@ Proof. intros. now apply Z.lt_le_incl, Z.le_succ_l. Qed. +#[global] Hint Resolve Z.le_succ_diag_r: zarith. +#[global] Hint Resolve Z.le_le_succ_r: zarith. (** Relating order wrt successor and order wrt predecessor *) @@ -357,6 +362,7 @@ Proof. intros n; induction n; simpl; intros. apply Z.le_refl. easy. Qed. +#[global] Hint Immediate Z.eq_le_incl: zarith. (** Derived lemma *) diff --git a/theories/ZArith/Zpow_facts.v b/theories/ZArith/Zpow_facts.v index c36ddad823..b69af424b1 100644 --- a/theories/ZArith/Zpow_facts.v +++ b/theories/ZArith/Zpow_facts.v @@ -57,6 +57,7 @@ Proof. apply Z.pow_gt_1. Qed. Theorem Zmult_power p q r : 0 <= r -> (p*q)^r = p^r * q^r. Proof. intros. apply Z.pow_mul_l. Qed. +#[global] Hint Resolve Z.pow_nonneg Z.pow_pos_nonneg : zarith. Theorem Zpower_le_monotone3 a b c : diff --git a/theories/ZArith/Zpower.v b/theories/ZArith/Zpower.v index ae12295ca4..6f464d89bb 100644 --- a/theories/ZArith/Zpower.v +++ b/theories/ZArith/Zpower.v @@ -79,7 +79,9 @@ Proof. now apply (Z.pow_add_r z (Zpos n) (Zpos m)). Qed. +#[global] Hint Immediate Zpower_nat_is_exp Zpower_pos_is_exp : zarith. +#[global] Hint Unfold Z.pow_pos Zpower_nat: zarith. Theorem Zpower_exp x n m : @@ -226,7 +228,9 @@ Section Powers_of_2. End Powers_of_2. +#[global] Hint Resolve two_p_gt_ZERO: zarith. +#[global] Hint Immediate two_p_pred two_p_S: zarith. Section power_div_with_rest. diff --git a/theories/ZArith/Zquot.v b/theories/ZArith/Zquot.v index f95831436a..943376ecfd 100644 --- a/theories/ZArith/Zquot.v +++ b/theories/ZArith/Zquot.v @@ -57,6 +57,7 @@ Proof. now destruct a. Qed. Lemma Zquot_0_l a : 0÷a = 0. Proof. now destruct a. Qed. +#[global] Hint Resolve Zrem_0_l Zrem_0_r Zquot_0_l Zquot_0_r Z.quot_1_r Z.rem_1_r : zarith. diff --git a/theories/ZArith/Zwf.v b/theories/ZArith/Zwf.v index 2ff6805c78..81d2a2d70d 100644 --- a/theories/ZArith/Zwf.v +++ b/theories/ZArith/Zwf.v @@ -57,6 +57,7 @@ Section wf_proof. End wf_proof. +#[global] Hint Resolve Zwf_well_founded: datatypes. @@ -87,4 +88,5 @@ Section wf_proof_up. End wf_proof_up. +#[global] Hint Resolve Zwf_up_well_founded: datatypes. diff --git a/theories/btauto/Algebra.v b/theories/btauto/Algebra.v index 4a603f2c52..08bb49a449 100644 --- a/theories/btauto/Algebra.v +++ b/theories/btauto/Algebra.v @@ -10,6 +10,7 @@ end. Arguments decide P /H. +#[global] Hint Extern 5 => progress bool : core. Ltac define t x H := @@ -147,6 +148,7 @@ Qed. (** * The core reflexive part. *) +#[local] Hint Constructors valid : core. Fixpoint beq_poly pl pr := @@ -315,6 +317,7 @@ Section Validity. (* Decision procedure of validity *) +#[local] Hint Constructors valid linear : core. Lemma valid_le_compat : forall k l p, valid k p -> (k <= l)%positive -> valid l p. @@ -414,6 +417,7 @@ intros pl; induction pl; intros pr var; simpl. rewrite poly_add_compat, poly_mul_mon_compat, IHpl1, IHpl2; ring. Qed. +#[local] Hint Extern 5 => match goal with | [ |- (Pos.max ?x ?y <= ?z)%positive ] => @@ -426,8 +430,10 @@ match goal with apply Pos.max_case_strong; intros; lia | _ => lia end : core. +#[local] Hint Resolve Pos.le_max_r Pos.le_max_l : core. +#[local] Hint Constructors valid linear : core. (* Compatibility of validity w.r.t algebraic operations *) diff --git a/theories/btauto/Reflect.v b/theories/btauto/Reflect.v index 867fe69550..a653b94d1c 100644 --- a/theories/btauto/Reflect.v +++ b/theories/btauto/Reflect.v @@ -77,9 +77,11 @@ intros var f; induction f; simpl poly_of_formula; simpl formula_eval; auto. end. Qed. +#[local] Hint Extern 5 => change 0 with (min 0 0) : core. Local Hint Resolve poly_add_valid_compat poly_mul_valid_compat : core. Local Hint Constructors valid : core. +#[local] Hint Extern 5 => lia : core. (* Compatibility with validity *) diff --git a/theories/micromega/Tauto.v b/theories/micromega/Tauto.v index 99af214396..ce12b02359 100644 --- a/theories/micromega/Tauto.v +++ b/theories/micromega/Tauto.v @@ -1562,6 +1562,7 @@ Section S. auto. Qed. + #[local] Hint Resolve no_middle_eval_tt : tauto. Lemma or_clause_correct : forall cl cl' env, eval_opt_clause env (or_clause cl cl') <-> eval_clause env cl \/ eval_clause env cl'. @@ -1702,6 +1703,7 @@ Section S. intros k; destruct k ; simpl; auto. Qed. + #[local] Hint Resolve hold_eTT : tauto. Lemma hold_eFF : forall k, @@ -1710,6 +1712,7 @@ Section S. intros k; destruct k ; simpl;auto. Qed. + #[local] Hint Resolve hold_eFF : tauto. Lemma hold_eAND : forall k r1 r2, diff --git a/theories/micromega/ZArith_hints.v b/theories/micromega/ZArith_hints.v index a6d3d92a99..3545e8b218 100644 --- a/theories/micromega/ZArith_hints.v +++ b/theories/micromega/ZArith_hints.v @@ -10,34 +10,56 @@ Require Import Lia. Import ZArith_base. +#[global] Hint Resolve Z.le_refl Z.add_comm Z.add_assoc Z.mul_comm Z.mul_assoc Z.add_0_l Z.add_0_r Z.mul_1_l Z.add_opp_diag_l Z.add_opp_diag_r Z.mul_add_distr_r Z.mul_add_distr_l: zarith. Require Export Zhints. +#[global] Hint Extern 10 (_ = _ :>nat) => abstract lia: zarith. +#[global] Hint Extern 10 (_ <= _) => abstract lia: zarith. +#[global] Hint Extern 10 (_ < _) => abstract lia: zarith. +#[global] Hint Extern 10 (_ >= _) => abstract lia: zarith. +#[global] Hint Extern 10 (_ > _) => abstract lia: zarith. +#[global] Hint Extern 10 (_ <> _ :>nat) => abstract lia: zarith. +#[global] Hint Extern 10 (~ _ <= _) => abstract lia: zarith. +#[global] Hint Extern 10 (~ _ < _) => abstract lia: zarith. +#[global] Hint Extern 10 (~ _ >= _) => abstract lia: zarith. +#[global] Hint Extern 10 (~ _ > _) => abstract lia: zarith. +#[global] Hint Extern 10 (_ = _ :>Z) => abstract lia: zarith. +#[global] Hint Extern 10 (_ <= _)%Z => abstract lia: zarith. +#[global] Hint Extern 10 (_ < _)%Z => abstract lia: zarith. +#[global] Hint Extern 10 (_ >= _)%Z => abstract lia: zarith. +#[global] Hint Extern 10 (_ > _)%Z => abstract lia: zarith. +#[global] Hint Extern 10 (_ <> _ :>Z) => abstract lia: zarith. +#[global] Hint Extern 10 (~ (_ <= _)%Z) => abstract lia: zarith. +#[global] Hint Extern 10 (~ (_ < _)%Z) => abstract lia: zarith. +#[global] Hint Extern 10 (~ (_ >= _)%Z) => abstract lia: zarith. +#[global] Hint Extern 10 (~ (_ > _)%Z) => abstract lia: zarith. +#[global] Hint Extern 10 False => abstract lia: zarith. diff --git a/theories/nsatz/Nsatz.v b/theories/nsatz/Nsatz.v index b684775bb4..21f0f30140 100644 --- a/theories/nsatz/Nsatz.v +++ b/theories/nsatz/Nsatz.v @@ -60,6 +60,7 @@ exact Rplus_opp_r. Defined. Class can_compute_Z (z : Z) := dummy_can_compute_Z : True. +#[global] Hint Extern 0 (can_compute_Z ?v) => match isZcst v with true => exact I end : typeclass_instances. Instance reify_IZR z lvar {_ : can_compute_Z z} : reify (PEc z) lvar (IZR z). diff --git a/theories/setoid_ring/Ring_tac.v b/theories/setoid_ring/Ring_tac.v index 76e9b1e947..9323ae23b9 100644 --- a/theories/setoid_ring/Ring_tac.v +++ b/theories/setoid_ring/Ring_tac.v @@ -41,7 +41,7 @@ Ltac Get_goal := match goal with [|- ?G] => G end. Ltac OnEquation req := match goal with | |- req ?lhs ?rhs => (fun f => f lhs rhs) - | _ => (fun _ => fail "Goal is not an equation (of expected equality)") + | _ => (fun _ => fail "Goal is not an equation (of expected equality)" req) end. Ltac OnEquationHyp req h := diff --git a/theories/ssr/ssrbool.v b/theories/ssr/ssrbool.v index e8a036bbb0..d1cefeb552 100644 --- a/theories/ssr/ssrbool.v +++ b/theories/ssr/ssrbool.v @@ -22,9 +22,10 @@ Require Import ssreflect ssrfun. is_true b == the coercion of b : bool to Prop (:= b = true). This is just input and displayed as `b''. reflect P b == the reflection inductive predicate, asserting - that the logical proposition P : prop with the - formula b : bool. Lemmas asserting reflect P b - are often referred to as "views". + that the logical proposition P : Prop holds iff + the formula b : bool is equal to true. Lemmas + asserting reflect P b are often referred to as + "views". iffP, appP, sameP, rwP :: lemmas for direct manipulation of reflection views: iffP is used to prove reflection from logical equivalence, appP to compose views, and @@ -33,7 +34,7 @@ Require Import ssreflect ssrfun. elimT :: coercion reflect >-> Funclass, which allows the direct application of `reflect' views to boolean assertions. - decidable P <-> P is effectively decidable (:= {P} + {~ P}. + decidable P <-> P is effectively decidable (:= {P} + {~ P}). contra, contraL, ... :: contraposition lemmas. altP my_viewP :: natural alternative for reflection; given lemma myviewP: reflect my_Prop my_formula, @@ -487,6 +488,7 @@ Ltac prop_congr := apply: prop_congr. Lemma is_true_true : true. Proof. by []. Qed. Lemma not_false_is_true : ~ false. Proof. by []. Qed. Lemma is_true_locked_true : locked true. Proof. by unlock. Qed. +#[global] Hint Resolve is_true_true not_false_is_true is_true_locked_true : core. (** Shorter names. **) diff --git a/theories/ssr/ssreflect.v b/theories/ssr/ssreflect.v index 175cae8415..d0508bef2e 100644 --- a/theories/ssr/ssreflect.v +++ b/theories/ssr/ssreflect.v @@ -543,8 +543,10 @@ Proof. by move=> /(_ P); apply. Qed. Require Export ssrunder. +#[global] Hint Extern 0 (@Under_rel.Over_rel _ _ _ _) => solve [ apply: Under_rel.over_rel_done ] : core. +#[global] Hint Resolve Under_rel.over_rel_done : core. Register Under_rel.Under_rel as plugins.ssreflect.Under_rel. diff --git a/theories/ssr/ssrfun.v b/theories/ssr/ssrfun.v index 053e86dc34..e1442e1da2 100644 --- a/theories/ssr/ssrfun.v +++ b/theories/ssr/ssrfun.v @@ -450,6 +450,7 @@ End ExtensionalEquality. Typeclasses Opaque eqfun. Typeclasses Opaque eqrel. +#[global] Hint Resolve frefl rrefl : core. Notation "f1 =1 f2" := (eqfun f1 f2) : fun_scope. diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index bbcfcc4826..d0d50aee70 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -149,6 +149,18 @@ let print_query opts = function heap increment and the GC pressure coefficient. *) +let set_gc_policy () = + Gc.set { (Gc.get ()) with + Gc.minor_heap_size = 32*1024*1024 (* 32Mwords x 8 bytes/word = 256Mb *) + ; Gc.space_overhead = 120 + } + +let set_gc_best_fit () = + Gc.set { (Gc.get ()) with + Gc.allocation_policy = 2 (* best-fit *) + ; Gc.space_overhead = 200 + } + let init_gc () = try (* OCAMLRUNPARAM environment variable is set. @@ -160,9 +172,8 @@ let init_gc () = (* OCAMLRUNPARAM environment variable is not set. * In this case, we put in place our preferred configuration. *) - Gc.set { (Gc.get ()) with - Gc.minor_heap_size = 32*1024*1024; (* 32Mwords x 8 bytes/word = 256Mb *) - Gc.space_overhead = 120} + set_gc_policy (); + if Coq_config.caml_version_nums >= [4;10;0] then set_gc_best_fit () else () let init_process () = (* Coq's init process, phase 1: diff --git a/vernac/attributes.ml b/vernac/attributes.ml index efba6d332a..fdaeedef8c 100644 --- a/vernac/attributes.ml +++ b/vernac/attributes.ml @@ -11,13 +11,29 @@ open CErrors (** The type of parsing attribute data *) +type vernac_flag_type = + | FlagIdent of string + | FlagString of string + type vernac_flags = vernac_flag list and vernac_flag = string * vernac_flag_value and vernac_flag_value = | VernacFlagEmpty - | VernacFlagLeaf of string + | VernacFlagLeaf of vernac_flag_type | VernacFlagList of vernac_flags +let pr_vernac_flag_leaf = function + | FlagIdent b -> Pp.str b + | FlagString s -> Pp.(quote (str s)) + +let rec pr_vernac_flag_value = let open Pp in function + | VernacFlagEmpty -> mt () + | VernacFlagLeaf l -> str "=" ++ pr_vernac_flag_leaf l + | VernacFlagList s -> surround (prlist_with_sep pr_comma pr_vernac_flag s) +and pr_vernac_flag (s, arguments) = + let open Pp in + str s ++ (pr_vernac_flag_value arguments) + let warn_unsupported_attributes = CWarnings.create ~name:"unsupported-attributes" ~category:"parsing" ~default:CWarnings.AsError (fun atts -> @@ -105,16 +121,82 @@ let single_key_parser ~name ~key v prev args = assert_once ~name prev; v -let bool_attribute ~name ~on ~off : bool option attribute = - attribute_of_list [(on, single_key_parser ~name ~key:on true); - (off, single_key_parser ~name ~key:off false)] +let pr_possible_values ~values = + Pp.(str "{" ++ prlist_with_sep pr_comma str (List.map fst values) ++ str "}") + +(** [key_value_attribute ~key ~default ~values] parses a attribute [key=value] + with possible [key] [value] in [values], [default] is for compatibility for users + doing [qualif(key)] which is parsed as [qualif(key=default)] *) +let key_value_attribute ~key ~default ~(values : (string * 'a) list) : 'a option attribute = + let parser = function + | Some v -> + CErrors.user_err Pp.(str "key '" ++ str key ++ str "' has been already set.") + | None -> + begin function + | VernacFlagLeaf (FlagIdent b) -> + begin match CList.assoc_f String.equal b values with + | exception Not_found -> + CErrors.user_err + Pp.(str "Invalid value '" ++ str b ++ str "' for key " ++ str key ++ fnl () ++ + str "use one of " ++ pr_possible_values ~values) + | value -> value + end + | VernacFlagEmpty -> + default + | err -> + CErrors.user_err + Pp.(str "Invalid syntax " ++ pr_vernac_flag (key, err) ++ str ", try " + ++ str key ++ str "=" ++ pr_possible_values ~values ++ str " instead.") + end + in + attribute_of_list [key, parser] + +let bool_attribute ~name : bool option attribute = + let values = ["yes", true; "no", false] in + key_value_attribute ~key:name ~default:true ~values + +let legacy_bool_attribute ~name ~on ~off : bool option attribute = + attribute_of_list + [(on, single_key_parser ~name ~key:on true); + (off, single_key_parser ~name ~key:off false)] + +(* important note: we use on as the default for the new bool_attribute ! *) +let deprecated_bool_attribute_warning = + CWarnings.create + ~name:"deprecated-attribute-syntax" + ~category:"parsing" + ~default:CWarnings.Enabled + (fun name -> + Pp.(str "Syntax for switching off boolean attributes has been updated, use " ++ str name ++ str "=no instead.")) + +let deprecated_bool_attribute ~name ~on ~off : bool option attribute = + bool_attribute ~name:on ++ legacy_bool_attribute ~name ~on ~off |> map (function + | None, None -> + None + | None, Some v -> + deprecated_bool_attribute_warning name; + Some v + | Some v, None -> Some v + | Some v1, Some v2 -> + CErrors.user_err + Pp.(str "attribute " ++ str name ++ + str ": cannot specify legacy and modern syntax at the same time.") + ) (* Variant of the [bool] attribute with only two values (bool has three). *) let get_bool_value ~key ~default = function | VernacFlagEmpty -> default - | VernacFlagList [ "true", VernacFlagEmpty ] -> true - | VernacFlagList [ "false", VernacFlagEmpty ] -> false + | VernacFlagList [ "true", VernacFlagEmpty ] -> + deprecated_bool_attribute_warning key; + true + | VernacFlagList [ "false", VernacFlagEmpty ] -> + deprecated_bool_attribute_warning key; + false + | VernacFlagLeaf (FlagIdent "yes") -> + true + | VernacFlagLeaf (FlagIdent "no") -> + false | _ -> user_err Pp.(str "Attribute " ++ str key ++ str " only accepts boolean values.") let enable_attribute ~key ~default : bool attribute = @@ -161,18 +243,37 @@ let () = let open Goptions in let program = enable_attribute ~key:"program" ~default:(fun () -> !program_mode) -let locality = bool_attribute ~name:"Locality" ~on:"local" ~off:"global" - -let option_locality = +(* This is a bit complex as the grammar in g_vernac.mlg doesn't + distingish between the boolean and ternary case.*) +let option_locality_parser = let name = "Locality" in attribute_of_list [ - ("local", single_key_parser ~name ~key:"local" Goptions.OptLocal); - ("global", single_key_parser ~name ~key:"global" Goptions.OptGlobal); - ("export", single_key_parser ~name ~key:"export" Goptions.OptExport); - ] >>= function + ("local", single_key_parser ~name ~key:"local" Goptions.OptLocal) + ; ("global", single_key_parser ~name ~key:"global" Goptions.OptGlobal) + ; ("export", single_key_parser ~name ~key:"export" Goptions.OptExport) + ] + +let option_locality = + option_locality_parser >>= function | None -> return Goptions.OptDefault | Some l -> return l +(* locality is supposed to be true when local, false when global *) +let locality = + let locality_to_bool = + function + | Goptions.OptLocal -> + true + | Goptions.OptGlobal -> + false + | Goptions.OptExport -> + CErrors.user_err Pp.(str "export attribute not supported here") + | Goptions.OptDefault -> + CErrors.user_err Pp.(str "default attribute not supported here") + in + option_locality_parser >>= function l -> + return (Option.map locality_to_bool l) + let ukey = "universes" let universe_polymorphism_option_name = ["Universe"; "Polymorphism"] @@ -188,12 +289,17 @@ let is_universe_polymorphism = fun () -> !b let polymorphic_base = - bool_attribute ~name:"Polymorphism" ~on:"polymorphic" ~off:"monomorphic" >>= function + deprecated_bool_attribute + ~name:"Polymorphism" + ~on:"polymorphic" ~off:"monomorphic" >>= function | Some b -> return b | None -> return (is_universe_polymorphism()) let template = - qualify_attribute ukey (bool_attribute ~name:"Template" ~on:"template" ~off:"notemplate") + qualify_attribute ukey + (deprecated_bool_attribute + ~name:"Template" + ~on:"template" ~off:"notemplate") let polymorphic = qualify_attribute ukey polymorphic_base @@ -201,12 +307,12 @@ let polymorphic = let deprecation_parser : Deprecation.t key_parser = fun orig args -> assert_once ~name:"deprecation" orig; match args with - | VernacFlagList [ "since", VernacFlagLeaf since ; "note", VernacFlagLeaf note ] - | VernacFlagList [ "note", VernacFlagLeaf note ; "since", VernacFlagLeaf since ] -> + | VernacFlagList [ "since", VernacFlagLeaf (FlagString since) ; "note", VernacFlagLeaf (FlagString note) ] + | VernacFlagList [ "note", VernacFlagLeaf (FlagString note) ; "since", VernacFlagLeaf (FlagString since) ] -> Deprecation.make ~since ~note () - | VernacFlagList [ "since", VernacFlagLeaf since ] -> + | VernacFlagList [ "since", VernacFlagLeaf (FlagString since) ] -> Deprecation.make ~since () - | VernacFlagList [ "note", VernacFlagLeaf note ] -> + | VernacFlagList [ "note", VernacFlagLeaf (FlagString note) ] -> Deprecation.make ~note () | _ -> CErrors.user_err (Pp.str "Ill formed “deprecated” attribute") @@ -218,7 +324,7 @@ let only_polymorphism atts = parse polymorphic atts let vernac_polymorphic_flag = ukey, VernacFlagList ["polymorphic", VernacFlagEmpty] -let vernac_monomorphic_flag = ukey, VernacFlagList ["monomorphic", VernacFlagEmpty] +let vernac_monomorphic_flag = ukey, VernacFlagList ["polymorphic", VernacFlagLeaf (FlagIdent "no")] let canonical_field = enable_attribute ~key:"canonical" ~default:(fun () -> true) @@ -228,7 +334,7 @@ let canonical_instance = let uses_parser : string key_parser = fun orig args -> assert_once ~name:"using" orig; match args with - | VernacFlagLeaf str -> str + | VernacFlagLeaf (FlagString str) -> str | _ -> CErrors.user_err (Pp.str "Ill formed \"using\" attribute") let using = attribute_of_list ["using",uses_parser] diff --git a/vernac/attributes.mli b/vernac/attributes.mli index 1969665082..03a14a03ff 100644 --- a/vernac/attributes.mli +++ b/vernac/attributes.mli @@ -9,13 +9,19 @@ (************************************************************************) (** The type of parsing attribute data *) +type vernac_flag_type = + | FlagIdent of string + | FlagString of string + type vernac_flags = vernac_flag list and vernac_flag = string * vernac_flag_value and vernac_flag_value = | VernacFlagEmpty - | VernacFlagLeaf of string + | VernacFlagLeaf of vernac_flag_type | VernacFlagList of vernac_flags +val pr_vernac_flag : vernac_flag -> Pp.t + type +'a attribute (** The type of attributes. When parsing attributes if an ['a attribute] is present then an ['a] value will be produced. @@ -82,10 +88,19 @@ val attribute_of_list : (string * 'a key_parser) list -> 'a option attribute (** Make an attribute from a list of key parsers together with their associated key. *) -val bool_attribute : name:string -> on:string -> off:string -> bool option attribute -(** Define boolean attribute [name] with value [true] when [on] is - provided and [false] when [off] is provided. The attribute may only - be set once for a command. *) +(** Define boolean attribute [name], of the form [name={yes,no}]. The + attribute may only be set once for a command. *) +val bool_attribute : name:string -> bool option attribute + +val deprecated_bool_attribute + : name:string + -> on:string + -> off:string + -> bool option attribute +(** Define boolean attribute [name] with will be set when [on] is + provided and unset when [off] is provided. The attribute may only + be set once for a command; this attribute both accepts the old [on] + [off] syntax and new attribute syntax [on=yes] [on=no] *) val qualify_attribute : string -> 'a attribute -> 'a attribute (** [qualified_attribute qual att] treats [#[qual(atts)]] like [att] diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index bb26ce652e..8cb077ca21 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -271,9 +271,8 @@ let inductive_levels env evd arities inds = if Sorts.is_prop a || Sorts.is_sprop a then None else Some (univ_of_sort a)) destarities in - let cstrs_levels, min_levels, sizes = - CList.split3 - (List.map2 (fun (_,tys) (arity,(ctx,du)) -> + let cstrs_levels, sizes = + CList.split (List.map2 (fun (_,tys) (arity,(ctx,du)) -> let len = List.length tys in let minlev = Sorts.univ_of_sort du in let minlev = @@ -283,13 +282,15 @@ let inductive_levels env evd arities inds = in let minlev = (* Indices contribute. *) - if indices_matter env && List.length ctx > 0 then ( + if indices_matter env then begin let ilev = sign_level env evd ctx in - Univ.sup ilev minlev) + Univ.sup ilev minlev + end else minlev in let clev = extract_level env evd minlev tys in - (clev, minlev, len)) inds destarities) + (clev, len)) + inds destarities) in (* Take the transitive closure of the system of constructors *) (* level constraints and remove the recursive dependencies *) @@ -326,8 +327,13 @@ let inductive_levels env evd arities inds = let duu = Sorts.univ_of_sort du in let template_prop, evd = if not (Univ.is_small_univ duu) && Univ.Universe.equal cu duu then - if is_flexible_sort evd duu && not (Evd.check_leq evd Univ.type0_univ duu) then - true, Evd.set_eq_sort env evd Sorts.prop du + if is_flexible_sort evd duu && not (Evd.check_leq evd Univ.type0_univ duu) + then if Term.isArity arity + (* If not a syntactic arity, the universe may be used in a + polymorphic instance and so cannot be lowered to Prop. + See #13300. *) + then true, Evd.set_eq_sort env evd Sorts.prop du + else false, Evd.set_eq_sort env evd Sorts.set du else false, evd else false, Evd.set_eq_sort env evd (sort_of_univ cu) du in @@ -367,7 +373,26 @@ let restrict_inductive_universes sigma ctx_params arities constructors = let uvars = List.fold_right (fun (_,ctypes) -> List.fold_right merge_universes_of_constr ctypes) constructors uvars in Evd.restrict_universe_context sigma uvars -let interp_mutual_inductive_constr ~sigma ~template ~udecl ~ctx_params ~indnames ~arities ~arityconcl ~constructors ~env_ar_params ~cumulative ~poly ~private_ind ~finite = +let check_trivial_variances variances = + Array.iter (function + | None | Some Univ.Variance.Invariant -> () + | Some _ -> + CErrors.user_err + Pp.(strbrk "Universe variance was specified but this inductive will not be cumulative.")) + variances + +let variance_of_entry ~cumulative ~variances uctx = + match uctx with + | Monomorphic_entry _ -> check_trivial_variances variances; None + | Polymorphic_entry (nas,_) -> + if not cumulative then begin check_trivial_variances variances; None end + else + let lvs = Array.length variances in + let lus = Array.length nas in + assert (lvs <= lus); + Some (Array.append variances (Array.make (lus - lvs) None)) + +let interp_mutual_inductive_constr ~sigma ~template ~udecl ~variances ~ctx_params ~indnames ~arities ~arityconcl ~constructors ~env_ar_params ~cumulative ~poly ~private_ind ~finite = (* Compute renewed arities *) let sigma = Evd.minimize_universes sigma in let nf = Evarutil.nf_evars_universes sigma in @@ -429,13 +454,13 @@ let interp_mutual_inductive_constr ~sigma ~template ~udecl ~ctx_params ~indnames mind_entry_private = if private_ind then Some false else None; mind_entry_universes = uctx; mind_entry_template = is_template; - mind_entry_cumulative = poly && cumulative; + mind_entry_variance = variance_of_entry ~cumulative ~variances uctx; } in mind_ent, Evd.universe_binders sigma let interp_params env udecl uparamsl paramsl = - let sigma, udecl = interp_univ_decl_opt env udecl in + let sigma, udecl, variances = interp_cumul_univ_decl_opt env udecl in let sigma, (uimpls, ((env_uparams, ctx_uparams), useruimpls)) = interp_context_evars ~program_mode:false env sigma uparamsl in let sigma, (impls, ((env_params, ctx_params), userimpls)) = @@ -443,7 +468,7 @@ let interp_params env udecl uparamsl paramsl = in (* Names of parameters as arguments of the inductive type (defs removed) *) sigma, env_params, (ctx_params, env_uparams, ctx_uparams, - userimpls, useruimpls, impls, udecl) + userimpls, useruimpls, impls, udecl, variances) (* When a hole remains for a param, pretend the param is uniform and do the unification. @@ -485,7 +510,7 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not (* In case of template polymorphism, we need to compute more constraints *) 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, userimpls, useruimpls, impls, udecl) = + let sigma, env_params, (ctx_params, env_uparams, ctx_uparams, userimpls, useruimpls, impls, udecl, variances) = interp_params env0 udecl uparamsl paramsl in @@ -563,7 +588,7 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not userimpls @ impls) cimpls) indimpls cimpls in - let mie, pl = interp_mutual_inductive_constr ~template ~sigma ~ctx_params ~udecl ~arities ~arityconcl ~constructors ~env_ar_params ~poly ~finite ~cumulative ~private_ind ~indnames in + let mie, pl = interp_mutual_inductive_constr ~template ~sigma ~ctx_params ~udecl ~variances ~arities ~arityconcl ~constructors ~env_ar_params ~poly ~finite ~cumulative ~private_ind ~indnames in (mie, pl, impls) diff --git a/vernac/comInductive.mli b/vernac/comInductive.mli index 91e8f609d5..8bce884ba4 100644 --- a/vernac/comInductive.mli +++ b/vernac/comInductive.mli @@ -22,7 +22,7 @@ type uniform_inductive_flag = val do_mutual_inductive : template:bool option - -> universe_decl_expr option + -> cumul_univ_decl_expr option -> (one_inductive_expr * decl_notation list) list -> cumulative:bool -> poly:bool @@ -45,6 +45,7 @@ val interp_mutual_inductive_constr : sigma:Evd.evar_map -> template:bool option -> udecl:UState.universe_decl + -> variances:Entries.variance_entry -> ctx_params:(EConstr.t, EConstr.t) Context.Rel.Declaration.pt list -> indnames:Names.Id.t list -> arities:EConstr.t list @@ -86,3 +87,13 @@ val maybe_unify_params_in : Environ.env -> Evd.evar_map -> ninds:int -> nparams: (** [nparams] is the number of parameters which aren't treated as uniform, ie the length of params (including letins) where the env is [uniform params, inductives, params, binders]. *) + +val variance_of_entry + : cumulative:bool + -> variances:Entries.variance_entry + -> Entries.universes_entry + -> Entries.variance_entry option +(** Will return None if non-cumulative, and resize if there are more + universes than originally specified. + If monomorphic, [cumulative] is treated as [false]. +*) diff --git a/vernac/declare.ml b/vernac/declare.ml index 1e8771b641..73ebca276d 100644 --- a/vernac/declare.ml +++ b/vernac/declare.ml @@ -39,8 +39,10 @@ module Hook = struct let make_g hook = CEphemeron.create hook let make (hook : S.t -> unit) : t = CEphemeron.create (fun x () -> hook x) - let call_g ?hook x s = Option.cata (fun hook -> CEphemeron.get hook x s) s hook - let call ?hook x = Option.iter (fun hook -> CEphemeron.get hook x ()) hook + let hcall hook x s = CEphemeron.default hook (fun _ x -> x) x s + + let call_g ?hook x s = Option.cata (fun hook -> hcall hook x s) s hook + let call ?hook x = Option.iter (fun hook -> hcall hook x ()) hook end @@ -1367,14 +1369,6 @@ module Proof_info = struct ; proof_ending = CEphemeron.create proof_ending } - (* This is used due to a deficiency on the API, should fix *) - let add_first_thm ~pinfo ~name ~typ ~impargs = - let cinfo : Constr.t CInfo.t = CInfo.make ~name ~impargs ~typ:(EConstr.Unsafe.to_constr typ) () in - { pinfo with cinfo = cinfo :: pinfo.cinfo } - - (* This is called by the STM, and we have to fixup cinfo later as - indeed it will not be correct *) - let default () = make ~cinfo:[] ~info:(Info.make ()) () end type t = @@ -1388,7 +1382,6 @@ type t = (*** Proof Global manipulation ***) -let info { pinfo } = pinfo let get ps = ps.proof let get_name ps = (Proof.data ps.proof).Proof.name let get_initial_euctx ps = ps.initial_euctx @@ -1566,6 +1559,7 @@ type proof_object = (* [name] only used in the STM *) ; entries : Evd.side_effects proof_entry list ; uctx: UState.t + ; pinfo : Proof_info.t } let get_po_name { name } = name @@ -1673,7 +1667,7 @@ let close_proof ~opaque ~keep_body_ucst_separate ps = definition_entry_core ~opaque ?using ~univs:utyp ~univsbody:ubody ~types:typ ~eff body in let entries = CList.map make_entry elist in - { name; entries; uctx } + { name; entries; uctx; pinfo } type closed_proof_output = (Constr.t * Evd.side_effects) list * UState.t @@ -1718,7 +1712,7 @@ let close_proof_delayed ~feedback_id ps (fpl : closed_proof_output Future.comput |> delayed_definition_entry ~opaque ~feedback_id ~using ~univs ~types in let entries = Future.map2 make_entry fpl (Proofview.initial_goals entry) in - { name; entries; uctx = initial_euctx } + { name; entries; uctx = initial_euctx; pinfo } let close_future_proof = close_proof_delayed @@ -1961,7 +1955,7 @@ let compute_proof_using_for_admitted proof typ pproofs = let finish_admitted ~pm ~pinfo ~uctx ~sec_vars ~univs = let cst = MutualEntry.declare_variable ~pinfo ~uctx ~sec_vars ~univs in (* If the constant was an obligation we need to update the program map *) - match CEphemeron.get pinfo.Proof_info.proof_ending with + match CEphemeron.default pinfo.Proof_info.proof_ending Proof_ending.Regular with | Proof_ending.End_obligation oinfo -> Obls_.obligation_admitted_terminator ~pm oinfo uctx (List.hd cst) | _ -> pm @@ -2083,7 +2077,7 @@ let save ~pm ~proof ~opaque ~idopt = let proof_info = process_idopt_for_save ~idopt proof.pinfo in finalize_proof ~pm proof_obj proof_info -let save_regular ~proof ~opaque ~idopt = +let save_regular ~(proof : t) ~opaque ~idopt = let open Proof_ending in match CEphemeron.default proof.pinfo.Proof_info.proof_ending Regular with | Regular -> @@ -2094,8 +2088,8 @@ let save_regular ~proof ~opaque ~idopt = (***********************************************************************) (* Special case to close a lemma without forcing a proof *) (***********************************************************************) -let save_lemma_admitted_delayed ~pm ~proof ~pinfo = - let { entries; uctx } = proof in +let save_lemma_admitted_delayed ~pm ~proof = + let { entries; uctx; pinfo } = proof in if List.length entries <> 1 then CErrors.user_err Pp.(str "Admitted does not support multiple statements"); let { proof_entry_secctx; proof_entry_type; proof_entry_universes } = List.hd entries in @@ -2106,16 +2100,10 @@ let save_lemma_admitted_delayed ~pm ~proof ~pinfo = let sec_vars = if get_keep_admitted_vars () then proof_entry_secctx else None in finish_admitted ~pm ~uctx ~pinfo ~sec_vars ~univs -let save_lemma_proved_delayed ~pm ~proof ~pinfo ~idopt = - (* vio2vo calls this but with invalid info, we have to workaround - that to add the name to the info structure *) - if CList.is_empty pinfo.Proof_info.cinfo then - let name = get_po_name proof in - let info = Proof_info.add_first_thm ~pinfo ~name ~typ:EConstr.mkSet ~impargs:[] in - finalize_proof ~pm proof info - else - let info = process_idopt_for_save ~idopt pinfo in - finalize_proof ~pm proof info +let save_lemma_proved_delayed ~pm ~proof ~idopt = + (* vio2vo used to call this with invalid [pinfo], now it should work fine. *) + let pinfo = process_idopt_for_save ~idopt proof.pinfo in + finalize_proof ~pm proof pinfo end (* Proof module *) diff --git a/vernac/declare.mli b/vernac/declare.mli index 0520bf8717..e4c77113af 100644 --- a/vernac/declare.mli +++ b/vernac/declare.mli @@ -278,14 +278,6 @@ module Proof : sig environment and empty evar_map. *) val get_current_context : t -> Evd.evar_map * Environ.env - (* Internal, don't use *) - module Proof_info : sig - type t - (* Make a dummy value, used in the stm *) - val default : unit -> t - end - val info : t -> Proof_info.t - (** {2 Proof delay API, warning, internal, not stable *) (* Intermediate step necessary to delegate the future. @@ -313,13 +305,11 @@ module Proof : sig val save_lemma_admitted_delayed : pm:OblState.t -> proof:proof_object - -> pinfo:Proof_info.t -> OblState.t val save_lemma_proved_delayed : pm:OblState.t -> proof:proof_object - -> pinfo:Proof_info.t -> idopt:Names.lident option -> OblState.t * GlobRef.t list diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 1c80d71ea5..116cfc6413 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -119,7 +119,8 @@ GRAMMAR EXTEND Gram ] ; attr_value: - [ [ "=" ; v = string -> { VernacFlagLeaf v } + [ [ "=" ; v = string -> { VernacFlagLeaf (FlagString v) } + | "=" ; v = IDENT -> { VernacFlagLeaf (FlagIdent v) } | "(" ; a = attribute_list ; ")" -> { VernacFlagList a } | -> { VernacFlagEmpty } ] ] @@ -136,7 +137,7 @@ GRAMMAR EXTEND Gram | IDENT "Cumulative" -> { ("universes", VernacFlagList ["cumulative", VernacFlagEmpty]) } | IDENT "NonCumulative" -> - { ("universes", VernacFlagList ["noncumulative", VernacFlagEmpty]) } + { ("universes", VernacFlagList ["cumulative", VernacFlagLeaf (FlagIdent "no")]) } | IDENT "Private" -> { ("private", VernacFlagList ["matching", VernacFlagEmpty]) } | IDENT "Program" -> @@ -194,6 +195,12 @@ let lname_of_lident : lident -> lname = let name_of_ident_decl : ident_decl -> name_decl = on_fst lname_of_lident +let test_variance_ident = + let open Pcoq.Lookahead in + to_entry "test_variance_ident" begin + lk_kws ["=";"+";"*"] >> lk_ident + end + } (* Gallina declarations *) @@ -283,7 +290,7 @@ GRAMMAR EXTEND Gram [ [ l = universe_name; ord = [ "<" -> { Univ.Lt } | "=" -> { Univ.Eq } | "<=" -> { Univ.Le } ]; r = universe_name -> { (l, ord, r) } ] ] ; - univ_decl : + univ_decl: [ [ "@{" ; l = LIST0 identref; ext = [ "+" -> { true } | -> { false } ]; cs = [ "|"; l' = LIST0 univ_constraint SEP ","; ext = [ "+" -> { true } | -> { false } ]; "}" -> { (l',ext) } @@ -296,10 +303,40 @@ GRAMMAR EXTEND Gram univdecl_extensible_constraints = snd cs } } ] ] ; + variance: + [ [ "+" -> { Univ.Variance.Covariant } + | "=" -> { Univ.Variance.Invariant } + | "*" -> { Univ.Variance.Irrelevant } + ] ] + ; + variance_identref: + [ [ id = identref -> { (id, None) } + | test_variance_ident; v = variance; id = identref -> { (id, Some v) } + (* We need this test to help the parser avoid the conflict + between "+" before ident (covariance) and trailing "+" (extra univs allowed) *) + ] ] + ; + cumul_univ_decl: + [ [ "@{" ; l = LIST0 variance_identref; ext = [ "+" -> { true } | -> { false } ]; + cs = [ "|"; l' = LIST0 univ_constraint SEP ","; + ext = [ "+" -> { true } | -> { false } ]; "}" -> { (l',ext) } + | ext = [ "}" -> { true } | bar_cbrace -> { false } ] -> { ([], ext) } ] + -> + { let open UState in + { univdecl_instance = l; + univdecl_extensible_instance = ext; + univdecl_constraints = fst cs; + univdecl_extensible_constraints = snd cs } } + ] ] + ; ident_decl: [ [ i = identref; l = OPT univ_decl -> { (i, l) } ] ] ; + cumul_ident_decl: + [ [ i = identref; l = OPT cumul_univ_decl -> { (i, l) } + ] ] + ; finite_token: [ [ IDENT "Inductive" -> { Inductive_kw } | IDENT "CoInductive" -> { CoInductive } @@ -345,7 +382,7 @@ GRAMMAR EXTEND Gram | -> { RecordDecl (None, []) } ] ] ; inductive_definition: - [ [ oc = opt_coercion; id = ident_decl; indpar = binders; + [ [ oc = opt_coercion; id = cumul_ident_decl; indpar = binders; extrapar = OPT [ "|"; p = binders -> { p } ]; c = OPT [ ":"; c = lconstr -> { c } ]; lc=opt_constructors_or_fields; ntn = decl_notations -> diff --git a/vernac/himsg.ml b/vernac/himsg.ml index bef9e29ac2..9d86ea90e6 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -744,6 +744,11 @@ let explain_bad_relevance env = let explain_bad_invert env = strbrk "Bad case inversion (maybe a bugged tactic)." +let explain_bad_variance env sigma ~lev ~expected ~actual = + str "Incorrect variance for universe " ++ Termops.pr_evd_level sigma lev ++ + str": expected " ++ Univ.Variance.pr expected ++ + str " but cannot be less restrictive than " ++ Univ.Variance.pr actual ++ str "." + let explain_type_error env sigma err = let env = make_all_name_different env sigma in match err with @@ -788,6 +793,7 @@ let explain_type_error env sigma err = | DisallowedSProp -> explain_disallowed_sprop () | BadRelevance -> explain_bad_relevance env | BadInvert -> explain_bad_invert env + | BadVariance {lev;expected;actual} -> explain_bad_variance env sigma ~lev ~expected ~actual let pr_position (cl,pos) = let clpos = match cl with diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 0e660bf20c..4cee4f7a47 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -68,10 +68,18 @@ let pr_univ_name_list = function | Some l -> str "@{" ++ prlist_with_sep spc pr_lname l ++ str"}" +let pr_variance_lident (lid,v) = + let v = Option.cata Univ.Variance.pr (mt()) v in + v ++ pr_lident lid + let pr_univdecl_instance l extensible = prlist_with_sep spc pr_lident l ++ (if extensible then str"+" else mt ()) +let pr_cumul_univdecl_instance l extensible = + prlist_with_sep spc pr_variance_lident l ++ + (if extensible then str"+" else mt ()) + let pr_univdecl_constraints l extensible = if List.is_empty l && extensible then mt () else str"|" ++ spc () ++ prlist_with_sep (fun () -> str",") pr_uconstraint l ++ @@ -85,9 +93,20 @@ let pr_universe_decl l = str"@{" ++ pr_univdecl_instance l.univdecl_instance l.univdecl_extensible_instance ++ pr_univdecl_constraints l.univdecl_constraints l.univdecl_extensible_constraints ++ str "}" +let pr_cumul_univ_decl l = + let open UState in + match l with + | None -> mt () + | Some l -> + str"@{" ++ pr_cumul_univdecl_instance l.univdecl_instance l.univdecl_extensible_instance ++ + pr_univdecl_constraints l.univdecl_constraints l.univdecl_extensible_constraints ++ str "}" + let pr_ident_decl (lid, l) = pr_lident lid ++ pr_universe_decl l +let pr_cumul_ident_decl (lid, l) = + pr_lident lid ++ pr_cumul_univ_decl l + let string_of_fqid fqid = String.concat "." (List.map Id.to_string fqid) @@ -848,7 +867,7 @@ let pr_vernac_expr v = let pr_oneind key (((coe,iddecl),(indupar,indpar),s,lc),ntn) = hov 0 ( str key ++ spc() ++ - (if coe then str"> " else str"") ++ pr_ident_decl iddecl ++ + (if coe then str"> " else str"") ++ pr_cumul_ident_decl iddecl ++ pr_and_type_binders_arg indupar ++ pr_opt (fun p -> str "|" ++ spc() ++ pr_and_type_binders_arg p) indpar ++ pr_opt (fun s -> str":" ++ spc() ++ pr_lconstr_expr s) s ++ @@ -1312,20 +1331,10 @@ let pr_control_flag (p : control_flag) = let pr_vernac_control flags = Pp.prlist pr_control_flag flags -let rec pr_vernac_flag (k, v) = - let k = keyword k in - let open Attributes in - match v with - | VernacFlagEmpty -> k - | VernacFlagLeaf v -> k ++ str " = " ++ qs v - | VernacFlagList m -> k ++ str "( " ++ pr_vernac_flags m ++ str " )" -and pr_vernac_flags m = - prlist_with_sep (fun () -> str ", ") pr_vernac_flag m - let pr_vernac_attributes = function | [] -> mt () - | flags -> str "#[" ++ pr_vernac_flags flags ++ str "]" ++ cut () + | flags -> str "#[" ++ prlist_with_sep pr_comma Attributes.pr_vernac_flag flags ++ str "]" ++ cut () let pr_vernac ({v = {control; attrs; expr}} as v) = tag_vernac v diff --git a/vernac/record.ml b/vernac/record.ml index 891d7fcebe..583164a524 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -190,11 +190,12 @@ type tc_result = (* Part relative to closing the definitions *) * UnivNames.universe_binders * Entries.universes_entry + * Entries.variance_entry * Constr.rel_context * DataR.t list (* ps = parameter list *) -let typecheck_params_and_fields def poly pl ps (records : DataI.t list) : tc_result = +let typecheck_params_and_fields def poly udecl ps (records : DataI.t list) : tc_result = let env0 = Global.env () in (* Special case elaboration for template-polymorphic inductives, lower bound on introduced universes is Prop so that we do not miss @@ -202,7 +203,7 @@ let typecheck_params_and_fields def poly pl ps (records : DataI.t list) : tc_res let is_template = List.exists (fun { DataI.arity; _} -> Option.cata check_anonymous_type true arity) records in let env0 = if not poly && is_template then Environ.set_universes_lbound env0 UGraph.Bound.Prop else env0 in - let sigma, decl = Constrintern.interp_univ_decl_opt env0 pl in + let sigma, decl, variances = Constrintern.interp_cumul_univ_decl_opt env0 udecl in let () = List.iter check_parameters_must_be_named ps in let sigma, (impls_env, ((env1,newps), imps)) = Constrintern.interp_context_evars ~program_mode:false env0 sigma ps in @@ -256,7 +257,7 @@ let typecheck_params_and_fields def poly pl ps (records : DataI.t list) : tc_res let ubinders = Evd.universe_binders sigma in let ce t = Pretyping.check_evars env0 sigma (EConstr.of_constr t) in let () = List.iter (iter_constr ce) (List.rev newps) in - template, imps, ubinders, univs, newps, ans + template, imps, ubinders, univs, variances, newps, ans type record_error = | MissingProj of Id.t * Id.t list @@ -525,7 +526,7 @@ let declare_structure_entry o = - prepares and declares the corresponding record projections, mainly taken care of by [declare_projections] *) -let declare_structure ~cumulative finite ~ubind ~univs paramimpls params template ?(kind=Decls.StructureComponent) ?name (record_data : Data.t list) = +let declare_structure ~cumulative finite ~ubind ~univs ~variances paramimpls params template ?(kind=Decls.StructureComponent) ?name (record_data : Data.t list) = let nparams = List.length params in let poly, ctx = match univs with @@ -568,7 +569,7 @@ let declare_structure ~cumulative finite ~ubind ~univs paramimpls params templat mind_entry_private = None; mind_entry_universes = univs; mind_entry_template = template; - mind_entry_cumulative = poly && cumulative; + mind_entry_variance = ComInductive.variance_of_entry ~cumulative ~variances univs; } in let impls = List.map (fun _ -> paramimpls, []) record_data in @@ -633,7 +634,8 @@ let build_class_constant ~univs ~rdata field implfs params paramimpls coers bind } in [cref, [m]] -let build_record_constant ~rdata ~ubind ~univs ~cumulative ~template fields params paramimpls coers id idbuild binder_name = +let build_record_constant ~rdata ~ubind ~univs ~variances ~cumulative ~template + fields params paramimpls coers id idbuild binder_name = let record_data = { Data.id ; idbuild @@ -641,7 +643,7 @@ let build_record_constant ~rdata ~ubind ~univs ~cumulative ~template fields para ; coers = List.map (fun _ -> { pf_subclass = false ; pf_canonical = true }) fields ; rdata } in - let inds = declare_structure ~cumulative Declarations.BiFinite ~ubind ~univs paramimpls + let inds = declare_structure ~cumulative Declarations.BiFinite ~ubind ~univs ~variances paramimpls params template ~kind:Decls.Method ~name:[|binder_name|] [record_data] in let map ind = @@ -677,7 +679,7 @@ let build_record_constant ~rdata ~ubind ~univs ~cumulative ~template fields para 2. declare the class, using the information from 1. in the form of [Classes.typeclass] *) -let declare_class def ~cumulative ~ubind ~univs id idbuild paramimpls params +let declare_class def ~cumulative ~ubind ~univs ~variances id idbuild paramimpls params rdata template ?(kind=Decls.StructureComponent) coers = let implfs = (* Make the class implicit in the projections, and the params if applicable. *) @@ -694,7 +696,8 @@ let declare_class def ~cumulative ~ubind ~univs id idbuild paramimpls params let binder = {binder with binder_name=Name binder_name} in build_class_constant ~rdata ~univs field implfs params paramimpls coers binder id proj_name | _ -> - build_record_constant ~rdata ~ubind ~univs ~cumulative ~template fields params paramimpls coers id idbuild binder_name + build_record_constant ~rdata ~ubind ~univs ~variances ~cumulative ~template + fields params paramimpls coers id idbuild binder_name in let univs, params, fields = match univs with @@ -852,7 +855,8 @@ let class_struture ~cumulative ~template ~ubind ~impargs ~univs ~params def reco declare_class def ~cumulative ~ubind ~univs name.CAst.v idbuild impargs params rdata template coers -let regular_structure ~cumulative ~template ~ubind ~impargs ~univs ~params ~finite records data = +let regular_structure ~cumulative ~template ~ubind ~impargs ~univs ~variances ~params ~finite + records data = let adjust_impls impls = impargs @ [CAst.make None] @ impls in let data = List.map (fun ({ DataR.implfs; _ } as d) -> { d with DataR.implfs = List.map adjust_impls implfs }) data in (* let map (min_univ, arity, fieldimpls, fields) { Ast.name; is_coercion; cfs; idbuild; _ } = *) @@ -866,30 +870,36 @@ let regular_structure ~cumulative ~template ~ubind ~impargs ~univs ~params ~fini { Data.id = name.CAst.v; idbuild; rdata; is_coercion; coers } in let data = List.map2 map data records in - let inds = declare_structure ~cumulative finite ~ubind ~univs impargs params template data in + let inds = declare_structure ~cumulative finite ~ubind ~univs ~variances + impargs params template data + in List.map (fun ind -> GlobRef.IndRef ind) inds (** [fs] corresponds to fields and [ps] to parameters; [coers] is a list telling if the corresponding fields must me declared as coercions or subinstances. *) -let definition_structure udecl kind ~template ~cumulative ~poly finite (records : Ast.t list) = +let definition_structure udecl kind ~template ~cumulative ~poly + finite (records : Ast.t list) : GlobRef.t list = let () = check_unique_names records in let () = check_priorities kind records in let ps, data = extract_record_data records in - let auto_template, impargs, ubind, univs, params, data = + let auto_template, impargs, ubind, univs, variances, params, data = (* In theory we should be able to use [Notation.with_notation_protection], due to the call to Metasyntax.set_notation_for_interpretation, however something is messing state beyond that. *) Vernacstate.System.protect (fun () -> - typecheck_params_and_fields (kind = Class true) poly udecl ps data) () in + typecheck_params_and_fields (kind = Class true) poly udecl ps data) () + in let template = template, auto_template in match kind with | Class def -> - class_struture ~template ~ubind ~impargs ~cumulative ~params ~univs def records data + class_struture ~template ~ubind ~impargs ~cumulative ~params ~univs ~variances + def records data | Inductive_kw | CoInductive | Variant | Record | Structure -> - regular_structure ~cumulative ~template ~ubind ~impargs ~univs ~params ~finite records data + regular_structure ~cumulative ~template ~ubind ~impargs ~univs ~variances ~params ~finite + records data module Internal = struct type nonrec projection_flags = projection_flags = { diff --git a/vernac/record.mli b/vernac/record.mli index ffcae2975e..7a40af048c 100644 --- a/vernac/record.mli +++ b/vernac/record.mli @@ -24,7 +24,7 @@ module Ast : sig end val definition_structure - : universe_decl_expr option + : cumul_univ_decl_expr option -> inductive_kind -> template:bool option -> cumulative:bool diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 761f6ef5b7..0f63dfe5ce 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -674,13 +674,19 @@ let is_polymorphic_inductive_cumulativity = let polymorphic_cumulative = let error_poly_context () = user_err - Pp.(str "The cumulative and noncumulative attributes can only be used in a polymorphic context."); + Pp.(str "The cumulative attribute can only be used in a polymorphic context."); in let open Attributes in let open Notations in + (* EJGA: this seems redudant with code in attributes.ml *) qualify_attribute "universes" - (bool_attribute ~name:"Polymorphism" ~on:"polymorphic" ~off:"monomorphic" - ++ bool_attribute ~name:"Cumulativity" ~on:"cumulative" ~off:"noncumulative") + (deprecated_bool_attribute + ~name:"Polymorphism" + ~on:"polymorphic" ~off:"monomorphic" + ++ + deprecated_bool_attribute + ~name:"Cumulativity" + ~on:"cumulative" ~off:"noncumulative") >>= function | Some poly, Some cum -> (* Case of Polymorphic|Monomorphic Cumulative|NonCumulative Inductive @@ -1314,6 +1320,14 @@ let warn_implicit_core_hint_db = (fun () -> strbrk "Adding and removing hints in the core database implicitly is deprecated. " ++ strbrk"Please specify a hint database.") +let warn_deprecated_hint_without_locality = + CWarnings.create ~name:"deprecated-hint-without-locality" ~category:"deprecated" + (fun () -> strbrk "The default value for hint locality is currently \ + \"local\" in a section and \"global\" otherwise, but is scheduled to change \ + in a future release. For the time being, adding hints outside of sections \ + without specifying an explicit locality is therefore deprecated. It is \ + recommended to use \"export\" whenever possible.") + let check_hint_locality = function | OptGlobal -> if Global.sections_are_opened () then @@ -1323,7 +1337,10 @@ let check_hint_locality = function if Global.sections_are_opened () then CErrors.user_err Pp.(str "This command does not support the export attribute in sections."); -| OptDefault | OptLocal -> () +| OptDefault -> + if not @@ Global.sections_are_opened () then + warn_deprecated_hint_without_locality () +| OptLocal -> () let vernac_remove_hints ~atts dbnames ids = let locality = Attributes.(parse option_locality atts) in diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index 6a9a74144f..defb0691c0 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -189,8 +189,9 @@ type inductive_params_expr = local_binder_expr list * local_binder_expr list opt (** If the option is nonempty the "|" marker was used *) type inductive_expr = - ident_decl with_coercion * inductive_params_expr * constr_expr option * - constructor_list_or_record_decl_expr + cumul_ident_decl with_coercion + * inductive_params_expr * constr_expr option + * constructor_list_or_record_decl_expr type one_inductive_expr = lident * inductive_params_expr * constr_expr option * constructor_expr list diff --git a/vernac/vernacinterp.ml b/vernac/vernacinterp.ml index edf48fef1a..57d9e0ac3c 100644 --- a/vernac/vernacinterp.ml +++ b/vernac/vernacinterp.ml @@ -226,24 +226,24 @@ and interp_control ~st ({ CAst.v = cmd } as vernac) = *) (* Interpreting a possibly delayed proof *) -let interp_qed_delayed ~proof ~pinfo ~st pe : Vernacstate.LemmaStack.t option * Declare.OblState.t = +let interp_qed_delayed ~proof ~st pe : Vernacstate.LemmaStack.t option * Declare.OblState.t = let stack = st.Vernacstate.lemmas in let pm = st.Vernacstate.program in let stack = Option.cata (fun stack -> snd @@ Vernacstate.LemmaStack.pop stack) None stack in let pm = match pe with | Admitted -> - Declare.Proof.save_lemma_admitted_delayed ~pm ~proof ~pinfo + Declare.Proof.save_lemma_admitted_delayed ~pm ~proof | Proved (_,idopt) -> - let pm, _ = Declare.Proof.save_lemma_proved_delayed ~pm ~proof ~pinfo ~idopt in + let pm, _ = Declare.Proof.save_lemma_proved_delayed ~pm ~proof ~idopt in pm in stack, pm -let interp_qed_delayed_control ~proof ~pinfo ~st ~control { CAst.loc; v=pe } = +let interp_qed_delayed_control ~proof ~st ~control { CAst.loc; v=pe } = let time_header = mk_time_header (CAst.make ?loc { control; attrs = []; expr = VernacEndProof pe }) in List.fold_right (fun flag fn -> interp_control_flag ~time_header flag fn) control - (fun ~st -> interp_qed_delayed ~proof ~pinfo ~st pe) + (fun ~st -> interp_qed_delayed ~proof ~st pe) ~st (* General interp with management of state *) @@ -273,6 +273,6 @@ let interp_gen ~verbosely ~st ~interp_fn cmd = let interp ?(verbosely=true) ~st cmd = interp_gen ~verbosely ~st ~interp_fn:interp_control cmd -let interp_qed_delayed_proof ~proof ~pinfo ~st ~control pe : Vernacstate.t = +let interp_qed_delayed_proof ~proof ~st ~control pe : Vernacstate.t = interp_gen ~verbosely:false ~st - ~interp_fn:(interp_qed_delayed_control ~proof ~pinfo ~control) pe + ~interp_fn:(interp_qed_delayed_control ~proof ~control) pe diff --git a/vernac/vernacinterp.mli b/vernac/vernacinterp.mli index 84d3256c9f..f31bebf7db 100644 --- a/vernac/vernacinterp.mli +++ b/vernac/vernacinterp.mli @@ -15,7 +15,6 @@ val interp : ?verbosely:bool -> st:Vernacstate.t -> Vernacexpr.vernac_control -> proof and won't be forced *) val interp_qed_delayed_proof : proof:Declare.Proof.proof_object - -> pinfo:Declare.Proof.Proof_info.t -> st:Vernacstate.t -> control:Vernacexpr.control_flag list -> Vernacexpr.proof_end CAst.t diff --git a/vernac/vernacstate.ml b/vernac/vernacstate.ml index 204008997d..011d943c9b 100644 --- a/vernac/vernacstate.ml +++ b/vernac/vernacstate.ml @@ -204,18 +204,14 @@ module Declare_ = struct s_lemmas := Some stack; res - type closed_proof = Declare.Proof.proof_object * Declare.Proof.Proof_info.t - let return_proof () = cc Declare.Proof.return_proof let return_partial_proof () = cc Declare.Proof.return_partial_proof let close_future_proof ~feedback_id pf = - cc (fun pt -> Declare.Proof.close_future_proof ~feedback_id pt pf, - Declare.Proof.info pt) + cc (fun pt -> Declare.Proof.close_future_proof ~feedback_id pt pf) let close_proof ~opaque ~keep_body_ucst_separate = - cc (fun pt -> Declare.Proof.close_proof ~opaque ~keep_body_ucst_separate pt, - Declare.Proof.info pt) + cc (fun pt -> Declare.Proof.close_proof ~opaque ~keep_body_ucst_separate pt) let discard_all () = s_lemmas := None let update_sigma_univs ugraph = dd (Declare.Proof.update_sigma_univs ugraph) diff --git a/vernac/vernacstate.mli b/vernac/vernacstate.mli index e1b13dcb73..e9e06e6d8e 100644 --- a/vernac/vernacstate.mli +++ b/vernac/vernacstate.mli @@ -104,13 +104,15 @@ module Declare : sig val return_proof : unit -> Declare.Proof.closed_proof_output val return_partial_proof : unit -> Declare.Proof.closed_proof_output - type closed_proof = Declare.Proof.proof_object * Declare.Proof.Proof_info.t - - val close_future_proof : - feedback_id:Stateid.t -> - Declare.Proof.closed_proof_output Future.computation -> closed_proof - - val close_proof : opaque:Vernacexpr.opacity_flag -> keep_body_ucst_separate:bool -> closed_proof + val close_future_proof + : feedback_id:Stateid.t + -> Declare.Proof.closed_proof_output Future.computation + -> Declare.Proof.proof_object + + val close_proof + : opaque:Vernacexpr.opacity_flag + -> keep_body_ucst_separate:bool + -> Declare.Proof.proof_object val discard_all : unit -> unit val update_sigma_univs : UGraph.t -> unit |