diff options
137 files changed, 1352 insertions, 1572 deletions
diff --git a/.gitignore b/.gitignore index 8fd9fc614c..5339a0c44d 100644 --- a/.gitignore +++ b/.gitignore @@ -165,7 +165,9 @@ ide/index_urls.txt # coqide generated files (when testing) *.crashcoqide -user-contrib +/user-contrib/* +!/user-contrib/Ltac2 + .*.sw* .#* @@ -183,5 +185,6 @@ plugins/*/dune theories/*/dune theories/*/*/dune theories/*/*/*/dune +/user-contrib/Ltac2/dune *.install !Makefile.install diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 2bfb91f27f..9e96d3602b 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -169,7 +169,15 @@ before_script: - not-a-real-job script: - cd _install_ci - - find lib/coq/ -name '*.vo' -print0 | xargs -0 bin/coqchk -silent -o -m -coqlib lib/coq/ + - find lib/coq/ -name '*.vo' -fprint0 vofiles + - xargs -0 --arg-file=vofiles bin/coqchk -o -m -coqlib lib/coq/ > ../coqchk.log 2>&1 || touch coqchk.failed + - tail -n 1000 ../coqchk.log # the log is too big for gitlab so pipe to a file and display the tail + - "[ ! -f coqchk.failed ]" # needs quoting for yml syntax reasons + artifacts: + name: "$CI_JOB_NAME.logs" + paths: + - coqchk.log + expire_in: 1 month .ci-template: stage: test @@ -638,9 +646,6 @@ plugin:ci-equations: plugin:ci-fiat_parsers: extends: .ci-template -plugin:ci-ltac2: - extends: .ci-template - plugin:ci-mtac2: extends: .ci-template diff --git a/Makefile.ci b/Makefile.ci index a244c17ef3..95ebd64ba1 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -32,7 +32,6 @@ CI_TARGETS= \ ci-coqhammer \ ci-hott \ ci-iris-lambda-rust \ - ci-ltac2 \ ci-math-classes \ ci-math-comp \ ci-mtac2 \ diff --git a/Makefile.vofiles b/Makefile.vofiles index e05822c889..5296ed43ff 100644 --- a/Makefile.vofiles +++ b/Makefile.vofiles @@ -13,7 +13,7 @@ endif ########################################################################### THEORIESVO := $(patsubst %.v,%.$(VO),$(shell find theories -type f -name "*.v")) -PLUGINSVO := $(patsubst %.v,%.$(VO),$(shell find plugins user-contrib -type f -name "*.v")) +PLUGINSVO := $(patsubst %.v,%.$(VO),$(shell find plugins $(addprefix user-contrib/, $(USERCONTRIBDIRS)) -type f -name "*.v")) ALLVO := $(THEORIESVO) $(PLUGINSVO) VFILES := $(ALLVO:.$(VO)=.v) 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/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index ea9af60330..d737632638 100755 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -1630,19 +1630,6 @@ function make_addon_ssreflect { fi } -# Ltac-2 plugin -# A new (experimental) tactic language - -function make_addon_ltac2 { - installer_addon_dependency ltac2 - if build_prep_overlay ltac2; then - installer_addon_section ltac2 "Ltac-2" "Coq plugin with the Ltac-2 enhanced tactic language" "" - log1 make $MAKE_OPT all - log2 make install - build_post - fi -} - # UniCoq plugin # An alternative unification algorithm function make_addon_unicoq { diff --git a/dev/ci/appveyor.sh b/dev/ci/appveyor.sh deleted file mode 100644 index f26e0904bc..0000000000 --- a/dev/ci/appveyor.sh +++ /dev/null @@ -1,17 +0,0 @@ -#!/bin/bash - -set -e -x - -APPVEYOR_OPAM_VARIANT=ocaml-variants.4.07.1+mingw64c -NJOBS=2 - -wget https://github.com/fdopen/opam-repository-mingw/releases/download/0.0.0.2/opam64.tar.xz -O opam64.tar.xz -tar -xf opam64.tar.xz -bash opam64/install.sh - -opam init default -j $NJOBS -a -y "https://github.com/fdopen/opam-repository-mingw.git#opam2" -c $APPVEYOR_OPAM_VARIANT --disable-sandboxing -eval "$(opam env)" -opam install -j $NJOBS -y num ocamlfind ounit - -# Full regular Coq Build -cd "$APPVEYOR_BUILD_FOLDER" && ./configure -local && make -j $NJOBS && make byte -j $NJOBS && make -j $NJOBS -C test-suite all INTERACTIVE= # && make validate diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 4f5988c59c..95fceb773a 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -81,13 +81,6 @@ : "${coqhammer_CI_ARCHIVEURL:=${coqhammer_CI_GITURL}/archive}" ######################################################################## -# Ltac2 -######################################################################## -: "${ltac2_CI_REF:=master}" -: "${ltac2_CI_GITURL:=https://github.com/ppedrot/ltac2}" -: "${ltac2_CI_ARCHIVEURL:=${ltac2_CI_GITURL}/archive}" - -######################################################################## # GeoCoq ######################################################################## : "${GeoCoq_CI_REF:=master}" @@ -105,7 +98,8 @@ # Coquelicot ######################################################################## : "${coquelicot_CI_REF:=master}" -: "${coquelicot_CI_GITURL:=https://scm.gforge.inria.fr/anonscm/git/coquelicot/coquelicot}" +: "${coquelicot_CI_GITURL:=https://gitlab.inria.fr/coquelicot/coquelicot}" +: "${coquelicot_CI_ARCHIVEURL:=${coquelicot_CI_GITURL}/-/archive}" ######################################################################## # CompCert diff --git a/dev/ci/ci-coquelicot.sh b/dev/ci/ci-coquelicot.sh index 33627fd8ef..6cb8dad604 100755 --- a/dev/ci/ci-coquelicot.sh +++ b/dev/ci/ci-coquelicot.sh @@ -5,7 +5,6 @@ ci_dir="$(dirname "$0")" install_ssreflect -FORCE_GIT=1 git_download coquelicot ( cd "${CI_BUILD_DIR}/coquelicot" && ./autogen.sh && ./configure && ./remake "-j${NJOBS}" ) diff --git a/dev/ci/ci-ltac2.sh b/dev/ci/ci-ltac2.sh deleted file mode 100755 index 4df22bf249..0000000000 --- a/dev/ci/ci-ltac2.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/usr/bin/env bash - -ci_dir="$(dirname "$0")" -. "${ci_dir}/ci-common.sh" - -git_download ltac2 - -( cd "${CI_BUILD_DIR}/ltac2" && make && make tests && make install ) diff --git a/dev/ci/gitlab.bat b/dev/ci/gitlab.bat index cc1931d13d..6c4ccfc14d 100755 --- a/dev/ci/gitlab.bat +++ b/dev/ci/gitlab.bat @@ -41,7 +41,6 @@ IF "%WINDOWS%" == "enabled_all_addons" ( SET EXTRA_ADDONS=^
-addon=bignums ^
-addon=equations ^
- -addon=ltac2 ^
-addon=mtac2 ^
-addon=mathcomp ^
-addon=menhir ^
diff --git a/dev/ci/nix/coquelicot.nix b/dev/ci/nix/coquelicot.nix new file mode 100644 index 0000000000..d379bfa73d --- /dev/null +++ b/dev/ci/nix/coquelicot.nix @@ -0,0 +1,9 @@ +{ autoconf, automake, ssreflect }: + +{ + buildInputs = [ autoconf automake ]; + coqBuildInputs = [ ssreflect ]; + configure = "./autogen.sh && ./configure"; + make = "./remake"; + clean = "./remake clean"; +} diff --git a/dev/ci/nix/default.nix b/dev/ci/nix/default.nix index 17070e66ee..a9cc91170f 100644 --- a/dev/ci/nix/default.nix +++ b/dev/ci/nix/default.nix @@ -72,6 +72,7 @@ let projects = { CoLoR = callPackage ./CoLoR.nix {}; CompCert = callPackage ./CompCert.nix {}; coq_dpdgraph = callPackage ./coq_dpdgraph.nix {}; + coquelicot = callPackage ./coquelicot.nix {}; Corn = callPackage ./Corn.nix {}; cross_crypto = callPackage ./cross_crypto.nix {}; Elpi = callPackage ./Elpi.nix {}; diff --git a/dev/ci/nix/flocq.nix b/dev/ci/nix/flocq.nix index e153043557..71028ec2dc 100644 --- a/dev/ci/nix/flocq.nix +++ b/dev/ci/nix/flocq.nix @@ -4,4 +4,5 @@ buildInputs = [ autoconf automake ]; configure = "./autogen.sh && ./configure"; make = "./remake"; + clean = "./remake clean"; } diff --git a/dev/ci/user-overlays/10052-ppedrot-cleanup-logic-convert-hyp.sh b/dev/ci/user-overlays/10052-ppedrot-cleanup-logic-convert-hyp.sh new file mode 100644 index 0000000000..9f9cc19e83 --- /dev/null +++ b/dev/ci/user-overlays/10052-ppedrot-cleanup-logic-convert-hyp.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "10052" ] || [ "$CI_BRANCH" = "cleanup-logic-convert-hyp" ]; then + + relation_algebra_CI_REF=cleanup-logic-convert-hyp + relation_algebra_CI_GITURL=https://github.com/ppedrot/relation-algebra + +fi diff --git a/dev/ci/user-overlays/10069-ppedrot-whd-for-evar-conv-no-stack.sh b/dev/ci/user-overlays/10069-ppedrot-whd-for-evar-conv-no-stack.sh new file mode 100644 index 0000000000..0e1449f36c --- /dev/null +++ b/dev/ci/user-overlays/10069-ppedrot-whd-for-evar-conv-no-stack.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "10069" ] || [ "$CI_BRANCH" = "whd-for-evar-conv-no-stack" ]; then + + unicoq_CI_REF=whd-for-evar-conv-no-stack + unicoq_CI_GITURL=https://github.com/ppedrot/unicoq + +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/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/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/03-notations/10061-print-custom-grammar.rst b/doc/changelog/03-notations/10061-print-custom-grammar.rst new file mode 100644 index 0000000000..8786c7ce6b --- /dev/null +++ b/doc/changelog/03-notations/10061-print-custom-grammar.rst @@ -0,0 +1,4 @@ +- 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). 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/conf.py b/doc/sphinx/conf.py index 25800d3a7d..ec3343dac6 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -47,7 +47,7 @@ with open("refman-preamble.rst") as s: # -- General configuration ------------------------------------------------ # If your documentation needs a minimal Sphinx version, state it here. -#needs_sphinx = '1.0' +needs_sphinx = '1.7.8' # Add any Sphinx extension module names here, as strings. They can be # extensions coming with Sphinx (named 'sphinx.ext.*') or your custom diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index 5308330820..ba766c8c3d 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/practical-tools/coqide.rst b/doc/sphinx/practical-tools/coqide.rst index 6cbd00f45d..efb5df720a 100644 --- a/doc/sphinx/practical-tools/coqide.rst +++ b/doc/sphinx/practical-tools/coqide.rst @@ -181,7 +181,14 @@ presented as a notebook. The first section is for selecting the text font used for scripts, goal and message windows. -The second section is devoted to file management: you may configure +The second and third sections are for controlling colors and style. + +The fourth section is for customizing the editor. It includes in +particular the ability to activate an Emacs mode named +micro-Proof-General (use the Help menu to know more about the +available bindings). + +The next section is devoted to file management: you may configure automatic saving of files, by periodically saving the contents into files named `#f#` for each opened file `f`. You may also activate the *revert* feature: in case a opened file is modified on the disk by a diff --git a/doc/sphinx/practical-tools/utilities.rst b/doc/sphinx/practical-tools/utilities.rst index 35231610fe..554f6bf230 100644 --- a/doc/sphinx/practical-tools/utilities.rst +++ b/doc/sphinx/practical-tools/utilities.rst @@ -909,13 +909,15 @@ Command line options :--coqlib url: Set base URL for the Coq standard library (default is `<http://coq.inria.fr/library/>`_). This is equivalent to ``--external url Coq``. - :-R dir coqdir: Map physical directory dir to |Coq| logical + :-R dir coqdir: Recursively map physical directory dir to |Coq| logical directory ``coqdir`` (similarly to |Coq| option ``-R``). + :-Q dir coqdir: Map physical directory dir to |Coq| logical + directory ``coqdir`` (similarly to |Coq| option ``-Q``). .. note:: - option ``-R`` only has - effect on the files *following* it on the command line, so you will + options ``-R`` and ``-Q`` only have + effect on the files *following* them on the command line, so you will probably need to put this option first. 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 0f78a9b84a..c728b925ac 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..be0318fbde 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) 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..d37b49e2dc 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -869,8 +869,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 = diff --git a/engine/evd.mli b/engine/evd.mli index b0fcddb068..29235050b0 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -615,9 +615,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..ecea637947 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -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 diff --git a/engine/proofview.mli b/engine/proofview.mli index 9455dae643..92f8b86df5 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 diff --git a/engine/termops.ml b/engine/termops.ml index 8e12c9be88..8a6bd17948 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 @@ -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/ide/coqide.ml b/ide/coqide.ml index aa9e150fd5..4f00be27a1 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -561,7 +561,7 @@ let update_status sn = | None -> "" | Some n -> ", proving " ^ n in - display ("Ready"^ (if nanoPG#get then ", [μPG]" else "") ^ path ^ name); + display ("Ready"^ (if microPG#get then ", [μPG]" else "") ^ path ^ name); Coq.return () in Coq.bind (Coq.status false) next @@ -1200,7 +1200,7 @@ let build_ui () = item "Help for μPG mode" ~label:"Help for μPG mode" ~callback:(fun _ -> on_current_term (fun sn -> sn.messages#default_route#clear; - sn.messages#default_route#add_string (NanoPG.get_documentation ()))); + sn.messages#default_route#add_string (MicroPG.get_documentation ()))); item "About Coq" ~label:"_About" ~stock:`ABOUT ~callback:MiscMenu.about ]; @@ -1234,7 +1234,7 @@ let build_ui () = let () = vbox#pack toolbar#coerce in (* Emacs/PG mode *) - NanoPG.init w notebook all_menus; + MicroPG.init w notebook all_menus; (* On tab switch, reset, update location *) let _ = notebook#connect#switch_page ~callback:(fun n -> @@ -1251,7 +1251,7 @@ let build_ui () = let () = refresh_notebook_pos () in let lower_hbox = GPack.hbox ~homogeneous:false ~packing:vbox#pack () in let () = lower_hbox#pack ~expand:true status#coerce in - let () = push_info ("Ready"^ if nanoPG#get then ", [μPG]" else "") in + let () = push_info ("Ready"^ if microPG#get then ", [μPG]" else "") in (* Location display *) let l = GMisc.label diff --git a/ide/ide.mllib b/ide/ide.mllib index ed6520f29f..f8e8ff48d6 100644 --- a/ide/ide.mllib +++ b/ide/ide.mllib @@ -30,5 +30,5 @@ CoqOps Wg_Command Session Coqide_ui -NanoPG +MicroPG Coqide diff --git a/ide/nanoPG.ml b/ide/microPG.ml index d85d87142c..25cab4638c 100644 --- a/ide/nanoPG.ml +++ b/ide/microPG.ml @@ -65,14 +65,27 @@ type 'c entry = { } let mC = [`CONTROL] -let mM = [`MOD1] +let mM = + if Coq_config.arch = "Darwin" then + (* We add both MOD2 and META because both are + returned when pressing Command on MacOS X *) + [`CONTROL;`MOD2;`META] + else + [`MOD1] -let mod_of t x = List.for_all (fun m -> List.mem m (GdkEvent.Key.state t)) x +let mod_of t x = + let y = GdkEvent.Key.state t in + List.for_all (fun m -> List.mem m y) x && + List.for_all (fun m -> List.mem m x) y let pr_keymod l = - if l = mC then "C-" - else if l = mM then "M-" - else "" + if l = mC then + "Ctrl-" + else + if l = mM then + if Coq_config.arch = "Darwin" then "Ctrl-Cmd-" else "Meta-" + else + "" let mkE ?(mods=mC) key keyname doc ?(alias=[]) contents = List.map (fun (mods, key, keyname) -> { mods; key; keyname; doc; contents }) @@ -147,6 +160,13 @@ let emacs = insert emacs "Emacs" [] [ mkE _e "e" "Move to end of line" (Motion(fun s i -> (if not i#ends_line then i#forward_to_line_end else i), { s with move = None })); + mkE ~mods:mM _Right "->" "Move to end of buffer" (Motion(fun s i -> + i#forward_to_end, + { s with move = None })); + mkE ~mods:mM _Left "<-" "Move to start of buffer" (Motion(fun s i -> + let buffer = new GText.buffer i#buffer in + buffer#start_iter, + { s with move = None })); mkE _a "a" "Move to beginning of line" (Motion(fun s i -> (i#set_line_offset 0), { s with move = None })); mkE ~mods:mM _e "e" "Move to end of sentence" (Motion(fun s i -> @@ -286,9 +306,9 @@ let find gui (Step(here,konts)) t = else if k = _c && mod_of t mC && sel_nonempty () then ignore(run t gui (Action("Edit","Copy")) empty); - let cmp { key; mods } = key = k && mod_of t mods in - try `Do (List.find cmp here) with Not_found -> - try `Cont (List.find cmp konts).contents with Not_found -> `NotFound + let cmp { key; mods } = key = k && mod_of t mods in + try `Do (List.find cmp here) with Not_found -> + try `Cont (List.find cmp konts).contents with Not_found -> `NotFound let init w nb ags = let gui = { notebook = nb; action_groups = ags } in @@ -305,7 +325,7 @@ let init w nb ags = then false else begin eprintf "got key %s\n%!" (pr_key t); - if nanoPG#get then begin + if microPG#get then begin match find gui !cur t with | `Do e -> eprintf "run (%s) %s on %s\n%!" e.keyname e.doc (pr_status !status); @@ -320,4 +340,6 @@ let init w nb ags = -let get_documentation () = print_keypaths pg +let get_documentation () = + "Chars, words, lines and sentences below pertain to standard unicode segmentation rules\n" ^ + print_keypaths pg diff --git a/ide/nanoPG.mli b/ide/microPG.mli index bc9b39d823..bc9b39d823 100644 --- a/ide/nanoPG.mli +++ b/ide/microPG.mli diff --git a/ide/preferences.ml b/ide/preferences.ml index 3893d023bd..4e2e3f31e6 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -561,7 +561,8 @@ let tab_length = let highlight_current_line = new preference ~name:["highlight_current_line"] ~init:false ~repr:Repr.(bool) -let nanoPG = +let microPG = + (* Legacy name in preference is "nanoPG" *) new preference ~name:["nanoPG"] ~init:false ~repr:Repr.(bool) let user_queries = @@ -799,7 +800,7 @@ let configure ?(apply=(fun () -> ())) parent = let () = button "Show progress bar" show_progress_bar in let () = button "Insert spaces instead of tabs" spaces_instead_of_tabs in let () = button "Highlight current line" highlight_current_line in - let () = button "Emacs/PG keybindings (μPG mode)" nanoPG in + let () = button "Emacs/PG keybindings (μPG mode)" microPG in let callback () = () in custom ~label box callback true in diff --git a/ide/preferences.mli b/ide/preferences.mli index 785c191b46..b01c4598d8 100644 --- a/ide/preferences.mli +++ b/ide/preferences.mli @@ -102,7 +102,7 @@ val show_progress_bar : bool preference val spaces_instead_of_tabs : bool preference val tab_length : int preference val highlight_current_line : bool preference -val nanoPG : bool preference +val microPG : bool preference val user_queries : (string * string) list preference val diffs : string preference 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..90fb5a2036 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 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/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index 2293ae9dfd..1b348ae777 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -29,13 +29,6 @@ #include "coq_uint63_emul.h" #endif -/* spiwack: I append here a few macros for value/number manipulation */ -#define uint32_of_value(val) (((uint32_t)(val)) >> 1) -#define value_of_uint32(i) ((value)((((uint32_t)(i)) << 1) | 1)) -#define UI64_of_uint32(lo) ((uint64_t)((uint32_t)(lo))) -#define UI64_of_value(val) (UI64_of_uint32(uint32_of_value(val))) -/* /spiwack */ - /* Registers for the abstract machine: @@ -1298,12 +1291,6 @@ value coq_interprete /*returns the multiplication on a pair */ print_instr("MULCINT63"); CheckInt2(); - /*accu = 2v+1, *sp=2w+1 ==> p = 2v*w */ - /* TODO: implement - p = I64_mul (UI64_of_value (accu), UI64_of_uint32 ((*sp++)^1)); - AllocPair(); */ - /* Field(accu, 0) = (value)(I64_lsr(p,31)|1) ; */ /*higher part*/ - /* Field(accu, 1) = (value)(I64_to_int32(p)|1); */ /*lower part*/ Uint63_mulc(accu, *sp, sp); *--sp = accu; AllocPair(); @@ -1374,40 +1361,11 @@ value coq_interprete Instruct (CHECKDIV21INT63) { print_instr("DIV21INT63"); CheckInt3(); - /* spiwack: takes three int31 (the two first ones represent an - int62) and performs the euclidian division of the - int62 by the int31 */ - /* TODO: implement this - bigint = UI64_of_value(accu); - bigint = I64_or(I64_lsl(bigint, 31),UI64_of_value(*sp++)); - uint64 divisor; - divisor = UI64_of_value(*sp++); - Alloc_small(accu, 2, 1); */ /* ( _ , arity, tag ) */ - /* if (I64_is_zero (divisor)) { - Field(accu, 0) = 1; */ /* 2*0+1 */ - /* Field(accu, 1) = 1; */ /* 2*0+1 */ - /* } - else { - uint64 quo, mod; - I64_udivmod(bigint, divisor, &quo, &mod); - Field(accu, 0) = value_of_uint32(I64_to_int32(quo)); - Field(accu, 1) = value_of_uint32(I64_to_int32(mod)); - } */ - int b; - Uint63_eq0(b, sp[1]); - if (b) { - AllocPair(); - Field(accu, 0) = sp[1]; - Field(accu, 1) = sp[1]; - } - else { - Uint63_div21(accu, sp[0], sp[1], sp); - sp[1] = sp[0]; - Swap_accu_sp; - AllocPair(); - Field(accu, 0) = sp[1]; - Field(accu, 1) = sp[0]; - } + Uint63_div21(accu, sp[0], sp[1], &(sp[1])); + Swap_accu_sp; + AllocPair(); + Field(accu, 0) = sp[1]; + Field(accu, 1) = sp[0]; sp += 2; Next; } @@ -1616,7 +1574,7 @@ value coq_push_vstack(value stk, value max_stack_size) { print_instr("push_vstack");print_int(len); for(i = 0; i < len; i++) coq_sp[i] = Field(stk,i); sp = coq_sp; - CHECK_STACK(uint32_of_value(max_stack_size)); + CHECK_STACK(uint_of_value(max_stack_size)); return Val_unit; } diff --git a/kernel/byterun/coq_uint63_emul.h b/kernel/byterun/coq_uint63_emul.h index d982f67566..528cc6fc1f 100644 --- a/kernel/byterun/coq_uint63_emul.h +++ b/kernel/byterun/coq_uint63_emul.h @@ -6,6 +6,8 @@ #define Is_uint63(v) (Tag_val(v) == Custom_tag) +#define uint_of_value(val) (((uint32_t)(val)) >> 1) + # define DECLARE_NULLOP(name) \ value uint63_##name() { \ static value* cb = 0; \ diff --git a/kernel/byterun/coq_uint63_native.h b/kernel/byterun/coq_uint63_native.h index d431dc1e5c..1fdafc9d8f 100644 --- a/kernel/byterun/coq_uint63_native.h +++ b/kernel/byterun/coq_uint63_native.h @@ -1,5 +1,6 @@ #define Is_uint63(v) (Is_long(v)) +#define uint_of_value(val) (((uint64_t)(val)) >> 1) #define uint63_of_value(val) ((uint64_t)(val) >> 1) /* 2^63 * y + x as a value */ @@ -109,37 +110,56 @@ value uint63_mulc(value x, value y, value* h) { #define lt128(xh,xl,yh,yl) (uint63_lt(xh,yh) || (uint63_eq(xh,yh) && uint63_lt(xl,yl))) #define le128(xh,xl,yh,yl) (uint63_lt(xh,yh) || (uint63_eq(xh,yh) && uint63_leq(xl,yl))) -value uint63_div21(value xh, value xl, value y, value* q) { - xh = (uint64_t)xh >> 1; - xl = ((uint64_t)xl >> 1) | ((uint64_t)xh << 63); - xh = (uint64_t)xh >> 1; +#define maxuint63 ((uint64_t)0x7FFFFFFFFFFFFFFF) +/* precondition: y <> 0 */ +/* outputs r and sets ql to q % 2^63 s.t. x = q * y + r, r < y */ +static value uint63_div21_aux(value xh, value xl, value y, value* ql) { + xh = uint63_of_value(xh); + xl = uint63_of_value(xl); + y = uint63_of_value(y); uint64_t maskh = 0; uint64_t maskl = 1; uint64_t dh = 0; - uint64_t dl = (uint64_t)y >> 1; + uint64_t dl = y; int cmp = 1; - while (dh >= 0 && cmp) { + /* int n = 0 */ + /* loop invariant: mask = 2^n, d = mask * y, (2 * d <= x -> cmp), n >= 0, d < 2^(2*63) */ + while (!(dh >> (63 - 1)) && cmp) { + dh = (dh << 1) | (dl >> (63 - 1)); + dl = (dl << 1) & maxuint63; + maskh = (maskh << 1) | (maskl >> (63 - 1)); + maskl = (maskl << 1) & maxuint63; + /* ++n */ cmp = lt128(dh,dl,xh,xl); - dh = (dh << 1) | (dl >> 63); - dl = dl << 1; - maskh = (maskh << 1) | (maskl >> 63); - maskl = maskl << 1; } uint64_t remh = xh; uint64_t reml = xl; - uint64_t quotient = 0; + /* uint64_t quotienth = 0; */ + uint64_t quotientl = 0; + /* loop invariant: x = quotient * y + rem, y * 2^(n+1) > r, + mask = floor(2^n), d = mask * y, n >= -1 */ while (maskh | maskl) { - if (le128(dh,dl,remh,reml)) { - quotient = quotient | maskl; - if (uint63_lt(reml,dl)) {remh = remh - dh - 1;} else {remh = remh - dh;} + if (le128(dh,dl,remh,reml)) { /* if rem >= d, add one bit and subtract d */ + /* quotienth = quotienth | maskh */ + quotientl = quotientl | maskl; + remh = (uint63_lt(reml,dl)) ? (remh - dh - 1) : (remh - dh); reml = reml - dl; } - maskl = (maskl >> 1) | (maskh << 63); + maskl = (maskl >> 1) | ((maskh << (63 - 1)) & maxuint63); maskh = maskh >> 1; - dl = (dl >> 1) | (dh << 63); + dl = (dl >> 1) | ((dh << (63 - 1)) & maxuint63); dh = dh >> 1; + /* decr n */ } - *q = Val_int(quotient); + *ql = Val_int(quotientl); return Val_int(reml); } +value uint63_div21(value xh, value xl, value y, value* ql) { + if (uint63_of_value(y) == 0) { + *ql = Val_int(0); + return Val_int(0); + } else { + return uint63_div21_aux(xh, xl, y, ql); + } +} #define Uint63_div21(xh, xl, y, q) (accu = uint63_div21(xh, xl, y, q)) 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/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/uint63.mli b/kernel/uint63.mli index b5f40ca804..f25f24512d 100644 --- a/kernel/uint63.mli +++ b/kernel/uint63.mli @@ -40,6 +40,10 @@ val rem : t -> t -> t (* Specific arithmetic operations *) val mulc : t -> t -> t * t val addmuldiv : t -> t -> t -> t + +(** [div21 xh xl y] returns [q % 2^63, r] + s.t. [xh * 2^63 + xl = q * y + r] and [r < y]. + When [y] is [0], returns [0, 0]. *) val div21 : t -> t -> t -> t * t (* comparison *) diff --git a/kernel/uint63_amd64.ml b/kernel/uint63_amd64.ml index 010b594de8..2d4d685775 100644 --- a/kernel/uint63_amd64.ml +++ b/kernel/uint63_amd64.ml @@ -102,26 +102,35 @@ let le128 xh xl yh yl = lt xh yh || (xh = yh && le xl yl) (* division of two numbers by one *) +(* precondition: y <> 0 *) +(* outputs: q % 2^63, r s.t. x = q * y + r, r < y *) let div21 xh xl y = let maskh = ref 0 in let maskl = ref 1 in let dh = ref 0 in let dl = ref y in let cmp = ref true in - while !dh >= 0 && !cmp do - cmp := lt128 !dh !dl xh xl; + (* n = ref 0 *) + (* loop invariant: mask = 2^n, d = mask * y, (2 * d <= x -> cmp), n >= 0 *) + while !dh >= 0 && !cmp do (* dh >= 0 tests that dh highest bit is zero *) (* We don't use addmuldiv below to avoid checks on 1 *) dh := (!dh lsl 1) lor (!dl lsr (uint_size - 1)); dl := !dl lsl 1; maskh := (!maskh lsl 1) lor (!maskl lsr (uint_size - 1)); - maskl := !maskl lsl 1 - done; (* mask = 2^N, d = 2^N * d, d >= x *) + maskl := !maskl lsl 1; + (* incr n *) + cmp := lt128 !dh !dl xh xl; + done; (* mask = 2^n, d = 2^n * y, 2 * d > x *) let remh = ref xh in let reml = ref xl in - let quotient = ref 0 in + (* quotienth = ref 0 *) + let quotientl = ref 0 in + (* loop invariant: x = quotient * y + rem, y * 2^(n+1) > r, + mask = floor(2^n), d = mask * y, n >= -1 *) while !maskh lor !maskl <> 0 do if le128 !dh !dl !remh !reml then begin (* if rem >= d, add one bit and subtract d *) - quotient := !quotient lor !maskl; + (* quotienth := !quotienth lor !maskh *) + quotientl := !quotientl lor !maskl; remh := if lt !reml !dl then !remh - !dh - 1 else !remh - !dh; reml := !reml - !dl; end; @@ -129,8 +138,11 @@ let div21 xh xl y = maskh := !maskh lsr 1; dl := (!dl lsr 1) lor (!dh lsl (uint_size - 1)); dh := !dh lsr 1; + (* decr n *) done; - !quotient, !reml + !quotientl, !reml + +let div21 xh xl y = if y = 0 then 0, 0 else div21 xh xl y (* exact multiplication *) (* TODO: check that none of these additions could be a logical or *) diff --git a/kernel/uint63_x86.ml b/kernel/uint63_x86.ml index 461184c432..fa45c90241 100644 --- a/kernel/uint63_x86.ml +++ b/kernel/uint63_x86.ml @@ -94,26 +94,35 @@ let le128 xh xl yh yl = lt xh yh || (xh = yh && le xl yl) (* division of two numbers by one *) +(* precondition: y <> 0 *) +(* outputs: q % 2^63, r s.t. x = q * y + r, r < y *) let div21 xh xl y = let maskh = ref zero in let maskl = ref one in let dh = ref zero in let dl = ref y in let cmp = ref true in - while le zero !dh && !cmp do - cmp := lt128 !dh !dl xh xl; + (* n = ref 0 *) + (* loop invariant: mask = 2^n, d = mask * y, (2 * d <= x -> cmp), n >= 0 *) + while Int64.equal (l_sr !dh (of_int (uint_size - 1))) zero && !cmp do (* We don't use addmuldiv below to avoid checks on 1 *) dh := l_or (l_sl !dh one) (l_sr !dl (of_int (uint_size - 1))); dl := l_sl !dl one; maskh := l_or (l_sl !maskh one) (l_sr !maskl (of_int (uint_size - 1))); - maskl := l_sl !maskl one - done; (* mask = 2^N, d = 2^N * d, d >= x *) + maskl := l_sl !maskl one; + (* incr n *) + cmp := lt128 !dh !dl xh xl; + done; (* mask = 2^n, d = 2^n * d, 2 * d > x *) let remh = ref xh in let reml = ref xl in - let quotient = ref zero in + (* quotienth = ref 0 *) + let quotientl = ref zero in + (* loop invariant: x = quotient * y + rem, y * 2^(n+1) > r, + mask = floor(2^n), d = mask * y, n >= -1 *) while not (Int64.equal (l_or !maskh !maskl) zero) do if le128 !dh !dl !remh !reml then begin (* if rem >= d, add one bit and subtract d *) - quotient := l_or !quotient !maskl; + (* quotienth := !quotienth lor !maskh *) + quotientl := l_or !quotientl !maskl; remh := if lt !reml !dl then sub (sub !remh !dh) one else sub !remh !dh; reml := sub !reml !dl end; @@ -121,9 +130,11 @@ let div21 xh xl y = maskh := l_sr !maskh one; dl := l_or (l_sr !dl one) (l_sl !dh (of_int (uint_size - 1))); dh := l_sr !dh one + (* decr n *) done; - !quotient, !reml + !quotientl, !reml +let div21 xh xl y = if Int64.equal y zero then zero, zero else div21 xh xl y (* exact multiplication *) let mulc x y = diff --git a/lib/acyclicGraph.ml b/lib/acyclicGraph.ml index 7d04c8f5a1..e1dcfcc6ce 100644 --- a/lib/acyclicGraph.ml +++ b/lib/acyclicGraph.ml @@ -721,7 +721,10 @@ module Make (Point:Point) = struct let rmap, csts = PSet.fold (fun u (rmap,csts) -> let arcu = repr g u in if PSet.mem arcu.canon kept then - PMap.add arcu.canon arcu.canon rmap, Constraint.add (u,Eq,arcu.canon) csts + let csts = if Point.equal u arcu.canon then csts + else Constraint.add (u,Eq,arcu.canon) csts + in + PMap.add arcu.canon arcu.canon rmap, csts else match PMap.find arcu.canon rmap with | v -> rmap, Constraint.add (u,Eq,v) csts 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/funind/recdef.ml b/plugins/funind/recdef.ml index 3c2b03dfe0..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|]);; @@ -701,7 +701,7 @@ let mkDestructEq : let changefun patvars env sigma = pattern_occs [Locus.AllOccurrencesBut [1], expr] (pf_env g2) sigma (pf_concl g2) in - Proofview.V82.of_tactic (change_in_concl None changefun) g2); + Proofview.V82.of_tactic (change_in_concl ~check:true None changefun) g2); Proofview.V82.of_tactic (simplest_case expr)]), to_revert @@ -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/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 99a9c1ab9a..a68efa4713 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -1574,8 +1574,8 @@ let newfail n s = let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = let open Proofview.Notations in (* For compatibility *) - let beta = Tactics.reduct_in_concl (Reductionops.nf_betaiota, DEFAULTcast) in - let beta_hyp id = Tactics.reduct_in_hyp Reductionops.nf_betaiota (id, InHyp) in + let beta = Tactics.reduct_in_concl ~check:false (Reductionops.nf_betaiota, DEFAULTcast) in + let beta_hyp id = Tactics.reduct_in_hyp ~check:false ~reorder:false Reductionops.nf_betaiota (id, InHyp) in let treat sigma res = match res with | None -> newfail 0 (str "Nothing to rewrite") @@ -1596,7 +1596,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = tclTHENFIRST (assert_replacing id newt tac) (beta_hyp id) | Some id, None -> Proofview.Unsafe.tclEVARS undef <*> - convert_hyp ~check:false (LocalAssum (make_annot id Sorts.Relevant, newt)) <*> + convert_hyp ~check:false ~reorder:false (LocalAssum (make_annot id Sorts.Relevant, newt)) <*> beta_hyp id | None, Some p -> Proofview.Unsafe.tclEVARS undef <*> 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/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index f3bc791b8d..ffc3506a1f 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -1849,12 +1849,12 @@ let destructure_hyps = match destructurate_type env sigma typ with | Kapp(Nat,_) -> (tclTHEN - (Tactics.convert_hyp ~check:false (NamedDecl.set_type (mkApp (Lazy.force coq_neq, [| t1;t2|])) + (Tactics.convert_hyp ~check:false ~reorder:false (NamedDecl.set_type (mkApp (Lazy.force coq_neq, [| t1;t2|])) decl)) (loop lit)) | Kapp(Z,_) -> (tclTHEN - (Tactics.convert_hyp ~check:false (NamedDecl.set_type (mkApp (Lazy.force coq_Zne, [| t1;t2|])) + (Tactics.convert_hyp ~check:false ~reorder:false (NamedDecl.set_type (mkApp (Lazy.force coq_Zne, [| t1;t2|])) decl)) (loop lit)) | _ -> loop lit diff --git a/plugins/setoid_ring/Field_theory.v b/plugins/setoid_ring/Field_theory.v index 813c521ab0..ad2ee821b3 100644 --- a/plugins/setoid_ring/Field_theory.v +++ b/plugins/setoid_ring/Field_theory.v @@ -1235,12 +1235,19 @@ Notation ring_correct := (ring_correct Rsth Reqe ARth CRmorph pow_th cdiv_th). (* simplify a field expression into a fraction *) -(* TODO: simplify when den is constant... *) Definition display_linear l num den := - NPphi_dev l num / NPphi_dev l den. + let lnum := NPphi_dev l num in + match den with + | Pc c => if ceqb c cI then lnum else lnum / NPphi_dev l den + | _ => lnum / NPphi_dev l den + end. Definition display_pow_linear l num den := - NPphi_pow l num / NPphi_pow l den. + let lnum := NPphi_pow l num in + match den with + | Pc c => if ceqb c cI then lnum else lnum / NPphi_pow l den + | _ => lnum / NPphi_pow l den + end. Theorem Field_rw_correct n lpe l : Ninterp_PElist l lpe -> @@ -1252,7 +1259,18 @@ Theorem Field_rw_correct n lpe l : Proof. intros Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp. rewrite (Fnorm_FEeval_PEeval _ _ H). - unfold display_linear; apply rdiv_ext; + unfold display_linear. + destruct (Nnorm _ _ _) as [c | | ] eqn: HN; + try ( apply rdiv_ext; + eapply ring_rw_correct; eauto). + destruct (ceqb_spec c cI). + set (nnum := NPphi_dev _ _). + apply eq_trans with (nnum / NPphi_dev l (Pc c)). + apply rdiv_ext; + eapply ring_rw_correct; eauto. + rewrite Pphi_dev_ok; try eassumption. + now simpl; rewrite H0, phi_1, <- rdiv1. + apply rdiv_ext; eapply ring_rw_correct; eauto. Qed. @@ -1266,8 +1284,19 @@ Theorem Field_rw_pow_correct n lpe l : Proof. intros Hlpe lmp lmp_eq fe nfe eq_nfe H; subst nfe lmp. rewrite (Fnorm_FEeval_PEeval _ _ H). - unfold display_pow_linear; apply rdiv_ext; - eapply ring_rw_pow_correct;eauto. + unfold display_pow_linear. + destruct (Nnorm _ _ _) as [c | | ] eqn: HN; + try ( apply rdiv_ext; + eapply ring_rw_pow_correct; eauto). + destruct (ceqb_spec c cI). + set (nnum := NPphi_pow _ _). + apply eq_trans with (nnum / NPphi_pow l (Pc c)). + apply rdiv_ext; + eapply ring_rw_pow_correct; eauto. + rewrite Pphi_pow_ok; try eassumption. + now simpl; rewrite H0, phi_1, <- rdiv1. + apply rdiv_ext; + eapply ring_rw_pow_correct; eauto. Qed. Theorem Field_correct n l lpe fe1 fe2 : diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 3f69701bd3..b02b97f656 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -89,10 +89,10 @@ let protect_red map env sigma c0 = EConstr.of_constr (eval 0 c) let protect_tac map = - Tactics.reduct_option (protect_red map,DEFAULTcast) None + Tactics.reduct_option ~check:false (protect_red map,DEFAULTcast) None let protect_tac_in map id = - Tactics.reduct_option (protect_red map,DEFAULTcast) (Some(id, Locus.InHyp)) + Tactics.reduct_option ~check:false (protect_red map,DEFAULTcast) (Some(id, Locus.InHyp)) (****************************************************************************) diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index a4caeb403c..56f17703ff 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -427,7 +427,7 @@ let mk_anon_id t gl_ids = Id.of_string_soft (Bytes.to_string (loop (n - 1))) let convert_concl_no_check t = Tactics.convert_concl ~check:false t DEFAULTcast -let convert_concl t = Tactics.convert_concl t DEFAULTcast +let convert_concl ~check t = Tactics.convert_concl ~check t DEFAULTcast let rename_hd_prod orig_name_ref gl = match EConstr.kind (project gl) (pf_concl gl) with @@ -799,7 +799,7 @@ let discharge_hyp (id', (id, mode)) gl = | NamedDecl.LocalDef (_, v, t), _ -> let id' = {(NamedDecl.get_annot decl) with binder_name = Name id'} in Proofview.V82.of_tactic - (convert_concl (EConstr.of_constr (mkLetIn (id', v, t, cl')))) gl + (convert_concl ~check:true (EConstr.of_constr (mkLetIn (id', v, t, cl')))) gl (* wildcard names *) let clear_wilds wilds gl = @@ -1170,7 +1170,7 @@ let gentac gen gl = ppdebug(lazy(str"c@gentac=" ++ pr_econstr_env (pf_env gl) (project gl) c)); let gl = pf_merge_uc ucst gl in if conv - then tclTHEN (Proofview.V82.of_tactic (convert_concl cl)) (old_cleartac clr) gl + then tclTHEN (Proofview.V82.of_tactic (convert_concl ~check:true cl)) (old_cleartac clr) gl else genclrtac cl [c] clr gl let genstac (gens, clr) = @@ -1215,7 +1215,7 @@ let unprotecttac gl = let prot, _ = EConstr.destConst (project gl) c in Tacticals.onClause (fun idopt -> let hyploc = Option.map (fun id -> id, InHyp) idopt in - Proofview.V82.of_tactic (Tactics.reduct_option + Proofview.V82.of_tactic (Tactics.reduct_option ~check:false (Reductionops.clos_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fBETA; @@ -1282,10 +1282,10 @@ let clr_of_wgen gen clrs = match gen with | clr, _ -> old_cleartac clr :: clrs -let reduct_in_concl t = Tactics.reduct_in_concl (t, DEFAULTcast) +let reduct_in_concl ~check t = Tactics.reduct_in_concl ~check (t, DEFAULTcast) let unfold cl = let module R = Reductionops in let module F = CClosure.RedFlags in - reduct_in_concl (R.clos_norm_flags (F.mkflags + reduct_in_concl ~check:false (R.clos_norm_flags (F.mkflags (List.map (fun c -> F.fCONST (fst (destConst (EConstr.Unsafe.to_constr c)))) cl @ [F.fBETA; F.fMATCH; F.fFIX; F.fCOFIX]))) diff --git a/plugins/ssr/ssrcommon.mli b/plugins/ssr/ssrcommon.mli index 58ce84ecb3..575f016014 100644 --- a/plugins/ssr/ssrcommon.mli +++ b/plugins/ssr/ssrcommon.mli @@ -252,7 +252,7 @@ val ssrevaltac : Tacinterp.interp_sign -> Tacinterp.Value.t -> unit Proofview.tactic val convert_concl_no_check : EConstr.t -> unit Proofview.tactic -val convert_concl : EConstr.t -> unit Proofview.tactic +val convert_concl : check:bool -> EConstr.t -> unit Proofview.tactic val red_safe : Reductionops.reduction_function -> diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index ad20113320..93c0d5c236 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -118,7 +118,7 @@ let newssrcongrtac arg ist gl = match try Some (pf_unify_HO gl_c (pf_concl gl) c) with exn when CErrors.noncritical exn -> None with | Some gl_c -> - tclTHEN (Proofview.V82.of_tactic (convert_concl (fs gl_c c))) + tclTHEN (Proofview.V82.of_tactic (convert_concl ~check:true (fs gl_c c))) (t_ok (proj gl_c)) gl | None -> t_fail () gl in let mk_evar gl ty = @@ -276,7 +276,7 @@ let unfoldintac occ rdx t (kt,_) gl = try beta env0 (EConstr.of_constr (eval_pattern env0 sigma0 concl0 rdx occ unfold)) with Option.IsNone -> errorstrm Pp.(str"Failed to unfold " ++ pr_econstr_pat env0 sigma t) in let _ = conclude () in - Proofview.V82.of_tactic (convert_concl concl) gl + Proofview.V82.of_tactic (convert_concl ~check:true concl) gl ;; let foldtac occ rdx ft gl = @@ -303,7 +303,7 @@ let foldtac occ rdx ft gl = let concl0 = EConstr.Unsafe.to_constr concl0 in let concl = eval_pattern env0 sigma0 concl0 rdx occ fold in let _ = conclude () in - Proofview.V82.of_tactic (convert_concl (EConstr.of_constr concl)) gl + Proofview.V82.of_tactic (convert_concl ~check:true (EConstr.of_constr concl)) gl ;; let converse_dir = function L2R -> R2L | R2L -> L2R @@ -406,7 +406,7 @@ let rwcltac ?under ?map_redex cl rdx dir sr gl = let cl' = EConstr.mkApp (EConstr.mkNamedLambda (make_annot pattern_id Sorts.Relevant) rdxt cl, [|rdx|]) in let sigma, _ = Typing.type_of env sigma cl' in let gl = pf_merge_uc_of sigma gl in - Proofview.V82.of_tactic (convert_concl cl'), rewritetac ?under dir r', gl + Proofview.V82.of_tactic (convert_concl ~check:true cl'), rewritetac ?under dir r', gl else let dc, r2 = EConstr.decompose_lam_n_assum (project gl) n r' in let r3, _, r3t = @@ -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 @@ -644,7 +644,7 @@ let unfoldtac occ ko t kt gl = let cl' = EConstr.Vars.subst1 (pf_unfoldn [OnlyOccurrences [1], get_evalref env (project gl) c] gl c) cl in let f = if ko = None then CClosure.betaiotazeta else CClosure.betaiota in Proofview.V82.of_tactic - (convert_concl (pf_reduce (Reductionops.clos_norm_flags f) gl cl')) gl + (convert_concl ~check:true (pf_reduce (Reductionops.clos_norm_flags f) gl cl')) gl let unlocktac ist args gl = let utac (occ, gt) gl = diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index 01d71aa96a..4d4400a0f8 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -56,7 +56,7 @@ let ssrsettac id ((_, (pat, pty)), (_, occ)) gl = | Cast(t, DEFAULTcast, ty) -> t, (gl, ty) | _ -> c, pfe_type_of gl c in let cl' = EConstr.mkLetIn (make_annot (Name id) Sorts.Relevant, c, cty, cl) in - Tacticals.tclTHEN (Proofview.V82.of_tactic (convert_concl cl')) (introid id) gl + Tacticals.tclTHEN (Proofview.V82.of_tactic (convert_concl ~check:true cl')) (introid id) gl open Util @@ -161,7 +161,7 @@ let havetac ist let gl, ty = pfe_type_of gl t in let ctx, _ = EConstr.decompose_prod_n_assum (project gl) 1 ty in let assert_is_conv gl = - try Proofview.V82.of_tactic (convert_concl (EConstr.it_mkProd_or_LetIn concl ctx)) gl + try Proofview.V82.of_tactic (convert_concl ~check:true (EConstr.it_mkProd_or_LetIn concl ctx)) gl with _ -> errorstrm (str "Given proof term is not of type " ++ pr_econstr_env (pf_env gl) (project gl) (EConstr.mkArrow (EConstr.mkVar (Id.of_string "_")) Sorts.Relevant concl)) in gl, ty, Tacticals.tclTHEN assert_is_conv (Proofview.V82.of_tactic (Tactics.apply t)), id, itac_c @@ -471,7 +471,7 @@ let undertac ?(pad_intro = false) ist ipats ((dir,_),_ as rule) hint = if hint = nohint then Proofview.tclUNIT () else - let betaiota = Tactics.reduct_in_concl (Reductionops.nf_betaiota, DEFAULTcast) in + let betaiota = Tactics.reduct_in_concl ~check:false (Reductionops.nf_betaiota, DEFAULTcast) in (* Usefulness of check_numgoals: tclDISPATCH would be enough, except for the error message w.r.t. the number of provided/expected tactics, as the last one is implied *) diff --git a/plugins/ssr/ssrtacticals.ml b/plugins/ssr/ssrtacticals.ml index 17e4114958..91ff432364 100644 --- a/plugins/ssr/ssrtacticals.ml +++ b/plugins/ssr/ssrtacticals.ml @@ -110,7 +110,7 @@ let endclausestac id_map clseq gl_id cl0 gl = | _ -> EConstr.map (project gl) unmark c in let utac hyp = Proofview.V82.of_tactic - (Tactics.convert_hyp ~check:false (NamedDecl.map_constr unmark hyp)) in + (Tactics.convert_hyp ~check:false ~reorder:false (NamedDecl.map_constr unmark hyp)) in let utacs = List.map utac (pf_hyps gl) in let ugtac gl' = Proofview.V82.of_tactic diff --git a/plugins/ssrmatching/ssrmatching.ml b/plugins/ssrmatching/ssrmatching.ml index 1deb935d5c..4e0866a0c5 100644 --- a/plugins/ssrmatching/ssrmatching.ml +++ b/plugins/ssrmatching/ssrmatching.ml @@ -1299,7 +1299,7 @@ let ssrpatterntac _ist arg gl = let concl_x = EConstr.of_constr concl_x in let gl, tty = pf_type_of gl t in let concl = EConstr.mkLetIn (make_annot (Name (Id.of_string "selected")) Sorts.Relevant, t, tty, concl_x) in - Proofview.V82.of_tactic (convert_concl concl DEFAULTcast) gl + Proofview.V82.of_tactic (convert_concl ~check:true concl DEFAULTcast) gl (* Register "ssrpattern" tactic *) let () = diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 0ccc4fd9f9..6b149a8b41 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -146,8 +146,8 @@ let flex_kind_of_term flags env evd c sk = let apprec_nohdbeta flags env evd c = let (t,sk as appr) = Reductionops.whd_nored_state evd (c, []) in if flags.modulo_betaiota && Stack.not_purely_applicative sk - then Stack.zip evd (fst (whd_betaiota_deltazeta_for_iota_state - flags.open_ts env evd Cst_stack.empty appr)) + then Stack.zip evd (whd_betaiota_deltazeta_for_iota_state + flags.open_ts env evd appr) else c let position_problem l2r = function @@ -496,8 +496,8 @@ let rec evar_conv_x flags env evd pbty term1 term2 = let term2 = apprec_nohdbeta flags env evd term2 in let default () = evar_eqappr_x flags env evd pbty - (whd_nored_state evd (term1,Stack.empty), Cst_stack.empty) - (whd_nored_state evd (term2,Stack.empty), Cst_stack.empty) + (whd_nored_state evd (term1,Stack.empty)) + (whd_nored_state evd (term2,Stack.empty)) in begin match EConstr.kind evd term1, EConstr.kind evd term2 with | Evar ev, _ when Evd.is_undefined evd (fst ev) && not (is_frozen flags ev) -> @@ -525,7 +525,7 @@ let rec evar_conv_x flags env evd pbty term1 term2 = end and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty - ((term1,sk1 as appr1),csts1) ((term2,sk2 as appr2),csts2) = + (term1, sk1 as appr1) (term2, sk2 as appr2) = let quick_fail i = (* not costly, loses info *) UnifFailure (i, NotSameHead) in @@ -555,8 +555,8 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty let c = nf_evar evd c1 in let env' = push_rel (RelDecl.LocalAssum (na,c)) env in let out1 = whd_betaiota_deltazeta_for_iota_state - flags.open_ts env' evd Cst_stack.empty (c'1, Stack.empty) in - let out2 = whd_nored_state evd + flags.open_ts env' evd (c'1, Stack.empty) in + let out2, _ = whd_nored_state evd (lift 1 (Stack.zip evd (term', sk')), Stack.append_app [|EConstr.mkRel 1|] Stack.empty), Cst_stack.empty in if onleft then evar_eqappr_x flags env' evd CONV out1 out2 @@ -636,11 +636,11 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty else quick_fail i) ev lF tM i in - let flex_maybeflex on_left ev ((termF,skF as apprF),cstsF) ((termM, skM as apprM),cstsM) vM = + let flex_maybeflex on_left ev (termF,skF as apprF) (termM, skM as apprM) vM = let switch f a b = if on_left then f a b else f b a in let delta i = - switch (evar_eqappr_x flags env i pbty) (apprF,cstsF) - (whd_betaiota_deltazeta_for_iota_state flags.open_ts env i cstsM (vM,skM)) + switch (evar_eqappr_x flags env i pbty) apprF + (whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (vM,skM)) in let default i = ise_try i [miller on_left ev apprF apprM; consume on_left apprF apprM; @@ -658,11 +658,11 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty let f = try let termM' = Retyping.expand_projection env evd p c [] in - let apprM', cstsM' = - whd_betaiota_deltazeta_for_iota_state flags.open_ts env evd cstsM (termM',skM) + let apprM' = + whd_betaiota_deltazeta_for_iota_state flags.open_ts env evd (termM',skM) in let delta' i = - switch (evar_eqappr_x flags env i pbty) (apprF,cstsF) (apprM',cstsM') + switch (evar_eqappr_x flags env i pbty) apprF apprM' in fun i -> ise_try i [miller on_left ev apprF apprM'; consume on_left apprF apprM'; delta'] @@ -718,7 +718,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty (position_problem true pbty,destEvar i' ev1',term2) else evar_eqappr_x flags env evd pbty - ((ev1', sk1), csts1) ((term2, sk2), csts2) + (ev1', sk1) (term2, sk2) | Some (r,[]), Success i' -> (* We have sk1'[] = sk2[] for some sk1' s.t. sk1[]=sk1'[r[]] *) (* we now unify r[?ev1] and ?ev2 *) @@ -728,7 +728,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty (position_problem false pbty,destEvar i' ev2',Stack.zip i' (term1,r)) else evar_eqappr_x flags env evd pbty - ((ev2', sk1), csts1) ((term2, sk2), csts2) + (ev2', sk1) (term2, sk2) | Some ([],r), Success i' -> (* Symmetrically *) (* We have sk1[] = sk2'[] for some sk2' s.t. sk2[]=sk2'[r[]] *) @@ -738,7 +738,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty solve_simple_eqn (conv_fun evar_conv_x) flags env i' (position_problem true pbty,destEvar i' ev1',Stack.zip i' (term2,r)) else evar_eqappr_x flags env evd pbty - ((ev1', sk1), csts1) ((term2, sk2), csts2) + (ev1', sk1) (term2, sk2) | None, (UnifFailure _ as x) -> (* sk1 and sk2 have no common outer part *) if Stack.not_purely_applicative sk2 then @@ -808,10 +808,10 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty ise_try evd [f1; f2; f3; f4; f5] | Flexible ev1, MaybeFlexible v2 -> - flex_maybeflex true ev1 (appr1,csts1) (appr2,csts2) v2 + flex_maybeflex true ev1 appr1 appr2 v2 | MaybeFlexible v1, Flexible ev2 -> - flex_maybeflex false ev2 (appr2,csts2) (appr1,csts1) v1 + flex_maybeflex false ev2 appr2 appr1 v1 | MaybeFlexible v1, MaybeFlexible v2 -> begin match EConstr.kind evd term1, EConstr.kind evd term2 with @@ -829,8 +829,8 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty evar_conv_x flags (push_rel (RelDecl.LocalDef (na,b,t)) env) i pbty c'1 c'2); (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] and f2 i = - let out1 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i csts1 (v1,sk1) - and out2 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i csts2 (v2,sk2) + let out1 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (v1,sk1) + and out2 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (v2,sk2) in evar_eqappr_x flags env i pbty out1 out2 in ise_try evd [f1; f2] @@ -841,8 +841,8 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty [(fun i -> evar_conv_x flags env i CONV c c'); (fun i -> exact_ise_stack2 env i (evar_conv_x flags) sk1 sk2)] and f2 i = - let out1 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i csts1 (v1,sk1) - and out2 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i csts2 (v2,sk2) + let out1 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (v1,sk1) + and out2 = whd_betaiota_deltazeta_for_iota_state flags.open_ts env i (v2,sk2) in evar_eqappr_x flags env i pbty out1 out2 in ise_try evd [f1; f2] @@ -855,8 +855,8 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty in (match res with | Some (f1,args1) -> - evar_eqappr_x flags env evd pbty ((f1,Stack.append_app args1 sk1),csts1) - (appr2,csts2) + evar_eqappr_x flags env evd pbty (f1,Stack.append_app args1 sk1) + appr2 | None -> UnifFailure (evd,NotSameHead)) | Const (p,u), Proj (p',c') when Constant.equal p (Projection.constant p') -> @@ -866,7 +866,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty in (match res with | Some (f2,args2) -> - evar_eqappr_x flags env evd pbty (appr1,csts1) ((f2,Stack.append_app args2 sk2),csts2) + evar_eqappr_x flags env evd pbty appr1 (f2,Stack.append_app args2 sk2) | None -> UnifFailure (evd,NotSameHead)) | _, _ -> @@ -906,16 +906,16 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty (* false (* immediate solution without Canon Struct *)*) | Lambda _ -> assert (match args with [] -> true | _ -> false); true | LetIn (_,b,_,c) -> is_unnamed - (fst (whd_betaiota_deltazeta_for_iota_state - flags.open_ts env i Cst_stack.empty (subst1 b c, args))) + (whd_betaiota_deltazeta_for_iota_state + flags.open_ts env i (subst1 b c, args)) | Fix _ -> true (* Partially applied fix can be the result of a whd call *) | Proj (p, _) -> Projection.unfolded p || Stack.not_purely_applicative args | Case _ | App _| Cast _ -> assert false in let rhs_is_stuck_and_unnamed () = let applicative_stack = fst (Stack.strip_app sk2) in is_unnamed - (fst (whd_betaiota_deltazeta_for_iota_state - flags.open_ts env i Cst_stack.empty (v2, applicative_stack))) in + (whd_betaiota_deltazeta_for_iota_state + flags.open_ts env i (v2, applicative_stack)) in let rhs_is_already_stuck = rhs_is_already_stuck || rhs_is_stuck_and_unnamed () in @@ -923,12 +923,12 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty && (not (Stack.not_purely_applicative sk1)) then evar_eqappr_x ~rhs_is_already_stuck flags env i pbty (whd_betaiota_deltazeta_for_iota_state - flags.open_ts env i (Cst_stack.add_cst term1 csts1) (v1,sk1)) - (appr2,csts2) + flags.open_ts env i(v1,sk1)) + appr2 else - evar_eqappr_x flags env i pbty (appr1,csts1) + evar_eqappr_x flags env i pbty appr1 (whd_betaiota_deltazeta_for_iota_state - flags.open_ts env i (Cst_stack.add_cst term2 csts2) (v2,sk2)) + flags.open_ts env i (v2,sk2)) in ise_try evd [f1; f2; f3] end @@ -957,8 +957,8 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty and f4 i = evar_eqappr_x flags env i pbty (whd_betaiota_deltazeta_for_iota_state - flags.open_ts env i (Cst_stack.add_cst term1 csts1) (v1,sk1)) - (appr2,csts2) + flags.open_ts env i (v1,sk1)) + appr2 in ise_try evd [f3; f4] @@ -969,9 +969,9 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty else conv_record flags env i (check_conv_record env i appr2 appr1) with Not_found -> UnifFailure (i,NoCanonicalStructure)) and f4 i = - evar_eqappr_x flags env i pbty (appr1,csts1) + evar_eqappr_x flags env i pbty appr1 (whd_betaiota_deltazeta_for_iota_state - flags.open_ts env i (Cst_stack.add_cst term2 csts2) (v2,sk2)) + flags.open_ts env i (v2,sk2)) in ise_try evd [f3; f4] @@ -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 0fe47c2a48..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. @@ -144,7 +131,7 @@ val evar_unify : Evarsolve.unifier (* For debugging *) val evar_eqappr_x : ?rhs_is_already_stuck:bool -> unify_flags -> env -> evar_map -> - conv_pb -> state * Cst_stack.t -> state * Cst_stack.t -> + conv_pb -> state -> state -> Evarsolve.unification_result val occur_rigidly : Evarsolve.unify_flags -> 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/pretyping/reductionops.ml b/pretyping/reductionops.ml index 1871609e18..85e6f51387 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -90,48 +90,43 @@ module ReductionBehaviour = struct open Names open Libobject - type t = { - b_nargs: int; - b_recargs: int list; - b_dont_expose_case: bool; - } + type t = NeverUnfold | UnfoldWhen of when_flags | UnfoldWhenNoMatch of when_flags + and when_flags = { recargs : int list ; nargs : int option } + + let more_args_when k { recargs; nargs } = + { nargs = Option.map ((+) k) nargs; + recargs = List.map ((+) k) recargs; + } + + let more_args k = function + | NeverUnfold -> NeverUnfold + | UnfoldWhen x -> UnfoldWhen (more_args_when k x) + | UnfoldWhenNoMatch x -> UnfoldWhenNoMatch (more_args_when k x) let table = Summary.ref (GlobRef.Map.empty : t GlobRef.Map.t) ~name:"reductionbehaviour" - type flag = [ `ReductionDontExposeCase | `ReductionNeverUnfold ] - type req = - | ReqLocal - | ReqGlobal of GlobRef.t * (int list * int * flag list) - let load _ (_,(_,(r, b))) = table := GlobRef.Map.add r b !table let cache o = load 1 o - let classify = function - | ReqLocal, _ -> Dispose - | ReqGlobal _, _ as o -> Substitute o + let classify (local,_ as o) = if local then Dispose else Substitute o - let subst (subst, (_, (r,o as orig))) = - ReqLocal, - let r' = fst (subst_global subst r) in if r==r' then orig else (r',o) + let subst (subst, (local, (r,o) as orig)) = + let r' = subst_global_reference subst r in if r==r' then orig + else (local,(r',o)) let discharge = function - | _,(ReqGlobal (ConstRef c as gr, req), (_, b)) -> + | _,(false, (gr, b)) -> let b = if Lib.is_in_section gr then let vars = Lib.variable_section_segment_of_reference gr in let extra = List.length vars in - let nargs' = - if b.b_nargs = max_int then max_int - else if b.b_nargs < 0 then b.b_nargs - else b.b_nargs + extra in - let recargs' = List.map ((+) extra) b.b_recargs in - { b with b_nargs = nargs'; b_recargs = recargs' } + more_args extra b else b in - Some (ReqGlobal (gr, req), (ConstRef c, b)) + Some (false, (gr, b)) | _ -> None let rebuild = function @@ -148,55 +143,45 @@ module ReductionBehaviour = struct rebuild_function = rebuild; } - let set local r (recargs, nargs, flags as req) = - let nargs = if List.mem `ReductionNeverUnfold flags then max_int else nargs in - let behaviour = { - b_nargs = nargs; b_recargs = recargs; - b_dont_expose_case = List.mem `ReductionDontExposeCase flags } in - let req = if local then ReqLocal else ReqGlobal (r, req) in - Lib.add_anonymous_leaf (inRedBehaviour (req, (r, behaviour))) - ;; + let set ~local r b = + Lib.add_anonymous_leaf (inRedBehaviour (local, (r, b))) - let get r = - try - let b = GlobRef.Map.find r !table in - let flags = - if Int.equal b.b_nargs max_int then [`ReductionNeverUnfold] - else if b.b_dont_expose_case then [`ReductionDontExposeCase] else [] in - Some (b.b_recargs, (if Int.equal b.b_nargs max_int then -1 else b.b_nargs), flags) - with Not_found -> None + let get r = GlobRef.Map.find_opt r !table let print ref = let open Pp in let pr_global = Nametab.pr_global_env Id.Set.empty in match get ref with | None -> mt () - | Some (recargs, nargs, flags) -> - let never = List.mem `ReductionNeverUnfold flags in - let nomatch = List.mem `ReductionDontExposeCase flags in - let pp_nomatch = spc() ++ if nomatch then - str "but avoid exposing match constructs" else str"" in - let pp_recargs = spc() ++ str "when the " ++ + | Some b -> + let pp_nomatch = spc () ++ str "but avoid exposing match constructs" in + let pp_recargs recargs = spc() ++ str "when the " ++ pr_enum (fun x -> pr_nth (x+1)) recargs ++ str (String.plural (List.length recargs) " argument") ++ str (String.plural (if List.length recargs >= 2 then 1 else 2) " evaluate") ++ str " to a constructor" in - let pp_nargs = - spc() ++ str "when applied to " ++ int nargs ++ - str (String.plural nargs " argument") in - hov 2 (str "The reduction tactics " ++ - match recargs, nargs, never with - | _,_, true -> str "never unfold " ++ pr_global ref - | [], 0, _ -> str "always unfold " ++ pr_global ref - | _::_, n, _ when n < 0 -> - str "unfold " ++ pr_global ref ++ pp_recargs ++ pp_nomatch - | _::_, n, _ when n > List.fold_left max 0 recargs -> - str "unfold " ++ pr_global ref ++ pp_recargs ++ - str " and" ++ pp_nargs ++ pp_nomatch - | _::_, _, _ -> - str "unfold " ++ pr_global ref ++ pp_recargs ++ pp_nomatch - | [], n, _ when n > 0 -> - str "unfold " ++ pr_global ref ++ pp_nargs ++ pp_nomatch - | _ -> str "unfold " ++ pr_global ref ++ pp_nomatch ) + let pp_nargs nargs = + spc() ++ str "when applied to " ++ int nargs ++ + str (String.plural nargs " argument") in + let pp_when = function + | { recargs = []; nargs = Some 0 } -> + str "always unfold " ++ pr_global ref + | { recargs = []; nargs = Some n } -> + str "unfold " ++ pr_global ref ++ pp_nargs n + | { recargs = []; nargs = None } -> + str "unfold " ++ pr_global ref + | { recargs; nargs = Some n } when n > List.fold_left max 0 recargs -> + str "unfold " ++ pr_global ref ++ pp_recargs recargs ++ + str " and" ++ pp_nargs n + | { recargs; nargs = _ } -> + str "unfold " ++ pr_global ref ++ pp_recargs recargs + in + let pp_behavior = function + | NeverUnfold -> str "never unfold " ++ pr_global ref + | UnfoldWhen x -> pp_when x + | UnfoldWhenNoMatch x -> pp_when x ++ pp_nomatch + in + hov 2 (str "The reduction tactics " ++ pp_behavior b) + end (** Machinery about stack of unfolded constants *) @@ -928,6 +913,7 @@ let equal_stacks sigma (x, l) (y, l') = let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = let open Context.Named.Declaration in + let open ReductionBehaviour in let rec whrec cst_l (x, stack) = let () = if !debug_RAKAM then let open Pp in @@ -974,37 +960,42 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = else (* Looks for ReductionBehaviour *) match ReductionBehaviour.get (Globnames.ConstRef c) with | None -> whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, stack) - | Some (recargs, nargs, flags) -> - if (List.mem `ReductionNeverUnfold flags - || (nargs > 0 && Stack.args_size stack < nargs)) - then fold () - else (* maybe unfolds *) - if List.mem `ReductionDontExposeCase flags then - let app_sk,sk = Stack.strip_app stack in - let (tm',sk'),cst_l' = - whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, app_sk) - in - let rec is_case x = match EConstr.kind sigma x with - | Lambda (_,_, x) | LetIn (_,_,_, x) | Cast (x, _,_) -> is_case x - | App (hd, _) -> is_case hd - | Case _ -> true - | _ -> false in - if equal_stacks sigma (x, app_sk) (tm', sk') - || Stack.will_expose_iota sk' - || is_case tm' - then fold () - else whrec cst_l' (tm', sk' @ sk) - else match recargs with - |[] -> (* if nargs has been specified *) - (* CAUTION : the constant is NEVER refold - (even when it hides a (co)fix) *) - whrec cst_l (body, stack) - |curr::remains -> match Stack.strip_n_app curr stack with - | None -> fold () - | Some (bef,arg,s') -> - whrec Cst_stack.empty - (arg,Stack.Cst(Stack.Cst_const (fst const, u'),curr,remains,bef,cst_l)::s') - end + | Some behavior -> + begin match behavior with + | NeverUnfold -> fold () + | (UnfoldWhen { nargs = Some n } | + UnfoldWhenNoMatch { nargs = Some n } ) + when Stack.args_size stack < n -> + fold () + | UnfoldWhenNoMatch { recargs } -> (* maybe unfolds *) + let app_sk,sk = Stack.strip_app stack in + let (tm',sk'),cst_l' = + whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, app_sk) + in + let rec is_case x = match EConstr.kind sigma x with + | Lambda (_,_, x) | LetIn (_,_,_, x) | Cast (x, _,_) -> is_case x + | App (hd, _) -> is_case hd + | Case _ -> true + | _ -> false in + if equal_stacks sigma (x, app_sk) (tm', sk') + || Stack.will_expose_iota sk' + || is_case tm' + then fold () + else whrec cst_l' (tm', sk' @ sk) + | UnfoldWhen { recargs } -> (* maybe unfolds *) + begin match recargs with + |[] -> (* if nargs has been specified *) + (* CAUTION : the constant is NEVER refold + (even when it hides a (co)fix) *) + whrec cst_l (body, stack) + |curr::remains -> match Stack.strip_n_app curr stack with + | None -> fold () + | Some (bef,arg,s') -> + whrec Cst_stack.empty + (arg,Stack.Cst(Stack.Cst_const (fst const, u'),curr,remains,bef,cst_l)::s') + end + end + end | exception NotEvaluableConst (IsPrimitive p) when Stack.check_native_args p stack -> let kargs = CPrimitives.kind p in let (kargs,o) = Stack.get_next_primitive_args kargs stack in @@ -1015,41 +1006,45 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = else fold () | Proj (p, c) when CClosure.RedFlags.red_projection flags p -> (let npars = Projection.npars p in - if not tactic_mode then - let stack' = (c, Stack.Proj (p, Cst_stack.empty (*cst_l*)) :: stack) in - whrec Cst_stack.empty stack' - else match ReductionBehaviour.get (Globnames.ConstRef (Projection.constant p)) with - | None -> + if not tactic_mode then + let stack' = (c, Stack.Proj (p, Cst_stack.empty (*cst_l*)) :: stack) in + whrec Cst_stack.empty stack' + else match ReductionBehaviour.get (Globnames.ConstRef (Projection.constant p)) with + | None -> let stack' = (c, Stack.Proj (p, cst_l) :: stack) in - let stack'', csts = whrec Cst_stack.empty stack' in - if equal_stacks sigma stack' stack'' then fold () - else stack'', csts - | Some (recargs, nargs, flags) -> - if (List.mem `ReductionNeverUnfold flags - || (nargs > 0 && Stack.args_size stack < (nargs - (npars + 1)))) - then fold () - else - let recargs = List.map_filter (fun x -> - let idx = x - npars in - if idx < 0 then None else Some idx) recargs - in - match recargs with - |[] -> (* if nargs has been specified *) - (* CAUTION : the constant is NEVER refold - (even when it hides a (co)fix) *) + let stack'', csts = whrec Cst_stack.empty stack' in + if equal_stacks sigma stack' stack'' then fold () + else stack'', csts + | Some behavior -> + begin match behavior with + | NeverUnfold -> fold () + | (UnfoldWhen { nargs = Some n } + | UnfoldWhenNoMatch { nargs = Some n }) + when Stack.args_size stack < n - (npars + 1) -> fold () + | UnfoldWhen { recargs } + | UnfoldWhenNoMatch { recargs }-> (* maybe unfolds *) + let recargs = List.map_filter (fun x -> + let idx = x - npars in + if idx < 0 then None else Some idx) recargs + in + match recargs with + |[] -> (* if nargs has been specified *) + (* CAUTION : the constant is NEVER refold + (even when it hides a (co)fix) *) let stack' = (c, Stack.Proj (p, cst_l) :: stack) in - whrec Cst_stack.empty(* cst_l *) stack' - | curr::remains -> - if curr == 0 then (* Try to reduce the record argument *) - whrec Cst_stack.empty - (c, Stack.Cst(Stack.Cst_proj p,curr,remains,Stack.empty,cst_l)::stack) - else - match Stack.strip_n_app curr stack with - | None -> fold () - | Some (bef,arg,s') -> - whrec Cst_stack.empty - (arg,Stack.Cst(Stack.Cst_proj p,curr,remains, - Stack.append_app [|c|] bef,cst_l)::s')) + whrec Cst_stack.empty(* cst_l *) stack' + | curr::remains -> + if curr == 0 then (* Try to reduce the record argument *) + whrec Cst_stack.empty + (c, Stack.Cst(Stack.Cst_proj p,curr,remains,Stack.empty,cst_l)::stack) + else + match Stack.strip_n_app curr stack with + | None -> fold () + | Some (bef,arg,s') -> + whrec Cst_stack.empty + (arg,Stack.Cst(Stack.Cst_proj p,curr,remains, + Stack.append_app [|c|] bef,cst_l)::s') + end) | LetIn (_,b,_,c) when CClosure.RedFlags.red_set flags CClosure.RedFlags.fZETA -> apply_subst (fun _ -> whrec) [b] sigma refold cst_l c stack @@ -1675,7 +1670,7 @@ let is_sort env sigma t = (* reduction to head-normal-form allowing delta/zeta only in argument of case/fix (heuristic used by evar_conv) *) -let whd_betaiota_deltazeta_for_iota_state ts env sigma csts s = +let whd_betaiota_deltazeta_for_iota_state ts env sigma s = let refold = false in let tactic_mode = false in let rec whrec csts s = @@ -1696,7 +1691,8 @@ let whd_betaiota_deltazeta_for_iota_state ts env sigma csts s = whrec Cst_stack.empty (Stack.nth stack_o (Projection.npars p + Projection.arg p), stack'') else s,csts' |_, ((Stack.App _|Stack.Cst _|Stack.Primitive _) :: _|[]) -> s,csts' - in whrec csts s + in + fst (whrec Cst_stack.empty s) let find_conclusion env sigma = let rec decrec env c = diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 5938d9b367..aa39921ea2 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -21,13 +21,12 @@ exception Elimconst (** Machinery to customize the behavior of the reduction *) module ReductionBehaviour : sig - type flag = [ `ReductionDontExposeCase | `ReductionNeverUnfold ] -(** [set is_local ref (recargs, nargs, flags)] *) - val set : - bool -> GlobRef.t -> (int list * int * flag list) -> unit - val get : - GlobRef.t -> (int list * int * flag list) option + type t = NeverUnfold | UnfoldWhen of when_flags | UnfoldWhenNoMatch of when_flags + and when_flags = { recargs : int list ; nargs : int option } + + val set : local:bool -> GlobRef.t -> t -> unit + val get : GlobRef.t -> t option val print : GlobRef.t -> Pp.t end @@ -312,8 +311,7 @@ val betazetaevar_applist : evar_map -> int -> constr -> constr list -> constr (** {6 Heuristic for Conversion with Evar } *) val whd_betaiota_deltazeta_for_iota_state : - TransparentState.t -> Environ.env -> Evd.evar_map -> Cst_stack.t -> state -> - state * Cst_stack.t + TransparentState.t -> Environ.env -> Evd.evar_map -> state -> state (** {6 Meta-related reduction functions } *) val meta_instance : evar_map -> constr freelisted -> constr diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index bcc20a41b4..231219c9de 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -664,18 +664,38 @@ let whd_nothing_for_iota env sigma s = it fails if no redex is around *) let rec red_elim_const env sigma ref u largs = + let open ReductionBehaviour in let nargs = List.length largs in let largs, unfold_anyway, unfold_nonelim, nocase = match recargs ref with | None -> largs, false, false, false - | Some (_,n,f) when nargs < n || List.mem `ReductionNeverUnfold f -> raise Redelimination - | Some (x::l,_,_) when nargs <= List.fold_left max x l -> raise Redelimination - | Some (l,n,f) -> - let is_empty = match l with [] -> true | _ -> false in - reduce_params env sigma largs l, - n >= 0 && is_empty && nargs >= n, - n >= 0 && not is_empty && nargs >= n, - List.mem `ReductionDontExposeCase f + | Some NeverUnfold -> raise Redelimination + | Some (UnfoldWhen { nargs = Some n } | UnfoldWhenNoMatch { nargs = Some n }) + when nargs < n -> raise Redelimination + | Some (UnfoldWhen { recargs = x::l } | UnfoldWhenNoMatch { recargs = x::l }) + when nargs <= List.fold_left max x l -> raise Redelimination + | Some (UnfoldWhen { recargs; nargs = None }) -> + reduce_params env sigma largs recargs, + false, + false, + false + | Some (UnfoldWhenNoMatch { recargs; nargs = None }) -> + reduce_params env sigma largs recargs, + false, + false, + true + | Some (UnfoldWhen { recargs; nargs = Some n }) -> + let is_empty = List.is_empty recargs in + reduce_params env sigma largs recargs, + is_empty && nargs >= n, + not is_empty && nargs >= n, + false + | Some (UnfoldWhenNoMatch { recargs; nargs = Some n }) -> + let is_empty = List.is_empty recargs in + reduce_params env sigma largs recargs, + is_empty && nargs >= n, + not is_empty && nargs >= n, + true in try match reference_eval env sigma ref with | EliminationCases n when nargs >= n -> @@ -737,6 +757,7 @@ and reduce_params env sigma stack l = a reducible iota/fix/cofix redex (the "simpl" tactic) *) and whd_simpl_stack env sigma = + let open ReductionBehaviour in let rec redrec s = let (x, stack) = decompose_app_vect sigma s in let stack = Array.to_list stack in @@ -761,30 +782,30 @@ and whd_simpl_stack env sigma = with Redelimination -> s') | Proj (p, c) -> - (try - let unf = Projection.unfolded p in - if unf || is_evaluable env (EvalConstRef (Projection.constant p)) then - let npars = Projection.npars p in - (match unf, ReductionBehaviour.get (ConstRef (Projection.constant p)) with - | false, Some (l, n, f) when List.mem `ReductionNeverUnfold f -> - (* simpl never *) s' - | false, Some (l, n, f) when not (List.is_empty l) -> - let l' = List.map_filter (fun i -> - let idx = (i - (npars + 1)) in - if idx < 0 then None else Some idx) l in - let stack = reduce_params env sigma stack l' in - (match reduce_projection env sigma p ~npars - (whd_construct_stack env sigma c) stack - with - | Reduced s' -> redrec (applist s') - | NotReducible -> s') - | _ -> - match reduce_projection env sigma p ~npars (whd_construct_stack env sigma c) stack with - | Reduced s' -> redrec (applist s') - | NotReducible -> s') - else s' - with Redelimination -> s') - + (try + let unf = Projection.unfolded p in + if unf || is_evaluable env (EvalConstRef (Projection.constant p)) then + let npars = Projection.npars p in + (match unf, get (ConstRef (Projection.constant p)) with + | false, Some NeverUnfold -> s' + | false, Some (UnfoldWhen { recargs } | UnfoldWhenNoMatch { recargs }) + when not (List.is_empty recargs) -> + let l' = List.map_filter (fun i -> + let idx = (i - (npars + 1)) in + if idx < 0 then None else Some idx) recargs in + let stack = reduce_params env sigma stack l' in + (match reduce_projection env sigma p ~npars + (whd_construct_stack env sigma c) stack + with + | Reduced s' -> redrec (applist s') + | NotReducible -> s') + | _ -> + match reduce_projection env sigma p ~npars (whd_construct_stack env sigma c) stack with + | Reduced s' -> redrec (applist s') + | NotReducible -> s') + else s' + with Redelimination -> s') + | _ -> match match_eval_ref env sigma x stack with | Some (ref, u) -> diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 9ba51dcfa9..d134c7319f 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -489,8 +489,8 @@ let unfold_projection env p stk = let expand_key ts env sigma = function | Some (IsKey k) -> Option.map EConstr.of_constr (expand_table_key env k) | Some (IsProj (p, c)) -> - let red = Stack.zip sigma (fst (whd_betaiota_deltazeta_for_iota_state ts env sigma - Cst_stack.empty (c, unfold_projection env p []))) + let red = Stack.zip sigma (whd_betaiota_deltazeta_for_iota_state ts env sigma + (c, unfold_projection env p [])) in if EConstr.eq_constr sigma (EConstr.mkProj (p, c)) red then None else Some red | None -> None @@ -597,8 +597,8 @@ let constr_cmp pb env sigma flags t u = None let do_reduce ts (env, nb) sigma c = - Stack.zip sigma (fst (whd_betaiota_deltazeta_for_iota_state - ts env sigma Cst_stack.empty (c, Stack.empty))) + Stack.zip sigma (whd_betaiota_deltazeta_for_iota_state + ts env sigma (c, Stack.empty)) let isAllowedEvar sigma flags c = match EConstr.kind sigma c with | Evar (evk,_) -> not (Evar.Set.mem evk flags.frozen_evars) 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/logic.ml b/proofs/logic.ml index a01ddf2388..b79e1e6024 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -78,14 +78,6 @@ let error_no_such_hypothesis env sigma id = raise (RefinerError (env, sigma, NoS let check = ref false let with_check = Flags.with_option check -(* [apply_to_hyp sign id f] splits [sign] into [tail::[id,_,_]::head] and - returns [tail::(f head (id,_,_) (rev tail))] *) -let apply_to_hyp env sigma check sign id f = - try apply_to_hyp sign id f - with Hyp_not_found -> - if check then error_no_such_hypothesis env sigma id - else sign - let check_typability env sigma c = if !check then let _ = unsafe_type_of env sigma (EConstr.of_constr c) in () @@ -161,12 +153,14 @@ let reorder_context env sigma sign ord = step ord ords sign mt_q [] let reorder_val_context env sigma sign ord = +match ord with +| [] | [_] -> + (* Single variable-free definitions need not be reordered *) + sign +| _ :: _ :: _ -> let open EConstr in val_of_named_context (reorder_context env sigma (named_context_of_val sign) ord) - - - let check_decl_position env sigma sign d = let open EConstr in let x = NamedDecl.get_id d in @@ -556,25 +550,25 @@ and treat_case sigma goal ci lbrty lf acc' = (lacc,sigma,fi::bacc)) (acc',sigma,[]) lbrty lf ci.ci_pp_info.cstr_tags -let convert_hyp check sign sigma d = +let convert_hyp ~check ~reorder env sigma d = let id = NamedDecl.get_id d in let b = NamedDecl.get_value d in - let env = Global.env () in - let reorder = ref [] in - let sign' = - apply_to_hyp env sigma check sign id - (fun _ d' _ -> - let c = Option.map EConstr.of_constr (NamedDecl.get_value d') in - let env = Global.env_of_context sign in - if check && not (is_conv env sigma (NamedDecl.get_type d) (EConstr.of_constr (NamedDecl.get_type d'))) then - user_err ~hdr:"Logic.convert_hyp" - (str "Incorrect change of the type of " ++ Id.print id ++ str "."); - if check && not (Option.equal (is_conv env sigma) b c) then - user_err ~hdr:"Logic.convert_hyp" - (str "Incorrect change of the body of "++ Id.print id ++ str "."); - if check then reorder := check_decl_position env sigma sign d; - map_named_decl EConstr.Unsafe.to_constr d) in - reorder_val_context env sigma sign' !reorder + let sign = Environ.named_context_val env in + match lookup_named_ctxt id sign with + | exception Not_found -> + if check then error_no_such_hypothesis env sigma id + else sign + | d' -> + let c = Option.map EConstr.of_constr (NamedDecl.get_value d') in + if check && not (is_conv env sigma (NamedDecl.get_type d) (EConstr.of_constr (NamedDecl.get_type d'))) then + user_err ~hdr:"Logic.convert_hyp" + (str "Incorrect change of the type of " ++ Id.print id ++ str "."); + if check && not (Option.equal (is_conv env sigma) b c) then + user_err ~hdr:"Logic.convert_hyp" + (str "Incorrect change of the body of "++ Id.print id ++ str "."); + let sign' = apply_to_hyp sign id (fun _ _ _ -> EConstr.Unsafe.to_named_decl d) in + if reorder then reorder_val_context env sigma sign' (check_decl_position env sigma sign d) + else sign' (************************************************************************) (************************************************************************) diff --git a/proofs/logic.mli b/proofs/logic.mli index f99076db23..406fe57985 100644 --- a/proofs/logic.mli +++ b/proofs/logic.mli @@ -62,7 +62,7 @@ type 'id move_location = val pr_move_location : ('a -> Pp.t) -> 'a move_location -> Pp.t -val convert_hyp : bool -> Environ.named_context_val -> evar_map -> +val convert_hyp : check:bool -> reorder:bool -> Environ.env -> evar_map -> EConstr.named_declaration -> Environ.named_context_val val move_hyp_in_named_context : Environ.env -> Evd.evar_map -> Id.t -> Id.t move_location -> diff --git a/proofs/proof.ml b/proofs/proof.ml index 978b1f6f78..778d98b2cd 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 @@ -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 @@ -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..1f4748141a 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 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/tactics/eauto.ml b/tactics/eauto.ml index 70854e6e3c..0857c05968 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -514,7 +514,7 @@ let autounfold_one db cl = in if did then match cl with - | Some hyp -> change_in_hyp None (make_change_arg c') hyp + | Some hyp -> change_in_hyp ~check:true None (make_change_arg c') hyp | None -> convert_concl ~check:false c' DEFAULTcast else Tacticals.New.tclFAIL 0 (str "Nothing to unfold") end diff --git a/tactics/equality.ml b/tactics/equality.ml index 3d760f1c3d..f049f8c568 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -1613,10 +1613,10 @@ let cutSubstInHyp l2r eqn id = tclTHEN (Proofview.Unsafe.tclEVARS sigma) (tclTHENFIRST (tclTHENLIST [ - (change_in_hyp None (make_change_arg typ) (id,InHypTypeOnly)); + (change_in_hyp ~check:true None (make_change_arg typ) (id,InHypTypeOnly)); (replace_core (onHyp id) l2r eqn) ]) - (change_in_hyp None (make_change_arg expected) (id,InHypTypeOnly))) + (change_in_hyp ~check:true None (make_change_arg expected) (id,InHypTypeOnly))) end let try_rewrite tac = 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 5e8869f9b0..806c955591 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -145,7 +145,7 @@ let introduction id = let error msg = CErrors.user_err Pp.(str msg) -let convert_concl ?(check=true) ty k = +let convert_concl ~check ty k = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let conclty = Proofview.Goal.concl gl in @@ -163,12 +163,12 @@ let convert_concl ?(check=true) ty k = end end -let convert_hyp ?(check=true) d = +let convert_hyp ~check ~reorder d = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let ty = Proofview.Goal.concl gl in - let sign = convert_hyp check (named_context_val env) sigma d in + let sign = convert_hyp ~check ~reorder env sigma d in let env = reset_with_named_context sign env in Refine.refine ~typecheck:false begin fun sigma -> Evarutil.new_evar env sigma ~principal:true ty @@ -176,7 +176,7 @@ let convert_hyp ?(check=true) d = end let convert_concl_no_check = convert_concl ~check:false -let convert_hyp_no_check = convert_hyp ~check:false +let convert_hyp_no_check = convert_hyp ~check:false ~reorder:false let convert_gen pb x y = Proofview.Goal.enter begin fun gl -> @@ -701,7 +701,7 @@ let bind_red_expr_occurrences occs nbcl redexp = (** Tactic reduction modulo evars (for universes essentially) *) -let e_change_in_concl ?(check = false) (redfun, sty) = +let e_change_in_concl ~check (redfun, sty) = Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let (sigma, c') = redfun (Tacmach.New.pf_env gl) sigma (Tacmach.New.pf_concl gl) in @@ -709,16 +709,16 @@ let e_change_in_concl ?(check = false) (redfun, sty) = (convert_concl ~check c' sty) end -let e_change_in_hyp ?(check = false) redfun (id,where) = +let e_change_in_hyp ~check ~reorder redfun (id,where) = Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let hyp = Tacmach.New.pf_get_hyp id gl in let (sigma, c) = e_pf_change_decl redfun where hyp (Proofview.Goal.env gl) sigma in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) - (convert_hyp ~check c) + (convert_hyp ~check ~reorder c) end -let e_change_in_hyps ?(check=true) f args = +let e_change_in_hyps ~check ~reorder f args = Proofview.Goal.enter begin fun gl -> let fold (env, sigma) arg = let (redfun, id, where) = f arg in @@ -728,7 +728,7 @@ let e_change_in_hyps ?(check=true) f args = raise (RefinerError (env, sigma, NoSuchHyp id)) in let (sigma, d) = e_pf_change_decl redfun where hyp env sigma in - let sign = Logic.convert_hyp check (named_context_val env) sigma d in + let sign = Logic.convert_hyp ~check ~reorder env sigma d in let env = reset_with_named_context sign env in (env, sigma) in @@ -745,26 +745,26 @@ let e_change_in_hyps ?(check=true) f args = let e_reduct_in_concl = e_change_in_concl -let reduct_in_concl ?(check = false) (redfun, sty) = +let reduct_in_concl ~check (redfun, sty) = let redfun env sigma c = (sigma, redfun env sigma c) in e_change_in_concl ~check (redfun, sty) -let e_reduct_in_hyp ?(check=false) redfun (id, where) = +let e_reduct_in_hyp ~check ~reorder redfun (id, where) = let redfun _ env sigma c = redfun env sigma c in - e_change_in_hyp ~check redfun (id, where) + e_change_in_hyp ~check ~reorder redfun (id, where) -let reduct_in_hyp ?(check = false) redfun (id, where) = +let reduct_in_hyp ~check ~reorder redfun (id, where) = let redfun _ env sigma c = (sigma, redfun env sigma c) in - e_change_in_hyp ~check redfun (id, where) + e_change_in_hyp ~check ~reorder redfun (id, where) let revert_cast (redfun,kind as r) = if kind == DEFAULTcast then (redfun,REVERTcast) else r -let e_reduct_option ?(check=false) redfun = function - | Some id -> e_reduct_in_hyp ~check (fst redfun) id +let e_reduct_option ~check redfun = function + | Some id -> e_reduct_in_hyp ~check ~reorder:check (fst redfun) id | None -> e_change_in_concl ~check (revert_cast redfun) -let reduct_option ?(check = false) (redfun, sty) where = +let reduct_option ~check (redfun, sty) where = let redfun env sigma c = (sigma, redfun env sigma c) in e_reduct_option ~check (redfun, sty) where @@ -802,7 +802,7 @@ let change_and_check cv_pb mayneedglobalcheck deep t env sigma c = | Some sigma -> (sigma, t') (* Use cumulativity only if changing the conclusion not a subterm *) -let change_on_subterm check cv_pb deep t where env sigma c = +let change_on_subterm ~check cv_pb deep t where env sigma c = let mayneedglobalcheck = ref false in let (sigma, c) = match where with | None -> @@ -825,15 +825,13 @@ let change_on_subterm check cv_pb deep t where env sigma c = end; (sigma, c) -let change_in_concl ?(check=true) occl t = +let change_in_concl ~check occl t = (* No need to check in e_change_in_concl, the check is done in change_on_subterm *) - e_change_in_concl ~check:false ((change_on_subterm check Reduction.CUMUL false t occl),DEFAULTcast) + e_change_in_concl ~check:false ((change_on_subterm ~check Reduction.CUMUL false t occl),DEFAULTcast) -let change_in_hyp ?(check=true) occl t id = - (* FIXME: we set the [check] flag only to reorder hypotheses in case of - introduction of dependencies in new variables. We should separate this - check from the conversion function. *) - e_change_in_hyp ~check (fun x -> change_on_subterm check Reduction.CONV x t occl) id +let change_in_hyp ~check occl t id = + (* Same as above *) + e_change_in_hyp ~check:false ~reorder:check (fun x -> change_on_subterm ~check Reduction.CONV x t occl) id let concrete_clause_of enum_hyps cl = match cl.onhyps with | None -> @@ -842,7 +840,7 @@ let concrete_clause_of enum_hyps cl = match cl.onhyps with | Some l -> List.map (fun ((occs, id), w) -> (id, occs, w)) l -let change ?(check=true) chg c cls = +let change ~check chg c cls = Proofview.Goal.enter begin fun gl -> let hyps = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cls in begin match cls.concl_occs with @@ -852,33 +850,34 @@ let change ?(check=true) chg c cls = <*> let f (id, occs, where) = let occl = bind_change_occurrences occs chg in - let redfun deep env sigma t = change_on_subterm check Reduction.CONV deep c occl env sigma t in + let redfun deep env sigma t = change_on_subterm ~check Reduction.CONV deep c occl env sigma t in (redfun, id, where) in - e_change_in_hyps ~check f hyps + (* Don't check, we do it already in [change_on_subterm] *) + e_change_in_hyps ~check:false ~reorder:check f hyps end let change_concl t = change_in_concl ~check:true None (make_change_arg t) (* Pour usage interne (le niveau User est pris en compte par reduce) *) -let red_in_concl = reduct_in_concl (red_product,REVERTcast) -let red_in_hyp = reduct_in_hyp red_product -let red_option = reduct_option (red_product,REVERTcast) -let hnf_in_concl = reduct_in_concl (hnf_constr,REVERTcast) -let hnf_in_hyp = reduct_in_hyp hnf_constr -let hnf_option = reduct_option (hnf_constr,REVERTcast) -let simpl_in_concl = reduct_in_concl (simpl,REVERTcast) -let simpl_in_hyp = reduct_in_hyp simpl -let simpl_option = reduct_option (simpl,REVERTcast) -let normalise_in_concl = reduct_in_concl (compute,REVERTcast) -let normalise_in_hyp = reduct_in_hyp compute -let normalise_option = reduct_option (compute,REVERTcast) -let normalise_vm_in_concl = reduct_in_concl (Redexpr.cbv_vm,VMcast) -let unfold_in_concl loccname = reduct_in_concl (unfoldn loccname,REVERTcast) -let unfold_in_hyp loccname = reduct_in_hyp (unfoldn loccname) -let unfold_option loccname = reduct_option (unfoldn loccname,DEFAULTcast) -let pattern_option l = e_reduct_option (pattern_occs l,DEFAULTcast) +let red_in_concl = reduct_in_concl ~check:false (red_product,REVERTcast) +let red_in_hyp = reduct_in_hyp ~check:false ~reorder:false red_product +let red_option = reduct_option ~check:false (red_product,REVERTcast) +let hnf_in_concl = reduct_in_concl ~check:false (hnf_constr,REVERTcast) +let hnf_in_hyp = reduct_in_hyp ~check:false ~reorder:false hnf_constr +let hnf_option = reduct_option ~check:false (hnf_constr,REVERTcast) +let simpl_in_concl = reduct_in_concl ~check:false (simpl,REVERTcast) +let simpl_in_hyp = reduct_in_hyp ~check:false ~reorder:false simpl +let simpl_option = reduct_option ~check:false (simpl,REVERTcast) +let normalise_in_concl = reduct_in_concl ~check:false (compute,REVERTcast) +let normalise_in_hyp = reduct_in_hyp ~check:false ~reorder:false compute +let normalise_option = reduct_option ~check:false (compute,REVERTcast) +let normalise_vm_in_concl = reduct_in_concl ~check:false (Redexpr.cbv_vm,VMcast) +let unfold_in_concl loccname = reduct_in_concl ~check:false (unfoldn loccname,REVERTcast) +let unfold_in_hyp loccname = reduct_in_hyp ~check:false ~reorder:false (unfoldn loccname) +let unfold_option loccname = reduct_option ~check:false (unfoldn loccname,DEFAULTcast) +let pattern_option l = e_reduct_option ~check:false (pattern_occs l,DEFAULTcast) (* The main reduction function *) @@ -893,6 +892,7 @@ let reduce redexp cl = let hyps = concrete_clause_of (fun () -> Tacmach.New.pf_ids_of_hyps gl) cl in let nbcl = (if cl.concl_occs = NoOccurrences then 0 else 1) + List.length hyps in let check = match redexp with Fold _ | Pattern _ -> true | _ -> false in + let reorder = match redexp with Fold _ | Pattern _ -> true | _ -> false in begin match cl.concl_occs with | NoOccurrences -> Proofview.tclUNIT () | occs -> @@ -907,7 +907,7 @@ let reduce redexp cl = let redfun _ env sigma c = redfun env sigma c in (redfun, id, where) in - e_change_in_hyps ~check f hyps + e_change_in_hyps ~check ~reorder f hyps end end @@ -2654,7 +2654,7 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = [ Proofview.Unsafe.tclEVARS sigma; convert_concl ~check:false newcl DEFAULTcast; intro_gen (NamingMustBe (CAst.make id)) (decode_hyp lastlhyp) true false; - Tacticals.New.tclMAP (convert_hyp ~check:false) depdecls; + Tacticals.New.tclMAP (convert_hyp ~check:false ~reorder:false) depdecls; eq_tac ] end @@ -3061,8 +3061,8 @@ let unfold_body x = Tacticals.New.afterHyp x begin fun aft -> let hl = List.fold_right (fun decl cl -> (NamedDecl.get_id decl, InHyp) :: cl) aft [] in let rfun _ _ c = replace_vars [x, xval] c in - let reducth h = reduct_in_hyp rfun h in - let reductc = reduct_in_concl (rfun, DEFAULTcast) in + let reducth h = reduct_in_hyp ~check:false ~reorder:false rfun h in + let reductc = reduct_in_concl ~check:false (rfun, DEFAULTcast) in Tacticals.New.tclTHENLIST [Tacticals.New.tclMAP reducth hl; reductc] end end diff --git a/tactics/tactics.mli b/tactics/tactics.mli index b3914816ac..9eb8196280 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -33,8 +33,8 @@ val is_quantified_hypothesis : Id.t -> Proofview.Goal.t -> bool (** {6 Primitive tactics. } *) val introduction : Id.t -> unit Proofview.tactic -val convert_concl : ?check:bool -> types -> cast_kind -> unit Proofview.tactic -val convert_hyp : ?check:bool -> named_declaration -> unit Proofview.tactic +val convert_concl : check:bool -> types -> cast_kind -> unit Proofview.tactic +val convert_hyp : check:bool -> reorder:bool -> named_declaration -> unit Proofview.tactic val convert_concl_no_check : types -> cast_kind -> unit Proofview.tactic [@@ocaml.deprecated "use [Tactics.convert_concl]"] val convert_hyp_no_check : named_declaration -> unit Proofview.tactic @@ -152,13 +152,13 @@ type e_tactic_reduction = Reductionops.e_reduction_function type change_arg = patvar_map -> env -> evar_map -> evar_map * constr val make_change_arg : constr -> change_arg -val reduct_in_hyp : ?check:bool -> tactic_reduction -> hyp_location -> unit Proofview.tactic -val reduct_option : ?check:bool -> tactic_reduction * cast_kind -> goal_location -> unit Proofview.tactic -val reduct_in_concl : ?check:bool -> tactic_reduction * cast_kind -> unit Proofview.tactic -val e_reduct_in_concl : ?check:bool -> e_tactic_reduction * cast_kind -> unit Proofview.tactic -val change_in_concl : ?check:bool -> (occurrences * constr_pattern) option -> change_arg -> unit Proofview.tactic +val reduct_in_hyp : check:bool -> reorder:bool -> tactic_reduction -> hyp_location -> unit Proofview.tactic +val reduct_option : check:bool -> tactic_reduction * cast_kind -> goal_location -> unit Proofview.tactic +val reduct_in_concl : check:bool -> tactic_reduction * cast_kind -> unit Proofview.tactic +val e_reduct_in_concl : check:bool -> e_tactic_reduction * cast_kind -> unit Proofview.tactic +val change_in_concl : check:bool -> (occurrences * constr_pattern) option -> change_arg -> unit Proofview.tactic val change_concl : constr -> unit Proofview.tactic -val change_in_hyp : ?check:bool -> (occurrences * constr_pattern) option -> change_arg -> +val change_in_hyp : check:bool -> (occurrences * constr_pattern) option -> change_arg -> hyp_location -> unit Proofview.tactic val red_in_concl : unit Proofview.tactic val red_in_hyp : hyp_location -> unit Proofview.tactic @@ -180,7 +180,7 @@ val unfold_in_hyp : val unfold_option : (occurrences * evaluable_global_reference) list -> goal_location -> unit Proofview.tactic val change : - ?check:bool -> constr_pattern option -> change_arg -> clause -> unit Proofview.tactic + check:bool -> constr_pattern option -> change_arg -> clause -> unit Proofview.tactic val pattern_option : (occurrences * constr) list -> goal_location -> unit Proofview.tactic val reduce : red_expr -> clause -> unit Proofview.tactic diff --git a/test-suite/arithmetic/diveucl_21.v b/test-suite/arithmetic/diveucl_21.v index 7e12a08906..b888c97be3 100644 --- a/test-suite/arithmetic/diveucl_21.v +++ b/test-suite/arithmetic/diveucl_21.v @@ -15,3 +15,11 @@ Check (eq_refl (4611686018427387904, 1) <: diveucl_21 3 1 2 = (46116860184273879 Check (eq_refl (4611686018427387904, 1) <<: diveucl_21 3 1 2 = (4611686018427387904, 1)). Definition compute2 := Eval compute in diveucl_21 3 1 2. Check (eq_refl compute2 : (4611686018427387904, 1) = (4611686018427387904, 1)). + +Check (eq_refl : diveucl_21 1 1 0 = (0,0)). +Check (eq_refl (0,0) <: diveucl_21 1 1 0 = (0,0)). +Check (eq_refl (0,0) <<: diveucl_21 1 1 0 = (0,0)). + +Check (eq_refl : diveucl_21 9223372036854775807 0 1 = (0,0)). +Check (eq_refl (0,0) <: diveucl_21 9223372036854775807 0 1 = (0,0)). +Check (eq_refl (0,0) <<: diveucl_21 9223372036854775807 0 1 = (0,0)). diff --git a/test-suite/bugs/closed/bug_10031.v b/test-suite/bugs/closed/bug_10031.v new file mode 100644 index 0000000000..15b53de00d --- /dev/null +++ b/test-suite/bugs/closed/bug_10031.v @@ -0,0 +1,9 @@ +Require Import Int63 ZArith. + +Open Scope int63_scope. + +Goal False. +cut (let (q, r) := (0, 0) in ([|q|], [|r|]) = (9223372036854775808%Z, 0%Z)); + [discriminate| ]. +Fail (change (0, 0) with (diveucl_21 1 0 1); apply diveucl_21_spec). +Abort. diff --git a/test-suite/output/Arguments.out b/test-suite/output/Arguments.out index 7074ad2d41..3c1e27ba9d 100644 --- a/test-suite/output/Arguments.out +++ b/test-suite/output/Arguments.out @@ -27,7 +27,7 @@ Nat.sub : nat -> nat -> nat Nat.sub is not universe polymorphic Argument scopes are [nat_scope nat_scope] The reduction tactics unfold Nat.sub when the 1st and - 2nd arguments evaluate to a constructor and when applied to 2 arguments + 2nd arguments evaluate to a constructor and when applied to 2 arguments Nat.sub is transparent Expands to: Constant Coq.Init.Nat.sub Nat.sub : nat -> nat -> nat @@ -35,7 +35,7 @@ Nat.sub : nat -> nat -> nat Nat.sub is not universe polymorphic Argument scopes are [nat_scope nat_scope] The reduction tactics unfold Nat.sub when the 1st and - 2nd arguments evaluate to a constructor + 2nd arguments evaluate to a constructor Nat.sub is transparent Expands to: Constant Coq.Init.Nat.sub pf : @@ -54,7 +54,7 @@ fcomp : forall A B C : Type, (B -> C) -> (A -> B) -> A -> C fcomp is not universe polymorphic Arguments A, B, C are implicit and maximally inserted Argument scopes are [type_scope type_scope type_scope _ _ _] -The reduction tactics unfold fcomp when applied to 6 arguments +The reduction tactics unfold fcomp when applied to 6 arguments fcomp is transparent Expands to: Constant Arguments.fcomp volatile : nat -> nat @@ -75,7 +75,7 @@ f : T1 -> T2 -> nat -> unit -> nat -> nat f is not universe polymorphic Argument scopes are [_ _ nat_scope _ nat_scope] The reduction tactics unfold f when the 3rd, 4th and - 5th arguments evaluate to a constructor + 5th arguments evaluate to a constructor f is transparent Expands to: Constant Arguments.S1.S2.f f : forall T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat @@ -84,7 +84,7 @@ f is not universe polymorphic Argument T2 is implicit Argument scopes are [type_scope _ _ nat_scope _ nat_scope] The reduction tactics unfold f when the 4th, 5th and - 6th arguments evaluate to a constructor + 6th arguments evaluate to a constructor f is transparent Expands to: Constant Arguments.S1.f f : forall T1 T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat @@ -93,7 +93,7 @@ f is not universe polymorphic Arguments T1, T2 are implicit Argument scopes are [type_scope type_scope _ _ nat_scope _ nat_scope] The reduction tactics unfold f when the 5th, 6th and - 7th arguments evaluate to a constructor + 7th arguments evaluate to a constructor f is transparent Expands to: Constant Arguments.f = forall v : unit, f 0 0 5 v 3 = 2 @@ -104,7 +104,7 @@ f : forall T1 T2 : Type, T1 -> T2 -> nat -> unit -> nat -> nat f is not universe polymorphic The reduction tactics unfold f when the 5th, 6th and - 7th arguments evaluate to a constructor + 7th arguments evaluate to a constructor f is transparent Expands to: Constant Arguments.f forall w : r, w 3 true = tt @@ -115,3 +115,13 @@ w 3 true = tt : Prop The command has indeed failed with message: Extra arguments: _, _. +volatilematch : nat -> nat + +volatilematch is not universe polymorphic +Argument scope is [nat_scope] +The reduction tactics always unfold volatilematch + but avoid exposing match constructs +volatilematch is transparent +Expands to: Constant Arguments.volatilematch + = fun n : nat => volatilematch n + : nat -> nat diff --git a/test-suite/output/Arguments.v b/test-suite/output/Arguments.v index 844f96aaa1..b909f1b64c 100644 --- a/test-suite/output/Arguments.v +++ b/test-suite/output/Arguments.v @@ -55,3 +55,12 @@ Arguments w x%F y%B : extra scopes. Check (w $ $ = tt). Fail Arguments w _%F _%B. +Definition volatilematch (n : nat) := + match n with + | O => O + | S p => p + end. + +Arguments volatilematch / n : simpl nomatch. +About volatilematch. +Eval simpl in fun n => volatilematch n. diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out index 3f0717666c..65c902202d 100644 --- a/test-suite/output/Arguments_renaming.out +++ b/test-suite/output/Arguments_renaming.out @@ -62,7 +62,7 @@ Arguments are renamed to Z, t, n, m Argument Z is implicit and maximally inserted Argument scopes are [type_scope _ nat_scope nat_scope] The reduction tactics unfold myplus when the 2nd and - 3rd arguments evaluate to a constructor + 3rd arguments evaluate to a constructor myplus is transparent Expands to: Constant Arguments_renaming.Test1.myplus @myplus @@ -101,7 +101,7 @@ Arguments are renamed to Z, t, n, m Argument Z is implicit and maximally inserted Argument scopes are [type_scope _ nat_scope nat_scope] The reduction tactics unfold myplus when the 2nd and - 3rd arguments evaluate to a constructor + 3rd arguments evaluate to a constructor myplus is transparent Expands to: Constant Arguments_renaming.myplus @myplus diff --git a/test-suite/output/Error_msg_diffs.v b/test-suite/output/Error_msg_diffs.v index 11c766b210..a26e683398 100644 --- a/test-suite/output/Error_msg_diffs.v +++ b/test-suite/output/Error_msg_diffs.v @@ -1,4 +1,4 @@ -(* coq-prog-args: ("-color" "on" "-async-proofs" "off") *) +(* coq-prog-args: ("-color" "on" "-diffs" "on" "-async-proofs" "off") *) (* Re: -async-proofs off, see https://github.com/coq/coq/issues/9671 *) (* Shows diffs in an error message for an "Unable to unify" error *) Require Import Arith List Bool. 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/output/bug_9370.out b/test-suite/output/bug_9370.out new file mode 100644 index 0000000000..0ff151c8b4 --- /dev/null +++ b/test-suite/output/bug_9370.out @@ -0,0 +1,12 @@ +1 subgoal + + ============================ + 1 = 1 +1 subgoal + + ============================ + 1 = 1 +1 subgoal + + ============================ + 1 = 1 diff --git a/test-suite/output/bug_9370.v b/test-suite/output/bug_9370.v new file mode 100644 index 0000000000..a7f4b7c23e --- /dev/null +++ b/test-suite/output/bug_9370.v @@ -0,0 +1,12 @@ +Require Import Reals. +Open Scope R_scope. +Goal 1/1=1. +Proof. + field_simplify (1/1). +Show. + field_simplify. +Show. + field_simplify. +Show. + reflexivity. +Qed. 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/theories/Numbers/Cyclic/Int63/Cyclic63.v b/theories/Numbers/Cyclic/Int63/Cyclic63.v index 3b431d5b47..c03e6615cb 100644 --- a/theories/Numbers/Cyclic/Int63/Cyclic63.v +++ b/theories/Numbers/Cyclic/Int63/Cyclic63.v @@ -177,21 +177,6 @@ Proof. inversion W;rewrite Zmult_comm;trivial. Qed. -Lemma diveucl_21_spec_aux : forall a1 a2 b, - wB/2 <= [|b|] -> - [|a1|] < [|b|] -> - let (q,r) := diveucl_21 a1 a2 b in - [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ - 0 <= [|r|] < [|b|]. -Proof. - intros a1 a2 b H1 H2;assert (W:= diveucl_21_spec a1 a2 b). - assert (W1:= to_Z_bounded a1). - assert ([|b|]>0) by (auto with zarith). - generalize (Z_div_mod ([|a1|]*wB+[|a2|]) [|b|] H). - destruct (diveucl_21 a1 a2 b);destruct (Z.div_eucl ([|a1|]*wB+[|a2|]) [|b|]). - inversion W;rewrite (Zmult_comm [|b|]);trivial. -Qed. - Lemma shift_unshift_mod_2 : forall n p a, 0 <= p <= n -> ((a * 2 ^ (n - p)) mod (2^n) / 2 ^ (n - p)) mod (2^n) = a mod 2 ^ p. diff --git a/theories/Numbers/Cyclic/Int63/Int63.v b/theories/Numbers/Cyclic/Int63/Int63.v index eac26add03..3c96130bf3 100644 --- a/theories/Numbers/Cyclic/Int63/Int63.v +++ b/theories/Numbers/Cyclic/Int63/Int63.v @@ -387,7 +387,8 @@ Axiom diveucl_def_spec : forall x y, diveucl x y = diveucl_def x y. Axiom diveucl_21_spec : forall a1 a2 b, let (q,r) := diveucl_21 a1 a2 b in - ([|q|],[|r|]) = Z.div_eucl ([|a1|] * wB + [|a2|]) [|b|]. + let (q',r') := Z.div_eucl ([|a1|] * wB + [|a2|]) [|b|] in + [|q|] = Z.modulo q' wB /\ [|r|] = r'. Axiom addmuldiv_def_spec : forall p x y, addmuldiv p x y = addmuldiv_def p x y. @@ -1413,12 +1414,51 @@ Proof. apply Z.le_trans with ([|ih|] * wB)%Z;try rewrite Z.pow_2_r; auto with zarith. Qed. -Lemma div2_phi ih il j: - [|fst (diveucl_21 ih il j)|] = [|| WW ih il||] /[|j|]. -Proof. - generalize (diveucl_21_spec ih il j). - case diveucl_21; intros q r Heq. - simpl zn2z_to_Z;unfold Z.div;rewrite <- Heq;trivial. +Lemma diveucl_21_spec_aux : forall a1 a2 b, + wB/2 <= [|b|] -> + [|a1|] < [|b|] -> + let (q,r) := diveucl_21 a1 a2 b in + [|a1|] *wB+ [|a2|] = [|q|] * [|b|] + [|r|] /\ + 0 <= [|r|] < [|b|]. +Proof. + intros a1 a2 b H1 H2;assert (W:= diveucl_21_spec a1 a2 b). + assert (W1:= to_Z_bounded a1). + assert (W2:= to_Z_bounded a2). + assert (Wb:= to_Z_bounded b). + assert ([|b|]>0) by (auto with zarith). + generalize (Z_div_mod ([|a1|]*wB+[|a2|]) [|b|] H). + revert W. + destruct (diveucl_21 a1 a2 b); destruct (Z.div_eucl ([|a1|]*wB+[|a2|]) [|b|]). + intros (H', H''); rewrite H', H''; clear H' H''. + intros (H', H''); split; [ |exact H'']. + rewrite H', Zmult_comm, Z.mod_small; [reflexivity| ]. + split. + { revert H'; case z; [now simpl..|intros p H']. + exfalso; apply (Z.lt_irrefl 0), (Z.le_lt_trans _ ([|a1|] * wB + [|a2|])). + { now apply Z.add_nonneg_nonneg; [apply Z.mul_nonneg_nonneg| ]. } + rewrite H'; apply (Zplus_lt_reg_r _ _ (- z0)); ring_simplify. + apply (Z.le_lt_trans _ (- [|b|])); [ |now auto with zarith]. + rewrite Z.opp_eq_mul_m1; apply Zmult_le_compat_l; [ |now apply Wb]. + rewrite <-!Pos2Z.opp_pos, <-Z.opp_le_mono. + now change 1 with (Z.succ 0); apply Zlt_le_succ. } + rewrite <-Z.nle_gt; intro Hz; revert H2; apply Zle_not_lt. + rewrite (Z.div_unique_pos (wB * [|a1|] + [|a2|]) wB [|a1|] [|a2|]); + [ |now simpl..]. + rewrite Z.mul_comm, H'. + rewrite (Z.div_unique_pos (wB * [|b|] + z0) wB [|b|] z0) at 1; + [ |split; [ |apply (Z.lt_trans _ [|b|])]; now simpl|reflexivity]. + apply Z_div_le; [now simpl| ]; rewrite Z.mul_comm; apply Zplus_le_compat_r. + now apply Zmult_le_compat_l. +Qed. + +Lemma div2_phi ih il j: (2^62 <= [|j|] -> [|ih|] < [|j|] -> + [|fst (diveucl_21 ih il j)|] = [|| WW ih il||] /[|j|])%Z. +Proof. + intros Hj Hj1. + generalize (diveucl_21_spec_aux ih il j Hj Hj1). + case diveucl_21; intros q r (Hq, Hr). + apply Zdiv_unique with [|r|]; auto with zarith. + simpl @fst; apply eq_trans with (1 := Hq); ring. Qed. Lemma sqrt2_step_correct rec ih il j: @@ -1436,9 +1476,9 @@ Proof. case (to_Z_bounded il); intros Hil1 _. case (to_Z_bounded j); intros _ Hj1. assert (Hp3: (0 < [||WW ih il||])). - simpl zn2z_to_Z;apply Z.lt_le_trans with ([|ih|] * wB)%Z; auto with zarith. + {simpl zn2z_to_Z;apply Z.lt_le_trans with ([|ih|] * wB)%Z; auto with zarith. apply Zmult_lt_0_compat; auto with zarith. - refine (Z.lt_le_trans _ _ _ _ Hih); auto with zarith. + refine (Z.lt_le_trans _ _ _ _ Hih); auto with zarith. } cbv zeta. case_eq (ih < j)%int63;intros Heq. rewrite -> ltb_spec in Heq. @@ -1450,28 +1490,28 @@ Proof. 2: rewrite Zmult_comm, Z_div_plus_full_l; unfold base; auto with zarith. case (Zle_or_lt (2^(Z_of_nat size -1)) [|j|]); intros Hjj. case_eq (fst (diveucl_21 ih il j) < j)%int63;intros Heq0. - 2: rewrite <-not_true_iff_false, ltb_spec, div2_phi in Heq0. + 2: rewrite <-not_true_iff_false, ltb_spec, (div2_phi _ _ _ Hjj Heq) in Heq0. 2: split; auto; apply sqrt_test_true; auto with zarith. - rewrite -> ltb_spec, div2_phi in Heq0. + rewrite -> ltb_spec, (div2_phi _ _ _ Hjj Heq) in Heq0. match goal with |- context[rec _ _ ?X] => set (u := X) end. assert (H: [|u|] = ([|j|] + ([||WW ih il||])/([|j|]))/2). - unfold u; generalize (addc_spec j (fst (diveucl_21 ih il j))); - case addc;unfold interp_carry;rewrite div2_phi;simpl zn2z_to_Z. - intros i H;rewrite lsr_spec, H;trivial. + { unfold u; generalize (addc_spec j (fst (diveucl_21 ih il j))); + case addc;unfold interp_carry;rewrite (div2_phi _ _ _ Hjj Heq);simpl zn2z_to_Z. + { intros i H;rewrite lsr_spec, H;trivial. } intros i H;rewrite <- H. case (to_Z_bounded i); intros H1i H2i. rewrite -> add_spec, Zmod_small, lsr_spec. - change (1 * wB) with ([|(1 << (digits -1))|] * 2)%Z. - rewrite Z_div_plus_full_l; auto with zarith. + { change (1 * wB) with ([|(1 << (digits -1))|] * 2)%Z. + rewrite Z_div_plus_full_l; auto with zarith. } change wB with (2 * (wB/2))%Z; auto. replace [|(1 << (digits - 1))|] with (wB/2); auto. rewrite lsr_spec; auto. replace (2^[|1|]) with 2%Z; auto. split; auto with zarith. assert ([|i|]/2 < wB/2); auto with zarith. - apply Zdiv_lt_upper_bound; auto with zarith. + apply Zdiv_lt_upper_bound; auto with zarith. } apply Hrec; rewrite H; clear u H. assert (Hf1: 0 <= [||WW ih il||]/ [|j|]) by (apply Z_div_pos; auto with zarith). case (Zle_lt_or_eq 1 ([|j|])); auto with zarith; intros Hf2. diff --git a/theories/Reals/Ratan.v b/theories/Reals/Ratan.v index 03e6ff61ab..38bed570a3 100644 --- a/theories/Reals/Ratan.v +++ b/theories/Reals/Ratan.v @@ -324,8 +324,6 @@ unfold cos_approx; simpl; unfold cos_term. rewrite !INR_IZR_INZ. simpl. field_simplify. -unfold Rdiv. -rewrite Rmult_0_l. apply Rdiv_lt_0_compat ; now apply IZR_lt. Qed. @@ -1612,4 +1610,3 @@ Lemma PI_ineq : Proof. intros; rewrite <- Alt_PI_eq; apply Alt_PI_ineq. Qed. - 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/tac2tactics.ml b/user-contrib/Ltac2/tac2tactics.ml index 603e00c815..a8c1a67f6f 100644 --- a/user-contrib/Ltac2/tac2tactics.ml +++ b/user-contrib/Ltac2/tac2tactics.ml @@ -167,7 +167,7 @@ let change pat c cl = delayed_of_tactic (Tac2ffi.app_fun1 c (array constr) constr subst) env sigma in let cl = mk_clause cl in - Tactics.change pat c cl + Tactics.change ~check:true pat c cl end let rewrite ev rw cl by = 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/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 082b22b373..b2382ce6fc 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -150,6 +150,7 @@ let explicit_flags = [print_universes; print_implicits; print_coercions; print_no_symbol] (* and more! *) ] let with_diffs pm pn = + if not (Proof_diffs.show_diffs ()) then pm, pn else try let tokenize_string = Proof_diffs.tokenize_string in Pp_diff.diff_pp ~tokenize_string pm pn @@ -1347,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/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/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/vernacentries.ml b/vernac/vernacentries.ml index 388f6957cf..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 *) @@ -1231,16 +1231,13 @@ let vernac_arguments ~section_local reference args more_implicits nargs_for_red let clear_implicits_flag = List.mem `ClearImplicits flags in let default_implicits_flag = List.mem `DefaultImplicits flags in let never_unfold_flag = List.mem `ReductionNeverUnfold flags in + let nomatch_flag = List.mem `ReductionDontExposeCase flags in let err_incompat x y = user_err Pp.(str ("Options \""^x^"\" and \""^y^"\" are incompatible.")) in if assert_flag && rename_flag then err_incompat "assert" "rename"; - if Option.has_some nargs_for_red && never_unfold_flag then - err_incompat "simpl never" "/"; - if never_unfold_flag && List.mem `ReductionDontExposeCase flags then - err_incompat "simpl never" "simpl nomatch"; if clear_scopes_flag && extra_scopes_flag then err_incompat "clear scopes" "extra scopes"; if clear_implicits_flag && default_implicits_flag then @@ -1385,19 +1382,24 @@ let vernac_arguments ~section_local reference args more_implicits nargs_for_red (Util.List.map_i (fun i { recarg_like = b } -> i, b) 0 args) in - let rec narrow = function - | #Reductionops.ReductionBehaviour.flag as x :: tl -> x :: narrow tl - | [] -> [] | _ :: tl -> narrow tl - in - let red_flags = narrow flags in - let red_modifiers_specified = - not (List.is_empty rargs) || Option.has_some nargs_for_red - || not (List.is_empty red_flags) + let red_behavior = + let open Reductionops.ReductionBehaviour in + match never_unfold_flag, nomatch_flag, rargs, nargs_for_red with + | true, false, [], None -> Some NeverUnfold + | true, true, _, _ -> err_incompat "simpl never" "simpl nomatch" + | true, _, _::_, _ -> err_incompat "simpl never" "!" + | true, _, _, Some _ -> err_incompat "simpl never" "/" + | false, false, [], None -> None + | false, false, _, _ -> Some (UnfoldWhen { nargs = nargs_for_red; + recargs = rargs; + }) + | false, true, _, _ -> Some (UnfoldWhenNoMatch { nargs = nargs_for_red; + recargs = rargs; + }) in - if not (List.is_empty rargs) && never_unfold_flag then - err_incompat "simpl never" "!"; + let red_modifiers_specified = Option.has_some red_behavior in (* Actions *) @@ -1424,8 +1426,8 @@ let vernac_arguments ~section_local reference args more_implicits nargs_for_red match sr with | ConstRef _ as c -> Reductionops.ReductionBehaviour.set - section_local c - (rargs, Option.default ~-1 nargs_for_red, red_flags) + ~local:section_local c (Option.get red_behavior) + | _ -> user_err (strbrk "Modifiers of the behavior of the simpl tactic "++ strbrk "are relevant for constants only.") @@ -1883,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 = |