diff options
132 files changed, 1130 insertions, 1481 deletions
diff --git a/clib/cString.ml b/clib/cString.ml index 111be3da82..423c08da13 100644 --- a/clib/cString.ml +++ b/clib/cString.ml @@ -17,16 +17,12 @@ sig val is_empty : string -> bool val explode : string -> string list val implode : string list -> string - val strip : string -> string - [@@ocaml.deprecated "Use [trim]"] val drop_simple_quotes : string -> string val string_index_from : string -> int -> string -> int val string_contains : where:string -> what:string -> bool val plural : int -> string -> string val conjugate_verb_to_be : int -> string val ordinal : int -> string - val split : char -> string -> string list - [@@ocaml.deprecated "Use [split_on_char]"] val is_sub : string -> string -> int -> bool module Set : Set.S with type elt = t module Map : CMap.ExtS with type key = t and module Set := Set @@ -59,8 +55,6 @@ let implode sl = String.concat "" sl let is_empty s = String.length s = 0 -let strip = String.trim - let drop_simple_quotes s = let n = String.length s in if n > 2 && s.[0] = '\'' && s.[n-1] = '\'' then String.sub s 1 (n-2) else s @@ -124,8 +118,6 @@ let ordinal n = (* string parsing *) -let split = String.split_on_char - module Self = struct type t = string diff --git a/clib/cString.mli b/clib/cString.mli index 364b6a34b1..f68bd3bb65 100644 --- a/clib/cString.mli +++ b/clib/cString.mli @@ -30,10 +30,6 @@ sig val implode : string list -> string (** [implode [s1; ...; sn]] returns [s1 ^ ... ^ sn] *) - val strip : string -> string - [@@ocaml.deprecated "Use [trim]"] - (** Alias for [String.trim] *) - val drop_simple_quotes : string -> string (** Remove the eventual first surrounding simple quotes of a string. *) @@ -52,10 +48,6 @@ sig val ordinal : int -> string (** Generate the ordinal number in English. *) - val split : char -> string -> string list - [@@ocaml.deprecated "Use [split_on_char]"] - (** [split c s] alias of [String.split_on_char] *) - val is_sub : string -> string -> int -> bool (** [is_sub p s off] tests whether [s] contains [p] at offset [off]. *) diff --git a/configure.ml b/configure.ml index 5b99851f83..57f31fec4c 100644 --- a/configure.ml +++ b/configure.ml @@ -17,6 +17,7 @@ let coq_macos_version = "8.9.90" (** "[...] should be a string comprised of three non-negative, period-separated integers [...]" *) let vo_magic = 8991 let state_magic = 58991 +let is_a_released_version = false let distributed_exec = ["coqtop.opt"; "coqidetop.opt"; "coqqueryworker.opt"; "coqproofworker.opt"; "coqtacticworker.opt"; "coqc.opt";"coqchk";"coqdoc";"coqworkmgr";"coq_makefile";"coq-tex";"coqwc";"csdpcert";"coqdep"] @@ -1205,8 +1206,8 @@ let write_configpy f = safe_remove f; let o = open_out f in let pr s = fprintf o s in - let pr_s = pr "%s = '%s'\n" in pr "# DO NOT EDIT THIS FILE: automatically generated by ../configure\n"; - pr_s "version" coq_version + pr "version = '%s'\n" coq_version; + pr "is_a_released_version = %s\n" (if is_a_released_version then "True" else "False") let _ = write_configpy "config/coq_config.py" diff --git a/dev/ci/user-overlays/08893-herbelin-master+moving-evars-of-term-on-econstr.sh b/dev/ci/user-overlays/08893-herbelin-master+moving-evars-of-term-on-econstr.sh new file mode 100644 index 0000000000..dc39ea5ef0 --- /dev/null +++ b/dev/ci/user-overlays/08893-herbelin-master+moving-evars-of-term-on-econstr.sh @@ -0,0 +1,7 @@ +if [ "$CI_PULL_REQUEST" = "8893" ] || [ "$CI_BRANCH" = "master+moving-evars-of-term-on-econstr" ]; then + + equations_CI_BRANCH=master+fix-evars_of_term-pr8893 + equations_CI_REF=master+fix-evars_of_term-pr8893 + equations_CI_GITURL=https://github.com/herbelin/Coq-Equations + +fi diff --git a/dev/ci/user-overlays/10076-vbgl-canonical-disable-hint.sh b/dev/ci/user-overlays/10076-vbgl-canonical-disable-hint.sh new file mode 100644 index 0000000000..2015935dd9 --- /dev/null +++ b/dev/ci/user-overlays/10076-vbgl-canonical-disable-hint.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "10076" ] || [ "$CI_BRANCH" = "canonical-disable-hint" ]; then + + elpi_CI_REF=canonical-disable-hint + elpi_CI_GITURL=https://github.com/vbgl/coq-elpi + +fi diff --git a/dev/ci/user-overlays/10125-SkySkimmer-run_tactic_gen.sh b/dev/ci/user-overlays/10125-SkySkimmer-run_tactic_gen.sh new file mode 100644 index 0000000000..4032b1c6b5 --- /dev/null +++ b/dev/ci/user-overlays/10125-SkySkimmer-run_tactic_gen.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "10125" ] || [ "$CI_BRANCH" = "run_tactic_gen" ]; then + + paramcoq_CI_REF=run_tactic_gen + paramcoq_CI_GITURL=https://github.com/SkySkimmer/paramcoq + +fi diff --git a/dev/ci/user-overlays/10135-maximedenes-detype-anonymous.sh b/dev/ci/user-overlays/10135-maximedenes-detype-anonymous.sh new file mode 100644 index 0000000000..bc8aa33565 --- /dev/null +++ b/dev/ci/user-overlays/10135-maximedenes-detype-anonymous.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "10135" ] || [ "$CI_BRANCH" = "detype-anonymous" ]; then + + unicoq_CI_REF=detype-anonymous + unicoq_CI_GITURL=https://github.com/maximedenes/unicoq + +fi diff --git a/dev/doc/changes.md b/dev/doc/changes.md index 9e0d47651e..7221c3de56 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -1,3 +1,10 @@ +## Changes between Coq 8.10 and Coq 8.11 + +### ML API + +- Functions and types deprecated in 8.10 have been removed in Coq + 8.11. + ## Changes between Coq 8.9 and Coq 8.10 ### ML4 Pre Processing diff --git a/dev/doc/release-process.md b/dev/doc/release-process.md index 60c0886896..189d6f9fa5 100644 --- a/dev/doc/release-process.md +++ b/dev/doc/release-process.md @@ -84,10 +84,18 @@ Coq has been tagged. - [ ] Have some people test the recently auto-generated Windows and MacOS packages. -- [ ] Change the version name from alpha to beta1 (see +- [ ] In a PR: + - Change the version name from alpha to beta1 (see [#7009](https://github.com/coq/coq/pull/7009/files)). - We generally do not update the magic numbers at this point. + - We generally do not update the magic numbers at this point. + - Set `is_a_released_version` to `true` in `configure.ml`. - [ ] Put the `VX.X+beta1` tag using `git tag -s`. +- [ ] Check using `git push --tags --dry-run` that you are not + pushing anything else than the new tag. If needed, remove spurious + tags with `git tag -d`. When this is OK, proceed with `git push --tags`. +- [ ] Set `is_a_released_version` to `false` in `configure.ml` + (if you forget about it, you'll be reminded whenever you try to + backport a PR with a changelog entry). ### These steps are the same for all releases (beta, final, patch-level) ### @@ -112,9 +120,17 @@ ## At the final release time ## -- [ ] Change the version name to X.X.0 and the magic numbers (see +- [ ] In a PR: + - Change the version name from X.X.0 and the magic numbers (see [#7271](https://github.com/coq/coq/pull/7271/files)). + - Set `is_a_released_version` to `true` in `configure.ml`. - [ ] Put the `VX.X.0` tag. +- [ ] Check using `git push --tags --dry-run` that you are not + pushing anything else than the new tag. If needed, remove spurious + tags with `git tag -d`. When this is OK, proceed with `git push --tags`. +- [ ] Set `is_a_released_version` to `false` in `configure.ml` + (if you forget about it, you'll be reminded whenever you try to + backport a PR with a changelog entry). Repeat the generic process documented above for all releases. diff --git a/dev/include_printers b/dev/include_printers index 90088e40bf..d077075eeb 100644 --- a/dev/include_printers +++ b/dev/include_printers @@ -11,6 +11,7 @@ #install_printer (* universes *) ppuniverses;; #install_printer (* univ level *) ppuni_level;; #install_printer (* univ context *) ppuniverse_context;; +#install_printer (* univ context *) ppaucontext;; #install_printer (* univ context future *) ppuniverse_context_future;; #install_printer (* univ context set *) ppuniverse_context_set;; #install_printer (* univ set *) ppuniverse_set;; diff --git a/dev/top_printers.dbg b/dev/top_printers.dbg index a6ecec7e33..82f2e79549 100644 --- a/dev/top_printers.dbg +++ b/dev/top_printers.dbg @@ -62,6 +62,7 @@ install_printer Top_printers.ppuni_level install_printer Top_printers.ppuniverse_set install_printer Top_printers.ppuniverse_instance install_printer Top_printers.ppuniverse_context +install_printer Top_printers.ppaucontext install_printer Top_printers.ppuniverse_context_set install_printer Top_printers.ppuniverse_subst install_printer Top_printers.ppuniverse_opt_subst diff --git a/dev/top_printers.ml b/dev/top_printers.ml index 816316487c..2859b56cbe 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -27,7 +27,6 @@ open Clenv let _ = Detyping.print_evar_arguments := true let _ = Detyping.print_universes := true let _ = Goptions.set_bool_option_value ["Printing";"Matching"] false -let _ = Detyping.set_detype_anonymous (fun ?loc _ -> raise Not_found) (* std_ppcmds *) let pp x = Pp.pp_with !Topfmt.std_ft x @@ -236,6 +235,15 @@ let ppnamedcontextval e = let sigma = Evd.from_env env in pp (pr_named_context env sigma (named_context_of_val e)) +let ppaucontext auctx = + let nas = AUContext.names auctx in + let prlev l = match Level.var_index l with + | Some n -> Name.print nas.(n) + | None -> prlev l + in + pp (pr_universe_context prlev (AUContext.repr auctx)) + + let ppenv e = pp (str "[" ++ pr_named_context_of e Evd.empty ++ str "]" ++ spc() ++ str "[" ++ pr_rel_context e Evd.empty (rel_context e) ++ str "]") diff --git a/dev/top_printers.mli b/dev/top_printers.mli index cb32d2294c..2aa1808322 100644 --- a/dev/top_printers.mli +++ b/dev/top_printers.mli @@ -137,6 +137,7 @@ val prlev : Univ.Level.t -> Pp.t (* with global names (does this work?) *) val ppuniverse_set : Univ.LSet.t -> unit val ppuniverse_instance : Univ.Instance.t -> unit val ppuniverse_context : Univ.UContext.t -> unit +val ppaucontext : Univ.AUContext.t -> unit val ppuniverse_context_set : Univ.ContextSet.t -> unit val ppuniverse_subst : Univ.universe_subst -> unit val ppuniverse_opt_subst : UnivSubst.universe_opt_subst -> unit diff --git a/doc/changelog/02-specification-language/10076-not-canonical-projection.rst b/doc/changelog/02-specification-language/10076-not-canonical-projection.rst new file mode 100644 index 0000000000..0a902079b9 --- /dev/null +++ b/doc/changelog/02-specification-language/10076-not-canonical-projection.rst @@ -0,0 +1,4 @@ +- Record fields can be annotated to prevent them from being used as canonical projections; + see :ref:`canonicalstructures` for details + (`#10076 <https://github.com/coq/coq/pull/10076>`_, + by Vincent Laporte). diff --git a/doc/changelog/04-tactics/09996-hint-mode.rst b/doc/changelog/04-tactics/09996-hint-mode.rst deleted file mode 100644 index 06e9059b45..0000000000 --- a/doc/changelog/04-tactics/09996-hint-mode.rst +++ /dev/null @@ -1,5 +0,0 @@ -- Modes are now taken into account by :tacn:`typeclasses eauto` for - local hypotheses - (`#9996 <https://github.com/coq/coq/pull/9996>`_, - fixes `#5752 <https://github.com/coq/coq/issues/5752>`_, - by Maxime Dénès, review by Pierre-Marie Pédrot). diff --git a/doc/changelog/04-tactics/10059-change-no-check.rst b/doc/changelog/04-tactics/10059-change-no-check.rst deleted file mode 100644 index 987b2a8ccd..0000000000 --- a/doc/changelog/04-tactics/10059-change-no-check.rst +++ /dev/null @@ -1,7 +0,0 @@ -- New variant :tacn:`change_no_check` of :tacn:`change`, usable as a - documented replacement of :tacn:`convert_concl_no_check` - (`#10012 <https://github.com/coq/coq/pull/10012>`_, - `#10017 <https://github.com/coq/coq/pull/10017>`_, - `#10053 <https://github.com/coq/coq/pull/10053>`_, and - `#10059 <https://github.com/coq/coq/pull/10059>`_, - by Hugo Herbelin and Paolo G. Giarrusso). diff --git a/doc/changelog/06-ssreflect/09995-notations.rst b/doc/changelog/06-ssreflect/09995-notations.rst deleted file mode 100644 index 3dfc45242d..0000000000 --- a/doc/changelog/06-ssreflect/09995-notations.rst +++ /dev/null @@ -1,8 +0,0 @@ -- `inE` now expands `y \in r x` when `r` is a `simpl_rel`. - New `{pred T}` notation for a `pred T` alias in the `pred_sort` coercion - class, simplified `predType` interface: `pred_class` and `mkPredType` - deprecated, `{pred T}` and `PredType` should be used instead. - `if c return t then ...` now expects `c` to be a variable bound in `t`. - New `nonPropType` interface matching types that do _not_ have sort `Prop`. - New `relpre R f` definition for the preimage of a relation R under f - (`#9995 <https://github.com/coq/coq/pull/9995>`_, by Georges Gonthier). diff --git a/doc/changelog/10-standard-library/09984-pairusualdecidabletypefull.rst b/doc/changelog/10-standard-library/09984-pairusualdecidabletypefull.rst deleted file mode 100644 index 732c088f45..0000000000 --- a/doc/changelog/10-standard-library/09984-pairusualdecidabletypefull.rst +++ /dev/null @@ -1,3 +0,0 @@ -- Added :g:`Coq.Structures.EqualitiesFacts.PairUsualDecidableTypeFull` - (`#9984 <https://github.com/coq/coq/pull/9984>`_, - by Jean-Christophe Léchenet and Oliver Nash). diff --git a/doc/changelog/12-misc/09964-changes.rst b/doc/changelog/12-misc/09964-changes.rst deleted file mode 100644 index 1113782180..0000000000 --- a/doc/changelog/12-misc/09964-changes.rst +++ /dev/null @@ -1,13 +0,0 @@ -- Changelog has been moved from a specific file `CHANGES.md` to the - reference manual; former Credits chapter of the reference manual has - been split in two parts: a History chapter which was enriched with - additional historical information about Coq versions 1 to 5, and a - Changes chapter which was enriched with the content formerly in - `CHANGES.md` and `COMPATIBILITY` - (`#9133 <https://github.com/coq/coq/pull/9133>`_, - `#9668 <https://github.com/coq/coq/pull/9668>`_, - `#9939 <https://github.com/coq/coq/pull/9939>`_, - `#9964 <https://github.com/coq/coq/pull/9964>`_, - by Théo Zimmermann, - with help and ideas from Emilio Jesús Gallego Arias, - Clément Pit-Claudel, Matthieu Sozeau, and Enrico Tassi). diff --git a/doc/sphinx/addendum/canonical-structures.rst b/doc/sphinx/addendum/canonical-structures.rst index dd21ea09bd..b593b0cef1 100644 --- a/doc/sphinx/addendum/canonical-structures.rst +++ b/doc/sphinx/addendum/canonical-structures.rst @@ -209,7 +209,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; class_of : class obj }. + Structure type := _Pack { obj : Type; #[canonical(false)] class_of : class obj }. Arguments Mixin {e le} _. @@ -219,6 +219,9 @@ The mixin component of the ``LEQ`` class contains all the extra content we are adding to ``EQ`` and ``LE``. In particular it contains the requirement that the two relations we are combining are compatible. +The `class_of` projection of the `type` structure is annotated as *not canonical*; +it plays no role in the search for instances. + Unfortunately there is still an obstacle to developing the algebraic theory of this new class. @@ -313,9 +316,7 @@ constructor ``*``. It also tests that they work as expected. Unfortunately, these declarations are very verbose. In the following subsection we show how to make them more compact. -.. FIXME shouldn't warn - -.. coqtop:: all warn +.. coqtop:: all Module Add_instance_attempt. @@ -420,9 +421,7 @@ the reader can refer to :cite:`CSwcu`. The declaration of canonical instances can now be way more compact: -.. FIXME should not warn - -.. coqtop:: all warn +.. coqtop:: all Canonical Structure nat_LEQty := Eval hnf in Pack nat nat_LEQmx. diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index e54c1a4eec..5e337bcef0 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -2,7 +2,9 @@ Recent changes -------------- -.. include:: ../unreleased.rst +.. ifconfig:: not coq_config.is_a_released_version + + .. include:: ../unreleased.rst Version 8.10 ------------ @@ -353,6 +355,11 @@ Other changes in 8.10+beta1 that will do it automatically, using the output of ``coqc`` (`#8638 <https://github.com/coq/coq/pull/8638>`_, by Jason Gross). + - Allow inspecting custom grammar entries by :cmd:`Print Custom Grammar` + (`#10061 <https://github.com/coq/coq/pull/10061>`_, + fixes `#9681 <http://github.com/coq/coq/pull/9681>`_, + by Jasper Hugunin, review by Pierre-Marie Pédrot and Hugo Herbelin). + - The `quote plugin <https://coq.inria.fr/distrib/V8.9.0/refman/proof-engine/detailed-tactic-examples.html#quote>`_ was removed. If some users are interested in maintaining this plugin @@ -398,7 +405,32 @@ Other changes in 8.10+beta1 closes `#7632 <https://github.com/coq/coq/issues/7632>`_, by Théo Zimmermann). - - SSReflect clear discipline made consistent across the entire proof language. + - Modes are now taken into account by :tacn:`typeclasses eauto` for + local hypotheses + (`#9996 <https://github.com/coq/coq/pull/9996>`_, + fixes `#5752 <https://github.com/coq/coq/issues/5752>`_, + by Maxime Dénès, review by Pierre-Marie Pédrot). + + - New variant :tacn:`change_no_check` of :tacn:`change`, usable as a + documented replacement of :tacn:`convert_concl_no_check` + (`#10012 <https://github.com/coq/coq/pull/10012>`_, + `#10017 <https://github.com/coq/coq/pull/10017>`_, + `#10053 <https://github.com/coq/coq/pull/10053>`_, and + `#10059 <https://github.com/coq/coq/pull/10059>`_, + by Hugo Herbelin and Paolo G. Giarrusso). + + - The simplified value returned by :tacn:`field_simplify` is not + always a fraction anymore. When the denominator is :g:`1`, it + returns :g:`x` while previously it was returning :g:`x/1`. This + change could break codes that were post-processing application of + :tacn:`field_simplify` to get rid of these :g:`x/1` + (`#9854 <https://github.com/coq/coq/pull/9854>`_, + by Laurent Théry, + with help from Michael Soegtrop, Maxime Dénès, and Vincent Laporte). + +- SSReflect: + + - Clear discipline made consistent across the entire proof language. Whenever a clear switch `{x..}` comes immediately before an existing proof context entry (used as a view, as a rewrite rule or as name for a new context entry) then such entry is cleared too. @@ -412,6 +444,15 @@ Other changes in 8.10+beta1 (`#9341 <https://github.com/coq/coq/pull/9341>`_, by Enrico Tassi). + - `inE` now expands `y \in r x` when `r` is a `simpl_rel`. + New `{pred T}` notation for a `pred T` alias in the `pred_sort` coercion + class, simplified `predType` interface: `pred_class` and `mkPredType` + deprecated, `{pred T}` and `PredType` should be used instead. + `if c return t then ...` now expects `c` to be a variable bound in `t`. + New `nonPropType` interface matching types that do _not_ have sort `Prop`. + New `relpre R f` definition for the preimage of a relation R under f + (`#9995 <https://github.com/coq/coq/pull/9995>`_, by Georges Gonthier). + - Vernacular commands: - Binders for an :cmd:`Instance` now act more like binders for a :cmd:`Theorem`. @@ -533,10 +574,28 @@ Other changes in 8.10+beta1 `fset` database (`#9725 <https://github.com/coq/coq/pull/9725>`_, by Frédéric Besson). + - Added :g:`Coq.Structures.EqualitiesFacts.PairUsualDecidableTypeFull` + (`#9984 <https://github.com/coq/coq/pull/9984>`_, + by Jean-Christophe Léchenet and Oliver Nash). + - Some error messages that show problems with a pair of non-matching values will now highlight the differences (`#8669 <https://github.com/coq/coq/pull/8669>`_, by Jim Fehrle). +- Changelog has been moved from a specific file `CHANGES.md` to the + reference manual; former Credits chapter of the reference manual has + been split in two parts: a History chapter which was enriched with + additional historical information about Coq versions 1 to 5, and a + Changes chapter which was enriched with the content formerly in + `CHANGES.md` and `COMPATIBILITY` + (`#9133 <https://github.com/coq/coq/pull/9133>`_, + `#9668 <https://github.com/coq/coq/pull/9668>`_, + `#9939 <https://github.com/coq/coq/pull/9939>`_, + `#9964 <https://github.com/coq/coq/pull/9964>`_, + and `#10085 <https://github.com/coq/coq/pull/10085>`_, + by Théo Zimmermann, + with help and ideas from Emilio Jesús Gallego Arias, Gaëtan + Gilbert, Clément Pit-Claudel, Matthieu Sozeau, and Enrico Tassi). Version 8.9 ----------- diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py index 972a53ae36..ec3343dac6 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -53,6 +53,7 @@ needs_sphinx = '1.7.8' # extensions coming with Sphinx (named 'sphinx.ext.*') or your custom # ones. extensions = [ + 'sphinx.ext.ifconfig', 'sphinx.ext.mathjax', 'sphinx.ext.todo', 'sphinxcontrib.bibtex', @@ -100,6 +101,7 @@ def copy_formatspecific_files(app): def setup(app): app.connect('builder-inited', copy_formatspecific_files) + app.add_config_value('coq_config', coq_config, 'env') # The master toctree document. # We create this file in `copy_master_doc` above. diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index af658b4698..ccd25ec9f3 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -2048,6 +2048,21 @@ 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. + .. note:: + To prevent a field from being involved in the inference of canonical instances, + its declaration can be annotated with the :g:`#[canonical(false)]` attribute. + + .. example:: + + For instance, when declaring the :g:`Setoid` structure above, the + :g:`Prf_equiv` field declaration could be written as follows. + + .. coqdoc:: + + #[canonical(false)] Prf_equiv : equivalence Carrier Equal + + See :ref:`canonicalstructures` for a more realistic example. + .. cmdv:: Canonical {? Structure } @ident {? : @type } := @term This is equivalent to a regular definition of :token:`ident` followed by the @@ -2067,6 +2082,10 @@ in :ref:`canonicalstructures`; here only a simple example is given. Print Canonical Projections. + .. note:: + + The last line would not show up if the corresponding projection (namely + :g:`Prf_equiv`) were annotated as not canonical, as described above. Implicit types of variables ~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/doc/sphinx/proof-engine/detailed-tactic-examples.rst b/doc/sphinx/proof-engine/detailed-tactic-examples.rst index b629d15b11..0ace9ef5b9 100644 --- a/doc/sphinx/proof-engine/detailed-tactic-examples.rst +++ b/doc/sphinx/proof-engine/detailed-tactic-examples.rst @@ -396,381 +396,3 @@ the optional tactic of the ``Hint Rewrite`` command. .. coqtop:: none Qed. - -Using the tactic language -------------------------- - - -About the cardinality of the set of natural numbers -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -The first example which shows how to use pattern matching over the -proof context is a proof of the fact that natural numbers have more -than two elements. This can be done as follows: - -.. coqtop:: in reset - - Lemma card_nat : - ~ exists x : nat, exists y : nat, forall z:nat, x = z \/ y = z. - Proof. - -.. coqtop:: in - - red; intros (x, (y, Hy)). - -.. coqtop:: in - - elim (Hy 0); elim (Hy 1); elim (Hy 2); intros; - - match goal with - | _ : ?a = ?b, _ : ?a = ?c |- _ => - cut (b = c); [ discriminate | transitivity a; auto ] - end. - -.. coqtop:: in - - Qed. - -We can notice that all the (very similar) cases coming from the three -eliminations (with three distinct natural numbers) are successfully -solved by a match goal structure and, in particular, with only one -pattern (use of non-linear matching). - - -Permutations of lists -~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -A more complex example is the problem of permutations of -lists. The aim is to show that a list is a permutation of -another list. - -.. coqtop:: in reset - - Section Sort. - -.. coqtop:: in - - Variable A : Set. - -.. coqtop:: in - - Inductive perm : list A -> list A -> Prop := - | perm_refl : forall l, perm l l - | perm_cons : forall a l0 l1, perm l0 l1 -> perm (a :: l0) (a :: l1) - | perm_append : forall a l, perm (a :: l) (l ++ a :: nil) - | perm_trans : forall l0 l1 l2, perm l0 l1 -> perm l1 l2 -> perm l0 l2. - -.. coqtop:: in - - End Sort. - -First, we define the permutation predicate as shown above. - -.. coqtop:: none - - Require Import List. - - -.. coqtop:: in - - Ltac perm_aux n := - match goal with - | |- (perm _ ?l ?l) => apply perm_refl - | |- (perm _ (?a :: ?l1) (?a :: ?l2)) => - let newn := eval compute in (length l1) in - (apply perm_cons; perm_aux newn) - | |- (perm ?A (?a :: ?l1) ?l2) => - match eval compute in n with - | 1 => fail - | _ => - let l1' := constr:(l1 ++ a :: nil) in - (apply (perm_trans A (a :: l1) l1' l2); - [ apply perm_append | compute; perm_aux (pred n) ]) - end - end. - -Next we define an auxiliary tactic ``perm_aux`` which takes an argument -used to control the recursion depth. This tactic behaves as follows. If -the lists are identical (i.e. convertible), it concludes. Otherwise, if -the lists have identical heads, it proceeds to look at their tails. -Finally, if the lists have different heads, it rotates the first list by -putting its head at the end if the new head hasn't been the head previously. To check this, we keep track of the -number of performed rotations using the argument ``n``. We do this by -decrementing ``n`` each time we perform a rotation. It works because -for a list of length ``n`` we can make exactly ``n - 1`` rotations -to generate at most ``n`` distinct lists. Notice that we use the natural -numbers of Coq for the rotation counter. From :ref:`ltac-syntax` we know -that it is possible to use the usual natural numbers, but they are only -used as arguments for primitive tactics and they cannot be handled, so, -in particular, we cannot make computations with them. Thus the natural -choice is to use Coq data structures so that Coq makes the computations -(reductions) by ``eval compute in`` and we can get the terms back by match. - -.. coqtop:: in - - Ltac solve_perm := - match goal with - | |- (perm _ ?l1 ?l2) => - match eval compute in (length l1 = length l2) with - | (?n = ?n) => perm_aux n - end - end. - -The main tactic is ``solve_perm``. It computes the lengths of the two lists -and uses them as arguments to call ``perm_aux`` if the lengths are equal (if they -aren't, the lists cannot be permutations of each other). Using this tactic we -can now prove lemmas as follows: - -.. coqtop:: in - - Lemma solve_perm_ex1 : - perm nat (1 :: 2 :: 3 :: nil) (3 :: 2 :: 1 :: nil). - Proof. solve_perm. Qed. - -.. coqtop:: in - - Lemma solve_perm_ex2 : - perm nat - (0 :: 1 :: 2 :: 3 :: 4 :: 5 :: 6 :: 7 :: 8 :: 9 :: nil) - (0 :: 2 :: 4 :: 6 :: 8 :: 9 :: 7 :: 5 :: 3 :: 1 :: nil). - Proof. solve_perm. Qed. - -Deciding intuitionistic propositional logic -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Pattern matching on goals allows a powerful backtracking when returning tactic -values. An interesting application is the problem of deciding intuitionistic -propositional logic. Considering the contraction-free sequent calculi LJT* of -Roy Dyckhoff :cite:`Dyc92`, it is quite natural to code such a tactic using the -tactic language as shown below. - -.. coqtop:: in reset - - Ltac basic := - match goal with - | |- True => trivial - | _ : False |- _ => contradiction - | _ : ?A |- ?A => assumption - end. - -.. coqtop:: in - - Ltac simplify := - repeat (intros; - match goal with - | H : ~ _ |- _ => red in H - | H : _ /\ _ |- _ => - elim H; do 2 intro; clear H - | H : _ \/ _ |- _ => - elim H; intro; clear H - | H : ?A /\ ?B -> ?C |- _ => - cut (A -> B -> C); - [ intro | intros; apply H; split; assumption ] - | H: ?A \/ ?B -> ?C |- _ => - cut (B -> C); - [ cut (A -> C); - [ intros; clear H - | intro; apply H; left; assumption ] - | intro; apply H; right; assumption ] - | H0 : ?A -> ?B, H1 : ?A |- _ => - cut B; [ intro; clear H0 | apply H0; assumption ] - | |- _ /\ _ => split - | |- ~ _ => red - end). - -.. coqtop:: in - - Ltac my_tauto := - simplify; basic || - match goal with - | H : (?A -> ?B) -> ?C |- _ => - cut (B -> C); - [ intro; cut (A -> B); - [ intro; cut C; - [ intro; clear H | apply H; assumption ] - | clear H ] - | intro; apply H; intro; assumption ]; my_tauto - | H : ~ ?A -> ?B |- _ => - cut (False -> B); - [ intro; cut (A -> False); - [ intro; cut B; - [ intro; clear H | apply H; assumption ] - | clear H ] - | intro; apply H; red; intro; assumption ]; my_tauto - | |- _ \/ _ => (left; my_tauto) || (right; my_tauto) - end. - -The tactic ``basic`` tries to reason using simple rules involving truth, falsity -and available assumptions. The tactic ``simplify`` applies all the reversible -rules of Dyckhoff’s system. Finally, the tactic ``my_tauto`` (the main -tactic to be called) simplifies with ``simplify``, tries to conclude with -``basic`` and tries several paths using the backtracking rules (one of the -four Dyckhoff’s rules for the left implication to get rid of the contraction -and the right ``or``). - -Having defined ``my_tauto``, we can prove tautologies like these: - -.. coqtop:: in - - Lemma my_tauto_ex1 : - forall A B : Prop, A /\ B -> A \/ B. - Proof. my_tauto. Qed. - -.. coqtop:: in - - Lemma my_tauto_ex2 : - forall A B : Prop, (~ ~ B -> B) -> (A -> B) -> ~ ~ A -> B. - Proof. my_tauto. Qed. - - -Deciding type isomorphisms -~~~~~~~~~~~~~~~~~~~~~~~~~~ - -A more tricky problem is to decide equalities between types modulo -isomorphisms. Here, we choose to use the isomorphisms of the simply -typed λ-calculus with Cartesian product and unit type (see, for -example, :cite:`RC95`). The axioms of this λ-calculus are given below. - -.. coqtop:: in reset - - Open Scope type_scope. - -.. coqtop:: in - - Section Iso_axioms. - -.. coqtop:: in - - Variables A B C : Set. - -.. coqtop:: in - - Axiom Com : A * B = B * A. - - Axiom Ass : A * (B * C) = A * B * C. - - Axiom Cur : (A * B -> C) = (A -> B -> C). - - Axiom Dis : (A -> B * C) = (A -> B) * (A -> C). - - Axiom P_unit : A * unit = A. - - Axiom AR_unit : (A -> unit) = unit. - - Axiom AL_unit : (unit -> A) = A. - -.. coqtop:: in - - Lemma Cons : B = C -> A * B = A * C. - - Proof. - - intro Heq; rewrite Heq; reflexivity. - - Qed. - -.. coqtop:: in - - End Iso_axioms. - -.. coqtop:: in - - Ltac simplify_type ty := - match ty with - | ?A * ?B * ?C => - rewrite <- (Ass A B C); try simplify_type_eq - | ?A * ?B -> ?C => - rewrite (Cur A B C); try simplify_type_eq - | ?A -> ?B * ?C => - rewrite (Dis A B C); try simplify_type_eq - | ?A * unit => - rewrite (P_unit A); try simplify_type_eq - | unit * ?B => - rewrite (Com unit B); try simplify_type_eq - | ?A -> unit => - rewrite (AR_unit A); try simplify_type_eq - | unit -> ?B => - rewrite (AL_unit B); try simplify_type_eq - | ?A * ?B => - (simplify_type A; try simplify_type_eq) || - (simplify_type B; try simplify_type_eq) - | ?A -> ?B => - (simplify_type A; try simplify_type_eq) || - (simplify_type B; try simplify_type_eq) - end - with simplify_type_eq := - match goal with - | |- ?A = ?B => try simplify_type A; try simplify_type B - end. - -.. coqtop:: in - - Ltac len trm := - match trm with - | _ * ?B => let succ := len B in constr:(S succ) - | _ => constr:(1) - end. - -.. coqtop:: in - - Ltac assoc := repeat rewrite <- Ass. - -.. coqtop:: in - - Ltac solve_type_eq n := - match goal with - | |- ?A = ?A => reflexivity - | |- ?A * ?B = ?A * ?C => - apply Cons; let newn := len B in solve_type_eq newn - | |- ?A * ?B = ?C => - match eval compute in n with - | 1 => fail - | _ => - pattern (A * B) at 1; rewrite Com; assoc; solve_type_eq (pred n) - end - end. - -.. coqtop:: in - - Ltac compare_structure := - match goal with - | |- ?A = ?B => - let l1 := len A - with l2 := len B in - match eval compute in (l1 = l2) with - | ?n = ?n => solve_type_eq n - end - end. - -.. coqtop:: in - - Ltac solve_iso := simplify_type_eq; compare_structure. - -The tactic to judge equalities modulo this axiomatization is shown above. -The algorithm is quite simple. First types are simplified using axioms that -can be oriented (this is done by ``simplify_type`` and ``simplify_type_eq``). -The normal forms are sequences of Cartesian products without Cartesian product -in the left component. These normal forms are then compared modulo permutation -of the components by the tactic ``compare_structure``. If they have the same -lengths, the tactic ``solve_type_eq`` attempts to prove that the types are equal. -The main tactic that puts all these components together is called ``solve_iso``. - -Here are examples of what can be solved by ``solve_iso``. - -.. coqtop:: in - - Lemma solve_iso_ex1 : - forall A B : Set, A * unit * B = B * (unit * A). - Proof. - intros; solve_iso. - Qed. - -.. coqtop:: in - - Lemma solve_iso_ex2 : - forall A B C : Set, - (A * unit -> B * (C * unit)) = - (A * unit -> (C -> unit) * C) * (unit -> A -> B). - Proof. - intros; solve_iso. - Qed. diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index d3562b52c5..a7eb7c2319 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -3,12 +3,25 @@ Ltac ==== -This chapter gives a compact documentation of |Ltac|, the tactic language -available in |Coq|. We start by giving the syntax, and next, we present the -informal semantics. If you want to know more regarding this language and -especially about its foundations, you can refer to :cite:`Del00`. Chapter -:ref:`detailedexamplesoftactics` is devoted to giving small but nontrivial -use examples of this language. +This chapter documents the tactic language |Ltac|. + +We start by giving the syntax, and next, we present the informal +semantics. To learn more about the language and +especially about its foundations, please refer to :cite:`Del00`. + +.. example:: Basic tactic macros + + Here are some examples of simple tactic macros that the + language lets you write. + + .. coqdoc:: + + Ltac reduce_and_try_to_solve := simpl; intros; auto. + + Ltac destruct_bool_and_rewrite b H1 H2 := + destruct b; [ rewrite H1; eauto | rewrite H2; eauto ]. + + See Section :ref:`ltac-examples` for more advanced examples. .. _ltac-syntax: @@ -1160,6 +1173,399 @@ Printing |Ltac| tactics This command displays a list of all user-defined tactics, with their arguments. + +.. _ltac-examples: + +Examples of using |Ltac| +------------------------- + +Proof that the natural numbers have at least two elements +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +.. example:: Proof that the natural numbers have at least two elements + + The first example shows how to use pattern matching over the proof + context to prove that natural numbers have at least two + elements. This can be done as follows: + + .. coqtop:: reset all + + Lemma card_nat : + ~ exists x y : nat, forall z:nat, x = z \/ y = z. + Proof. + intros (x & y & Hz). + destruct (Hz 0), (Hz 1), (Hz 2). + + At this point, the :tacn:`congruence` tactic would finish the job: + + .. coqtop:: all abort + + all: congruence. + + But for the purpose of the example, let's craft our own custom + tactic to solve this: + + .. coqtop:: none + + Lemma card_nat : + ~ exists x y : nat, forall z:nat, x = z \/ y = z. + Proof. + intros (x & y & Hz). + destruct (Hz 0), (Hz 1), (Hz 2). + + .. coqtop:: all abort + + all: match goal with + | _ : ?a = ?b, _ : ?a = ?c |- _ => assert (b = c) by now transitivity a + end. + all: discriminate. + + Notice that all the (very similar) cases coming from the three + eliminations (with three distinct natural numbers) are successfully + solved by a ``match goal`` structure and, in particular, with only one + pattern (use of non-linear matching). + + +Proving that a list is a permutation of a second list +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +.. example:: Proving that a list is a permutation of a second list + + Let's first define the permutation predicate: + + .. coqtop:: in reset + + Section Sort. + + Variable A : Set. + + Inductive perm : list A -> list A -> Prop := + | perm_refl : forall l, perm l l + | perm_cons : forall a l0 l1, perm l0 l1 -> perm (a :: l0) (a :: l1) + | perm_append : forall a l, perm (a :: l) (l ++ a :: nil) + | perm_trans : forall l0 l1 l2, perm l0 l1 -> perm l1 l2 -> perm l0 l2. + + End Sort. + + .. coqtop:: none + + Require Import List. + + + Next we define an auxiliary tactic :g:`perm_aux` which takes an + argument used to control the recursion depth. This tactic works as + follows: If the lists are identical (i.e. convertible), it + completes the proof. Otherwise, if the lists have identical heads, + it looks at their tails. Finally, if the lists have different + heads, it rotates the first list by putting its head at the end. + + Every time we perform a rotation, we decrement :g:`n`. When :g:`n` + drops down to :g:`1`, we stop performing rotations and we fail. + The idea is to give the length of the list as the initial value of + :g:`n`. This way of counting the number of rotations will avoid + going back to a head that had been considered before. + + From Section :ref:`ltac-syntax` we know that Ltac has a primitive + notion of integers, but they are only used as arguments for + primitive tactics and we cannot make computations with them. Thus, + instead, we use Coq's natural number type :g:`nat`. + + .. coqtop:: in + + Ltac perm_aux n := + match goal with + | |- (perm _ ?l ?l) => apply perm_refl + | |- (perm _ (?a :: ?l1) (?a :: ?l2)) => + let newn := eval compute in (length l1) in + (apply perm_cons; perm_aux newn) + | |- (perm ?A (?a :: ?l1) ?l2) => + match eval compute in n with + | 1 => fail + | _ => + let l1' := constr:(l1 ++ a :: nil) in + (apply (perm_trans A (a :: l1) l1' l2); + [ apply perm_append | compute; perm_aux (pred n) ]) + end + end. + + + The main tactic is :g:`solve_perm`. It computes the lengths of the + two lists and uses them as arguments to call :g:`perm_aux` if the + lengths are equal. (If they aren't, the lists cannot be + permutations of each other.) + + .. coqtop:: in + + Ltac solve_perm := + match goal with + | |- (perm _ ?l1 ?l2) => + match eval compute in (length l1 = length l2) with + | (?n = ?n) => perm_aux n + end + end. + + And now, here is how we can use the tactic :g:`solve_perm`: + + .. coqtop:: out + + Goal perm nat (1 :: 2 :: 3 :: nil) (3 :: 2 :: 1 :: nil). + + .. coqtop:: all abort + + solve_perm. + + .. coqtop:: out + + Goal perm nat + (0 :: 1 :: 2 :: 3 :: 4 :: 5 :: 6 :: 7 :: 8 :: 9 :: nil) + (0 :: 2 :: 4 :: 6 :: 8 :: 9 :: 7 :: 5 :: 3 :: 1 :: nil). + + .. coqtop:: all abort + + solve_perm. + + +Deciding intuitionistic propositional logic +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Pattern matching on goals allows powerful backtracking when returning tactic +values. An interesting application is the problem of deciding intuitionistic +propositional logic. Considering the contraction-free sequent calculi LJT* of +Roy Dyckhoff :cite:`Dyc92`, it is quite natural to code such a tactic using the +tactic language as shown below. + +.. coqtop:: in reset + + Ltac basic := + match goal with + | |- True => trivial + | _ : False |- _ => contradiction + | _ : ?A |- ?A => assumption + end. + +.. coqtop:: in + + Ltac simplify := + repeat (intros; + match goal with + | H : ~ _ |- _ => red in H + | H : _ /\ _ |- _ => + elim H; do 2 intro; clear H + | H : _ \/ _ |- _ => + elim H; intro; clear H + | H : ?A /\ ?B -> ?C |- _ => + cut (A -> B -> C); + [ intro | intros; apply H; split; assumption ] + | H: ?A \/ ?B -> ?C |- _ => + cut (B -> C); + [ cut (A -> C); + [ intros; clear H + | intro; apply H; left; assumption ] + | intro; apply H; right; assumption ] + | H0 : ?A -> ?B, H1 : ?A |- _ => + cut B; [ intro; clear H0 | apply H0; assumption ] + | |- _ /\ _ => split + | |- ~ _ => red + end). + +.. coqtop:: in + + Ltac my_tauto := + simplify; basic || + match goal with + | H : (?A -> ?B) -> ?C |- _ => + cut (B -> C); + [ intro; cut (A -> B); + [ intro; cut C; + [ intro; clear H | apply H; assumption ] + | clear H ] + | intro; apply H; intro; assumption ]; my_tauto + | H : ~ ?A -> ?B |- _ => + cut (False -> B); + [ intro; cut (A -> False); + [ intro; cut B; + [ intro; clear H | apply H; assumption ] + | clear H ] + | intro; apply H; red; intro; assumption ]; my_tauto + | |- _ \/ _ => (left; my_tauto) || (right; my_tauto) + end. + +The tactic ``basic`` tries to reason using simple rules involving truth, falsity +and available assumptions. The tactic ``simplify`` applies all the reversible +rules of Dyckhoff’s system. Finally, the tactic ``my_tauto`` (the main +tactic to be called) simplifies with ``simplify``, tries to conclude with +``basic`` and tries several paths using the backtracking rules (one of the +four Dyckhoff’s rules for the left implication to get rid of the contraction +and the right ``or``). + +Having defined ``my_tauto``, we can prove tautologies like these: + +.. coqtop:: in + + Lemma my_tauto_ex1 : + forall A B : Prop, A /\ B -> A \/ B. + Proof. my_tauto. Qed. + +.. coqtop:: in + + Lemma my_tauto_ex2 : + forall A B : Prop, (~ ~ B -> B) -> (A -> B) -> ~ ~ A -> B. + Proof. my_tauto. Qed. + + +Deciding type isomorphisms +~~~~~~~~~~~~~~~~~~~~~~~~~~ + +A trickier problem is to decide equalities between types modulo +isomorphisms. Here, we choose to use the isomorphisms of the simply +typed λ-calculus with Cartesian product and unit type (see, for +example, :cite:`RC95`). The axioms of this λ-calculus are given below. + +.. coqtop:: in reset + + Open Scope type_scope. + +.. coqtop:: in + + Section Iso_axioms. + +.. coqtop:: in + + Variables A B C : Set. + +.. coqtop:: in + + Axiom Com : A * B = B * A. + + Axiom Ass : A * (B * C) = A * B * C. + + Axiom Cur : (A * B -> C) = (A -> B -> C). + + Axiom Dis : (A -> B * C) = (A -> B) * (A -> C). + + Axiom P_unit : A * unit = A. + + Axiom AR_unit : (A -> unit) = unit. + + Axiom AL_unit : (unit -> A) = A. + +.. coqtop:: in + + Lemma Cons : B = C -> A * B = A * C. + + Proof. + + intro Heq; rewrite Heq; reflexivity. + + Qed. + +.. coqtop:: in + + End Iso_axioms. + +.. coqtop:: in + + Ltac simplify_type ty := + match ty with + | ?A * ?B * ?C => + rewrite <- (Ass A B C); try simplify_type_eq + | ?A * ?B -> ?C => + rewrite (Cur A B C); try simplify_type_eq + | ?A -> ?B * ?C => + rewrite (Dis A B C); try simplify_type_eq + | ?A * unit => + rewrite (P_unit A); try simplify_type_eq + | unit * ?B => + rewrite (Com unit B); try simplify_type_eq + | ?A -> unit => + rewrite (AR_unit A); try simplify_type_eq + | unit -> ?B => + rewrite (AL_unit B); try simplify_type_eq + | ?A * ?B => + (simplify_type A; try simplify_type_eq) || + (simplify_type B; try simplify_type_eq) + | ?A -> ?B => + (simplify_type A; try simplify_type_eq) || + (simplify_type B; try simplify_type_eq) + end + with simplify_type_eq := + match goal with + | |- ?A = ?B => try simplify_type A; try simplify_type B + end. + +.. coqtop:: in + + Ltac len trm := + match trm with + | _ * ?B => let succ := len B in constr:(S succ) + | _ => constr:(1) + end. + +.. coqtop:: in + + Ltac assoc := repeat rewrite <- Ass. + +.. coqtop:: in + + Ltac solve_type_eq n := + match goal with + | |- ?A = ?A => reflexivity + | |- ?A * ?B = ?A * ?C => + apply Cons; let newn := len B in solve_type_eq newn + | |- ?A * ?B = ?C => + match eval compute in n with + | 1 => fail + | _ => + pattern (A * B) at 1; rewrite Com; assoc; solve_type_eq (pred n) + end + end. + +.. coqtop:: in + + Ltac compare_structure := + match goal with + | |- ?A = ?B => + let l1 := len A + with l2 := len B in + match eval compute in (l1 = l2) with + | ?n = ?n => solve_type_eq n + end + end. + +.. coqtop:: in + + Ltac solve_iso := simplify_type_eq; compare_structure. + +The tactic to judge equalities modulo this axiomatization is shown above. +The algorithm is quite simple. First types are simplified using axioms that +can be oriented (this is done by ``simplify_type`` and ``simplify_type_eq``). +The normal forms are sequences of Cartesian products without a Cartesian product +in the left component. These normal forms are then compared modulo permutation +of the components by the tactic ``compare_structure``. If they have the same +length, the tactic ``solve_type_eq`` attempts to prove that the types are equal. +The main tactic that puts all these components together is ``solve_iso``. + +Here are examples of what can be solved by ``solve_iso``. + +.. coqtop:: in + + Lemma solve_iso_ex1 : + forall A B : Set, A * unit * B = B * (unit * A). + Proof. + intros; solve_iso. + Qed. + +.. coqtop:: in + + Lemma solve_iso_ex2 : + forall A B C : Set, + (A * unit -> B * (C * unit)) = + (A * unit -> (C -> unit) * C) * (unit -> A -> B). + Proof. + intros; solve_iso. + Qed. + + Debugging |Ltac| tactics ------------------------ diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index c8442d7ea1..537a40c53c 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -3561,7 +3561,7 @@ Automation .. tacn:: autorewrite with {+ @ident} :name: autorewrite - This tactic [4]_ carries out rewritings according to the rewriting rule + This tactic carries out rewritings according to the rewriting rule bases :n:`{+ @ident}`. Each rewriting rule from the base :n:`@ident` is applied to the main subgoal until @@ -4661,9 +4661,12 @@ Non-logical tactics .. example:: - .. coqtop:: all reset + .. coqtop:: none reset Parameter P : nat -> Prop. + + .. coqtop:: all abort + Goal P 1 /\ P 2 /\ P 3 /\ P 4 /\ P 5. repeat split. all: cycle 2. @@ -4679,9 +4682,8 @@ Non-logical tactics .. example:: - .. coqtop:: reset all + .. coqtop:: all abort - Parameter P : nat -> Prop. Goal P 1 /\ P 2 /\ P 3 /\ P 4 /\ P 5. repeat split. all: swap 1 3. @@ -4694,9 +4696,8 @@ Non-logical tactics .. example:: - .. coqtop:: all reset + .. coqtop:: all abort - Parameter P : nat -> Prop. Goal P 1 /\ P 2 /\ P 3 /\ P 4 /\ P 5. repeat split. all: revgoals. @@ -4717,7 +4718,7 @@ Non-logical tactics .. example:: - .. coqtop:: all reset + .. coqtop:: all abort Goal exists n, n=0. refine (ex_intro _ _ _). @@ -4746,39 +4747,6 @@ Non-logical tactics The ``give_up`` tactic can be used while editing a proof, to choose to write the proof script in a non-sequential order. -Simple tactic macros -------------------------- - -A simple example has more value than a long explanation: - -.. example:: - - .. coqtop:: reset all - - Ltac Solve := simpl; intros; auto. - - Ltac ElimBoolRewrite b H1 H2 := - elim b; [ intros; rewrite H1; eauto | intros; rewrite H2; eauto ]. - -The tactics macros are synchronous with the Coq section mechanism: a -tactic definition is deleted from the current environment when you -close the section (see also :ref:`section-mechanism`) where it was -defined. If you want that a tactic macro defined in a module is usable in the -modules that require it, you should put it outside of any section. - -:ref:`ltac` gives examples of more complex -user-defined tactics. - -.. [1] Actually, only the second subgoal will be generated since the - other one can be automatically checked. -.. [2] This corresponds to the cut rule of sequent calculus. -.. [3] Reminder: opaque constants will not be expanded by δ reductions. -.. [4] The behavior of this tactic has changed a lot compared to the - versions available in the previous distributions (V6). This may cause - significant changes in your theories to obtain the same result. As a - drawback of the re-engineering of the code, this tactic has also been - completely revised to get a very compact and readable version. - Delaying solving unification constraints ---------------------------------------- @@ -4917,3 +4885,8 @@ Performance-oriented tactic variants Goal False. native_cast_no_check I. Fail Qed. + +.. [1] Actually, only the second subgoal will be generated since the + other one can be automatically checked. +.. [2] This corresponds to the cut rule of sequent calculus. +.. [3] Reminder: opaque constants will not be expanded by δ reductions. diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index ac079ea7d5..edec13f681 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -840,10 +840,11 @@ gives a way to let any arbitrary expression which is not handled by the custom entry ``expr`` be parsed or printed by the main grammar of term up to the insertion of a pair of curly brackets. -.. cmd:: Print Grammar @ident. +.. cmd:: Print Custom Grammar @ident. + :name: Print Custom Grammar - This displays the state of the grammar for terms and grammar for - patterns associated to the custom entry :token:`ident`. + This displays the state of the grammar for terms associated to + the custom entry :token:`ident`. Summary ~~~~~~~ diff --git a/engine/evarutil.ml b/engine/evarutil.ml index 96beb72a56..0a5bba39b9 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -26,24 +26,7 @@ let safe_evar_value sigma ev = try Some (EConstr.Unsafe.to_constr @@ Evd.existential_value sigma ev) with NotInstantiatedEvar | Not_found -> None -(** Combinators *) - -let evd_comb0 f evdref = - let (evd',x) = f !evdref in - evdref := evd'; - x - -let evd_comb1 f evdref x = - let (evd',y) = f !evdref x in - evdref := evd'; - y - -let evd_comb2 f evdref x y = - let (evd',z) = f !evdref x y in - evdref := evd'; - z - -let new_global evd x = +let new_global evd x = let (evd, c) = Evd.fresh_global (Global.env()) evd x in (evd, c) @@ -673,26 +656,26 @@ let clear_hyps2_in_evi env sigma hyps t concl ids = (* spiwack: a few functions to gather evars on which goals depend. *) let queue_set q is_dependent set = Evar.Set.iter (fun a -> Queue.push (is_dependent,a) q) set -let queue_term q is_dependent c = - queue_set q is_dependent (evars_of_term (EConstr.Unsafe.to_constr c)) +let queue_term evm q is_dependent c = + queue_set q is_dependent (evars_of_term evm c) let process_dependent_evar q acc evm is_dependent e = let evi = Evd.find evm e in (* Queues evars appearing in the types of the goal (conclusion, then hypotheses), they are all dependent. *) - queue_term q true evi.evar_concl; + queue_term evm q true evi.evar_concl; List.iter begin fun decl -> let open NamedDecl in - queue_term q true (NamedDecl.get_type decl); + queue_term evm q true (NamedDecl.get_type decl); match decl with | LocalAssum _ -> () - | LocalDef (_,b,_) -> queue_term q true b + | LocalDef (_,b,_) -> queue_term evm q true b end (EConstr.named_context_of_val evi.evar_hyps); match evi.evar_body with | Evar_empty -> if is_dependent then Evar.Map.add e None acc else acc | Evar_defined b -> - let subevars = evars_of_term (EConstr.Unsafe.to_constr b) in + let subevars = evars_of_term evm b in (* evars appearing in the definition of an evar [e] are marked as dependent when [e] is dependent itself: if [e] is a non-dependent goal, then, unless they are reach from another @@ -812,7 +795,7 @@ let filtered_undefined_evars_of_evar_info ?cache sigma evi = in let accu = match evi.evar_body with | Evar_empty -> Evar.Set.empty - | Evar_defined b -> evars_of_term (EConstr.Unsafe.to_constr b) + | Evar_defined b -> evars_of_term sigma b in let accu = Evar.Set.union (undefined_evars_of_term sigma evi.evar_concl) accu in let ctxt = EConstr.Unsafe.to_named_context (evar_filtered_context evi) in diff --git a/engine/evarutil.mli b/engine/evarutil.mli index bb0da44103..8eaff8bd13 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -274,15 +274,6 @@ val push_rel_context_to_named_context : ?hypnaming:naming_mode -> val generalize_evar_over_rels : evar_map -> existential -> types * constr list -(** Evar combinators *) - -val evd_comb0 : (evar_map -> evar_map * 'a) -> evar_map ref -> 'a -[@@ocaml.deprecated "References to [evar_map] are deprecated, please update your API calls"] -val evd_comb1 : (evar_map -> 'b -> evar_map * 'a) -> evar_map ref -> 'b -> 'a -[@@ocaml.deprecated "References to [evar_map] are deprecated, please update your API calls"] -val evd_comb2 : (evar_map -> 'b -> 'c -> evar_map * 'a) -> evar_map ref -> 'b -> 'c -> 'a -[@@ocaml.deprecated "References to [evar_map] are deprecated, please update your API calls"] - val subterm_source : Evar.t -> ?where:Evar_kinds.subevar_kind -> Evar_kinds.t Loc.located -> Evar_kinds.t Loc.located diff --git a/engine/evd.ml b/engine/evd.ml index b89222cf8e..0f10a380d3 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -823,33 +823,6 @@ let loc_of_conv_pb evd (pbty,env,t1,t2) = | Evar (evk2,_) -> fst (evar_source evk2 evd) | _ -> None -(** The following functions return the set of evars immediately - contained in the object *) - -(* excluding defined evars *) - -let evars_of_term c = - let rec evrec acc c = - match kind c with - | Evar (n, l) -> Evar.Set.add n (Array.fold_left evrec acc l) - | _ -> Constr.fold evrec acc c - in - evrec Evar.Set.empty c - -let evars_of_named_context nc = - Context.Named.fold_outside - (NamedDecl.fold_constr (fun constr s -> Evar.Set.union s (evars_of_term constr))) - nc - ~init:Evar.Set.empty - -let evars_of_filtered_evar_info evi = - Evar.Set.union (evars_of_term evi.evar_concl) - (Evar.Set.union - (match evi.evar_body with - | Evar_empty -> Evar.Set.empty - | Evar_defined b -> evars_of_term b) - (evars_of_named_context (evar_filtered_context evi))) - (**********************************************************) (* Sort variables *) @@ -869,8 +842,6 @@ let to_universe_context evd = UState.context evd.universes let univ_entry ~poly evd = UState.univ_entry ~poly evd.universes -let const_univ_entry = univ_entry - let check_univ_decl ~poly evd decl = UState.check_univ_decl ~poly evd.universes decl let restrict_universe_context evd vars = @@ -1406,3 +1377,30 @@ module MiniEConstr = struct let to_rel_decl sigma d = Context.Rel.Declaration.map_constr (to_constr sigma) d end + +(** The following functions return the set of evars immediately + contained in the object *) + +(* excluding defined evars *) + +let evars_of_term evd c = + let rec evrec acc c = + match MiniEConstr.kind evd c with + | Evar (n, l) -> Evar.Set.add n (Array.fold_left evrec acc l) + | _ -> Constr.fold evrec acc c + in + evrec Evar.Set.empty c + +let evars_of_named_context evd nc = + Context.Named.fold_outside + (NamedDecl.fold_constr (fun constr s -> Evar.Set.union s (evars_of_term evd constr))) + nc + ~init:Evar.Set.empty + +let evars_of_filtered_evar_info evd evi = + Evar.Set.union (evars_of_term evd evi.evar_concl) + (Evar.Set.union + (match evi.evar_body with + | Evar_empty -> Evar.Set.empty + | Evar_defined b -> evars_of_term evd b) + (evars_of_named_context evd (evar_filtered_context evi))) diff --git a/engine/evd.mli b/engine/evd.mli index b0fcddb068..587a1de044 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -491,16 +491,15 @@ val extract_changed_conv_pbs : evar_map -> val extract_all_conv_pbs : evar_map -> evar_map * evar_constraint list val loc_of_conv_pb : evar_map -> evar_constraint -> Loc.t option -(** The following functions return the set of evars immediately - contained in the object; need the term to be evar-normal otherwise - defined evars are returned too. *) +(** The following functions return the set of undefined evars + contained in the object. *) -val evars_of_term : constr -> Evar.Set.t +val evars_of_term : evar_map -> econstr -> Evar.Set.t (** including evars in instances of evars *) -val evars_of_named_context : (econstr, etypes) Context.Named.pt -> Evar.Set.t +val evars_of_named_context : evar_map -> (econstr, etypes) Context.Named.pt -> Evar.Set.t -val evars_of_filtered_evar_info : evar_info -> Evar.Set.t +val evars_of_filtered_evar_info : evar_map -> evar_info -> Evar.Set.t (** Metas *) val meta_list : evar_map -> (metavariable * clbinding) list @@ -615,9 +614,6 @@ val to_universe_context : evar_map -> Univ.UContext.t val univ_entry : poly:bool -> evar_map -> Entries.universes_entry -val const_univ_entry : poly:bool -> evar_map -> Entries.universes_entry -[@@ocaml.deprecated "Use [univ_entry]."] - val check_univ_decl : poly:bool -> evar_map -> UState.universe_decl -> Entries.universes_entry val merge_universe_context : evar_map -> UState.t -> evar_map diff --git a/engine/ftactic.ml b/engine/ftactic.ml index ac0344148a..dab2e7d5ef 100644 --- a/engine/ftactic.ml +++ b/engine/ftactic.ml @@ -56,13 +56,6 @@ let bind (type a) (type b) (m : a t) (f : a -> b t) : b t = m >>= function let goals = Proofview.Goal.goals >>= fun l -> Proofview.tclUNIT (Depends l) -let nf_enter f = - bind goals - (fun gl -> - gl >>= fun gl -> - Proofview.Goal.normalize gl >>= fun nfgl -> - Proofview.V82.wrap_exceptions (fun () -> f nfgl)) [@warning "-3"] - let enter f = bind goals (fun gl -> gl >>= fun gl -> Proofview.V82.wrap_exceptions (fun () -> f gl)) diff --git a/engine/ftactic.mli b/engine/ftactic.mli index 3c4fa6f4e8..ed95d62bc6 100644 --- a/engine/ftactic.mli +++ b/engine/ftactic.mli @@ -41,9 +41,6 @@ val run : 'a t -> ('a -> unit Proofview.tactic) -> unit Proofview.tactic (** {5 Focussing} *) -val nf_enter : (Proofview.Goal.t -> 'a t) -> 'a t -[@@ocaml.deprecated "Normalization is enforced by EConstr, please use [enter]"] - (** Enter a goal. The resulting tactic is focussed. *) val enter : (Proofview.Goal.t -> 'a t) -> 'a t diff --git a/engine/proofview.ml b/engine/proofview.ml index f278c83912..1fd8b5d50e 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -641,7 +641,7 @@ let shelve_goals l = [sigma]. *) let depends_on sigma src tgt = let evi = Evd.find sigma tgt in - Evar.Set.mem src (Evd.evars_of_filtered_evar_info (Evarutil.nf_evar_info sigma evi)) + Evar.Set.mem src (Evd.evars_of_filtered_evar_info sigma (Evarutil.nf_evar_info sigma evi)) let unifiable_delayed g l = CList.exists (fun (tgt, lazy evs) -> not (Evar.equal g tgt) && Evar.Set.mem g evs) l @@ -1104,13 +1104,6 @@ module Goal = struct tclZERO ~info e end end - - let normalize { self; state } = - Env.get >>= fun env -> - tclEVARMAP >>= fun sigma -> - let (gl,sigma) = nf_gmake env sigma (goal_with_state self state) in - tclTHEN (Unsafe.tclEVARS sigma) (tclUNIT gl) - let gmake env sigma goal = let state = get_state goal in let goal = drop_state goal in @@ -1258,9 +1251,9 @@ module V82 = struct let goals = CList.map (fun (t,_) -> fst (Constr.destEvar (EConstr.Unsafe.to_constr t))) initial in { Evd.it = goals ; sigma=solution; } - let top_evars initial = + let top_evars initial { solution=sigma; } = let evars_of_initial (c,_) = - Evar.Set.elements (Evd.evars_of_term (EConstr.Unsafe.to_constr c)) + Evar.Set.elements (Evd.evars_of_term sigma c) in CList.flatten (CList.map evars_of_initial initial) diff --git a/engine/proofview.mli b/engine/proofview.mli index 9455dae643..b7ff3ac432 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -505,10 +505,6 @@ module Goal : sig (** Type of goals. *) type t - (** Normalises the argument goal. *) - val normalize : t -> t tactic - [@@ocaml.deprecated "Normalization is enforced by EConstr, [normalize] is not needed anymore"] - (** [concl], [hyps], [env] and [sigma] given a goal [gl] return respectively the conclusion of [gl], the hypotheses of [gl], the environment of [gl] (i.e. the global environment and the @@ -599,7 +595,7 @@ module V82 : sig val top_goals : entry -> proofview -> Evar.t list Evd.sigma (* returns the existential variable used to start the proof *) - val top_evars : entry -> Evar.t list + val top_evars : entry -> proofview -> Evar.t list (* Caution: this function loses quite a bit of information. It should be avoided as much as possible. It should work as diff --git a/engine/termops.ml b/engine/termops.ml index 8e12c9be88..fcacb53ac4 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -25,11 +25,6 @@ module CompactedDecl = Context.Compacted.Declaration module Internal = struct -let pr_sort_family = Sorts.pr_sort_family -[@@ocaml.deprecated "Use [Sorts.pr_sort_family]"] -let pr_fix = Constr.debug_print_fix -[@@ocaml.deprecated "Use [Constr.debug_print_fix]"] - let debug_print_constr c = Constr.debug_print EConstr.Unsafe.(to_constr c) let debug_print_constr_env env sigma c = Constr.debug_print EConstr.(to_constr sigma c) let term_printer = ref debug_print_constr_env @@ -192,7 +187,7 @@ let compute_evar_dependency_graph sigma = in match evar_body evi with | Evar_empty -> acc - | Evar_defined c -> Evar.Set.fold fold_ev (evars_of_term (EConstr.Unsafe.to_constr c)) acc + | Evar_defined c -> Evar.Set.fold fold_ev (evars_of_term sigma c) acc in Evd.fold fold sigma EvMap.empty @@ -761,13 +756,6 @@ let fold_constr_with_binders sigma g f n acc c = let c = Unsafe.to_constr (whd_evar sigma c) in Constr.fold_constr_with_binders g f n acc c -(* [iter_constr_with_full_binders g f acc c] iters [f acc] on the immediate - subterms of [c]; it carries an extra data [acc] which is processed by [g] at - each binder traversal; it is not recursive and the order with which - subterms are processed is not specified *) - -let iter_constr_with_full_binders = EConstr.iter_with_full_binders - (***************************) (* occurs check functions *) (***************************) @@ -862,8 +850,6 @@ let collect_vars sigma c = | _ -> EConstr.fold sigma aux vars c in aux Id.Set.empty c -let vars_of_global_reference = vars_of_global - (* Tests whether [m] is a subterm of [t]: [m] is appropriately lifted through abstractions of [t] *) @@ -1417,10 +1403,6 @@ let prod_applist_assum sigma n c l = | _ -> anomaly (Pp.str "Not enough prod/let's.") in app n [] c l -let on_judgment = Environ.on_judgment -let on_judgment_value = Environ.on_judgment_value -let on_judgment_type = Environ.on_judgment_type - (* Cut a context ctx in 2 parts (ctx1,ctx2) with ctx1 containing k non let-in variables skips let-in's; let-in's in the middle are put in ctx2 *) let context_chop k ctx = diff --git a/engine/termops.mli b/engine/termops.mli index 1dd9941c5e..a9217b3586 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -16,12 +16,6 @@ open Constr open Environ open EConstr -(** printers *) -val pr_sort_family : Sorts.family -> Pp.t -[@@ocaml.deprecated "Use [Sorts.pr_sort_family]"] -val pr_fix : ('a -> Pp.t) -> ('a, 'a) pfixpoint -> Pp.t -[@@ocaml.deprecated "Use [Constr.debug_print_fix]"] - (** about contexts *) val push_rel_assum : Name.t Context.binder_annot * types -> env -> env val push_rels_assum : (Name.t Context.binder_annot * Constr.types) list -> env -> env @@ -84,12 +78,6 @@ val fold_constr_with_full_binders : Evd.evar_map -> ('a -> 'b -> constr -> 'b) -> 'a -> 'b -> constr -> 'b -val iter_constr_with_full_binders : Evd.evar_map -> - (rel_declaration -> 'a -> 'a) -> - ('a -> constr -> unit) -> 'a -> - constr -> unit -[@@ocaml.deprecated "Use [EConstr.iter_with_full_binders]."] - (**********************************************************************) val strip_head_cast : Evd.evar_map -> constr -> constr @@ -121,9 +109,6 @@ val count_occurrences : Evd.evar_map -> constr -> constr -> int val collect_metas : Evd.evar_map -> constr -> int list val collect_vars : Evd.evar_map -> constr -> Id.Set.t (** for visible vars only *) -val vars_of_global_reference : env -> GlobRef.t -> Id.Set.t -[@@ocaml.deprecated "Use [Environ.vars_of_global]"] - (* Substitution of metavariables *) type meta_value_map = (metavariable * Constr.constr) list val subst_meta : meta_value_map -> Constr.constr -> Constr.constr @@ -292,15 +277,6 @@ val is_Type : Evd.evar_map -> constr -> bool val reference_of_level : Evd.evar_map -> Univ.Level.t -> Libnames.qualid option -(** Combinators on judgments *) - -val on_judgment : ('a -> 'b) -> ('a, 'a) punsafe_judgment -> ('b, 'b) punsafe_judgment -[@@ocaml.deprecated "Use [Environ.on_judgment]."] -val on_judgment_value : ('c -> 'c) -> ('c, 't) punsafe_judgment -> ('c, 't) punsafe_judgment -[@@ocaml.deprecated "Use [Environ.on_judgment_value]."] -val on_judgment_type : ('t -> 't) -> ('c, 't) punsafe_judgment -> ('c, 't) punsafe_judgment -[@@ocaml.deprecated "Use [Environ.on_judgment_type]."] - (** {5 Debug pretty-printers} *) open Evd diff --git a/engine/uState.ml b/engine/uState.ml index aa14f66df6..adea78d4c9 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -116,8 +116,6 @@ let univ_entry ~poly uctx = Polymorphic_entry (nas, uctx) else Monomorphic_entry (context_set uctx) -let const_univ_entry = univ_entry - let of_context_set ctx = { empty with uctx_local = ctx } let subst ctx = ctx.uctx_univ_variables diff --git a/engine/uState.mli b/engine/uState.mli index a358813825..3df7f9e8e9 100644 --- a/engine/uState.mli +++ b/engine/uState.mli @@ -67,9 +67,6 @@ val context : t -> Univ.UContext.t val univ_entry : poly:bool -> t -> Entries.universes_entry (** Pick from {!context} or {!context_set} based on [poly]. *) -val const_univ_entry : poly:bool -> t -> Entries.universes_entry -[@@ocaml.deprecated "Use [univ_entry]."] - (** {5 Constraints handling} *) val drop_weak_constraints : bool ref diff --git a/engine/univGen.ml b/engine/univGen.ml index c310331b15..f1deb1bfaf 100644 --- a/engine/univGen.ml +++ b/engine/univGen.ml @@ -25,11 +25,6 @@ let new_univ_global () = let fresh_level () = Univ.Level.make (new_univ_global ()) -(* TODO: remove *) -let new_univ () = Univ.Universe.make (fresh_level ()) -let new_Type () = mkType (new_univ ()) -let new_Type_sort () = sort_of_univ (new_univ ()) - let fresh_instance auctx = let inst = Array.init (AUContext.size auctx) (fun _ -> fresh_level()) in let ctx = Array.fold_right LSet.add inst LSet.empty in @@ -83,10 +78,6 @@ let constr_of_monomorphic_global gr = Pp.(str "globalization of polymorphic reference " ++ Nametab.pr_global_env Id.Set.empty gr ++ str " would forget universes.") -let constr_of_global gr = constr_of_monomorphic_global gr - -let constr_of_global_univ = mkRef - let fresh_global_or_constr_instance env = function | IsConstr c -> c, ContextSet.empty | IsGlobal gr -> fresh_global_instance env gr @@ -99,34 +90,6 @@ let global_of_constr c = | Var id -> VarRef id, Instance.empty | _ -> raise Not_found -open Declarations - -let type_of_reference env r = - match r with - | VarRef id -> Environ.named_type id env, ContextSet.empty - - | ConstRef c -> - let cb = Environ.lookup_constant c env in - let ty = cb.const_type in - let auctx = Declareops.constant_polymorphic_context cb in - let inst, ctx = fresh_instance auctx in - Vars.subst_instance_constr inst ty, ctx - - | IndRef ind -> - let (mib, _ as specif) = Inductive.lookup_mind_specif env ind in - let auctx = Declareops.inductive_polymorphic_context mib in - let inst, ctx = fresh_instance auctx in - let ty = Inductive.type_of_inductive env (specif, inst) in - ty, ctx - - | ConstructRef (ind,_ as cstr) -> - let (mib,_ as specif) = Inductive.lookup_mind_specif env ind in - let auctx = Declareops.inductive_polymorphic_context mib in - let inst, ctx = fresh_instance auctx in - Inductive.type_of_constructor (cstr,inst) specif, ctx - -let type_of_global t = type_of_reference (Global.env ()) t - let fresh_sort_in_family = function | InSProp -> Sorts.sprop, ContextSet.empty | InProp -> Sorts.prop, ContextSet.empty @@ -135,11 +98,6 @@ let fresh_sort_in_family = function let u = fresh_level () in sort_of_univ (Univ.Universe.make u), ContextSet.singleton u -let new_sort_in_family sf = - fst (fresh_sort_in_family sf) - -let extend_context = Univ.extend_in_context_set - let new_global_univ () = let u = fresh_level () in (Univ.Universe.make u, ContextSet.singleton u) diff --git a/engine/univGen.mli b/engine/univGen.mli index b4598e10d0..34920e5620 100644 --- a/engine/univGen.mli +++ b/engine/univGen.mli @@ -24,16 +24,7 @@ val new_univ_id : unit -> univ_unique_id (** for the stm *) val new_univ_global : unit -> Level.UGlobal.t val fresh_level : unit -> Level.t -val new_univ : unit -> Universe.t -[@@ocaml.deprecated "Use [new_univ_level]"] -val new_Type : unit -> types -[@@ocaml.deprecated "Use [new_univ_level]"] -val new_Type_sort : unit -> Sorts.t -[@@ocaml.deprecated "Use [new_univ_level]"] - val new_global_univ : unit -> Universe.t in_universe_context_set -val new_sort_in_family : Sorts.family -> Sorts.t -[@@ocaml.deprecated "Use [fresh_sort_in_family]"] (** Build a fresh instance for a given context, its associated substitution and the instantiated constraints. *) @@ -66,27 +57,9 @@ val fresh_universe_context_set_instance : ContextSet.t -> (** Raises [Not_found] if not a global reference. *) val global_of_constr : constr -> GlobRef.t puniverses -val constr_of_global_univ : GlobRef.t puniverses -> constr -[@@ocaml.deprecated "Use [Constr.mkRef]"] - -val extend_context : 'a in_universe_context_set -> ContextSet.t -> - 'a in_universe_context_set -[@@ocaml.deprecated "Use [Univ.extend_in_context_set]"] - (** Create a fresh global in the global environment, without side effects. BEWARE: this raises an error on polymorphic constants/inductives: the constraints should be properly added to an evd. See Evd.fresh_global, Evarutil.new_global, and pf_constr_of_global for the proper way to get a fresh copy of a polymorphic global reference. *) val constr_of_monomorphic_global : GlobRef.t -> constr - -val constr_of_global : GlobRef.t -> constr -[@@ocaml.deprecated "constr_of_global will crash on polymorphic constants,\ - use [constr_of_monomorphic_global] if the reference is guaranteed to\ - be monomorphic, [Evarutil.new_global] or [Tacmach.New.pf_constr_of_global] otherwise"] - -(** Returns the type of the global reference, by creating a fresh instance of polymorphic - references and computing their instantiated universe context. (side-effect on the - universe counter, use with care). *) -val type_of_global : GlobRef.t -> types in_universe_context_set -[@@ocaml.deprecated "use [Typeops.type_of_global]"] diff --git a/interp/constrextern.ml b/interp/constrextern.ml index e5bf52571c..bb66658a37 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -850,10 +850,10 @@ let rec extern inctx scopes vars r = | Some c :: q -> match locs with | [] -> anomaly (Pp.str "projections corruption [Constrextern.extern].") - | (_, false) :: locs' -> + | { Recordops.pk_true_proj = false } :: locs' -> (* we don't want to print locals *) ip q locs' args acc - | (_, true) :: locs' -> + | { Recordops.pk_true_proj = true } :: locs' -> match args with | [] -> raise No_match (* we give up since the constructor is not complete *) diff --git a/interp/constrintern.ml b/interp/constrintern.ml index c0801067ce..f06493b374 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -1368,7 +1368,7 @@ let sort_fields ~complete loc fields completer = let first_field = GlobRef.equal field_glob_ref first_field_glob_ref in begin match proj_kinds with | [] -> anomaly (Pp.str "Number of projections mismatch.") - | (_, regular) :: proj_kinds -> + | { Recordops.pk_true_proj = regular } :: proj_kinds -> (* "regular" is false when the field is defined by a let-in in the record declaration (its value is fixed from other fields). *) diff --git a/interp/impargs.ml b/interp/impargs.ml index d83a0ce918..806fe93297 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -120,8 +120,6 @@ let argument_position_eq p1 p2 = match p1, p2 with | Hyp h1, Hyp h2 -> Int.equal h1 h2 | _ -> false -let explicitation_eq = Constrexpr_ops.explicitation_eq - type implicit_explanation = | DepRigid of argument_position | DepFlex of argument_position @@ -499,9 +497,9 @@ type implicit_interactive_request = type implicit_discharge_request = | ImplLocal - | ImplConstant of Constant.t * implicits_flags + | ImplConstant of implicits_flags | ImplMutualInductive of MutInd.t * implicits_flags - | ImplInteractive of GlobRef.t * implicits_flags * + | ImplInteractive of implicits_flags * implicit_interactive_request let implicits_table = Summary.ref GlobRef.Map.empty ~name:"implicits" @@ -554,39 +552,24 @@ let add_section_impls vars extra_impls (cond,impls) = let discharge_implicits (_,(req,l)) = match req with | ImplLocal -> None - | ImplInteractive (ref,flags,exp) -> - (try - let vars = variable_section_segment_of_reference ref in - let extra_impls = impls_of_context vars in - let l' = [ref, List.map (add_section_impls vars extra_impls) (snd (List.hd l))] in - Some (ImplInteractive (ref,flags,exp),l') - with Not_found -> (* ref not defined in this section *) Some (req,l)) - | ImplConstant (con,flags) -> - (try - let vars = variable_section_segment_of_reference (ConstRef con) in - let extra_impls = impls_of_context vars in - let newimpls = List.map (add_section_impls vars extra_impls) (snd (List.hd l)) in - let l' = [ConstRef con,newimpls] in - Some (ImplConstant (con,flags),l') - with Not_found -> (* con not defined in this section *) Some (req,l)) - | ImplMutualInductive (kn,flags) -> - (try - let l' = List.map (fun (gr, l) -> - let vars = variable_section_segment_of_reference gr in - let extra_impls = impls_of_context vars in - (gr, - List.map (add_section_impls vars extra_impls) l)) l - in - Some (ImplMutualInductive (kn,flags),l') - with Not_found -> (* ref not defined in this section *) Some (req,l)) + | ImplMutualInductive _ | ImplInteractive _ | ImplConstant _ -> + let l' = + try + List.map (fun (gr, l) -> + let vars = variable_section_segment_of_reference gr in + let extra_impls = impls_of_context vars in + let newimpls = List.map (add_section_impls vars extra_impls) l in + (gr, newimpls)) l + with Not_found -> l in + Some (req,l') let rebuild_implicits (req,l) = match req with | ImplLocal -> assert false - | ImplConstant (con,flags) -> - let oldimpls = snd (List.hd l) in - let newimpls = compute_constant_implicits flags con in - req, [ConstRef con, List.map2 merge_impls oldimpls newimpls] + | ImplConstant flags -> + let ref,oldimpls = List.hd l in + let newimpls = compute_global_implicits flags ref in + req, [ref, List.map2 merge_impls oldimpls newimpls] | ImplMutualInductive (kn,flags) -> let newimpls = compute_all_mib_implicits flags kn in let rec aux olds news = @@ -597,15 +580,14 @@ let rebuild_implicits (req,l) = | _, _ -> assert false in req, aux l newimpls - | ImplInteractive (ref,flags,o) -> + | ImplInteractive (flags,o) -> + let ref,oldimpls = List.hd l in (if isVarRef ref && is_in_section ref then ImplLocal else req), match o with | ImplAuto -> - let oldimpls = snd (List.hd l) in let newimpls = compute_global_implicits flags ref in [ref,List.map2 merge_impls oldimpls newimpls] | ImplManual userimplsize -> - let oldimpls = snd (List.hd l) in if flags.auto then let newimpls = List.hd (compute_global_implicits flags ref) in let p = List.length (snd newimpls) - userimplsize in @@ -640,7 +622,7 @@ let declare_implicits_gen req flags ref = let declare_implicits local ref = let flags = { !implicit_args with auto = true } in let req = - if is_local local ref then ImplLocal else ImplInteractive(ref,flags,ImplAuto) in + if is_local local ref then ImplLocal else ImplInteractive(flags,ImplAuto) in declare_implicits_gen req flags ref let declare_var_implicits id = @@ -649,7 +631,7 @@ let declare_var_implicits id = let declare_constant_implicits con = let flags = !implicit_args in - declare_implicits_gen (ImplConstant (con,flags)) flags (ConstRef con) + declare_implicits_gen (ImplConstant flags) flags (ConstRef con) let declare_mib_implicits kn = let flags = !implicit_args in @@ -699,7 +681,7 @@ let declare_manual_implicits local ref ?enriching l = let l = [DefaultImpArgs, set_manual_implicits flags enriching autoimpls l] in let req = if is_local local ref then ImplLocal - else ImplInteractive(ref,flags,ImplManual (List.length autoimpls)) + else ImplInteractive(flags,ImplManual (List.length autoimpls)) in add_anonymous_leaf (inImplicits (req,[ref,l])) let maybe_declare_manual_implicits local ref ?enriching l = @@ -758,7 +740,7 @@ let set_implicits local ref l = compute_implicit_statuses autoimpls imps)) l in let req = if is_local local ref then ImplLocal - else ImplInteractive(ref,flags,ImplManual (List.length autoimpls)) + else ImplInteractive(flags,ImplManual (List.length autoimpls)) in add_anonymous_leaf (inImplicits (req,[ref,l'])) let extract_impargs_data impls = diff --git a/interp/impargs.mli b/interp/impargs.mli index 0070423530..ccdd448460 100644 --- a/interp/impargs.mli +++ b/interp/impargs.mli @@ -143,7 +143,3 @@ val projection_implicits : env -> Projection.t -> implicit_status list -> val select_impargs_size : int -> implicits_list list -> implicit_status list val select_stronger_impargs : implicits_list list -> implicit_status list - -val explicitation_eq : Constrexpr.explicitation -> Constrexpr.explicitation -> bool - [@@ocaml.deprecated "Use Constrexpr_ops.explicitation_eq instead (since 8.10)"] -(** Equality on [explicitation]. *) diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index dffccf02fc..6277d874dd 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -281,7 +281,7 @@ let implicits_of_glob_constr ?(with_products=true) l = | _ -> () in [] | GLambda (na, bk, t, b) -> abs na bk b - | GLetIn (na, b, t, c) -> aux i b + | GLetIn (na, b, t, c) -> aux i c | GRec (fix_kind, nas, args, tys, bds) -> let nb = match fix_kind with |GFix (_, n) -> n | GCoFix n -> n in List.fold_left_i (fun i l (na,bk,_,_) -> add_impl i na bk l) i (aux (List.length args.(nb) + i) bds.(nb)) args.(nb) diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index 1b348ae777..4b45608ae5 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -97,7 +97,8 @@ if (sp - num_args < coq_stack_threshold) { \ several architectures. */ -#if defined(__GNUC__) && !defined(DEBUG) +#if defined(__GNUC__) && !defined(DEBUG) && !defined(__INTEL_COMPILER) \ + && !defined(__llvm__) #ifdef __mips__ #define PC_REG asm("$16") #define SP_REG asm("$17") @@ -126,7 +127,7 @@ if (sp - num_args < coq_stack_threshold) { \ #define SP_REG asm("%edi") #define ACCU_REG #endif -#if defined(PPC) || defined(_POWER) || defined(_IBMR2) +#if defined(__ppc__) || defined(__ppc64__) #define PC_REG asm("26") #define SP_REG asm("27") #define ACCU_REG asm("28") @@ -141,8 +142,9 @@ if (sp - num_args < coq_stack_threshold) { \ #define SP_REG asm("a4") #define ACCU_REG asm("d7") #endif -#if defined(__arm__) && !defined(__thumb2__) -#define PC_REG asm("r9") +/* OCaml PR#4953: these specific registers not available in Thumb mode */ +#if defined(__arm__) && !defined(__thumb__) +#define PC_REG asm("r6") #define SP_REG asm("r8") #define ACCU_REG asm("r7") #endif @@ -152,6 +154,17 @@ if (sp - num_args < coq_stack_threshold) { \ #define ACCU_REG asm("38") #define JUMPTBL_BASE_REG asm("39") #endif +#ifdef __x86_64__ +#define PC_REG asm("%r15") +#define SP_REG asm("%r14") +#define ACCU_REG asm("%r13") +#endif +#ifdef __aarch64__ +#define PC_REG asm("%x19") +#define SP_REG asm("%x20") +#define ACCU_REG asm("%x21") +#define JUMPTBL_BASE_REG asm("%x22") +#endif #endif #define CheckInt1() do{ \ diff --git a/kernel/entries.ml b/kernel/entries.ml index a3d32267a7..adb3f6bd29 100644 --- a/kernel/entries.ml +++ b/kernel/entries.ml @@ -108,21 +108,7 @@ type module_entry = | MExpr of module_params_entry * module_struct_entry * module_struct_entry option - -type seff_env = - [ `Nothing - (* The proof term and its universes. - Same as the constant_body's but not in an ephemeron *) - | `Opaque of Constr.t * Univ.ContextSet.t ] - (** Not used by the kernel. *) type side_effect_role = | Subproof | Schema of inductive * string - -type side_eff = { - seff_constant : Constant.t; - seff_body : Declarations.constant_body; - seff_env : seff_env; - seff_role : side_effect_role; -} diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 009eb3da38..bb3b0a538e 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -49,20 +49,6 @@ let weaker_noccur_between env x nvars t = (************************************************************************) (* Various well-formedness check for inductive declarations *) -(* Errors related to inductive constructions *) -type inductive_error = Type_errors.inductive_error = - | NonPos of env * constr * constr - | NotEnoughArgs of env * constr * constr - | NotConstructor of env * Id.t * constr * constr * int * int - | NonPar of env * constr * int * constr * constr - | SameNamesTypes of Id.t - | SameNamesConstructors of Id.t - | SameNamesOverlap of Id.t list - | NotAnArity of env * constr - | BadEntry - | LargeNonPropInductiveNotInType - | BadUnivs - exception InductiveError = Type_errors.InductiveError (************************************************************************) @@ -84,6 +70,7 @@ exception IllFormedInd of ill_formed_ind let mind_extract_params = decompose_prod_n_assum let explain_ind_err id ntyp env nparamsctxt c err = + let open Type_errors in let (_lparams,c') = mind_extract_params nparamsctxt c in match err with | LocalNonPos kt -> @@ -329,7 +316,7 @@ let check_positivity_one ~chkpos recursive (env,_,ntypes,_ as ienv) paramsctxt ( | Prod (na,b,d) -> let () = assert (List.is_empty largs) in if not recursive && not (noccur_between n ntypes b) then - raise (InductiveError BadEntry); + raise (InductiveError Type_errors.BadEntry); let nmr',recarg = check_pos ienv nmr b in let ienv' = ienv_push_var ienv (na,b,mk_norec) in check_constr_rec ienv' nmr' (recarg::lrec) d diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli index 7810c1723e..1b8e4208ff 100644 --- a/kernel/indtypes.mli +++ b/kernel/indtypes.mli @@ -9,28 +9,9 @@ (************************************************************************) open Names -open Constr open Declarations open Environ open Entries (** Check an inductive. *) val check_inductive : env -> MutInd.t -> mutual_inductive_entry -> mutual_inductive_body - -(** Deprecated *) -type inductive_error = - | NonPos of env * constr * constr - | NotEnoughArgs of env * constr * constr - | NotConstructor of env * Id.t * constr * constr * int * int - | NonPar of env * constr * int * constr * constr - | SameNamesTypes of Id.t - | SameNamesConstructors of Id.t - | SameNamesOverlap of Id.t list - | NotAnArity of env * constr - | BadEntry - | LargeNonPropInductiveNotInType - | BadUnivs -[@@ocaml.deprecated "Use [Type_errors.inductive_error]"] - -exception InductiveError of Type_errors.inductive_error -[@@ocaml.deprecated "Use [Type_errors.InductiveError]"] diff --git a/kernel/modops.ml b/kernel/modops.ml index 4f992d3972..4fdd7ab334 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -608,11 +608,7 @@ let clean_bounded_mod_expr sign = (** {6 Stm machinery } *) let join_constant_body except otab cb = match cb.const_body with - | OpaqueDef o -> - (match Opaqueproof.uuid_opaque otab o with - | Some uuid when not(Future.UUIDSet.mem uuid except) -> - Opaqueproof.join_opaque otab o - | _ -> ()) + | OpaqueDef o -> Opaqueproof.join_opaque ~except otab o | _ -> () let join_structure except otab s = diff --git a/kernel/names.ml b/kernel/names.ml index 9f27212967..047a1d6525 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -376,9 +376,6 @@ module KerName = struct { modpath; knlabel; refhash = -1; } let repr kn = (kn.modpath, kn.knlabel) - let make2 = make - [@@ocaml.deprecated "Please use [KerName.make]"] - let modpath kn = kn.modpath let label kn = kn.knlabel diff --git a/kernel/names.mli b/kernel/names.mli index 61df3bad0e..2238e932b0 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -278,9 +278,6 @@ sig val make : ModPath.t -> Label.t -> t val repr : t -> ModPath.t * Label.t - val make2 : ModPath.t -> Label.t -> t - [@@ocaml.deprecated "Please use [KerName.make]"] - (** Projections *) val modpath : t -> ModPath.t val label : t -> Label.t diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml index 303cb06c55..57059300b8 100644 --- a/kernel/opaqueproof.ml +++ b/kernel/opaqueproof.ml @@ -87,19 +87,18 @@ let discharge_direct_opaque ~cook_constr ci = function | Direct (d,cu) -> Direct (ci::d,Future.chain cu (fun (c, u) -> cook_constr c, u)) -let join_opaque { opaque_val = prfs; opaque_dir = odp; _ } = function - | Direct (_,cu) -> ignore(Future.join cu) +let join except cu = match except with +| None -> ignore (Future.join cu) +| Some except -> + if Future.UUIDSet.mem (Future.uuid cu) except then () + else ignore (Future.join cu) + +let join_opaque ?except { opaque_val = prfs; opaque_dir = odp; _ } = function + | Direct (_,cu) -> join except cu | Indirect (_,dp,i) -> if DirPath.equal dp odp then let fp = snd (Int.Map.find i prfs) in - ignore(Future.join fp) - -let uuid_opaque { opaque_val = prfs; opaque_dir = odp; _ } = function - | Direct (_,cu) -> Some (Future.uuid cu) - | Indirect (_,dp,i) -> - if DirPath.equal dp odp - then Some (Future.uuid (snd (Int.Map.find i prfs))) - else None + join except fp let force_proof { opaque_val = prfs; opaque_dir = odp; _ } = function | Direct (_,cu) -> @@ -128,16 +127,6 @@ let get_constraints { opaque_val = prfs; opaque_dir = odp; _ } = function then Some(Future.chain (snd (Int.Map.find i prfs)) snd) else !get_univ dp i -let get_proof { opaque_val = prfs; opaque_dir = odp; _ } = function - | Direct (_,cu) -> Future.chain cu fst - | Indirect (l,dp,i) -> - let pt = - if DirPath.equal dp odp - then Future.chain (snd (Int.Map.find i prfs)) fst - else !get_opaque dp i in - Future.chain pt (fun c -> - force_constr (List.fold_right subst_substituted l (from_val c))) - module FMap = Future.UUIDMap let a_constr = Future.from_val (mkRel 1) diff --git a/kernel/opaqueproof.mli b/kernel/opaqueproof.mli index 5ea6da649b..d47c0bbb3c 100644 --- a/kernel/opaqueproof.mli +++ b/kernel/opaqueproof.mli @@ -39,7 +39,6 @@ val turn_indirect : DirPath.t -> opaque -> opaquetab -> opaque * opaquetab indirect opaque accessor configured below. *) val force_proof : opaquetab -> opaque -> constr val force_constraints : opaquetab -> opaque -> Univ.ContextSet.t -val get_proof : opaquetab -> opaque -> constr Future.computation val get_constraints : opaquetab -> opaque -> Univ.ContextSet.t Future.computation option @@ -60,8 +59,7 @@ type cooking_info = { val discharge_direct_opaque : cook_constr:(constr -> constr) -> cooking_info -> opaque -> opaque -val uuid_opaque : opaquetab -> opaque -> Future.UUID.t option -val join_opaque : opaquetab -> opaque -> unit +val join_opaque : ?except:Future.UUIDSet.t -> opaquetab -> opaque -> unit val dump : opaquetab -> Constr.t Future.computation array * diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 673f025c75..75375812c0 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -228,6 +228,12 @@ let check_engagement env expected_impredicative_set = (** {6 Stm machinery } *) +type seff_env = + [ `Nothing + (* The proof term and its universes. + Same as the constant_body's but not in an ephemeron *) + | `Opaque of Constr.t * Univ.ContextSet.t ] + let get_opaque_body env cbo = match cbo.const_body with | Undef _ -> assert false @@ -240,7 +246,10 @@ let get_opaque_body env cbo = type side_effect = { from_env : Declarations.structure_body CEphemeron.key; - eff : Entries.side_eff list; + seff_constant : Constant.t; + seff_body : Declarations.constant_body; + seff_env : seff_env; + seff_role : Entries.side_effect_role; } module SideEffects : @@ -254,11 +263,9 @@ end = struct module SeffOrd = struct -open Entries type t = side_effect let compare e1 e2 = - let cmp e1 e2 = Constant.CanOrd.compare e1.seff_constant e2.seff_constant in - List.compare cmp e1.eff e2.eff + Constant.CanOrd.compare e1.seff_constant e2.seff_constant end module SeffSet = Set.Make(SeffOrd) @@ -279,37 +286,37 @@ end type private_constants = SideEffects.t let side_effects_of_private_constants l = - let ans = List.rev (SideEffects.repr l) in - List.map_append (fun { eff; _ } -> eff) ans + List.rev (SideEffects.repr l) + +let push_private_constants env eff = + let eff = side_effects_of_private_constants eff in + let add_if_undefined env eff = + try ignore(Environ.lookup_constant eff.seff_constant env); env + with Not_found -> Environ.add_constant eff.seff_constant eff.seff_body env + in + List.fold_left add_if_undefined env eff let empty_private_constants = SideEffects.empty -let add_private mb eff effs = - let from_env = CEphemeron.create mb in - SideEffects.add { eff; from_env } effs let concat_private = SideEffects.concat -let make_eff env cst r = - let open Entries in +let private_constant env role cst = + (** The constant must be the last entry of the safe environment *) + let () = match env.revstruct with + | (lbl, SFBconst _) :: _ -> assert (Label.equal lbl (Constant.label cst)) + | _ -> assert false + in + let from_env = CEphemeron.create env.revstruct in let cbo = Environ.lookup_constant cst env.env in - { + let eff = { + from_env = from_env; seff_constant = cst; seff_body = cbo; seff_env = get_opaque_body env.env cbo; - seff_role = r; - } - -let private_con_of_con env c = - let open Entries in - let eff = [make_eff env c Subproof] in - add_private env.revstruct eff empty_private_constants - -let private_con_of_scheme ~kind env cl = - let open Entries in - let eff = List.map (fun (i, c) -> make_eff env c (Schema (i, kind))) cl in - add_private env.revstruct eff empty_private_constants + seff_role = role; + } in + SideEffects.add eff empty_private_constants let universes_of_private eff = - let open Entries in let fold acc eff = let acc = match eff.seff_env with | `Nothing -> acc @@ -588,22 +595,17 @@ let add_constant_aux ~in_section senv (kn, cb) = let mk_pure_proof c = (c, Univ.ContextSet.empty), SideEffects.empty let inline_side_effects env body side_eff = - let open Entries in let open Constr in (** First step: remove the constants that are still in the environment *) - let filter { eff = se; from_env = mb } = - let map e = (e.seff_constant, e.seff_body, e.seff_env) in - let cbl = List.map map se in - let not_exists (c,_,_) = - try ignore(Environ.lookup_constant c env); false - with Not_found -> true in - let cbl = List.filter not_exists cbl in - (cbl, mb) + let filter e = + let cb = (e.seff_constant, e.seff_body, e.seff_env) in + try ignore (Environ.lookup_constant e.seff_constant env); None + with Not_found -> Some (cb, e.from_env) in (* CAVEAT: we assure that most recent effects come first *) - let side_eff = List.map filter (SideEffects.repr side_eff) in - let sigs = List.rev_map (fun (cbl, mb) -> mb, List.length cbl) side_eff in - let side_eff = List.fold_left (fun accu (cbl, _) -> cbl @ accu) [] side_eff in + let side_eff = List.map_filter filter (SideEffects.repr side_eff) in + let sigs = List.rev_map (fun (_, mb) -> mb) side_eff in + let side_eff = List.fold_left (fun accu (cb, _) -> cb :: accu) [] side_eff in let side_eff = List.rev side_eff in (** Most recent side-effects first in side_eff *) if List.is_empty side_eff then (body, Univ.ContextSet.empty, sigs) @@ -675,24 +677,22 @@ let inline_private_constants_in_definition_entry env ce = let inline_private_constants_in_constr env body side_eff = pi1 (inline_side_effects env body side_eff) -let rec is_nth_suffix n l suf = - if Int.equal n 0 then l == suf - else match l with - | [] -> false - | _ :: l -> is_nth_suffix (pred n) l suf +let is_suffix l suf = match l with +| [] -> false +| _ :: l -> l == suf (* Given the list of signatures of side effects, checks if they match. * I.e. if they are ordered descendants of the current revstruct. Returns the number of effects that can be trusted. *) let check_signatures curmb sl = - let is_direct_ancestor accu (mb, how_many) = + let is_direct_ancestor accu mb = match accu with | None -> None | Some (n, curmb) -> try let mb = CEphemeron.get mb in - if is_nth_suffix how_many mb curmb - then Some (n + how_many, mb) + if is_suffix mb curmb + then Some (n + 1, mb) else None with CEphemeron.InvalidKey -> None in let sl = List.fold_left is_direct_ancestor (Some (0, curmb)) sl in @@ -725,7 +725,6 @@ let constant_entry_of_side_effect cb u = const_entry_inline_code = cb.const_inline_code } let turn_direct orig = - let open Entries in let cb = orig.seff_body in if Declareops.is_opaque cb then let p = match orig.seff_env with @@ -738,7 +737,6 @@ let turn_direct orig = else orig let export_eff eff = - let open Entries in (eff.seff_constant, eff.seff_body, eff.seff_role) let export_side_effects mb env c = @@ -751,10 +749,9 @@ let export_side_effects mb env c = let not_exists e = try ignore(Environ.lookup_constant e.seff_constant env); false with Not_found -> true in - let aux (acc,sl) { eff = se; from_env = mb } = - let cbl = List.filter not_exists se in - if List.is_empty cbl then acc, sl - else cbl :: acc, (mb,List.length cbl) :: sl in + let aux (acc,sl) e = + if not (not_exists e) then acc, sl + else e :: acc, e.from_env :: sl in let seff, signatures = List.fold_left aux ([],[]) (SideEffects.repr eff) in let trusted = check_signatures mb signatures in let push_seff env eff = @@ -772,10 +769,9 @@ let export_side_effects mb env c = let rec translate_seff sl seff acc env = match seff with | [] -> List.rev acc, ce - | cbs :: rest -> + | eff :: rest -> if Int.equal sl 0 then - let env, cbs = - List.fold_left (fun (env,cbs) eff -> + let env, cb = let { seff_constant = kn; seff_body = ocb; seff_env = u ; _ } = eff in let ce = constant_entry_of_side_effect ocb u in let cb = Term_typing.translate_constant Term_typing.Pure env kn ce in @@ -783,15 +779,14 @@ let export_side_effects mb env c = seff_body = cb; seff_env = `Nothing; } in - (push_seff env eff, export_eff eff :: cbs)) - (env,[]) cbs in - translate_seff 0 rest (cbs @ acc) env + (push_seff env eff, export_eff eff) + in + translate_seff 0 rest (cb :: acc) env else - let cbs_len = List.length cbs in - let cbs = List.map turn_direct cbs in - let env = List.fold_left push_seff env cbs in - let ecbs = List.map export_eff cbs in - translate_seff (sl - cbs_len) rest (ecbs @ acc) env + let cb = turn_direct eff in + let env = push_seff env cb in + let ecb = export_eff cb in + translate_seff (sl - 1) rest (ecb :: acc) env in translate_seff trusted seff [] env diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index 46c97c1fb8..d6c7022cf5 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -43,18 +43,13 @@ type 'a safe_transformer = safe_environment -> 'a * safe_environment type private_constants -val side_effects_of_private_constants : - private_constants -> Entries.side_eff list -(** Return the list of individual side-effects in the order of their - creation. *) - val empty_private_constants : private_constants val concat_private : private_constants -> private_constants -> private_constants (** [concat_private e1 e2] adds the constants of [e1] to [e2], i.e. constants in [e1] must be more recent than those of [e2]. *) -val private_con_of_con : safe_environment -> Constant.t -> private_constants -val private_con_of_scheme : kind:string -> safe_environment -> (inductive * Constant.t) list -> private_constants +val private_constant : safe_environment -> Entries.side_effect_role -> Constant.t -> private_constants +(** Constant must be the last definition of the safe_environment. *) val mk_pure_proof : Constr.constr -> private_constants Entries.proof_output val inline_private_constants_in_constr : @@ -62,6 +57,9 @@ val inline_private_constants_in_constr : val inline_private_constants_in_definition_entry : Environ.env -> private_constants Entries.definition_entry -> unit Entries.definition_entry +val push_private_constants : Environ.env -> private_constants -> Environ.env +(** Push the constants in the environment if not already there. *) + val universes_of_private : private_constants -> Univ.ContextSet.t list val is_curmod_library : safe_environment -> bool diff --git a/lib/rtree.ml b/lib/rtree.ml index e1c6a4c4d6..66d9eba3f7 100644 --- a/lib/rtree.ml +++ b/lib/rtree.ml @@ -115,8 +115,6 @@ struct end -let smartmap = Smart.map - (** Structural equality test, parametrized by an equality on elements *) let rec raw_eq cmp t t' = match t, t' with @@ -149,9 +147,6 @@ let equiv cmp cmp' = let equal cmp t t' = t == t' || raw_eq cmp t t' || equiv cmp cmp t t' -(** Deprecated alias *) -let eq_rtree = equal - (** Intersection of rtrees of same arity *) let rec inter cmp interlbl def n histo t t' = try diff --git a/lib/rtree.mli b/lib/rtree.mli index 5ab14f6039..67519aa387 100644 --- a/lib/rtree.mli +++ b/lib/rtree.mli @@ -77,15 +77,9 @@ val incl : ('a -> 'a -> bool) -> ('a -> 'a -> 'a option) -> 'a -> 'a t -> 'a t - (** See also [Smart.map] *) val map : ('a -> 'b) -> 'a t -> 'b t -val smartmap : ('a -> 'a) -> 'a t -> 'a t -(** @deprecated Same as [Smart.map] *) - (** A rather simple minded pretty-printer *) val pp_tree : ('a -> Pp.t) -> 'a t -> Pp.t -val eq_rtree : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool -(** @deprecated Same as [Rtree.equal] *) - module Smart : sig diff --git a/library/global.ml b/library/global.ml index 55aed1c56e..06e06a8cf2 100644 --- a/library/global.ml +++ b/library/global.ml @@ -157,11 +157,6 @@ let import c u d = globalize (Safe_typing.import c u d) let env_of_context hyps = reset_with_named_context hyps (env()) -let type_of_global_in_context = Typeops.type_of_global_in_context - -let universes_of_global gr = - universes_of_global (env ()) gr - let is_polymorphic r = Environ.is_polymorphic (env()) r let is_template_polymorphic r = is_template_polymorphic (env ()) r diff --git a/library/global.mli b/library/global.mli index 76ac3f6279..a60de48897 100644 --- a/library/global.mli +++ b/library/global.mli @@ -131,14 +131,6 @@ val is_polymorphic : GlobRef.t -> bool val is_template_polymorphic : GlobRef.t -> bool val is_type_in_type : GlobRef.t -> bool -val type_of_global_in_context : Environ.env -> - GlobRef.t -> Constr.types * Univ.AUContext.t - [@@ocaml.deprecated "alias of [Typeops.type_of_global_in_context]"] - -(** Returns the universe context of the global reference (whatever its polymorphic status is). *) -val universes_of_global : GlobRef.t -> Univ.AUContext.t -[@@ocaml.deprecated "Use [Environ.universes_of_global]"] - (** {6 Retroknowledge } *) val register_inline : Constant.t -> unit diff --git a/library/globnames.ml b/library/globnames.ml index db2e8bfaed..99dcc43ad1 100644 --- a/library/globnames.ml +++ b/library/globnames.ml @@ -85,15 +85,6 @@ let printable_constr_of_global = function | ConstructRef sp -> mkConstruct sp | IndRef sp -> mkInd sp -module RefOrdered = Names.GlobRef.Ordered -module RefOrdered_env = Names.GlobRef.Ordered_env - -module Refmap = Names.GlobRef.Map -module Refset = Names.GlobRef.Set - -module Refmap_env = Names.GlobRef.Map_env -module Refset_env = Names.GlobRef.Set_env - (* Extended global references *) type syndef_name = KerName.t @@ -134,6 +125,3 @@ end type global_reference_or_constr = | IsGlobal of global_reference | IsConstr of constr - -(* Deprecated *) -let eq_gr = GlobRef.equal diff --git a/library/globnames.mli b/library/globnames.mli index d49ed453f5..14e422b743 100644 --- a/library/globnames.mli +++ b/library/globnames.mli @@ -25,8 +25,6 @@ val isConstRef : GlobRef.t -> bool val isIndRef : GlobRef.t -> bool val isConstructRef : GlobRef.t -> bool -val eq_gr : GlobRef.t -> GlobRef.t -> bool -[@@ocaml.deprecated "Use Names.GlobRef.equal"] val canonical_gr : GlobRef.t -> GlobRef.t val destVarRef : GlobRef.t -> variable @@ -48,22 +46,6 @@ val printable_constr_of_global : GlobRef.t -> constr raise [Not_found] if not a global reference *) val global_of_constr : constr -> GlobRef.t -module RefOrdered = Names.GlobRef.Ordered -[@@ocaml.deprecated "Use Names.GlobRef.Ordered"] - -module RefOrdered_env = Names.GlobRef.Ordered_env -[@@ocaml.deprecated "Use Names.GlobRef.Ordered_env"] - -module Refset = Names.GlobRef.Set -[@@ocaml.deprecated "Use Names.GlobRef.Set"] -module Refmap = Names.GlobRef.Map -[@@ocaml.deprecated "Use Names.GlobRef.Map"] - -module Refset_env = GlobRef.Set_env -[@@ocaml.deprecated "Use Names.GlobRef.Set_env"] -module Refmap_env = GlobRef.Map_env -[@@ocaml.deprecated "Use Names.GlobRef.Map_env"] - (** {6 Extended global references } *) type syndef_name = KerName.t diff --git a/library/lib.ml b/library/lib.ml index d4381a6923..a046360822 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -278,7 +278,7 @@ let start_mod is_type export id mp fs = let prefix = Nametab.{ obj_dir = dir; obj_mp = mp; obj_sec = Names.DirPath.empty } in let exists = if is_type then Nametab.exists_cci (make_path id) - else Nametab.exists_module dir + else Nametab.exists_dir dir in if exists then user_err ~hdr:"open_module" (Id.print id ++ str " already exists"); @@ -569,7 +569,7 @@ let open_section id = let opp = !lib_state.path_prefix in let obj_dir = add_dirpath_suffix opp.Nametab.obj_dir id in let prefix = Nametab.{ obj_dir; obj_mp = opp.obj_mp; obj_sec = add_dirpath_suffix opp.obj_sec id } in - if Nametab.exists_section obj_dir then + if Nametab.exists_dir obj_dir then user_err ~hdr:"open_section" (Id.print id ++ str " already exists."); let fs = Summary.freeze_summaries ~marshallable:false in add_entry (make_foname id) (OpenedSection (prefix, fs)); diff --git a/library/nametab.ml b/library/nametab.ml index 95890b2edf..bd0ea5f04f 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -43,12 +43,6 @@ module GlobDirRef = struct end -type global_dir_reference = GlobDirRef.t -[@@ocaml.deprecated "Use [GlobDirRef.t]"] - -let eq_global_dir_reference = GlobDirRef.equal -[@@ocaml.deprecated "Use [GlobDirRef.equal]"] - exception GlobalizationError of qualid let error_global_not_found qid = @@ -516,10 +510,6 @@ let exists_cci sp = ExtRefTab.exists sp !the_ccitab let exists_dir dir = DirTab.exists dir !the_dirtab -let exists_section = exists_dir - -let exists_module = exists_dir - let exists_modtype sp = MPTab.exists sp !the_modtypetab let exists_universe kn = UnivTab.exists kn !the_univtab @@ -585,10 +575,3 @@ let global_inductive qid = | ref -> user_err ?loc:qid.CAst.loc ~hdr:"global_inductive" (pr_qualid qid ++ spc () ++ str "is not an inductive type") - -(********************************************************************) - -(* Deprecated synonyms *) - -let extended_locate = locate_extended -let absolute_reference = global_of_path diff --git a/library/nametab.mli b/library/nametab.mli index fccb8fd918..a4f177aad0 100644 --- a/library/nametab.mli +++ b/library/nametab.mli @@ -89,13 +89,6 @@ module GlobDirRef : sig val equal : t -> t -> bool end -type global_dir_reference = GlobDirRef.t -[@@ocaml.deprecated "Use [GlobDirRef.t]"] - -val eq_global_dir_reference : - GlobDirRef.t -> GlobDirRef.t -> bool -[@@ocaml.deprecated "Use [GlobDirRef.equal]"] - exception GlobalizationError of qualid (** Raises a globalization error *) @@ -170,10 +163,6 @@ val extended_global_of_path : full_path -> extended_global_reference val exists_cci : full_path -> bool val exists_modtype : full_path -> bool val exists_dir : DirPath.t -> bool -val exists_section : DirPath.t -> bool (** deprecated synonym of [exists_dir] *) - -val exists_module : DirPath.t -> bool (** deprecated synonym of [exists_dir] *) - val exists_universe : full_path -> bool (** {6 These functions locate qualids into full user names } *) @@ -220,11 +209,6 @@ val shortest_qualid_of_modtype : ?loc:Loc.t -> ModPath.t -> qualid val shortest_qualid_of_module : ?loc:Loc.t -> ModPath.t -> qualid val shortest_qualid_of_universe : ?loc:Loc.t -> Univ.Level.UGlobal.t -> qualid -(** Deprecated synonyms *) - -val extended_locate : qualid -> extended_global_reference (*= locate_extended *) -val absolute_reference : full_path -> GlobRef.t (** = global_of_path *) - (** {5 Generic name handling} *) (** NOT FOR PUBLIC USE YET. Plugin writers, please do not rely on this API. *) diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index 4425e41652..4769c2dc53 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -102,6 +102,7 @@ let start_deriving f suchthat lemma = let terminator = Proof_global.make_terminator terminator in let pstate = Proof_global.start_dependent_proof ~ontop:None lemma kind goals terminator in - fst @@ Proof_global.with_current_proof begin fun _ p -> - Proof.run_tactic env Proofview.(tclFOCUS 1 2 shelve) p + Proof_global.simple_with_current_proof begin fun _ p -> + let p,_,() = Proof.run_tactic env Proofview.(tclFOCUS 1 2 shelve) p in + p end pstate diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 3dd3a430e8..1fca132655 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -132,7 +132,7 @@ let nat = function () -> (coq_init_constant "nat") let iter_ref () = try find_reference ["Recdef"] "iter" with Not_found -> user_err Pp.(str "module Recdef not loaded") -let iter_rd = function () -> (constr_of_global (delayed_force iter_ref)) +let iter_rd = function () -> (constr_of_monomorphic_global (delayed_force iter_ref)) let eq = function () -> (coq_init_constant "eq") let le_lt_SS = function () -> (constant ["Recdef"] "le_lt_SS") let le_lt_n_Sm = function () -> (coq_constant arith_Lt "le_lt_n_Sm") @@ -145,7 +145,7 @@ let coq_O = function () -> (coq_init_constant "O") let coq_S = function () -> (coq_init_constant "S") let lt_n_O = function () -> (coq_constant arith_Nat "nlt_0_r") let max_ref = function () -> (find_reference ["Recdef"] "max") -let max_constr = function () -> EConstr.of_constr (constr_of_global (delayed_force max_ref)) +let max_constr = function () -> EConstr.of_constr (constr_of_monomorphic_global (delayed_force max_ref)) let f_S t = mkApp(delayed_force coq_S, [|t|]);; @@ -1041,13 +1041,13 @@ let compute_terminate_type nb_args func = let open Term in let open Constr in let open CVars in - let _,a_arrow_b,_ = destLambda(def_of_const (constr_of_global func)) in + let _,a_arrow_b,_ = destLambda(def_of_const (constr_of_monomorphic_global func)) in let rev_args,b = decompose_prod_n nb_args a_arrow_b in let left = mkApp(delayed_force iter_rd, Array.of_list (lift 5 a_arrow_b:: mkRel 3:: - constr_of_global func::mkRel 1:: + constr_of_monomorphic_global func::mkRel 1:: List.rev (List.map_i (fun i _ -> mkRel (6+i)) 0 rev_args) ) ) @@ -1065,7 +1065,7 @@ let compute_terminate_type nb_args func = delayed_force nat, (mkProd (make_annot (Name k_id) Sorts.Relevant, delayed_force nat, mkArrow cond Sorts.Relevant result))))|])in - let value = mkApp(constr_of_global (Util.delayed_force coq_sig_ref), + let value = mkApp(constr_of_monomorphic_global (Util.delayed_force coq_sig_ref), [|b; (mkLambda (make_annot (Name v_id) Sorts.Relevant, b, nb_iter))|]) in compose_prod rev_args value @@ -1161,7 +1161,7 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a fun g -> let sigma = project g in let ids = Termops.ids_of_named_context (pf_hyps g) in - let func_body = (def_of_const (constr_of_global func)) in + let func_body = (def_of_const (constr_of_monomorphic_global func)) in let func_body = EConstr.of_constr func_body in let (f_name, _, body1) = destLambda sigma func_body in let f_id = @@ -1222,7 +1222,7 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a let get_current_subgoals_types pstate = let p = Proof_global.give_me_the_proof pstate in - let sgs,_,_,_,sigma = Proof.proof p in + let Proof.{ goals=sgs; sigma; _ } = Proof.data p in sigma, List.map (Goal.V82.abstract_type sigma) sgs exception EmptySubgoals @@ -1253,7 +1253,7 @@ let build_and_l sigma l = let c,tac,nb = f pl in mk_and p1 c, tclTHENS - (Proofview.V82.of_tactic (apply (EConstr.of_constr (constr_of_global conj_constr)))) + (Proofview.V82.of_tactic (apply (EConstr.of_constr (constr_of_monomorphic_global conj_constr)))) [tclIDTAC; tac ],nb+1 @@ -1437,7 +1437,7 @@ let start_equation (f:GlobRef.t) (term_f:GlobRef.t) (cont_tactic:Id.t list -> tactic) g = let sigma = project g in let ids = pf_ids_of_hyps g in - let terminate_constr = constr_of_global term_f in + let terminate_constr = constr_of_monomorphic_global term_f in let terminate_constr = EConstr.of_constr terminate_constr in let nargs = nb_prod (project g) (EConstr.of_constr (type_of_const sigma terminate_constr)) in let x = n_x_id ids nargs in @@ -1457,7 +1457,7 @@ let com_eqn sign uctx nb_arg eq_name functional_ref f_ref terminate_ref equation | _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant.") in let evd = Evd.from_ctx uctx in - let f_constr = constr_of_global f_ref in + let f_constr = constr_of_monomorphic_global f_ref in let equation_lemma_type = subst1 f_constr equation_lemma_type in let pstate = Lemmas.start_proof ~ontop:None eq_name (Global, false, Proof Lemma) ~sign evd (EConstr.of_constr equation_lemma_type) in @@ -1466,12 +1466,12 @@ let com_eqn sign uctx nb_arg eq_name functional_ref f_ref terminate_ref equation (fun x -> prove_eq (fun _ -> tclIDTAC) {nb_arg=nb_arg; - f_terminate = EConstr.of_constr (constr_of_global terminate_ref); + f_terminate = EConstr.of_constr (constr_of_monomorphic_global terminate_ref); f_constr = EConstr.of_constr f_constr; concl_tac = tclIDTAC; func=functional_ref; info=(instantiate_lambda Evd.empty - (EConstr.of_constr (def_of_const (constr_of_global functional_ref))) + (EConstr.of_constr (def_of_const (constr_of_monomorphic_global functional_ref))) (EConstr.of_constr f_constr::List.map mkVar x) ); is_main_branch = true; @@ -1570,9 +1570,9 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num if not stop then let eq_ref = Nametab.locate (qualid_of_ident equation_id ) in - let f_ref = destConst (constr_of_global f_ref) - and functional_ref = destConst (constr_of_global functional_ref) - and eq_ref = destConst (constr_of_global eq_ref) in + let f_ref = destConst (constr_of_monomorphic_global f_ref) + and functional_ref = destConst (constr_of_monomorphic_global functional_ref) + and eq_ref = destConst (constr_of_monomorphic_global eq_ref) in generate_induction_principle f_ref tcc_lemma_constr functional_ref eq_ref rec_arg_num (EConstr.of_constr rec_arg_type) diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index ef6af16036..de9dec0f74 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -207,7 +207,7 @@ struct * ZMicromega.v *) - let gen_constant_in_modules s m n = EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.gen_reference_in_modules s m n) + let gen_constant_in_modules s m n = EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.gen_reference_in_modules s m n) let init_constant = gen_constant_in_modules "ZMicromega" Coqlib.init_modules [@@@ocaml.warning "+3"] diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index e349031952..93c0d5c236 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -446,7 +446,7 @@ let lz_setoid_relation = | Some (env', srel) when env' == env -> srel | _ -> let srel = - try Some (UnivGen.constr_of_global @@ + try Some (UnivGen.constr_of_monomorphic_global @@ Coqlib.find_reference "Class_setoid" ("Coq"::sdir) "RewriteRelation" [@ocaml.warning "-3"]) with _ -> None in last_srel := Some (env, srel); srel @@ -491,7 +491,7 @@ let rwprocess_rule dir rule gl = | _ -> let sigma, pi2 = Evd.fresh_global env sigma coq_prod.Coqlib.proj2 in EConstr.mkApp (pi2, ra), sigma in - if EConstr.eq_constr sigma a.(0) (EConstr.of_constr (UnivGen.constr_of_global @@ Coqlib.(lib_ref "core.True.type"))) then + if EConstr.eq_constr sigma a.(0) (EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.(lib_ref "core.True.type"))) then let s, sigma = sr sigma 2 in loop (converse_dir d) sigma s a.(1) rs 0 else diff --git a/plugins/ssr/ssrview.ml b/plugins/ssr/ssrview.ml index 075ebf006a..0a5c85f4ab 100644 --- a/plugins/ssr/ssrview.ml +++ b/plugins/ssr/ssrview.ml @@ -290,7 +290,7 @@ let finalize_view s0 ?(simple_types=true) p = Goal.enter_one ~__LOC__ begin fun g -> let env = Goal.env g in let sigma = Goal.sigma g in - let evars_of_p = Evd.evars_of_term (EConstr.to_constr ~abort_on_undefined_evars:false sigma p) in + let evars_of_p = Evd.evars_of_term sigma p in let filter x _ = Evar.Set.mem x evars_of_p in let sigma = Typeclasses.resolve_typeclasses ~fail:false ~filter env sigma in let p = Reductionops.nf_evar sigma p in @@ -307,7 +307,7 @@ Goal.enter_one ~__LOC__ begin fun g -> let und0 = (* Unassigned evars in the initial goal *) let sigma0 = Tacmach.project s0 in let g0info = Evd.find sigma0 (Tacmach.sig_it s0) in - let g0 = Evd.evars_of_filtered_evar_info g0info in + let g0 = Evd.evars_of_filtered_evar_info sigma0 g0info in List.filter (fun k -> Evar.Set.mem k g0) (List.map fst (Evar.Map.bindings (Evd.undefined_map sigma0))) in let rigid = rigid_of und0 in diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index 4e0866a0c5..adbcfb8f3b 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -529,8 +529,8 @@ exception FoundUnif of (evar_map * UState.t * tpattern) (* Note: we don't update env as we descend into the term, as the primitive *) (* unification procedure always rejects subterms with bound variables. *) -let dont_impact_evars_in cl = - let evs_in_cl = Evd.evars_of_term cl in +let dont_impact_evars_in sigma0 cl = + let evs_in_cl = Evd.evars_of_term sigma0 cl in fun sigma -> Evar.Set.for_all (fun k -> try let _ = Evd.find_undefined sigma k in true with Not_found -> false) evs_in_cl @@ -544,7 +544,7 @@ let dont_impact_evars_in cl = (* - w_unify expands let-in (zeta conversion) eagerly, whereas we want to *) (* match a head let rigidly. *) let match_upats_FO upats env sigma0 ise orig_c = - let dont_impact_evars = dont_impact_evars_in orig_c in + let dont_impact_evars = dont_impact_evars_in sigma0 (EConstr.of_constr orig_c) in let rec loop c = let f, a = splay_app ise c in let i0 = ref (-1) in let fpats = @@ -586,7 +586,7 @@ let match_upats_FO upats env sigma0 ise orig_c = let match_upats_HO ~on_instance upats env sigma0 ise c = - let dont_impact_evars = dont_impact_evars_in c in + let dont_impact_evars = dont_impact_evars_in sigma0 (EConstr.of_constr c) in let it_did_match = ref false in let failed_because_of_TC = ref false in let rec aux upats env sigma0 ise c = diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 062e3ca8b2..82726eccf0 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -708,9 +708,6 @@ type binder_kind = BProd | BLambda | BLetIn (**********************************************************************) (* Main detyping function *) -let detype_anonymous = ref (fun ?loc n -> anomaly ~label:"detype" (Pp.str "index to an anonymous variable.")) -let set_detype_anonymous f = detype_anonymous := f - let detype_level sigma l = let l = hack_qualid_of_univ_level sigma l in GType (UNamed l) @@ -732,11 +729,13 @@ and detype_r d flags avoid env sigma t = match EConstr.kind sigma (collapse_appl sigma t) with | Rel n -> (try match lookup_name_of_rel n (fst env) with - | Name id -> GVar id - | Anonymous -> GVar (!detype_anonymous n) + | Name id -> GVar id + | Anonymous -> + let s = "_ANONYMOUS_REL_"^(string_of_int n) in + GVar (Id.of_string s) with Not_found -> - let s = "_UNBOUND_REL_"^(string_of_int n) - in GVar (Id.of_string s)) + let s = "_UNBOUND_REL_"^(string_of_int n) + in GVar (Id.of_string s)) | Meta n -> (* Meta in constr are not user-parsable and are mapped to Evar *) if n = Constr_matching.special_meta then diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli index 1a8e97efb8..00b0578a52 100644 --- a/pretyping/detyping.mli +++ b/pretyping/detyping.mli @@ -68,9 +68,6 @@ val detype_closed_glob : ?lax:bool -> bool -> Id.Set.t -> env -> evar_map -> clo val lookup_name_as_displayed : env -> evar_map -> constr -> Id.t -> int option val lookup_index_as_renamed : env -> evar_map -> constr -> int -> int option -(* XXX: This is a hack and should go away *) -val set_detype_anonymous : (?loc:Loc.t -> int -> Id.t) -> unit - val force_wildcard : unit -> bool val synthetize_type : unit -> bool diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 99013a19c9..6b149a8b41 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -1769,28 +1769,3 @@ let unify ?flags ?(with_ho=true) env evd cv_pb ty1 ty2 = solve_unif_constraints_with_heuristics ~flags ~with_ho env evd | UnifFailure (evd, reason) -> raise (PretypeError (env, evd, CannotUnify (ty1, ty2, Some reason))) - -(* deprecated *) -let the_conv_x env ?(ts=default_transparent_state env) t1 t2 evd = - let flags = default_flags_of ts in - match evar_conv_x flags env evd CONV t1 t2 with - | Success evd' -> evd' - | UnifFailure (evd',e) -> raise (UnableToUnify (evd',e)) - -let the_conv_x_leq env ?(ts=default_transparent_state env) t1 t2 evd = - let flags = default_flags_of ts in - match evar_conv_x flags env evd CUMUL t1 t2 with - | Success evd' -> evd' - | UnifFailure (evd',e) -> raise (UnableToUnify (evd',e)) - -let make_opt = function - | Success evd -> Some evd - | UnifFailure _ -> None - -let conv env ?(ts=default_transparent_state env) evd t1 t2 = - let flags = default_flags_of ts in - make_opt(evar_conv_x flags env evd CONV t1 t2) - -let cumul env ?(ts=default_transparent_state env) evd t1 t2 = - let flags = default_flags_of ts in - make_opt(evar_conv_x flags env evd CUMUL t1 t2) diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli index bf83f5e88f..eae961714d 100644 --- a/pretyping/evarconv.mli +++ b/pretyping/evarconv.mli @@ -46,19 +46,6 @@ exception UnableToUnify of evar_map * Pretype_errors.unification_error val unify_delay : ?flags:unify_flags -> env -> evar_map -> constr -> constr -> evar_map val unify_leq_delay : ?flags:unify_flags -> env -> evar_map -> constr -> constr -> evar_map -(** returns exception UnableToUnify with best known evar_map if not unifiable *) -val the_conv_x : env -> ?ts:TransparentState.t -> constr -> constr -> evar_map -> evar_map -[@@ocaml.deprecated "Use Evarconv.unify_delay instead"] -val the_conv_x_leq : env -> ?ts:TransparentState.t -> constr -> constr -> evar_map -> evar_map -[@@ocaml.deprecated "Use Evarconv.unify_leq_delay instead"] -(** The same function resolving evars by side-effect and - catching the exception *) - -val conv : env -> ?ts:TransparentState.t -> evar_map -> constr -> constr -> evar_map option -[@@ocaml.deprecated "Use Evarconv.unify_delay instead"] -val cumul : env -> ?ts:TransparentState.t -> evar_map -> constr -> constr -> evar_map option -[@@ocaml.deprecated "Use Evarconv.unify_leq_delay instead"] - (** This function also calls [solve_unif_constraints_with_heuristics] to resolve any remaining constraints. In case of success the two terms are unified without condition. diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index d69824a256..a23c58c062 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -27,16 +27,27 @@ open Reductionops (*s A structure S is a non recursive inductive type with a single constructor (the name of which defaults to Build_S) *) -(* Table des structures: le nom de la structure (un [inductive]) donne - le nom du constructeur, le nombre de paramètres et pour chaque - argument réel du constructeur, le nom de la projection - correspondante, si valide, et un booléen disant si c'est une vraie - projection ou bien une fonction constante (associée à un LetIn) *) +(* Table of structures. + It maps to each structure name (of type [inductive]): + - the name of its constructor; + - the number of parameters; + - for each true argument, some data about the corresponding projection: + * its name (may be anonymous); + * whether it is a true projection (as opposed to a constant function, LetIn); + * whether it should be used as a canonical hint; + * the constant realizing this projection (if any). +*) + +type proj_kind = { + pk_name: Name.t; + pk_true_proj: bool; + pk_canonical: bool; +} type struc_typ = { s_CONST : constructor; s_EXPECTEDPARAM : int; - s_PROJKIND : (Name.t * bool) list; + s_PROJKIND : proj_kind list; s_PROJ : Constant.t option list } let structure_table = @@ -47,7 +58,7 @@ let projection_table = (* TODO: could be unify struc_typ and struc_tuple ? *) type struc_tuple = - constructor * (Name.t * bool) list * Constant.t option list + constructor * proj_kind list * Constant.t option list let register_structure env (id,kl,projs) = let open Declarations in @@ -161,7 +172,7 @@ let canonical_projections () = !object_table [] let keep_true_projections projs kinds = - let filter (p, (_, b)) = if b then Some p else None in + let filter (p, { pk_true_proj ; pk_canonical }) = if pk_true_proj then Some (p, pk_canonical) else None in List.map_filter filter (List.combine projs kinds) let rec cs_pattern_of_constr env t = @@ -206,17 +217,20 @@ let compute_canonical_projections env ~warn (con,ind) = let o_NPARAMS = List.length o_TPARAMS in let lpj = keep_true_projections lpj kl in let nenv = Termops.push_rels_assum sign env in - List.fold_left2 (fun acc spopt t -> - Option.cata (fun proji_sp -> - match cs_pattern_of_constr nenv t with - | patt, o_INJ, o_TCOMPS -> - ((ConstRef proji_sp, (patt, t)), - { o_DEF ; o_CTX ; o_INJ ; o_TABS ; o_TPARAMS ; o_NPARAMS ; o_TCOMPS }) - :: acc - | exception Not_found -> - if warn then warn_projection_no_head_constant (sign, env, t, con, proji_sp); - acc - ) acc spopt + List.fold_left2 (fun acc (spopt, canonical) t -> + if canonical + then + Option.cata (fun proji_sp -> + match cs_pattern_of_constr nenv t with + | patt, o_INJ, o_TCOMPS -> + ((ConstRef proji_sp, (patt, t)), + { o_DEF ; o_CTX ; o_INJ ; o_TABS ; o_TPARAMS ; o_NPARAMS ; o_TCOMPS }) + :: acc + | exception Not_found -> + if warn then warn_projection_no_head_constant (sign, env, t, con, proji_sp); + acc + ) acc spopt + else acc ) [] lpj projs let pr_cs_pattern = function @@ -288,7 +302,7 @@ let check_and_decompose_canonical_structure env sigma ref = with Not_found -> error_not_structure ref (str "Could not find the record or structure " ++ Termops.Internal.print_constr_env env sigma (EConstr.mkInd indsp)) in - let ntrue_projs = List.count snd s.s_PROJKIND in + let ntrue_projs = List.count (fun { pk_true_proj } -> pk_true_proj) s.s_PROJKIND in if s.s_EXPECTEDPARAM + ntrue_projs > Array.length args then error_not_structure ref (str "Got too few arguments to the record or structure constructor."); (sp,indsp) diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index f0594d513a..25b6cd0751 100644 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -17,14 +17,20 @@ open Constr (** A structure S is a non recursive inductive type with a single constructor (the name of which defaults to Build_S) *) +type proj_kind = { + pk_name: Name.t; + pk_true_proj: bool; + pk_canonical: bool; +} + type struc_typ = { s_CONST : constructor; s_EXPECTEDPARAM : int; - s_PROJKIND : (Name.t * bool) list; + s_PROJKIND : proj_kind list; s_PROJ : Constant.t option list } type struc_tuple = - constructor * (Name.t * bool) list * Constant.t option list + constructor * proj_kind list * Constant.t option list val register_structure : Environ.env -> struc_tuple -> unit val subst_structure : Mod_subst.substitution -> struc_tuple -> struc_tuple diff --git a/printing/printmod.ml b/printing/printmod.ml index f4986652b3..bd97104f60 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -63,7 +63,7 @@ let keyword s = tag_keyword (str s) let get_new_id locals id = let rec get_id l id = let dir = DirPath.make [id] in - if not (Nametab.exists_module dir) then + if not (Nametab.exists_dir dir) then id else get_id (Id.Set.add id l) (Namegen.next_ident_away id l) diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 4f36354f79..52e15f466f 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -98,7 +98,7 @@ let solve ?with_end_tac gi info_lvl tac pr = else tac in let env = Global.env () in - let (p,(status,info)) = Proof.run_tactic env tac pr in + let (p,(status,info),()) = Proof.run_tactic env tac pr in let env = Global.env () in let sigma = Evd.from_env env in let () = @@ -161,7 +161,7 @@ let refine_by_tactic ~name ~poly env sigma ty tac = let prev_future_goals = save_future_goals sigma in (* Start a proof *) let prf = Proof.start ~name ~poly sigma [env, ty] in - let (prf, _) = + let (prf, _, ()) = try Proof.run_tactic env tac prf with Logic_monad.TacticFailure e as src -> (* Catch the inner error of the monad tactic *) diff --git a/proofs/proof.ml b/proofs/proof.ml index 978b1f6f78..09e4e898fe 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -126,9 +126,6 @@ type t = (** Locality, polymorphism, and "kind" [Coercion, Definition, etc...] *) } -let initial_goals pf = Proofview.initial_goals pf.entry -let initial_euctx pf = pf.initial_euctx - (*** General proof functions ***) let proof p = @@ -147,33 +144,6 @@ let proof p = let given_up = p.given_up in (goals,stack,shelf,given_up,sigma) -type 'a pre_goals = { - fg_goals : 'a list; - (** List of the focussed goals *) - bg_goals : ('a list * 'a list) list; - (** Zipper representing the unfocussed background goals *) - shelved_goals : 'a list; - (** List of the goals on the shelf. *) - given_up_goals : 'a list; - (** List of the goals that have been given up *) -} - -let map_structured_proof pfts process_goal: 'a pre_goals = - let (goals, zipper, shelf, given_up, sigma) = proof pfts in - let fg = List.map (process_goal sigma) goals in - let map_zip (lg, rg) = - let lg = List.map (process_goal sigma) lg in - let rg = List.map (process_goal sigma) rg in - (lg, rg) - in - let bg = List.map map_zip zipper in - let shelf = List.map (process_goal sigma) shelf in - let given_up = List.map (process_goal sigma) given_up in - { fg_goals = fg; - bg_goals = bg; - shelved_goals = shelf; - given_up_goals = given_up; } - let rec unroll_focus pv = function | (_,_,ctx)::stk -> unroll_focus (Proofview.unfocus ctx pv) stk | [] -> pv @@ -402,7 +372,7 @@ let run_tactic env tac pr = let sp = pr.proofview in let undef sigma l = List.filter (fun g -> Evd.is_undefined sigma g) l in let tac = - tac >>= fun () -> + tac >>= fun result -> Proofview.tclEVARMAP >>= fun sigma -> (* Already solved goals are not to be counted as shelved. Nor are they to be marked as unresolvable. *) @@ -413,10 +383,10 @@ let run_tactic env tac pr = CErrors.anomaly Pp.(str "Evars generated outside of proof engine (e.g. V82, clear, ...) are not supposed to be explicitly given up."); let sigma = Proofview.Unsafe.mark_as_goals sigma retrieved in Proofview.Unsafe.tclEVARS sigma >>= fun () -> - Proofview.tclUNIT retrieved + Proofview.tclUNIT (result,retrieved) in let { name; poly } = pr in - let (retrieved,proofview,(status,to_shelve,give_up),info_trace) = + let ((result,retrieved),proofview,(status,to_shelve,give_up),info_trace) = Proofview.apply ~name ~poly env tac sp in let sigma = Proofview.return proofview in @@ -430,7 +400,7 @@ let run_tactic env tac pr = in let given_up = pr.given_up@give_up in let proofview = Proofview.Unsafe.reset_future_goals proofview in - { pr with proofview ; shelf ; given_up },(status,info_trace) + { pr with proofview ; shelf ; given_up },(status,info_trace),result (*** Commands ***) @@ -441,22 +411,6 @@ let in_proof p k = k (Proofview.return p.proofview) let unshelve p = { p with proofview = Proofview.unshelve (p.shelf) (p.proofview) ; shelf = [] } -let pr_proof p = - let p = map_structured_proof p (fun _sigma g -> g) in - Pp.( - let pr_goal_list = prlist_with_sep spc Goal.pr_goal in - let rec aux acc = function - | [] -> acc - | (before,after)::stack -> - aux (pr_goal_list before ++ spc () ++ str "{" ++ acc ++ str "}" ++ spc () ++ - pr_goal_list after) stack in - str "[" ++ str "focus structure: " ++ - aux (pr_goal_list p.fg_goals) p.bg_goals ++ str ";" ++ spc () ++ - str "shelved: " ++ pr_goal_list p.shelved_goals ++ str ";" ++ spc () ++ - str "given up: " ++ pr_goal_list p.given_up_goals ++ - str "]" - ) - (*** Compatibility layer with <=v8.2 ***) module V82 = struct @@ -471,7 +425,7 @@ module V82 = struct { Evd.it=List.hd gls ; sigma=sigma; } let top_evars p = - Proofview.V82.top_evars p.entry + Proofview.V82.top_evars p.entry p.proofview let grab_evars p = if not (is_done p) then @@ -554,3 +508,19 @@ let data { proofview; focus_stack; entry; shelf; given_up; initial_euctx; name; let stack = map_minus_one (fun (_,_,c) -> Proofview.focus_context c) focus_stack in { sigma; goals; entry; stack; shelf; given_up; initial_euctx; name; poly } + +let pr_proof p = + let { goals=fg_goals; stack=bg_goals; shelf; given_up; _ } = data p in + Pp.( + let pr_goal_list = prlist_with_sep spc Goal.pr_goal in + let rec aux acc = function + | [] -> acc + | (before,after)::stack -> + aux (pr_goal_list before ++ spc () ++ str "{" ++ acc ++ str "}" ++ spc () ++ + pr_goal_list after) stack in + str "[" ++ str "focus structure: " ++ + aux (pr_goal_list fg_goals) bg_goals ++ str ";" ++ spc () ++ + str "shelved: " ++ pr_goal_list shelf ++ str ";" ++ spc () ++ + str "given up: " ++ pr_goal_list given_up ++ + str "]" + ) diff --git a/proofs/proof.mli b/proofs/proof.mli index defef57a8d..248b9d921e 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -34,30 +34,6 @@ (* Type of a proof. *) type t -(* Returns a stylised view of a proof for use by, for instance, - ide-s. *) -(* spiwack: the type of [proof] will change as we push more refined - functions to ide-s. This would be better than spawning a new nearly - identical function everytime. Hence the generic name. *) -(* In this version: returns the focused goals, a representation of the - focus stack (the goals at each level), a representation of the - shelf (the list of goals on the shelf), a representation of the - given up goals (the list of the given up goals) and the underlying - evar_map *) -val proof : t -> - Goal.goal list - * (Goal.goal list * Goal.goal list) list - * Goal.goal list - * Goal.goal list - * Evd.evar_map -[@@ocaml.deprecated "use [Proof.data]"] - -val initial_goals : t -> (EConstr.constr * EConstr.types) list -[@@ocaml.deprecated "use [Proof.data]"] - -val initial_euctx : t -> UState.t -[@@ocaml.deprecated "use [Proof.data]"] - type data = { sigma : Evd.evar_map (** A representation of the evar_map [EJGA wouldn't it better to just return the proofview?] *) @@ -81,29 +57,6 @@ type data = val data : t -> data -(* Generic records structured like the return type of proof *) -type 'a pre_goals = { - fg_goals : 'a list; - [@ocaml.deprecated "use [Proof.data]"] - (** List of the focussed goals *) - bg_goals : ('a list * 'a list) list; - [@ocaml.deprecated "use [Proof.data]"] - (** Zipper representing the unfocussed background goals *) - shelved_goals : 'a list; - [@ocaml.deprecated "use [Proof.data]"] - (** List of the goals on the shelf. *) - given_up_goals : 'a list; - [@ocaml.deprecated "use [Proof.data]"] - (** List of the goals that have been given up *) -} -[@@ocaml.deprecated "use [Proof.data]"] - -(* needed in OCaml 4.05.0, not needed in newer ones *) -[@@@ocaml.warning "-3"] -val map_structured_proof : t -> (Evd.evar_map -> Goal.goal -> 'a) -> ('a pre_goals) [@ocaml.warning "-3"] -[@@ocaml.deprecated "use [Proof.data]"] -[@@@ocaml.warning "+3"] - (*** General proof functions ***) val start : name:Names.Id.t @@ -219,7 +172,7 @@ val no_focused_goal : t -> bool used. In which case it is [false]. *) val run_tactic : Environ.env - -> unit Proofview.tactic -> t -> t * (bool*Proofview_monad.Info.tree) + -> 'a Proofview.tactic -> t -> t * (bool*Proofview_monad.Info.tree) * 'a val maximal_unfocus : 'a focus_kind -> t -> t diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 08b98d702a..40ae4acc88 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -345,6 +345,6 @@ let update_global_env (pf : t) = with_current_proof (fun _ p -> Proof.in_proof p (fun sigma -> let tac = Proofview.Unsafe.tclEVARS (Evd.update_sigma_env sigma (Global.env ())) in - let (p,(status,info)) = Proof.run_tactic (Global.env ()) tac p in + let (p,(status,info),()) = Proof.run_tactic (Global.env ()) tac p in (p, ()))) pf in res diff --git a/proofs/refine.ml b/proofs/refine.ml index 06e6b89df1..4a9404aa96 100644 --- a/proofs/refine.ml +++ b/proofs/refine.ml @@ -44,17 +44,6 @@ let typecheck_evar ev env sigma = let sigma, _ = Typing.sort_of env sigma (Evd.evar_concl info) in sigma -(* Get the side-effect's constant declarations to update the monad's - * environmnent *) -let add_if_undefined env eff = - let open Entries in - try ignore(Environ.lookup_constant eff.seff_constant env); env - with Not_found -> Environ.add_constant eff.seff_constant eff.seff_body env - -(* Add the side effects to the monad's environment, if not already done. *) -let add_side_effects env eff = - List.fold_left add_if_undefined env eff - let generic_refine ~typecheck f gl = let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in @@ -71,8 +60,7 @@ let generic_refine ~typecheck f gl = let evs = Evd.save_future_goals sigma in (* Redo the effects in sigma in the monad's env *) let privates_csts = Evd.eval_side_effects sigma in - let sideff = Safe_typing.side_effects_of_private_constants privates_csts in - let env = add_side_effects env sideff in + let env = Safe_typing.push_private_constants env privates_csts in (* Check that the introduced evars are well-typed *) let fold accu ev = typecheck_evar ev env accu in let sigma = if typecheck then Evd.fold_future_goals fold sigma evs else sigma in diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 7b3d9e534b..93031c2202 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -104,10 +104,6 @@ let db_pr_goal sigma g = let pr_gls gls = hov 0 (pr_evar_map (Some 2) (pf_env gls) (sig_sig gls) ++ fnl () ++ db_pr_goal (project gls) (sig_it gls)) -let pr_glls glls = - hov 0 (pr_evar_map (Some 2) (Global.env()) (sig_sig glls) ++ fnl () ++ - prlist_with_sep fnl (db_pr_goal (project glls)) (sig_it glls)) - (* Variants of [Tacmach] functions built with the new proof engine *) module New = struct diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index 218011c316..23e1e6f566 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -68,8 +68,6 @@ val pf_conv_x_leq : Goal.goal sigma -> constr -> constr -> bool (** {6 Pretty-printing functions (debug only). } *) val pr_gls : Goal.goal sigma -> Pp.t -val pr_glls : Goal.goal list sigma -> Pp.t -[@@ocaml.deprecated "Please move to \"new\" proof engine"] (** Variants of [Tacmach] functions built with the new proof engine *) module New : sig diff --git a/stm/proofBlockDelimiter.ml b/stm/proofBlockDelimiter.ml index 2b32838964..04f10e7399 100644 --- a/stm/proofBlockDelimiter.ml +++ b/stm/proofBlockDelimiter.ml @@ -41,8 +41,8 @@ let simple_goal sigma g gs = let open Evd in let open Evarutil in let evi = Evd.find sigma g in - Set.is_empty (evars_of_term (EConstr.Unsafe.to_constr evi.evar_concl)) && - Set.is_empty (evars_of_filtered_evar_info (nf_evar_info sigma evi)) && + Set.is_empty (evars_of_term sigma evi.evar_concl) && + Set.is_empty (evars_of_filtered_evar_info sigma (nf_evar_info sigma evi)) && not (List.exists (Proofview.depends_on sigma g) gs) let is_focused_goal_simple ~doc id = diff --git a/stm/stm.ml b/stm/stm.ml index 3eb6d03529..21618bc044 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -2085,8 +2085,8 @@ end = struct (* {{{ *) let st = Vernacstate.freeze_interp_state ~marshallable:false in stm_fail ~st fail (fun () -> (if time then System.with_time ~batch ~header:(Pp.mt ()) else (fun x -> x)) (fun () -> - ignore(TaskQueue.with_n_workers nworkers (fun queue -> - PG_compat.with_current_proof (fun _ p -> + TaskQueue.with_n_workers nworkers (fun queue -> + PG_compat.simple_with_current_proof (fun _ p -> let Proof.{goals} = Proof.data p in let open TacTask in let res = CList.map_i (fun i g -> @@ -2131,7 +2131,8 @@ end = struct (* {{{ *) if solve then Tacticals.New.tclSOLVE [] else tclUNIT () end) in - Proof.run_tactic (Global.env()) assign_tac p)))) ()) + let p,_,() = Proof.run_tactic (Global.env()) assign_tac p in + p))) ()) end (* }}} *) diff --git a/tactics/abstract.ml b/tactics/abstract.ml index 7a61deba0c..499152f39a 100644 --- a/tactics/abstract.ml +++ b/tactics/abstract.ml @@ -174,7 +174,7 @@ let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = let lem = mkConstU (cst, inst) in let evd = Evd.set_universe_context evd ectx in let open Safe_typing in - let eff = private_con_of_con (Global.safe_env ()) cst in + let eff = private_constant (Global.safe_env ()) Entries.Subproof cst in let effs = concat_private eff Entries.(snd (Future.force const.const_entry_body)) in let solve = diff --git a/tactics/equality.ml b/tactics/equality.ml index f049f8c568..45a4799ea1 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -417,7 +417,7 @@ let leibniz_rewrite_ebindings_clause cls lft2rgt tac c t l with_evars frzevars d find_elim hdcncl lft2rgt dep cls (Some t) >>= fun elim -> general_elim_clause with_evars frzevars tac cls c t l (match lft2rgt with None -> false | Some b -> b) - {elimindex = None; elimbody = (elim,NoBindings); elimrename = None} + {elimindex = None; elimbody = (elim,NoBindings) } end let adjust_rewriting_direction args lft2rgt = diff --git a/tactics/ind_tables.ml b/tactics/ind_tables.ml index 16829482e5..e95778a90d 100644 --- a/tactics/ind_tables.ml +++ b/tactics/ind_tables.ml @@ -147,9 +147,10 @@ let define_individual_scheme_base kind suff f mode idopt (mind,i as ind) = | Some id -> id | None -> add_suffix mib.mind_packets.(i).mind_typename suff in let const = define mode id c (Declareops.inductive_is_polymorphic mib) ctx in + let role = Entries.Schema (ind, kind) in + let neff = Safe_typing.private_constant (Global.safe_env ()) role const in declare_scheme kind [|ind,const|]; - const, Safe_typing.concat_private - (Safe_typing.private_con_of_scheme ~kind (Global.safe_env()) [ind,const]) eff + const, Safe_typing.concat_private neff eff let define_individual_scheme kind mode names (mind,i as ind) = match Hashtbl.find scheme_object_table kind with @@ -163,15 +164,16 @@ let define_mutual_scheme_base kind suff f mode names mind = let ids = Array.init (Array.length mib.mind_packets) (fun i -> try Int.List.assoc i names with Not_found -> add_suffix mib.mind_packets.(i).mind_typename suff) in - let consts = Array.map2 (fun id cl -> - define mode id cl (Declareops.inductive_is_polymorphic mib) ctx) ids cl in + let fold i effs id cl = + let cst = define mode id cl (Declareops.inductive_is_polymorphic mib) ctx in + let role = Entries.Schema ((mind, i), kind)in + let neff = Safe_typing.private_constant (Global.safe_env ()) role cst in + (Safe_typing.concat_private neff effs, cst) + in + let (eff, consts) = Array.fold_left2_map_i fold eff ids cl in let schemes = Array.mapi (fun i cst -> ((mind,i),cst)) consts in declare_scheme kind schemes; - consts, - Safe_typing.concat_private - (Safe_typing.private_con_of_scheme - ~kind (Global.safe_env()) (Array.to_list schemes)) - eff + consts, eff let define_mutual_scheme kind mode names mind = match Hashtbl.find scheme_object_table kind with diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 4aa4d13e1e..6efa1ece9c 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -204,10 +204,7 @@ let inversion_scheme ~name ~poly env sigma t sort dep_option inv_op = (str"Computed inversion goal was not closed in initial signature."); *) let pf = Proof.start ~name ~poly (Evd.from_ctx (evar_universe_context sigma)) [invEnv,invGoal] in - let pf = - fst (Proof.run_tactic env ( - tclTHEN intro (onLastHypId inv_op)) pf) - in + let pf, _, () = Proof.run_tactic env (tclTHEN intro (onLastHypId inv_op)) pf in let pfterm = List.hd (Proof.partial_proof pf) in let global_named_context = Global.named_context_val () in let ownSign = ref begin diff --git a/tactics/ppred.mli b/tactics/ppred.mli index be21236f4e..c68fab5296 100644 --- a/tactics/ppred.mli +++ b/tactics/ppred.mli @@ -6,11 +6,6 @@ val pr_with_occurrences : val pr_short_red_flag : ('a -> Pp.t) -> 'a glob_red_flag -> Pp.t val pr_red_flag : ('a -> Pp.t) -> 'a glob_red_flag -> Pp.t -val pr_red_expr : - ('a -> Pp.t) * ('a -> Pp.t) * ('b -> Pp.t) * ('c -> Pp.t) -> - (string -> Pp.t) -> ('a,'b,'c) red_expr_gen -> Pp.t - [@@ocaml.deprecated "Use pr_red_expr_env instead"] - val pr_red_expr_env : Environ.env -> Evd.evar_map -> (Environ.env -> Evd.evar_map -> 'a -> Pp.t) * (Environ.env -> Evd.evar_map -> 'a -> Pp.t) * diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 806c955591..2bdfc85d6d 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1302,14 +1302,11 @@ let do_replace id = function [Ti] and the first one (resp last one) being [G] whose hypothesis [id] is replaced by P using the proof given by [tac] *) -let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true) - targetid id sigma0 clenv tac = +let clenv_refine_in with_evars targetid id sigma0 clenv tac = let clenv = Clenvtac.clenv_pose_dependent_evars ~with_evars clenv in let clenv = - if with_classes then { clenv with evd = Typeclasses.resolve_typeclasses ~fail:(not with_evars) clenv.env clenv.evd } - else clenv in let new_hyp_typ = clenv_type clenv in if not with_evars then check_unresolved_evars_of_metas sigma0 clenv; @@ -1321,11 +1318,7 @@ let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true) let with_clear = do_replace (Some id) naming in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS (clear_metas clenv.evd)) - (if sidecond_first then - Tacticals.New.tclTHENFIRST - (assert_before_then_gen with_clear naming new_hyp_typ tac) exact_tac - else - Tacticals.New.tclTHENLAST + (Tacticals.New.tclTHENLAST (assert_after_then_gen with_clear naming new_hyp_typ tac) exact_tac) (********************************************) @@ -1360,22 +1353,25 @@ let rec contract_letin_in_lam_header sigma c = | LetIn (x,b,t,c) -> contract_letin_in_lam_header sigma (subst1 b c) | _ -> c -let elimination_clause_scheme with_evars ?(with_classes=true) ?(flags=elim_flags ()) - rename i (elim, elimty, bindings) indclause = - Proofview.Goal.enter begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let elim = contract_letin_in_lam_header sigma elim in - let elimclause = make_clenv_binding env sigma (elim, elimty) bindings in - let indmv = - (match EConstr.kind sigma (nth_arg sigma i elimclause.templval.rebus) with - | Meta mv -> mv - | _ -> user_err ~hdr:"elimination_clause" - (str "The type of elimination clause is not well-formed.")) +let elimination_in_clause_scheme env sigma with_evars ~flags + id hypmv elimclause = + let hyp = mkVar id in + let hyp_typ = Retyping.get_type_of env sigma hyp in + let hypclause = mk_clenv_from_env env sigma (Some 0) (hyp, hyp_typ) in + let elimclause'' = + (* The evarmap of elimclause is assumed to be an extension of hypclause, so + we do not need to merge the universes coming from hypclause. *) + try clenv_fchain ~with_univs:false ~flags hypmv elimclause hypclause + with PretypeError (env,evd,NoOccurrenceFound (op,_)) -> + (* Set the hypothesis name in the message *) + raise (PretypeError (env,evd,NoOccurrenceFound (op,Some id))) in - let elimclause' = clenv_fchain ~flags indmv elimclause indclause in - Clenvtac.res_pf elimclause' ~with_evars ~with_classes ~flags - end + let new_hyp_typ = clenv_type elimclause'' in + if EConstr.eq_constr sigma hyp_typ new_hyp_typ then + user_err ~hdr:"general_rewrite_in" + (str "Nothing to rewrite in " ++ Id.print id ++ str"."); + clenv_refine_in with_evars id id sigma elimclause'' + (fun id -> Proofview.tclUNIT ()) (* * Elimination tactic with bindings and using an arbitrary @@ -1387,11 +1383,10 @@ let elimination_clause_scheme with_evars ?(with_classes=true) ?(flags=elim_flags type eliminator = { elimindex : int option; (* None = find it automatically *) - elimrename : (bool * int array) option; (** None = don't rename Prop hyps with H-names *) elimbody : EConstr.constr with_bindings } -let general_elim_clause_gen elimtac indclause elim = +let general_elim_clause with_evars flags where indclause elim = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in @@ -1399,7 +1394,27 @@ let general_elim_clause_gen elimtac indclause elim = let elimt = Retyping.get_type_of env sigma elimc in let i = match elim.elimindex with None -> index_of_ind_arg sigma elimt | Some i -> i in - elimtac elim.elimrename i (elimc, elimt, lbindelimc) indclause + let elimc = contract_letin_in_lam_header sigma elimc in + let elimclause = make_clenv_binding env sigma (elimc, elimt) lbindelimc in + let indmv = + (match EConstr.kind sigma (nth_arg sigma i elimclause.templval.rebus) with + | Meta mv -> mv + | _ -> user_err ~hdr:"elimination_clause" + (str "The type of elimination clause is not well-formed.")) + in + match where with + | None -> + let elimclause = clenv_fchain ~flags indmv elimclause indclause in + Clenvtac.res_pf elimclause ~with_evars ~with_classes:true ~flags + | Some id -> + let hypmv = + match List.remove Int.equal indmv (clenv_independent elimclause) with + | [a] -> a + | _ -> user_err ~hdr:"elimination_clause" + (str "The type of elimination clause is not well-formed.") + in + let elimclause = clenv_fchain ~flags indmv elimclause indclause in + elimination_in_clause_scheme env sigma with_evars ~flags id hypmv elimclause end let general_elim with_evars clear_flag (c, lbindc) elim = @@ -1408,12 +1423,12 @@ let general_elim with_evars clear_flag (c, lbindc) elim = let sigma = Tacmach.New.project gl in let ct = Retyping.get_type_of env sigma c in let t = try snd (reduce_to_quantified_ind env sigma ct) with UserError _ -> ct in - let elimtac = elimination_clause_scheme with_evars in let indclause = make_clenv_binding env sigma (c, t) lbindc in let sigma = meta_merge sigma (clear_metas indclause.evd) in + let flags = elim_flags () in Proofview.Unsafe.tclEVARS sigma <*> Tacticals.New.tclTHEN - (general_elim_clause_gen elimtac indclause elim) + (general_elim_clause with_evars flags None indclause elim) (apply_clear_request clear_flag (use_clear_hyp_by_default ()) c) end @@ -1436,8 +1451,7 @@ let general_case_analysis_in_context with_evars clear_flag (c,lbindc) = let elim = EConstr.of_constr elim in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (general_elim with_evars clear_flag (c,lbindc) - {elimindex = None; elimbody = (elim,NoBindings); - elimrename = Some (false, constructors_nrealdecls env (fst mind))}) + {elimindex = None; elimbody = (elim,NoBindings); }) end let general_case_analysis with_evars clear_flag (c,lbindc as cx) = @@ -1468,8 +1482,7 @@ let find_eliminator c gl = let ((ind,u),t) = Tacmach.New.pf_reduce_to_quantified_ind gl (Tacmach.New.pf_unsafe_type_of gl c) in if is_nonrec ind then raise IsNonrec; let evd, c = find_ind_eliminator ind (Tacticals.New.elimination_sort_of_goal gl) gl in - evd, {elimindex = None; elimbody = (c,NoBindings); - elimrename = Some (true, constructors_nrealdecls (Global.env()) ind)} + evd, { elimindex = None; elimbody = (c,NoBindings) } let default_elim with_evars clear_flag (c,_ as cx) = Proofview.tclORELSE @@ -1489,7 +1502,7 @@ let default_elim with_evars clear_flag (c,_ as cx) = let elim_in_context with_evars clear_flag c = function | Some elim -> general_elim with_evars clear_flag c - {elimindex = Some (-1); elimbody = elim; elimrename = None} + { elimindex = Some (-1); elimbody = elim } | None -> default_elim with_evars clear_flag c let elim with_evars clear_flag (c,lbindc as cx) elim = @@ -1515,48 +1528,6 @@ let simplest_elim c = default_elim false None (c,NoBindings) (e.g. it could replace id:A->B->C by id:C, knowing A/\B) *) -let clenv_fchain_in id ?(flags=elim_flags ()) mv elimclause hypclause = - (* The evarmap of elimclause is assumed to be an extension of hypclause, so - we do not need to merge the universes coming from hypclause. *) - try clenv_fchain ~with_univs:false ~flags mv elimclause hypclause - with PretypeError (env,evd,NoOccurrenceFound (op,_)) -> - (* Set the hypothesis name in the message *) - raise (PretypeError (env,evd,NoOccurrenceFound (op,Some id))) - -let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) - id rename i (elim, elimty, bindings) indclause = - Proofview.Goal.enter begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in - let elim = contract_letin_in_lam_header sigma elim in - let elimclause = make_clenv_binding env sigma (elim, elimty) bindings in - let indmv = destMeta sigma (nth_arg sigma i elimclause.templval.rebus) in - let hypmv = - match List.remove Int.equal indmv (clenv_independent elimclause) with - | [a] -> a - | _ -> user_err ~hdr:"elimination_clause" - (str "The type of elimination clause is not well-formed.") - in - let elimclause' = clenv_fchain ~flags indmv elimclause indclause in - let hyp = mkVar id in - let hyp_typ = Retyping.get_type_of env sigma hyp in - let hypclause = mk_clenv_from_env env sigma (Some 0) (hyp, hyp_typ) in - let elimclause'' = clenv_fchain_in id ~flags hypmv elimclause' hypclause in - let new_hyp_typ = clenv_type elimclause'' in - if EConstr.eq_constr sigma hyp_typ new_hyp_typ then - user_err ~hdr:"general_rewrite_in" - (str "Nothing to rewrite in " ++ Id.print id ++ str"."); - clenv_refine_in with_evars id id sigma elimclause'' - (fun id -> Proofview.tclUNIT ()) - end - -let general_elim_clause with_evars flags id c e = - let elim = match id with - | None -> elimination_clause_scheme with_evars ~with_classes:true ~flags - | Some id -> elimination_in_clause_scheme with_evars ~flags id - in - general_elim_clause_gen elim c e - (* Apply a tactic below the products of the conclusion of a lemma *) type conjunction_status = @@ -1828,7 +1799,7 @@ let apply_in_once_main flags innerclause env sigma (loc,d,lbind) = in aux (make_clenv_binding env sigma (d,thm) lbind) -let apply_in_once ?(respect_opaque = false) sidecond_first with_delta +let apply_in_once ?(respect_opaque = false) with_delta with_destruct with_evars naming id (clear_flag,{ CAst.loc; v= d,lbind}) tac = let open Context.Rel.Declaration in Proofview.Goal.enter begin fun gl -> @@ -1849,7 +1820,7 @@ let apply_in_once ?(respect_opaque = false) sidecond_first with_delta if with_delta then default_unify_flags () else default_no_delta_unify_flags ts in try let clause = apply_in_once_main flags innerclause env sigma (loc,c,lbind) in - clenv_refine_in ~sidecond_first with_evars targetid id sigma clause + clenv_refine_in with_evars targetid id sigma clause (fun id -> Tacticals.New.tclTHENLIST [ apply_clear_request clear_flag false c; @@ -1866,14 +1837,14 @@ let apply_in_once ?(respect_opaque = false) sidecond_first with_delta aux [] with_destruct d end -let apply_in_delayed_once ?(respect_opaque = false) sidecond_first with_delta +let apply_in_delayed_once ?(respect_opaque = false) with_delta with_destruct with_evars naming id (clear_flag,{CAst.loc;v=f}) tac = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let (sigma, c) = f env sigma in Tacticals.New.tclWITHHOLES with_evars - (apply_in_once ~respect_opaque sidecond_first with_delta with_destruct with_evars + (apply_in_once ~respect_opaque with_delta with_destruct with_evars naming id (clear_flag,CAst.(make ?loc c)) tac) sigma end @@ -2493,7 +2464,7 @@ and intro_pattern_action ?loc with_evars b style pat thin destopt tac id = clear [id] in let f env sigma = let (sigma, c) = f env sigma in (sigma,(c, NoBindings)) in - apply_in_delayed_once false true true with_evars naming id (None,CAst.make ?loc:loc' f) + apply_in_delayed_once true true with_evars naming id (None,CAst.make ?loc:loc' f) (fun id -> Tacticals.New.tclTHENLIST [doclear; tac_ipat id; tac thin None []]) and prepare_intros ?loc with_evars dft destopt = function @@ -2561,10 +2532,10 @@ let assert_as first hd ipat t = (* apply in as *) -let general_apply_in ?(respect_opaque=false) sidecond_first with_delta +let general_apply_in ?(respect_opaque=false) with_delta with_destruct with_evars id lemmas ipat = let tac (naming,lemma) tac id = - apply_in_delayed_once ~respect_opaque sidecond_first with_delta + apply_in_delayed_once ~respect_opaque with_delta with_destruct with_evars naming id lemma tac in Proofview.Goal.enter begin fun gl -> let destopt = @@ -2593,10 +2564,10 @@ let general_apply_in ?(respect_opaque=false) sidecond_first with_delta let apply_in simple with_evars id lemmas ipat = let lemmas = List.map (fun (k,{CAst.loc;v=l}) -> k, CAst.make ?loc (fun _ sigma -> (sigma,l))) lemmas in - general_apply_in false simple simple with_evars id lemmas ipat + general_apply_in simple simple with_evars id lemmas ipat let apply_delayed_in simple with_evars id lemmas ipat = - general_apply_in ~respect_opaque:true false simple simple with_evars id lemmas ipat + general_apply_in ~respect_opaque:true simple simple with_evars id lemmas ipat (*****************************) (* Tactics abstracting terms *) @@ -4183,7 +4154,7 @@ let find_induction_type isrec elim hyp0 gl = let scheme = compute_elim_sig sigma ~elimc elimt in if Option.is_empty scheme.indarg then error "Cannot find induction type"; let indsign = compute_scheme_signature evd scheme hyp0 ind_guess in - let elim = ({elimindex = Some(-1); elimbody = elimc; elimrename = None},elimt) in + let elim = ({ elimindex = Some(-1); elimbody = elimc },elimt) in scheme, ElimUsing (elim,indsign) in match scheme.indref with @@ -4210,10 +4181,7 @@ let get_eliminator elim dep s gl = | ElimOver (isrec,id) -> let evd, (elimc,elimt),_ as elims = guess_elim isrec dep s id gl in let _, (l, s) = compute_elim_signature elims id in - let branchlengthes = List.map (fun d -> assert (RelDecl.is_local_assum d); pi1 (decompose_prod_letin (Tacmach.New.project gl) (RelDecl.get_type d))) - (List.rev s.branches) - in - evd, isrec, ({elimindex = None; elimbody = elimc; elimrename = Some (isrec,Array.of_list branchlengthes)}, elimt), l + evd, isrec, ({ elimindex = None; elimbody = elimc }, elimt), l (* Instantiate all meta variables of elimclause using lid, some elts of lid are parameters (first ones), the other are @@ -4257,7 +4225,7 @@ let recolle_clenv i params args elimclause gl = let induction_tac with_evars params indvars elim = Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in - let ({elimindex=i;elimbody=(elimc,lbindelimc);elimrename=rename},elimt) = elim in + let ({ elimindex=i;elimbody=(elimc,lbindelimc) },elimt) = elim in let i = match i with None -> index_of_ind_arg sigma elimt | Some i -> i in (* elimclause contains this: (elimc ?i ?j ?k...?l) *) let elimc = contract_letin_in_lam_header sigma elimc in @@ -4362,7 +4330,7 @@ let induction_without_atomization isrec with_evars elim names lid = (* FIXME: Tester ca avec un principe dependant et non-dependant *) induction_tac with_evars params realindvars elim; ] in - let elim = ElimUsing (({elimindex = Some (-1); elimbody = Option.get scheme.elimc; elimrename = None}, scheme.elimt), indsign) in + let elim = ElimUsing (({ elimindex = Some (-1); elimbody = Option.get scheme.elimc }, scheme.elimt), indsign) in apply_induction_in_context with_evars None [] elim indvars names induct_tac end diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 9eb8196280..32c64bacf6 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -282,7 +282,6 @@ val compute_elim_sig : evar_map -> ?elimc:constr with_bindings -> types -> elim_ (** elim principle with the index of its inductive arg *) type eliminator = { elimindex : int option; (** None = find it automatically *) - elimrename : (bool * int array) option; (** None = don't rename Prop hyps with H-names *) elimbody : constr with_bindings } diff --git a/test-suite/bugs/closed/bug_10026.v b/test-suite/bugs/closed/bug_10026.v new file mode 100644 index 0000000000..0d3142d0f2 --- /dev/null +++ b/test-suite/bugs/closed/bug_10026.v @@ -0,0 +1,3 @@ +Require Import Coq.Lists.List. +Set Debug RAKAM. +Check fun _ => fold_right (fun A B => prod A B) unit _. diff --git a/test-suite/bugs/closed/bug_10189.v b/test-suite/bugs/closed/bug_10189.v new file mode 100644 index 0000000000..d603bff386 --- /dev/null +++ b/test-suite/bugs/closed/bug_10189.v @@ -0,0 +1,9 @@ +Definition foo : forall (x := unit) {y : nat}, nat := fun y => y. +Check foo (y := 3). (*We fail to get implicits in the type past a let-in*) +Definition foo' : forall (x : Set) {y : nat}, nat := fun _ y => y. +Check foo' unit (y := 3). (* It works with a function binder *) + +Definition bar := let f {x} : nat -> nat := fun y => x in f (x := 3). +(* Adding bar : nat -> nat gives implicits-in-term warning *) +Fail Check bar (x := 3). +(* The implicits from the type of the local definition leak to the outer term *) diff --git a/test-suite/bugs/opened/bug_3754.v b/test-suite/bugs/closed/bug_3754.v index 18820b1a4c..7031cbf132 100644 --- a/test-suite/bugs/opened/bug_3754.v +++ b/test-suite/bugs/closed/bug_3754.v @@ -281,5 +281,7 @@ Defined. (factor2 fact)). rewrite <- ap_p_pp; rewrite_moveL_Mp_p. Set Debug Tactic Unification. - Fail rewrite (concat_Ap ff2). + rewrite (concat_Ap ff2). Abort. + +End Factorization. diff --git a/test-suite/dune b/test-suite/dune index c430400ba5..cd33319fa4 100644 --- a/test-suite/dune +++ b/test-suite/dune @@ -20,6 +20,8 @@ ../dev/header.ml ../dev/tools/update-compat.py ../doc/stdlib/index-list.html.template + ; For the changelog test + ../config/coq_config.py (package coq) ; For fake_ide (package coqide-server) diff --git a/test-suite/misc/changelog.sh b/test-suite/misc/changelog.sh new file mode 100755 index 0000000000..8b4a49e577 --- /dev/null +++ b/test-suite/misc/changelog.sh @@ -0,0 +1,18 @@ +#!/bin/sh + +while read line; do + if [ "$line" = "is_a_released_version = False" ]; then + echo "This is not a released version: nothing to test." + exit 0 + fi +done < ../config/coq_config.py + +for d in ../doc/changelog/*; do + if [ -d "$d" ]; then + if [ "$(ls $d/*.rst | wc -l)" != "1" ]; then + echo "Fatal: unreleased changelog entries remain in ${d#../}/" + echo "Include them in doc/sphinx/changes.rst and remove them from doc/changelog/" + exit 1 + fi + fi +done diff --git a/test-suite/output/Notations4.out b/test-suite/output/Notations4.out index 9d972a68f7..c1b9a2b1c6 100644 --- a/test-suite/output/Notations4.out +++ b/test-suite/output/Notations4.out @@ -1,5 +1,15 @@ [< 0 > + < 1 > * < 2 >] : nat +Entry constr:myconstr is +[ "6" RIGHTA + [ ] +| "5" RIGHTA + [ SELF; "+"; NEXT ] +| "4" RIGHTA + [ SELF; "*"; NEXT ] +| "3" RIGHTA + [ "<"; constr:operconstr LEVEL "10"; ">" ] ] + [< b > + < b > * < 2 >] : nat [<< # 0 >>] diff --git a/test-suite/output/Notations4.v b/test-suite/output/Notations4.v index 81c64418cb..d1063bfd04 100644 --- a/test-suite/output/Notations4.v +++ b/test-suite/output/Notations4.v @@ -9,6 +9,7 @@ Notation "x + y" := (Nat.add x y) (in custom myconstr at level 5). Notation "x * y" := (Nat.mul x y) (in custom myconstr at level 4). Notation "< x >" := x (in custom myconstr at level 3, x constr at level 10). Check [ < 0 > + < 1 > * < 2 >]. +Print Custom Grammar myconstr. Axiom a : nat. Notation b := a. diff --git a/test-suite/success/Notations2.v b/test-suite/success/Notations2.v index 2533a39cc4..d047f7560e 100644 --- a/test-suite/success/Notations2.v +++ b/test-suite/success/Notations2.v @@ -151,8 +151,8 @@ Module M16. Local Notation "##" := 0 (in custom foo2). (* Test Print Grammar *) - Print Grammar foo. - Print Grammar foo2. + Print Custom Grammar foo. + Print Custom Grammar foo2. End M16. (* Example showing the need for strong evaluation of diff --git a/test-suite/success/attribute_syntax.v b/test-suite/success/attribute_syntax.v index f4f59a3c16..4717759dec 100644 --- a/test-suite/success/attribute_syntax.v +++ b/test-suite/success/attribute_syntax.v @@ -20,6 +20,10 @@ Check ι _ ι. Fixpoint f (n: nat) {wf lt n} : nat := _. Reset f. +#[program(true)] +Fixpoint f (n: nat) {wf lt n} : nat := _. +Reset f. + #[deprecated(since="8.9.0")] Ltac foo := foo. diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index 9a18baa0bc..ec43dbb1d7 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -184,10 +184,6 @@ let warn_deprecated_inputstate = CWarnings.create ~name:"deprecated-inputstate" ~category:"deprecated" (fun () -> Pp.strbrk "The inputstate option is deprecated and discouraged.") -let warn_deprecated_boot = - CWarnings.create ~name:"deprecated-boot" ~category:"noop" - (fun () -> Pp.strbrk "The -boot option is deprecated, please use -q and/or -coqlib options instead.") - let set_inputstate opts s = warn_deprecated_inputstate (); { opts with inputstate = Some s } @@ -488,9 +484,6 @@ let parse_args ~help ~init arglist : t * string list = { oval with batch = true } |"-test-mode" -> Vernacentries.test_mode := true; oval |"-beautify" -> Flags.beautify := true; oval - |"-boot" -> - warn_deprecated_boot (); - { oval with load_rcfile = false; } |"-bt" -> Backtrace.record_backtrace true; oval |"-color" -> set_color oval (next ()) |"-config"|"--config" -> { oval with print_config = true } diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 9323a57417..b769405cf6 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -271,31 +271,6 @@ let init_toploop opts = let state = { doc; sid; proof = None; time = opts.time } in Ccompile.load_init_vernaculars opts ~state, opts -(* To remove in 8.11 *) -let call_coqc args = - let remove str arr = Array.(of_list List.(filter (fun l -> not String.(equal l str)) (to_list arr))) in - let coqc_name = Filename.remove_extension (System.get_toplevel_path "coqc") in - let args = remove "-compile" args in - Unix.execv coqc_name args - -let deprecated_coqc_warning = CWarnings.(create - ~name:"deprecate-compile-arg" - ~category:"toplevel" - ~default:Enabled - (fun opt_name -> Pp.(seq [str "The option "; str opt_name; str" is deprecated, please use coqc."]))) - -let rec coqc_deprecated_check args acc extras = - match extras with - | [] -> acc - | "-o" :: _ :: rem -> - deprecated_coqc_warning "-o"; - coqc_deprecated_check args acc rem - | ("-compile"|"-compile-verbose") :: file :: rem -> - deprecated_coqc_warning "-compile"; - call_coqc args - | x :: rem -> - coqc_deprecated_check args (x::acc) rem - let coqtop_init ~opts extra = init_color opts; CoqworkmgrApi.(init !async_proofs_worker_priority); @@ -317,7 +292,6 @@ let start_coq custom = init_toplevel ~help:Usage.print_usage_coqtop ~init:default custom.init (List.tl (Array.to_list Sys.argv)) in - let extras = coqc_deprecated_check Sys.argv [] extras in if not (CList.is_empty extras) then begin prerr_endline ("Don't know what to do with "^String.concat " " extras); prerr_endline "See -help for the list of supported options"; diff --git a/toplevel/usage.ml b/toplevel/usage.ml index 7074215afe..da2094653b 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -102,12 +102,6 @@ let print_usage_coqtop () = coqtop specific options:\ \n\ \n -batch batch mode (exits just after argument parsing)\ -\n\ -\nDeprecated options [use coqc instead]:\ -\n\ -\n -compile f.v compile Coq file f.v (implies -batch)\ -\n -compile-verbose f.v verbosely compile Coq file f.v (implies -batch)\ -\n -o f.vo use f.vo as the output file name\ \n"; flush stderr ; exit 1 @@ -128,14 +122,6 @@ coqc specific options:\ \nUndocumented:\ \n -vio2vo [see manual]\ \n -check-vio-tasks [see manual]\ -\n\ -\nDeprecated options:\ -\n\ -\n -image f specify an alternative executable for Coq\ -\n -opt run the native-code version of Coq\ -\n -byte run the bytecode version of Coq\ -\n -t keep temporary files\ -\n -outputstate file save summary state in file \ \n"; flush stderr ; exit 1 diff --git a/user-contrib/Ltac2/Constr.v b/user-contrib/Ltac2/Constr.v index d8d222730e..1701bf4365 100644 --- a/user-contrib/Ltac2/Constr.v +++ b/user-contrib/Ltac2/Constr.v @@ -38,6 +38,7 @@ Ltac2 Type kind := [ | Fix (int array, int, ident option array, constr array, constr array) | CoFix (int, ident option array, constr array, constr array) | Proj (projection, constr) +| Uint63 (uint63) ]. Ltac2 @ external kind : constr -> kind := "ltac2" "constr_kind". diff --git a/user-contrib/Ltac2/Init.v b/user-contrib/Ltac2/Init.v index 16e7d7a6f9..dc1690bdfb 100644 --- a/user-contrib/Ltac2/Init.v +++ b/user-contrib/Ltac2/Init.v @@ -14,6 +14,7 @@ Ltac2 Type int. Ltac2 Type string. Ltac2 Type char. Ltac2 Type ident. +Ltac2 Type uint63. (** Constr-specific built-in types *) Ltac2 Type meta. diff --git a/user-contrib/Ltac2/tac2core.ml b/user-contrib/Ltac2/tac2core.ml index d7e7b91ee6..da8600109e 100644 --- a/user-contrib/Ltac2/tac2core.ml +++ b/user-contrib/Ltac2/tac2core.ml @@ -424,8 +424,8 @@ let () = define1 "constr_kind" constr begin fun c -> Value.of_ext Value.val_projection p; Value.of_constr c; |] - | Int _ -> - assert false + | Int n -> + v_blk 17 [|Value.of_uint63 n|] end end @@ -503,6 +503,9 @@ let () = define1 "constr_make" valexpr begin fun knd -> let p = Value.to_ext Value.val_projection p in let c = Value.to_constr c in EConstr.mkProj (p, c) + | (17, [|n|]) -> + let n = Value.to_uint63 n in + EConstr.mkInt n | _ -> assert false in return (Value.of_constr c) diff --git a/user-contrib/Ltac2/tac2entries.ml b/user-contrib/Ltac2/tac2entries.ml index 9fd01426de..254c2e5086 100644 --- a/user-contrib/Ltac2/tac2entries.ml +++ b/user-contrib/Ltac2/tac2entries.ml @@ -740,7 +740,6 @@ let register_redefinition ?(local = false) qid e = Lib.add_anonymous_leaf (inTac2Redefinition def) let perform_eval ~pstate e = - let open Proofview.Notations in let env = Global.env () in let (e, ty) = Tac2intern.intern ~strict:false e in let v = Tac2interp.interp Tac2interp.empty_environment e in @@ -761,12 +760,8 @@ let perform_eval ~pstate e = | Goal_select.SelectAll -> v | Goal_select.SelectAlreadyFocused -> assert false (* TODO **) in - (* HACK: the API doesn't allow to return a value *) - let ans = ref None in - let tac = (v >>= fun r -> ans := Some r; Proofview.tclUNIT ()) in - let (proof, _) = Proof.run_tactic (Global.env ()) tac proof in + let (proof, _, ans) = Proof.run_tactic (Global.env ()) v proof in let sigma = Proof.in_proof proof (fun sigma -> sigma) in - let ans = match !ans with None -> assert false | Some r -> r in let name = int_name () in Feedback.msg_notice (str "- : " ++ pr_glbtype name (snd ty) ++ spc () ++ str "=" ++ spc () ++ diff --git a/user-contrib/Ltac2/tac2ffi.ml b/user-contrib/Ltac2/tac2ffi.ml index e3127ab9df..1043d25a75 100644 --- a/user-contrib/Ltac2/tac2ffi.ml +++ b/user-contrib/Ltac2/tac2ffi.ml @@ -30,6 +30,8 @@ type valexpr = (** Open constructors *) | ValExt : 'a Tac2dyn.Val.tag * 'a -> valexpr (** Arbitrary data *) +| ValUint63 of Uint63.t + (** Primitive integers *) and closure = MLTactic : (valexpr, 'v) arity0 * 'v -> closure @@ -47,21 +49,21 @@ type t = valexpr let is_int = function | ValInt _ -> true -| ValBlk _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ -> false +| ValBlk _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ | ValUint63 _ -> false let tag v = match v with | ValBlk (n, _) -> n -| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ -> +| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ | ValUint63 _ -> CErrors.anomaly (Pp.str "Unexpected value shape") let field v n = match v with | ValBlk (_, v) -> v.(n) -| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ -> +| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ | ValUint63 _ -> CErrors.anomaly (Pp.str "Unexpected value shape") let set_field v n w = match v with | ValBlk (_, v) -> v.(n) <- w -| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ -> +| ValInt _ | ValStr _ | ValCls _ | ValOpn _ | ValExt _ | ValUint63 _ -> CErrors.anomaly (Pp.str "Unexpected value shape") let make_block tag v = ValBlk (tag, v) @@ -192,7 +194,7 @@ let of_closure cls = ValCls cls let to_closure = function | ValCls cls -> cls -| ValExt _ | ValInt _ | ValBlk _ | ValStr _ | ValOpn _ -> assert false +| ValExt _ | ValInt _ | ValBlk _ | ValStr _ | ValOpn _ | ValUint63 _ -> assert false let closure = { r_of = of_closure; @@ -318,6 +320,17 @@ let open_ = { r_id = false; } +let of_uint63 n = ValUint63 n +let to_uint63 = function +| ValUint63 n -> n +| _ -> assert false + +let uint63 = { + r_of = of_uint63; + r_to = to_uint63; + r_id = false; +} + let of_constant c = of_ext val_constant c let to_constant c = to_ext val_constant c let constant = repr_ext val_constant diff --git a/user-contrib/Ltac2/tac2ffi.mli b/user-contrib/Ltac2/tac2ffi.mli index bfc93d99e6..f8581061a0 100644 --- a/user-contrib/Ltac2/tac2ffi.mli +++ b/user-contrib/Ltac2/tac2ffi.mli @@ -28,6 +28,8 @@ type valexpr = (** Open constructors *) | ValExt : 'a Tac2dyn.Val.tag * 'a -> valexpr (** Arbitrary data *) +| ValUint63 of Uint63.t + (** Primitive integers *) type 'a arity @@ -143,6 +145,10 @@ val of_open : KerName.t * valexpr array -> valexpr val to_open : valexpr -> KerName.t * valexpr array val open_ : (KerName.t * valexpr array) repr +val of_uint63 : Uint63.t -> valexpr +val to_uint63 : valexpr -> Uint63.t +val uint63 : Uint63.t repr + type ('a, 'b) fun1 val app_fun1 : ('a, 'b) fun1 -> 'a repr -> 'b repr -> 'a -> 'b Proofview.tactic diff --git a/vernac/attributes.ml b/vernac/attributes.ml index 9b8c4efb37..1ad5862d5d 100644 --- a/vernac/attributes.ml +++ b/vernac/attributes.ml @@ -82,9 +82,12 @@ let assert_empty k v = if v <> VernacFlagEmpty then user_err Pp.(str "Attribute " ++ str k ++ str " does not accept arguments") +let error_twice ~name : 'a = + user_err Pp.(str "Attribute for " ++ str name ++ str " specified twice.") + let assert_once ~name prev = if Option.has_some prev then - user_err Pp.(str "Attribute for " ++ str name ++ str " specified twice.") + error_twice ~name let attribute_of_list (l:(string * 'a key_parser) list) : 'a option attribute = let rec p extra v = function @@ -107,6 +110,24 @@ 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)] +(* 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 + | _ -> user_err Pp.(str "Attribute " ++ str key ++ str " only accepts boolean values.") + +let enable_attribute ~key ~default : bool attribute = + fun atts -> + let default = default () in + let this, extra = List.partition (fun (k, _) -> String.equal key k) atts in + extra, + match this with + | [] -> default + | [ _, value ] -> get_bool_value ~key ~default:true value + | _ -> error_twice ~name:key + let qualify_attribute qual (parser:'a attribute) : 'a attribute = fun atts -> let rec extract extra qualified = function @@ -139,11 +160,8 @@ let () = let open Goptions in optread = (fun () -> !program_mode); optwrite = (fun b -> program_mode:=b) } -let program_opt = bool_attribute ~name:"Program mode" ~on:"program" ~off:"noprogram" - -let program = program_opt >>= function - | Some b -> return b - | None -> return (!program_mode) +let program = + enable_attribute ~key:"program" ~default:(fun () -> !program_mode) let locality = bool_attribute ~name:"Locality" ~on:"local" ~off:"global" @@ -219,3 +237,6 @@ let only_polymorphism atts = parse polymorphic atts let vernac_polymorphic_flag = ukey, VernacFlagList ["polymorphic", VernacFlagEmpty] let vernac_monomorphic_flag = ukey, VernacFlagList ["monomorphic", VernacFlagEmpty] + +let canonical = + enable_attribute ~key:"canonical" ~default:(fun () -> true) diff --git a/vernac/attributes.mli b/vernac/attributes.mli index 3cb4d69ca0..44688ddafc 100644 --- a/vernac/attributes.mli +++ b/vernac/attributes.mli @@ -52,6 +52,7 @@ val program : bool attribute val template : bool option attribute val locality : bool option attribute val deprecation : deprecation option attribute +val canonical : bool attribute val program_mode_option_name : string list (** For internal use when messing with the global option. *) diff --git a/vernac/classes.ml b/vernac/classes.ml index 9f233a2551..ece9fc8937 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -374,6 +374,7 @@ let declare_instance_open ~pstate env sigma ?hook ~tac ~program_mode ~global ~po let obls, constr, typ = match term with | Some t -> + let termtype = EConstr.of_constr termtype in let obls, _, constr, typ = Obligations.eterm_obligations env id sigma 0 t termtype in obls, Some constr, typ @@ -400,7 +401,7 @@ let declare_instance_open ~pstate env sigma ?hook ~tac ~program_mode ~global ~po if not (Option.is_empty term) then let init_refine = Tacticals.New.tclTHENLIST [ - Refine.refine ~typecheck:false (fun sigma -> (sigma,EConstr.of_constr (Option.get term))); + Refine.refine ~typecheck:false (fun sigma -> (sigma, Option.get term)); Proofview.Unsafe.tclNEWGOALS (CList.map Proofview.with_empty_state gls); Tactics.New.reduce_after_refine; ] @@ -497,10 +498,10 @@ let do_instance ~pstate env env' sigma ?hook ~refine ~tac ~global ~poly ~program (* Check that the type is free of evars now. *) Pretyping.check_evars env (Evd.from_env env) sigma termtype; let termtype = to_constr sigma termtype in - let term = Option.map (to_constr ~abort_on_undefined_evars:false sigma) term in let pstate = if not (Evd.has_undefined sigma) && not (Option.is_empty props) then - (declare_instance_constant k pri global imps ?hook id decl poly sigma (Option.get term) termtype; + let term = to_constr sigma (Option.get term) in + (declare_instance_constant k pri global imps ?hook id decl poly sigma term termtype; None) else if program_mode || refine || Option.is_empty props then declare_instance_open ~pstate env sigma ?hook ~tac ~program_mode ~global ~poly k id pri imps decl (List.map RelDecl.get_name ctx) term termtype diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index 12df3215ad..d2c986fe5c 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -88,11 +88,12 @@ let do_definition ~ontop ~program_mode ?hook ident k univdecl bl red_option c ct let (c,ctx), sideff = Future.force ce.const_entry_body in assert(Safe_typing.empty_private_constants = sideff); assert(Univ.ContextSet.is_empty ctx); + Obligations.check_evars env evd; + let c = EConstr.of_constr c in let typ = match ce.const_entry_type with - | Some t -> t - | None -> EConstr.to_constr ~abort_on_undefined_evars:false evd (Retyping.get_type_of env evd (EConstr.of_constr c)) + | Some t -> EConstr.of_constr t + | None -> Retyping.get_type_of env evd c in - Obligations.check_evars env evd; let obls, _, c, cty = Obligations.eterm_obligations env ident evd 0 c typ in diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index 20a2db7ca2..69e2a209eb 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -230,12 +230,9 @@ let build_wellfounded (recname,pl,bl,arityc,body) poly r measure notation = in (* XXX: Capturing sigma here... bad bad *) let hook = Lemmas.mk_hook (hook sigma) in - (* XXX: Grounding non-ground terms here... bad bad *) - let fullcoqc = EConstr.to_constr ~abort_on_undefined_evars:false sigma def in - let fullctyp = EConstr.to_constr ~abort_on_undefined_evars:false sigma typ in Obligations.check_evars env sigma; let evars, _, evars_def, evars_typ = - Obligations.eterm_obligations env recname sigma 0 fullcoqc fullctyp + Obligations.eterm_obligations env recname sigma 0 def typ in let ctx = Evd.evar_universe_context sigma in ignore(Obligations.add_definition recname ~term:evars_def ~univdecl:decl @@ -246,7 +243,7 @@ let out_def = function | None -> user_err Pp.(str "Program Fixpoint needs defined bodies.") let collect_evars_of_term evd c ty = - let evars = Evar.Set.union (Evd.evars_of_term c) (Evd.evars_of_term ty) in + let evars = Evar.Set.union (Evd.evars_of_term evd c) (Evd.evars_of_term evd ty) in Evar.Set.fold (fun ev acc -> Evd.add acc ev (Evd.find_undefined evd ev)) evars (Evd.from_ctx (Evd.evar_universe_context evd)) @@ -262,17 +259,13 @@ let do_program_recursive local poly fixkind fixl ntns = let evd = nf_evar_map_undefined evd in let collect_evars id def typ imps = (* Generalize by the recursive prototypes *) - let def = - EConstr.to_constr ~abort_on_undefined_evars:false evd (Termops.it_mkNamedLambda_or_LetIn def rec_sign) - and typ = - (* Worrying... *) - EConstr.to_constr ~abort_on_undefined_evars:false evd (Termops.it_mkNamedProd_or_LetIn typ rec_sign) - in + let def = nf_evar evd (Termops.it_mkNamedLambda_or_LetIn def rec_sign) in + let typ = nf_evar evd (Termops.it_mkNamedProd_or_LetIn typ rec_sign) in let evm = collect_evars_of_term evd def typ in let evars, _, def, typ = Obligations.eterm_obligations env id evm - (List.length rec_sign) def typ - in (id, def, typ, imps, evars) + (List.length rec_sign) def typ in + (id, def, typ, imps, evars) in let (fixnames,fixrs,fixdefs,fixtypes) = fix in let fiximps = List.map pi2 info in diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 59d2a66259..6438b48e32 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -43,6 +43,7 @@ let query_command = Entry.create "vernac:query_command" let subprf = Entry.create "vernac:subprf" +let quoted_attributes = Entry.create "vernac:quoted_attributes" let class_rawexpr = Entry.create "vernac:class_rawexpr" let thm_token = Entry.create "vernac:thm_token" let def_body = Entry.create "vernac:def_body" @@ -75,7 +76,7 @@ let parse_compat_version = let open Flags in function } GRAMMAR EXTEND Gram - GLOBAL: vernac_control gallina_ext noedit_mode subprf; + GLOBAL: vernac_control quoted_attributes gallina_ext noedit_mode subprf; vernac_control: FIRST [ [ IDENT "Time"; c = vernac_control -> { CAst.make ~loc @@ VernacTime (false,c) } | IDENT "Redirect"; s = ne_string; c = vernac_control -> { CAst.make ~loc @@ VernacRedirect (s, c) } @@ -447,10 +448,12 @@ GRAMMAR EXTEND Gram *) (* ... with coercions *) record_field: - [ [ bd = record_binder; rf_priority = OPT [ "|"; n = natural -> { n } ]; + [ [ attr = LIST0 quoted_attributes ; + bd = record_binder; rf_priority = OPT [ "|"; n = natural -> { n } ]; rf_notation = decl_notation -> { + let rf_canonical = attr |> List.flatten |> parse canonical in let rf_subclass, rf_decl = bd in - rf_decl, { rf_subclass ; rf_priority ; rf_notation } } ] ] + rf_decl, { rf_subclass ; rf_priority ; rf_notation ; rf_canonical } } ] ] ; record_fields: [ [ f = record_field; ";"; fs = record_fields -> { f :: fs } @@ -1003,6 +1006,9 @@ GRAMMAR EXTEND Gram | IDENT "Grammar"; ent = IDENT -> (* This should be in "syntax" section but is here for factorization*) { PrintGrammar ent } + | IDENT "Custom"; IDENT "Grammar"; ent = IDENT -> + (* Should also be in "syntax" section *) + { PrintCustomGrammar ent } | IDENT "LoadPath"; dir = OPT dirpath -> { PrintLoadPath dir } | IDENT "Modules" -> { user_err Pp.(str "Print Modules is obsolete; use Print Libraries instead") } diff --git a/vernac/himsg.ml b/vernac/himsg.ml index f58eeae6dc..b2382ce6fc 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -1348,9 +1348,6 @@ let explain_pattern_matching_error env sigma = function | CannotInferPredicate typs -> explain_cannot_infer_predicate env sigma typs -let map_pguard_error = map_pguard_error -let map_ptype_error = map_ptype_error - let explain_reduction_tactic_error = function | Tacred.InvalidAbstraction (env,sigma,c,(env',e)) -> let e = map_ptype_error EConstr.of_constr e in diff --git a/vernac/himsg.mli b/vernac/himsg.mli index d0f42ea16b..d1c1c092e3 100644 --- a/vernac/himsg.mli +++ b/vernac/himsg.mli @@ -43,9 +43,4 @@ val explain_module_error : Modops.module_typing_error -> Pp.t val explain_module_internalization_error : Modintern.module_internalization_error -> Pp.t -val map_pguard_error : ('c -> 'd) -> 'c pguard_error -> 'd pguard_error -[@@ocaml.deprecated "Use [Type_errors.map_pguard_error]."] -val map_ptype_error : ('c -> 'd) -> ('c, 'c) ptype_error -> ('d, 'd) ptype_error -[@@ocaml.deprecated "Use [Type_errors.map_ptype_error]."] - val explain_prim_token_notation_error : string -> env -> Evd.evar_map -> Notation.prim_token_notation_error -> Pp.t diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 1c7cc5e636..317cf487cc 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -75,13 +75,7 @@ let adjust_guardness_conditions const = function List.interval 0 (List.length ((lam_assum c)))) lemma_guard (Array.to_list fixdefs) in *) - let fold env eff = - try - let _ = Environ.lookup_constant eff.seff_constant env in - env - with Not_found -> Environ.add_constant eff.seff_constant eff.seff_body env - in - let env = List.fold_left fold env (Safe_typing.side_effects_of_private_constants eff) in + let env = Safe_typing.push_private_constants env eff in let indexes = search_guard env possible_indexes fixdecls in @@ -395,10 +389,10 @@ let start_proof_with_initialization ~ontop ?hook kind sigma decl recguard thms s maybe_declare_manual_implicits false ref imps; call_hook ?hook ctx [] strength ref) thms_data in let pstate = start_proof ~ontop id ~pl:decl kind sigma t ~hook ~compute_guard:guard in - let pstate, _ = Proof_global.with_current_proof (fun _ p -> + let pstate = Proof_global.simple_with_current_proof (fun _ p -> match init_tac with - | None -> p,(true,[]) - | Some tac -> Proof.run_tactic Global.(env ()) tac p) pstate in + | None -> p + | Some tac -> pi1 @@ Proof.run_tactic Global.(env ()) tac p) pstate in pstate let start_proof_com ~program_mode ~ontop ?inference_hook ?hook kind thms = diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 843296d24e..50914959dc 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -50,10 +50,10 @@ let pr_entry e = str (Buffer.contents entry_buf) let pr_registered_grammar name = - let gram = try Some (Pcoq.find_grammars_by_name name) with Not_found -> None in + let gram = Pcoq.find_grammars_by_name name in match gram with - | None -> user_err Pp.(str "Unknown or unprintable grammar entry.") - | Some entries -> + | [] -> user_err Pp.(str "Unknown or unprintable grammar entry.") + | entries -> let pr_one (Pcoq.AnyEntry e) = str "Entry " ++ str (Pcoq.Entry.name e) ++ str " is" ++ fnl () ++ pr_entry e @@ -85,6 +85,8 @@ let pr_grammar = function pr_entry Pvernac.Vernac_.gallina_ext | name -> pr_registered_grammar name +let pr_custom_grammar name = pr_registered_grammar ("constr:"^name) + (**********************************************************************) (* Parse a format (every terminal starting with a letter or a single quote (except a single quote alone) must be quoted) *) diff --git a/vernac/metasyntax.mli b/vernac/metasyntax.mli index 38dbdf7e41..6435df23c7 100644 --- a/vernac/metasyntax.mli +++ b/vernac/metasyntax.mli @@ -57,6 +57,7 @@ val add_syntactic_definition : env -> Id.t -> Id.t list * constr_expr -> (** Print the Camlp5 state of a grammar *) val pr_grammar : string -> Pp.t +val pr_custom_grammar : string -> Pp.t val check_infix_modifiers : syntax_modifier list -> unit diff --git a/vernac/obligations.ml b/vernac/obligations.ml index 1b1c618dc7..f768278dd7 100644 --- a/vernac/obligations.ml +++ b/vernac/obligations.ml @@ -39,7 +39,7 @@ let check_evars env evm = type oblinfo = { ev_name: int * Id.t; - ev_hyps: Constr.named_context; + ev_hyps: EConstr.named_context; ev_status: bool * Evar_kinds.obligation_definition_status; ev_chop: int option; ev_src: Evar_kinds.t Loc.located; @@ -50,11 +50,11 @@ type oblinfo = (** Substitute evar references in t using de Bruijn indices, where n binders were passed through. *) -let subst_evar_constr evs n idf t = +let subst_evar_constr evm evs n idf t = let seen = ref Int.Set.empty in let transparent = ref Id.Set.empty in let evar_info id = List.assoc_f Evar.equal id evs in - let rec substrec (depth, fixrels) c = match Constr.kind c with + let rec substrec (depth, fixrels) c = match EConstr.kind evm c with | Evar (k, args) -> let { ev_name = (id, idstr) ; ev_hyps = hyps ; ev_chop = chop } = @@ -84,18 +84,18 @@ let subst_evar_constr evs n idf t = in aux hyps args [] in if List.exists - (fun x -> match Constr.kind x with + (fun x -> match EConstr.kind evm x with | Rel n -> Int.List.mem n fixrels | _ -> false) args then transparent := Id.Set.add idstr !transparent; - mkApp (idf idstr, Array.of_list args) + EConstr.mkApp (idf idstr, Array.of_list args) | Fix _ -> - Constr.map_with_binders succfix substrec (depth, 1 :: fixrels) c - | _ -> Constr.map_with_binders succfix substrec (depth, fixrels) c + EConstr.map_with_binders evm succfix substrec (depth, 1 :: fixrels) c + | _ -> EConstr.map_with_binders evm succfix substrec (depth, fixrels) c in let t' = substrec (0, []) t in - t', !seen, !transparent + EConstr.to_constr evm t', !seen, !transparent (** Substitute variable references in t using de Bruijn indices, @@ -112,18 +112,18 @@ let subst_vars acc n t = to a product : forall H1 : t1, ..., forall Hn : tn, concl. Changes evars and hypothesis references to variable references. *) -let etype_of_evar evs hyps concl = +let etype_of_evar evm evs hyps concl = let open Context.Named.Declaration in let rec aux acc n = function decl :: tl -> - let t', s, trans = subst_evar_constr evs n mkVar (NamedDecl.get_type decl) in + let t', s, trans = subst_evar_constr evm evs n EConstr.mkVar (NamedDecl.get_type decl) in let t'' = subst_vars acc 0 t' in let rest, s', trans' = aux (NamedDecl.get_id decl :: acc) (succ n) tl in let s' = Int.Set.union s s' in let trans' = Id.Set.union trans trans' in (match decl with | LocalDef (id,c,_) -> - let c', s'', trans'' = subst_evar_constr evs n mkVar c in + let c', s'', trans'' = subst_evar_constr evm evs n EConstr.mkVar c in let c' = subst_vars acc 0 c' in mkNamedProd_or_LetIn (LocalDef (id, c', t'')) rest, Int.Set.union s'' s', @@ -131,7 +131,7 @@ let etype_of_evar evs hyps concl = | LocalAssum (id,_) -> mkNamedProd_or_LetIn (LocalAssum (id, t'')) rest, s', trans') | [] -> - let t', s, trans = subst_evar_constr evs n mkVar concl in + let t', s, trans = subst_evar_constr evm evs n EConstr.mkVar concl in subst_vars acc 0 t', s, trans in aux [] 0 (List.rev hyps) @@ -151,7 +151,7 @@ let evar_dependencies evm oev = let one_step deps = Evar.Set.fold (fun ev s -> let evi = Evd.find evm ev in - let deps' = evars_of_filtered_evar_info evi in + let deps' = evars_of_filtered_evar_info evm evi in if Evar.Set.mem oev deps' then invalid_arg ("Ill-formed evar map: cycle detected for evar " ^ Pp.string_of_ppcmds @@ Evar.print oev) else Evar.Set.union deps' s) @@ -209,9 +209,7 @@ let eterm_obligations env name evm fs ?status t ty = (fun (id, (n, nstr), ev) l -> let hyps = Evd.evar_filtered_context ev in let hyps = trunc_named_context nc_len hyps in - let hyps = EConstr.Unsafe.to_named_context hyps in - let concl = EConstr.Unsafe.to_constr ev.evar_concl in - let evtyp, deps, transp = etype_of_evar l hyps concl in + let evtyp, deps, transp = etype_of_evar evm l hyps ev.evar_concl in let evtyp, hyps, chop = match chop_product fs evtyp with | Some t -> t, trunc_named_context fs hyps, fs @@ -237,9 +235,9 @@ let eterm_obligations env name evm fs ?status t ty = evn [] in let t', _, transparent = (* Substitute evar refs in the term by variables *) - subst_evar_constr evts 0 mkVar t + subst_evar_constr evm evts 0 EConstr.mkVar t in - let ty, _, _ = subst_evar_constr evts 0 mkVar ty in + let ty, _, _ = subst_evar_constr evm evts 0 EConstr.mkVar ty in let evars = List.map (fun (ev, info) -> let { ev_name = (_, name); ev_status = force_status, status; @@ -252,7 +250,7 @@ let eterm_obligations env name evm fs ?status t ty = in name, typ, src, (force_status, status), deps, tac) evts in let evnames = List.map (fun (ev, info) -> ev, snd info.ev_name) evts in - let evmap f c = pi1 (subst_evar_constr evts 0 f c) in + let evmap f c = pi1 (subst_evar_constr evm evts 0 f c) in Array.of_list (List.rev evars), (evnames, evmap), t', ty let hide_obligation () = diff --git a/vernac/obligations.mli b/vernac/obligations.mli index d25daeed9c..9214ddd4b9 100644 --- a/vernac/obligations.mli +++ b/vernac/obligations.mli @@ -26,14 +26,14 @@ val sort_dependencies : (Evar.t * evar_info * Evar.Set.t) list -> (Evar.t * evar (* env, id, evars, number of function prototypes to try to clear from evars contexts, object and type *) val eterm_obligations : env -> Id.t -> evar_map -> int -> - ?status:Evar_kinds.obligation_definition_status -> constr -> types -> + ?status:Evar_kinds.obligation_definition_status -> EConstr.constr -> EConstr.types -> (Id.t * types * Evar_kinds.t Loc.located * (bool * Evar_kinds.obligation_definition_status) * Int.Set.t * unit Proofview.tactic option) array (* Existential key, obl. name, type as product, location of the original evar, associated tactic, status and dependencies as indexes into the array *) - * ((Evar.t * Id.t) list * ((Id.t -> constr) -> constr -> constr)) * + * ((Evar.t * Id.t) list * ((Id.t -> EConstr.constr) -> EConstr.constr -> constr)) * constr * types (* Translations from existential identifiers to obligation identifiers and for terms with existentials to closed terms, given a diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index 889dbafabd..f2332bab8b 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -476,6 +476,8 @@ open Pputils keyword "Print Section" ++ spc() ++ Libnames.pr_qualid s | PrintGrammar ent -> keyword "Print Grammar" ++ spc() ++ str ent + | PrintCustomGrammar ent -> + keyword "Print Custom Grammar" ++ spc() ++ str ent | PrintLoadPath dir -> keyword "Print LoadPath" ++ pr_opt DirPath.print dir | PrintModules -> diff --git a/vernac/record.ml b/vernac/record.ml index f489707eb3..f737a8c524 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -276,8 +276,13 @@ let instantiate_possibly_recursive_type ind u ntypes paramdecls fields = let subst' = List.init ntypes (fun i -> mkIndU ((ind, ntypes - i - 1), u)) in Termops.substl_rel_context (subst @ subst') fields +type projection_flags = { + pf_subclass: bool; + pf_canonical: bool; +} + (* We build projections *) -let declare_projections indsp ctx ?(kind=StructureComponent) binder_name coers fieldimpls fields = +let declare_projections indsp ctx ?(kind=StructureComponent) binder_name flags fieldimpls fields = let env = Global.env() in let (mib,mip) = Global.lookup_inductive indsp in let poly = Declareops.inductive_is_polymorphic mib in @@ -299,7 +304,7 @@ let declare_projections indsp ctx ?(kind=StructureComponent) binder_name coers f in let (_,_,kinds,sp_projs,_) = List.fold_left3 - (fun (nfi,i,kinds,sp_projs,subst) coe decl impls -> + (fun (nfi,i,kinds,sp_projs,subst) flags decl impls -> let fi = RelDecl.get_name decl in let ti = RelDecl.get_type decl in let (sp_projs,i,subst) = @@ -359,17 +364,17 @@ let declare_projections indsp ctx ?(kind=StructureComponent) binder_name coers f in let refi = ConstRef kn in Impargs.maybe_declare_manual_implicits false refi impls; - if coe then begin + if flags.pf_subclass then begin let cl = Class.class_of_global (IndRef indsp) in Class.try_add_new_coercion_with_source refi ~local:false poly ~source:cl end; let i = if is_local_assum decl then i+1 else i in (Some kn::sp_projs, i, Projection term::subst) with NotDefinable why -> - warning_or_error coe indsp why; + warning_or_error flags.pf_subclass indsp why; (None::sp_projs,i,NoProjection fi::subst) in - (nfi-1,i,(fi, is_local_assum decl)::kinds,sp_projs,subst)) - (List.length fields,0,[],[],[]) coers (List.rev fields) (List.rev fieldimpls) + (nfi - 1, i, { Recordops.pk_name = fi ; pk_true_proj = is_local_assum decl ; pk_canonical = flags.pf_canonical } :: kinds, sp_projs, subst)) + (List.length fields,0,[],[],[]) flags (List.rev fields) (List.rev fieldimpls) in (kinds,sp_projs) open Typeclasses @@ -525,7 +530,8 @@ let declare_class def cum ubinders univs id idbuild paramimpls params arity in [cref, [Name proj_name, sub, Some proj_cst]] | _ -> - let record_data = [id, idbuild, arity, fieldimpls, fields, false, List.map (fun _ -> false) fields] in + let record_data = [id, idbuild, arity, fieldimpls, fields, false, + List.map (fun _ -> { pf_subclass = false ; pf_canonical = true }) fields] in let inds = declare_structure ~cum Declarations.BiFinite ubinders univs paramimpls params template ~kind:Method ~name:[|binder_name|] record_data in @@ -699,7 +705,11 @@ let definition_structure udecl kind ~template cum poly finite records = let map impls = implpars @ Impargs.lift_implicits (succ (List.length params)) impls in let data = List.map (fun (arity, implfs, fields) -> (arity, List.map map implfs, fields)) data in let map (arity, implfs, fields) (is_coe, id, _, cfs, idbuild, _) = - let coe = List.map (fun (_, { rf_subclass }) -> not (Option.is_empty rf_subclass)) cfs in + let coe = List.map (fun (_, { rf_subclass ; rf_canonical }) -> + { pf_subclass = not (Option.is_empty rf_subclass); + pf_canonical = rf_canonical }) + cfs + in id.CAst.v, idbuild, arity, implfs, fields, is_coe, coe in let data = List.map2 map data records in diff --git a/vernac/record.mli b/vernac/record.mli index d6e63901cd..24bb27e107 100644 --- a/vernac/record.mli +++ b/vernac/record.mli @@ -14,15 +14,20 @@ open Constrexpr val primitive_flag : bool ref +type projection_flags = { + pf_subclass: bool; + pf_canonical: bool; +} + val declare_projections : inductive -> Entries.universes_entry -> ?kind:Decl_kinds.definition_object_kind -> Id.t -> - bool list -> + projection_flags list -> Impargs.manual_implicits list -> Constr.rel_context -> - (Name.t * bool) list * Constant.t option list + Recordops.proj_kind list * Constant.t option list val declare_structure_entry : Recordops.struc_tuple -> unit diff --git a/vernac/topfmt.ml b/vernac/topfmt.ml index 118c126970..bf2efb2542 100644 --- a/vernac/topfmt.ml +++ b/vernac/topfmt.ml @@ -201,7 +201,7 @@ let set_emacs_print_strings () = let diff = "diff." in List.iter (fun b -> let (name, attrs) = b in - if diff = (String.sub name 0 (String.length diff)) then + if CString.is_sub diff name 0 then tag_map := CString.Map.add name { attrs with prefix = Some (Printf.sprintf "<%s>" name); suffix = Some (Printf.sprintf "</%s>" name) } diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 279d4f0935..e1d134f3a9 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -744,7 +744,7 @@ let vernac_inductive ~atts cum lo finite indl = let (coe, (lid, ce)) = l in let coe' = if coe then Some true else None in let f = AssumExpr ((make ?loc:lid.loc @@ Name lid.v), ce), - { rf_subclass = coe' ; rf_priority = None ; rf_notation = [] } in + { rf_subclass = coe' ; rf_priority = None ; rf_notation = [] ; rf_canonical = true } in vernac_record ~template udecl cum (Class true) poly finite [id, bl, c, None, [f]] else if List.for_all is_record indl then (* Mutual record case *) @@ -1885,6 +1885,7 @@ let vernac_print ~(pstate : Proof_global.t option) ~atts = | PrintSectionContext qid -> print_sec_context_typ env sigma qid | PrintInspect n -> inspect env sigma n | PrintGrammar ent -> Metasyntax.pr_grammar ent + | PrintCustomGrammar ent -> Metasyntax.pr_custom_grammar ent | PrintLoadPath dir -> (* For compatibility ? *) print_loadpath dir | PrintModules -> print_modules () | PrintModule qid -> print_module qid diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index 34a9b9394a..23633e39ab 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -29,6 +29,7 @@ type printable = | PrintSectionContext of qualid | PrintInspect of int | PrintGrammar of string + | PrintCustomGrammar of string | PrintLoadPath of DirPath.t option | PrintModules | PrintModule of qualid @@ -148,6 +149,7 @@ type record_field_attr = { rf_subclass: instance_flag; (* the projection is an implicit coercion or an instance *) rf_priority: int option; (* priority of the instance, if relevant *) rf_notation: decl_notation list; + rf_canonical: bool; (* use this projection in the search for canonical instances *) } type constructor_expr = (lident * constr_expr) with_coercion type constructor_list_or_record_decl_expr = |