diff options
435 files changed, 10355 insertions, 5057 deletions
diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index 8dbdf43e52..b7418f54bd 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -23,6 +23,7 @@ /dev/ci/ @coq/ci-maintainers /.travis.yml @coq/ci-maintainers /.gitlab-ci.yml @coq/ci-maintainers +/.github/workflows @coq/ci-maintainers /azure-pipelines.yml @coq/ci-maintainers /Makefile.ci @coq/ci-maintainers @@ -33,6 +34,8 @@ # Trick to avoid getting review requests # each time someone adds an overlay +/dev/bench/ @coq/bench-maintainers + ########## Documentation ########## /README.md @coq/doc-maintainers @@ -103,6 +106,7 @@ /kernel/native* @coq/vm-native-maintainers /kernel/vm* @coq/vm-native-maintainers /kernel/vconv.* @coq/vm-native-maintainers +/kernel/genOpcodefiles.* @coq/vm-native-maintainers /kernel/sorts.* @coq/universes-maintainers /kernel/uGraph.* @coq/universes-maintainers diff --git a/.github/ISSUE_TEMPLATE.md b/.github/ISSUE_TEMPLATE.md index aec6cd0a21..c564105c9c 100644 --- a/.github/ISSUE_TEMPLATE.md +++ b/.github/ISSUE_TEMPLATE.md @@ -3,7 +3,9 @@ #### Description of the problem <!-- If you can, it's helpful to provide self-contained example of some code -that reproduces the bug. If not, a link to a larger example is also helpful. --> +that reproduces the bug. If not, a link to a larger example is also helpful. +You can generate a shorter version of your program by following these +instructions: https://github.com/coq/coq/wiki/Coqbot-minimize-feature. --> #### Coq Version diff --git a/.github/workflows/check-conflicts.yml b/.github/workflows/check-conflicts.yml new file mode 100644 index 0000000000..33ed944488 --- /dev/null +++ b/.github/workflows/check-conflicts.yml @@ -0,0 +1,13 @@ +name: "Check conflicts" +on: [push] +# Only on push because @coqbot already takes care of checking for +# conflicts when PRs are opened or synchronized + +jobs: + main: + runs-on: ubuntu-latest + steps: + - uses: eps1lon/actions-label-merge-conflict@b8bf8341285ec9a4567d4318ba474fee998a6919 + with: + dirtyLabel: "needs: rebase" + repoToken: "${{ secrets.GITHUB_TOKEN }}" diff --git a/.gitignore b/.gitignore index 557655317c..bdd692420f 100644 --- a/.gitignore +++ b/.gitignore @@ -113,7 +113,6 @@ doc/stdlib/FullLibrary.coqdoc.tex doc/stdlib/html/ doc/stdlib/index-body.html doc/stdlib/index-list.html -doc/tools/docgram/productionlistGrammar doc/tools/docgram/editedGrammar doc/tools/docgram/prodnGrammar doc/unreleased.rst @@ -154,7 +153,7 @@ plugins/ssr/ssrvernac.ml kernel/byterun/coq_instruct.h kernel/byterun/coq_jumptbl.h kernel/genOpcodeFiles.exe -kernel/copcodes.ml +kernel/vmopcodes.ml kernel/uint63.ml ide/coqide/default.bindings ide/coqide/default_bindings_src.exe diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 32b05ec746..cfa6f84147 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -19,7 +19,7 @@ stages: variables: # Format: $IMAGE-V$DATE [Cache is not used as of today but kept here # for reference] - CACHEKEY: "bionic_coq-V2020-07-21-V38" + CACHEKEY: "bionic_coq-V2020-09-07-V22" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -27,6 +27,9 @@ variables: OPAM_VARIANT: "" GIT_DEPTH: "10" +include: + - local: '/dev/bench/gitlab-bench.yml' + docker-boot: stage: docker image: docker:stable @@ -597,7 +600,7 @@ test-suite:edge:dune:dev: - opam repo add ocaml-beta https://github.com/ocaml/ocaml-beta-repository.git - opam update - opam install ocaml-variants=$OCAMLVER - - opam install dune num + - opam install dune num zarith - eval $(opam env) - export COQ_UNIT_TEST=noop - make -f Makefile.dune test-suite @@ -612,12 +615,6 @@ test-suite:edge:dune:dev: expire_in: 2 week allow_failure: true -test-suite:4.11+trunk+dune: - extends: .test-suite:ocaml+beta+dune-template - variables: - OCAMLVER: 4.11.0+trunk - -# Pending on https://github.com/ocaml/dune/pull/3585 # test-suite:4.12+trunk+dune: # extends: .test-suite:ocaml+beta+dune-template # variables: @@ -806,7 +803,7 @@ library:ci-geocoq: library:ci-hott: extends: .ci-template -library:ci-lambda_rust: +library:ci-iris: extends: .ci-template-flambda library:ci-math_classes: diff --git a/.ocamlformat b/.ocamlformat index a0d4ef6bbb..93f5ab4007 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,4 @@ -version=0.14.2 +version=0.15.0 profile=ocamlformat # to enable a whole directory, put "disable=false" in dir/.ocamlformat diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index d561ec8a12..a96b93154c 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -791,10 +791,12 @@ organization, because of a limitation of GitHub). #### Additional notes for pull request reviewers and assignees #### -- NEVER USE GITHUB'S MERGE BUTTON. Instead, we provide a script - [`dev/tools/merge-pr.sh`][merge-pr] which you should use to merge a - PR (requires having configured gpg with git). In the future, we - will also support merging through a command to **@coqbot**. +- NEVER USE GITHUB'S MERGE BUTTON. Instead, you should either: + - run the [`dev/tools/merge-pr.sh`][merge-pr] script (requires + having configured gpg with git); + - or post a comment containing "@coqbot: merge now" (this is + especially convenient for developers who do not have a GPG key and + for when you do not have access to a console). - PR authors or co-authors cannot review, self-assign, or merge the PR they contributed to. However, reviewers may push small fixes to the diff --git a/INSTALL.md b/INSTALL.md index c44c3dde7d..05a92ca005 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -1,17 +1,25 @@ Installing From Sources ======================= +This document presents instructions to install this branch of Coq. +For more general installation instructions and information about known +build system issues, please consult the wiki page: + + https://github.com/coq/coq/wiki#coq-installation + Build Requirements ------------------ To compile Coq yourself, you need: - [OCaml](https://ocaml.org/) (version >= 4.05.0) - (This version of Coq has been tested up to OCaml 4.10.0) + (This version of Coq has been tested up to OCaml 4.11.1) - The [num](https://github.com/ocaml/num) library; note that it is included in the OCaml distribution for OCaml versions < 4.06.0 +- The [ZArith library](https://github.com/ocaml/Zarith) >= 1.8 + - The [findlib](http://projects.camlcity.org/projects/findlib.html) library (version >= 1.8.0) - GNU Make (version >= 3.81) @@ -45,7 +53,7 @@ CoqIDE with: Opam (https://opam.ocaml.org/) is recommended to install OCaml and the corresponding packages. - $ opam switch create coq 4.10.0+flambda + $ opam switch create coq 4.11.1+flambda $ eval $(opam env) $ opam install num ocamlfind lablgtk3-sourceview3 diff --git a/META.coq.in b/META.coq.in index 095f54dde7..5aaa8cc8a6 100644 --- a/META.coq.in +++ b/META.coq.in @@ -120,7 +120,7 @@ package "interp" ( description = "Coq Term Interpretation" version = "8.13" - requires = "coq.pretyping" + requires = "zarith, coq.pretyping" directory = "interp" archive(byte) = "interp.cma" @@ -327,7 +327,7 @@ package "plugins" ( description = "Coq micromega plugin" version = "8.13" - requires = "num,coq.plugins.ltac" + requires = "num, coq.plugins.ltac" directory = "micromega" archive(byte) = "micromega_plugin.cmo" @@ -462,7 +462,7 @@ package "plugins" ( description = "Coq nsatz plugin" version = "8.13" - requires = "num,coq.plugins.ltac" + requires = "zarith, coq.plugins.ltac" directory = "nsatz" archive(byte) = "nsatz_plugin.cmo" @@ -507,7 +507,7 @@ package "plugins" ( description = "Coq string_notation plugin" version = "8.13" - requires = "" + requires = "coq.vernac" directory = "syntax" archive(byte) = "string_notation_plugin.cmo" @@ -517,6 +517,20 @@ package "plugins" ( plugin(native) = "string_notation_plugin.cmxs" ) + package "numeral_notation" ( + description = "Coq numeral notation plugin" + version = "8.13" + + requires = "coq.vernac" + directory = "numeral_notation" + + archive(byte) = "numeral_notation_plugin.cmo" + archive(native) = "numeral_notation_plugin.cmx" + + plugin(byte) = "numeral_notation_plugin.cmo" + plugin(native) = "numeral_notation_plugin.cmxs" + ) + package "derive" ( description = "Coq derive plugin" diff --git a/Makefile.build b/Makefile.build index 7806dce79c..061489f47f 100644 --- a/Makefile.build +++ b/Makefile.build @@ -245,7 +245,7 @@ COQOPTS=$(NATIVECOMPUTE) $(COQWARNERROR) $(COQUSERFLAGS) BOOTCOQC=$(TIMER) $(COQC) -coqlib . -q $(COQOPTS) LOCALINCLUDES=$(addprefix -I ,$(SRCDIRS)) -MLINCLUDES=$(LOCALINCLUDES) +MLINCLUDES=$(LOCALINCLUDES) -package zarith USERCONTRIBINCLUDES=$(addprefix -I user-contrib/,$(USERCONTRIBDIRS)) @@ -302,7 +302,7 @@ $(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) $(CUSTOM) -o $@ -linkpkg $(1) $^ endef # Main packages linked by Coq. -SYSMOD:=-package num,str,unix,dynlink,threads +SYSMOD:=-package str,unix,dynlink,threads,num,zarith ########################################################################### # Infrastructure for the rest of the Makefile @@ -367,7 +367,7 @@ kernel/byterun/coq_jumptbl.h: kernel/genOpcodeFiles.exe $(SHOW)'WRITE $@' $(HIDE)$< jump > $@ -kernel/copcodes.ml: kernel/genOpcodeFiles.exe +kernel/vmopcodes.ml: kernel/genOpcodeFiles.exe $(SHOW)'WRITE $@' $(HIDE)$< copml > $@ @@ -709,10 +709,6 @@ plugins/micromega/%.cmi: plugins/micromega/%.mli $(SHOW)'OCAMLC $<' $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -package unix,num -c $< -plugins/nsatz/%.cmi: plugins/nsatz/%.mli - $(SHOW)'OCAMLC $<' - $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -package unix,num -c $< - %.cmi: %.mli $(SHOW)'OCAMLC $<' $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -c $< @@ -721,10 +717,6 @@ plugins/micromega/%.cmo: plugins/micromega/%.ml $(SHOW)'OCAMLC $<' $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -package unix,num -c $< -plugins/nsatz/%.cmo: plugins/nsatz/%.ml - $(SHOW)'OCAMLC $<' - $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -package unix,num -c $< - %.cmo: %.ml $(SHOW)'OCAMLC $<' $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -c $< @@ -762,10 +754,6 @@ plugins/micromega/%.cmx: plugins/micromega/%.ml $(SHOW)'OCAMLOPT $<' $(HIDE)$(OCAMLOPT) $(COND_OPTFLAGS) $(HACKMLI) $($(@:.cmx=_FORPACK)) -package unix,num -c $< -plugins/nsatz/%.cmx: plugins/nsatz/%.ml - $(SHOW)'OCAMLOPT $<' - $(HIDE)$(OCAMLOPT) $(COND_OPTFLAGS) $(HACKMLI) $($(@:.cmx=_FORPACK)) -package unix,num -c $< - plugins/%.cmx: plugins/%.ml $(SHOW)'OCAMLOPT $<' $(HIDE)$(OCAMLOPT) $(COND_OPTFLAGS) $(HACKMLI) $($(@:.cmx=_FORPACK)) -c $< diff --git a/Makefile.ci b/Makefile.ci index 85e4b965f9..af78f252df 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -37,7 +37,7 @@ CI_TARGETS= \ ci-geocoq \ ci-coqhammer \ ci-hott \ - ci-lambda_rust \ + ci-iris \ ci-math_classes \ ci-mathcomp \ ci-metacoq \ diff --git a/Makefile.doc b/Makefile.doc index cc6277ca79..473a70fb72 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -223,7 +223,7 @@ install-doc-stdlib-html: $(MKDIR) $(FULLDOCDIR)/html/stdlib $(INSTALLLIB) doc/stdlib/html/* $(FULLDOCDIR)/html/stdlib -install-doc-printable: +install-doc-printable: $(MKDIR) $(FULLDOCDIR)/ps $(FULLDOCDIR)/pdf $(INSTALLLIB) doc/stdlib/Library.pdf $(FULLDOCDIR)/pdf $(INSTALLLIB) doc/stdlib/Library.ps $(FULLDOCDIR)/ps @@ -250,7 +250,8 @@ $(DOC_GRAM): $(DOC_GRAMCMO) coqpp/coqpp_parser.mli coqpp/coqpp_parser.ml doc/too PLUGIN_MLGS := $(wildcard plugins/*/*.mlg) OMITTED_PLUGIN_MLGS := plugins/ssr/ssrparser.mlg plugins/ssr/ssrvernac.mlg plugins/ssrmatching/g_ssrmatching.mlg \ plugins/ssrsearch/g_search.mlg -DOC_MLGS := $(wildcard */*.mlg) $(sort $(filter-out $(OMITTED_PLUGIN_MLGS), $(PLUGIN_MLGS))) +DOC_MLGS := $(wildcard */*.mlg) $(sort $(filter-out $(OMITTED_PLUGIN_MLGS), $(PLUGIN_MLGS))) \ + user-contrib/Ltac2/g_ltac2.mlg DOC_EDIT_MLGS := $(wildcard doc/tools/docgram/*.edit_mlg) DOC_RSTS := $(wildcard doc/sphinx/*/*.rst) $(wildcard doc/sphinx/*/*/*.rst) diff --git a/Makefile.make b/Makefile.make index 7191738612..51d6d1c3c1 100644 --- a/Makefile.make +++ b/Makefile.make @@ -107,7 +107,7 @@ GRAMMLIFILES := $(addsuffix .mli, $(GRAMFILES)) GENGRAMMLFILES := $(GRAMMLFILES) gramlib/.pack/gramlib.ml # why is gramlib.ml not in GRAMMLFILES? GENMLGFILES:= $(MLGFILES:.mlg=.ml) -GENMLFILES:=$(LEXFILES:.mll=.ml) $(YACCFILES:.mly=.ml) $(GENMLGFILES) $(GENGRAMMLFILES) ide/coqide/coqide_os_specific.ml kernel/copcodes.ml kernel/uint63.ml +GENMLFILES:=$(LEXFILES:.mll=.ml) $(YACCFILES:.mly=.ml) $(GENMLGFILES) $(GENGRAMMLFILES) ide/coqide/coqide_os_specific.ml kernel/vmopcodes.ml kernel/uint63.ml GENMLIFILES:=$(GRAMMLIFILES) GENHFILES:=kernel/byterun/coq_instruct.h kernel/byterun/coq_jumptbl.h GENFILES:=$(GENMLFILES) $(GENMLIFILES) $(GENHFILES) kernel/genOpcodeFiles.exe diff --git a/azure-pipelines.yml b/azure-pipelines.yml index b27d1df39d..17228bda8a 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -22,7 +22,7 @@ jobs: powershell -Command "(New-Object Net.WebClient).DownloadFile('http://www.cygwin.com/setup-x86_64.exe', 'setup-x86_64.exe')" SET CYGROOT=C:\cygwin64 SET CYGCACHE=%CYGROOT%\var\cache\setup - setup-x86_64.exe -qnNdO -R %CYGROOT% -l %CYGCACHE% -s %CYGMIRROR% -P rsync -P patch -P diffutils -P make -P unzip -P m4 -P findutils -P time -P wget -P curl -P git -P mingw64-x86_64-binutils,mingw64-x86_64-gcc-core,mingw64-x86_64-gcc-g++,mingw64-x86_64-pkg-config,mingw64-x86_64-windows_default_manifest -P mingw64-x86_64-headers,mingw64-x86_64-runtime,mingw64-x86_64-pthreads,mingw64-x86_64-zlib -P python3 + setup-x86_64.exe -qnNdO -R %CYGROOT% -l %CYGCACHE% -s %CYGMIRROR% -P rsync -P patch -P diffutils -P make -P unzip -P m4 -P findutils -P time -P wget -P curl -P git -P mingw64-x86_64-binutils,mingw64-x86_64-gcc-core,mingw64-x86_64-gcc-g++,mingw64-x86_64-pkg-config,mingw64-x86_64-windows_default_manifest -P mingw64-x86_64-headers,mingw64-x86_64-runtime,mingw64-x86_64-pthreads,mingw64-x86_64-zlib,mingw64-x86_64-gmp -P python3 SET TARGET_ARCH=x86_64-w64-mingw32 SET CD_MFMT=%cd:\=/% @@ -64,7 +64,7 @@ jobs: set -e brew update (cd $(brew --repository)/Library/Taps/homebrew/homebrew-core/ && git fetch --shallow-since=${HBCORE_DATE} && git checkout ${HBCORE_REF}) - brew install gnu-time opam pkg-config gtksourceview3 adwaita-icon-theme || true + brew install gnu-time opam pkg-config gtksourceview3 adwaita-icon-theme gmp || true # || true: workaround #12657, see also #12672 and commit message for this line pip3 install macpack displayName: 'Install system dependencies' @@ -80,11 +80,11 @@ jobs: opam switch set ocaml-base-compiler.$COMPILER eval $(opam env) opam update - opam install -j "$NJOBS" num ocamlfind${FINDLIB_VER} ounit lablgtk3-sourceview3 + opam install -j "$NJOBS" num ocamlfind${FINDLIB_VER} ounit lablgtk3-sourceview3 zarith.1.9.1 opam list displayName: 'Install OCaml dependencies' env: - COMPILER: "4.10.0" + COMPILER: "4.11.1" FINDLIB_VER: ".1.8.1" OPAMYES: "true" diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index 999f44bf1d..a881b7804f 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -100,26 +100,27 @@ let mk_mtb mp sign delta = mod_delta = delta; mod_retroknowledge = ModTypeRK; } -let collect_constants_without_body sign mp = +let rec collect_constants_without_body sign mp accu = let collect_sf s lab = function | SFBconst cb -> let c = Constant.make2 mp lab in if Declareops.constant_has_body cb then s else Cset.add c s - | SFBmind _ | SFBmodule _ | SFBmodtype _ -> s in + | SFBmodule msb -> collect_constants_without_body msb.mod_type (MPdot(mp,lab)) s + | SFBmind _ | SFBmodtype _ -> s in match sign with | MoreFunctor _ -> Cset.empty (* currently ignored *) | NoFunctor struc -> - List.fold_left (fun s (lab,mb) -> collect_sf s lab mb) Cset.empty struc + List.fold_left (fun s (lab,mb) -> collect_sf s lab mb) accu struc -let rec check_module env opac mp mb = +let rec check_module env opac mp mb opacify = Flags.if_verbose Feedback.msg_notice (str " checking module: " ++ str (ModPath.to_string mp)); let env = Modops.add_retroknowledge mb.mod_retroknowledge env in let sign, opac = - check_signature env opac mb.mod_type mb.mod_mp mb.mod_delta Cset.empty + check_signature env opac mb.mod_type mb.mod_mp mb.mod_delta opacify in let optsign, opac = match mb.mod_expr with |Struct sign_struct -> - let opacify = collect_constants_without_body sign mb.mod_mp in + let opacify = collect_constants_without_body sign mb.mod_mp opacify in let sign, opac = check_signature env opac sign_struct mb.mod_mp mb.mod_delta opacify in Some (sign, mb.mod_delta), opac |Algebraic me -> Some (check_mexpression env opac me mb.mod_mp mb.mod_delta), opac @@ -152,7 +153,7 @@ and check_structure_field env opac mp lab res opacify = function let kn = Mod_subst.mind_of_delta_kn res kn in CheckInductive.check_inductive env kn mib, opac | SFBmodule msb -> - let opac = check_module env opac (MPdot(mp,lab)) msb in + let opac = check_module env opac (MPdot(mp,lab)) msb opacify in Modops.add_module msb env, opac | SFBmodtype mty -> check_module_type env mty; @@ -194,3 +195,5 @@ and check_signature env opac sign mp_mse res opacify = match sign with check_structure_field env opac mp_mse lab res opacify mb) (env, opac) struc in NoFunctor struc, opac + +let check_module env opac mp mb = check_module env opac mp mb Cset.empty diff --git a/clib/bigint.ml b/clib/bigint.ml deleted file mode 100644 index 735ff3261e..0000000000 --- a/clib/bigint.ml +++ /dev/null @@ -1,526 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(***************************************************) -(* Basic operations on (unbounded) integer numbers *) -(***************************************************) - -(* An integer is canonically represented as an array of k-digits blocs, - i.e. in base 10^k. - - 0 is represented by the empty array and -1 by the singleton [|-1|]. - The first bloc is in the range ]0;base[ for positive numbers. - The first bloc is in the range [-base;-1[ for numbers < -1. - All other blocs are numbers in the range [0;base[. - - Negative numbers are represented using 2's complementation : - one unit is "borrowed" from the top block for complementing - the other blocs. For instance, with 4-digits blocs, - [|-5;6789|] denotes -43211 - since -5.10^4+6789=-((4.10^4)+(10000-6789)) = -43211 - - The base is a power of 10 in order to facilitate the parsing and printing - of numbers in digital notation. - - All functions, to the exception of to_string and of_string should work - with an arbitrary base, even if not a power of 10. - - In practice, we set k=4 on 32-bits machines, so that no overflow in ocaml - machine words (i.e. the interval [-2^30;2^30-1]) occur when multiplying two - numbers less than (10^k). On 64-bits machines, k=9. -*) - -(* The main parameters *) - -let size = - let rec log10 n = if n < 10 then 0 else 1 + log10 (n / 10) in - (log10 max_int) / 2 - -let format_size = - (* How to parametrize a printf format *) - if Int.equal size 4 then Printf.sprintf "%04d" - else if Int.equal size 9 then Printf.sprintf "%09d" - else fun n -> - let rec aux j l n = - if Int.equal j size then l else aux (j+1) (string_of_int (n mod 10) :: l) (n/10) - in String.concat "" (aux 0 [] n) - -(* The base is 10^size *) -let base = - let rec exp10 = function 0 -> 1 | n -> 10 * exp10 (n-1) in exp10 size - -(******************************************************************) -(* First, we represent all numbers by int arrays. - Later, we will optimize the particular case of small integers *) -(******************************************************************) - -module ArrayInt = struct - -(* Basic numbers *) -let zero = [||] - -let is_zero = function -| [||] -> true -| _ -> false - -(* An array is canonical when - - it is empty - - it is [|-1|] - - its first bloc is in [-base;-1[U]0;base[ - and the other blocs are in [0;base[. *) -(* -let canonical n = - let ok x = (0 <= x && x < base) in - let rec ok_tail k = (Int.equal k 0) || (ok n.(k) && ok_tail (k-1)) in - let ok_init x = (-base <= x && x < base && not (Int.equal x (-1)) && not (Int.equal x 0)) - in - (is_zero n) || (match n with [|-1|] -> true | _ -> false) || - (ok_init n.(0) && ok_tail (Array.length n - 1)) -*) - -(* [normalize_pos] : removing initial blocks of 0 *) - -let normalize_pos n = - let k = ref 0 in - while !k < Array.length n && Int.equal n.(!k) 0 do incr k done; - Array.sub n !k (Array.length n - !k) - -(* [normalize_neg] : avoid (-1) as first bloc. - input: an array with -1 as first bloc and other blocs in [0;base[ - output: a canonical array *) - -let normalize_neg n = - let k = ref 1 in - while !k < Array.length n && Int.equal n.(!k) (base - 1) do incr k done; - let n' = Array.sub n !k (Array.length n - !k) in - if Int.equal (Array.length n') 0 then [|-1|] else (n'.(0) <- n'.(0) - base; n') - -(* [normalize] : avoid 0 and (-1) as first bloc. - input: an array with first bloc in [-base;base[ and others in [0;base[ - output: a canonical array *) - -let normalize n = - if Int.equal (Array.length n) 0 then n - else if Int.equal n.(0) (-1) then normalize_neg n - else if Int.equal n.(0) 0 then normalize_pos n - else n - -(* Opposite (expects and returns canonical arrays) *) - -let neg m = - if is_zero m then zero else - let n = Array.copy m in - let i = ref (Array.length m - 1) in - while !i > 0 && Int.equal n.(!i) 0 do decr i done; - if Int.equal !i 0 then begin - n.(0) <- - n.(0); - (* n.(0) cannot be 0 since m is canonical *) - if Int.equal n.(0) (-1) then normalize_neg n - else if Int.equal n.(0) base then (n.(0) <- 0; Array.append [| 1 |] n) - else n - end else begin - (* here n.(!i) <> 0, hence 0 < base - n.(!i) < base for n canonical *) - n.(!i) <- base - n.(!i); decr i; - while !i > 0 do n.(!i) <- base - 1 - n.(!i); decr i done; - (* since -base <= n.(0) <= base-1, hence -base <= -n.(0)-1 <= base-1 *) - n.(0) <- - n.(0) - 1; - (* since m is canonical, m.(0)<>0 hence n.(0)<>-1, - and m=-1 is already handled above, so here m.(0)<>-1 hence n.(0)<>0 *) - n - end - -let push_carry r j = - let j = ref j in - while !j > 0 && r.(!j) < 0 do - r.(!j) <- r.(!j) + base; decr j; r.(!j) <- r.(!j) - 1 - done; - while !j > 0 && r.(!j) >= base do - r.(!j) <- r.(!j) - base; decr j; r.(!j) <- r.(!j) + 1 - done; - (* here r.(0) could be in [-2*base;2*base-1] *) - if r.(0) >= base then (r.(0) <- r.(0) - base; Array.append [| 1 |] r) - else if r.(0) < -base then (r.(0) <- r.(0) + 2*base; Array.append [| -2 |] r) - else normalize r (* in case r.(0) is 0 or -1 *) - -let add_to r a j = - if is_zero a then r else begin - for i = Array.length r - 1 downto j+1 do - r.(i) <- r.(i) + a.(i-j); - if r.(i) >= base then (r.(i) <- r.(i) - base; r.(i-1) <- r.(i-1) + 1) - done; - r.(j) <- r.(j) + a.(0); - push_carry r j - end - -let add n m = - let d = Array.length n - Array.length m in - if d > 0 then add_to (Array.copy n) m d else add_to (Array.copy m) n (-d) - -let sub_to r a j = - if is_zero a then r else begin - for i = Array.length r - 1 downto j+1 do - r.(i) <- r.(i) - a.(i-j); - if r.(i) < 0 then (r.(i) <- r.(i) + base; r.(i-1) <- r.(i-1) - 1) - done; - r.(j) <- r.(j) - a.(0); - push_carry r j - end - -let sub n m = - let d = Array.length n - Array.length m in - if d >= 0 then sub_to (Array.copy n) m d - else let r = neg m in add_to r n (Array.length r - Array.length n) - -let mult m n = - if is_zero m || is_zero n then zero else - let l = Array.length m + Array.length n in - let r = Array.make l 0 in - for i = Array.length m - 1 downto 0 do - for j = Array.length n - 1 downto 0 do - let p = m.(i) * n.(j) + r.(i+j+1) in - let (q,s) = - if p < 0 - then (p + 1) / base - 1, (p + 1) mod base + base - 1 - else p / base, p mod base in - r.(i+j+1) <- s; - if not (Int.equal q 0) then r.(i+j) <- r.(i+j) + q; - done - done; - normalize r - -(* Comparisons *) - -let is_strictly_neg n = not (is_zero n) && n.(0) < 0 -let is_strictly_pos n = not (is_zero n) && n.(0) > 0 -let is_neg_or_zero n = is_zero n || n.(0) < 0 -let is_pos_or_zero n = is_zero n || n.(0) > 0 - -(* Is m without its i first blocs less then n without its j first blocs ? - Invariant : |m|-i = |n|-j *) - -let rec less_than_same_size m n i j = - i < Array.length m && - (m.(i) < n.(j) || (Int.equal m.(i) n.(j) && less_than_same_size m n (i+1) (j+1))) - -let less_than m n = - if is_strictly_neg m then - is_pos_or_zero n || Array.length m > Array.length n - || (Int.equal (Array.length m) (Array.length n) && less_than_same_size m n 0 0) - else - is_strictly_pos n && (Array.length m < Array.length n || - (Int.equal (Array.length m) (Array.length n) && less_than_same_size m n 0 0)) - -(* For this equality test it is critical that n and m are canonical *) - -let rec array_eq len v1 v2 i = - if Int.equal len i then true - else - Int.equal v1.(i) v2.(i) && array_eq len v1 v2 (succ i) - -let equal m n = - let lenm = Array.length m in - let lenn = Array.length n in - (Int.equal lenm lenn) && (array_eq lenm m n 0) - -(* Is m without its k top blocs less than n ? *) - -let less_than_shift_pos k m n = - (Array.length m - k < Array.length n) - || (Int.equal (Array.length m - k) (Array.length n) && less_than_same_size m n k 0) - -let rec can_divide k m d i = - (Int.equal i (Array.length d)) || - (m.(k+i) > d.(i)) || - (Int.equal m.(k+i) d.(i) && can_divide k m d (i+1)) - -(* For two big nums m and d and a small number q, - computes m - d * q * base^(|m|-|d|-k) in-place (in m). - Both m d and q are positive. *) - -let sub_mult m d q k = - if not (Int.equal q 0) then - for i = Array.length d - 1 downto 0 do - let v = d.(i) * q in - m.(k+i) <- m.(k+i) - v mod base; - if m.(k+i) < 0 then (m.(k+i) <- m.(k+i) + base; m.(k+i-1) <- m.(k+i-1) -1); - if v >= base then begin - m.(k+i-1) <- m.(k+i-1) - v / base; - let j = ref (i-1) in - while m.(k + !j) < 0 do (* result is positive, hence !j remains >= 0 *) - m.(k + !j) <- m.(k + !j) + base; decr j; m.(k + !j) <- m.(k + !j) -1 - done - end - done - -(** Euclid division m/d = (q,r), with m = q*d+r and |r|<|q|. - This is the "Trunc" variant (a.k.a "Truncated-Toward-Zero"), - as with ocaml's / (but not as ocaml's Big_int.quomod_big_int). - We have sign r = sign m *) - -let euclid m d = - let isnegm, m = - if is_strictly_neg m then (-1),neg m else 1,Array.copy m in - let isnegd, d = if is_strictly_neg d then (-1),neg d else 1,d in - if is_zero d then raise Division_by_zero; - let q,r = - if less_than m d then (zero,m) else - let ql = Array.length m - Array.length d in - let q = Array.make (ql+1) 0 in - let i = ref 0 in - while not (less_than_shift_pos !i m d) do - if Int.equal m.(!i) 0 then incr i else - if can_divide !i m d 0 then begin - let v = - if Array.length d > 1 && not (Int.equal d.(0) m.(!i)) then - (m.(!i) * base + m.(!i+1)) / (d.(0) * base + d.(1) + 1) - else - m.(!i) / d.(0) in - q.(!i) <- q.(!i) + v; - sub_mult m d v !i - end else begin - let v = (m.(!i) * base + m.(!i+1)) / (d.(0) + 1) in - q.(!i) <- q.(!i) + v / base; - sub_mult m d (v / base) !i; - q.(!i+1) <- q.(!i+1) + v mod base; - if q.(!i+1) >= base then - (q.(!i+1) <- q.(!i+1)-base; q.(!i) <- q.(!i)+1); - sub_mult m d (v mod base) (!i+1) - end - done; - (normalize q, normalize m) in - (if Int.equal (isnegd * isnegm) (-1) then neg q else q), - (if Int.equal isnegm (-1) then neg r else r) - -(* Parsing/printing ordinary 10-based numbers *) - -let of_string s = - let len = String.length s in - let isneg = len > 1 && s.[0] == '-' in - let d = ref (if isneg then 1 else 0) in - while !d < len && s.[!d] == '0' do incr d done; - if Int.equal !d len then zero else - let r = (len - !d) mod size in - let h = String.sub s (!d) r in - let e = match h with "" -> 0 | _ -> 1 in - let l = (len - !d) / size in - let a = Array.make (l + e) 0 in - if Int.equal e 1 then a.(0) <- int_of_string h; - for i = 1 to l do - a.(i+e-1) <- int_of_string (String.sub s ((i-1)*size + !d + r) size) - done; - if isneg then neg a else a - -let to_string_pos sgn n = - if Int.equal (Array.length n) 0 then "0" else - sgn ^ - String.concat "" - (string_of_int n.(0) :: List.map format_size (List.tl (Array.to_list n))) - -let to_string n = - if is_strictly_neg n then to_string_pos "-" (neg n) - else to_string_pos "" n - -end - -(******************************************************************) -(* Optimized operations on (unbounded) integer numbers *) -(* integers smaller than base are represented as machine integers *) -(******************************************************************) - -open ArrayInt - -type bigint = Obj.t - -(* Since base is the largest power of 10 such that base*base <= max_int, - we have max_int < 100*base*base : any int can be represented - by at most three blocs *) - -let small n = (-base <= n) && (n < base) - -let mkarray n = - (* n isn't small, this case is handled separately below *) - let lo = n mod base - and hi = n / base in - let t = if small hi then [|hi;lo|] else [|hi/base;hi mod base;lo|] - in - for i = Array.length t -1 downto 1 do - if t.(i) < 0 then (t.(i) <- t.(i) + base; t.(i-1) <- t.(i-1) -1) - done; - t - -let ints_of_int n = - if Int.equal n 0 then [| |] - else if small n then [| n |] - else mkarray n - -let of_int n = - if small n then Obj.repr n else Obj.repr (mkarray n) - -let of_ints n = - let n = normalize n in (* TODO: using normalize here seems redundant now *) - if is_zero n then Obj.repr 0 else - if Int.equal (Array.length n) 1 then Obj.repr n.(0) else - Obj.repr n - -let coerce_to_int = (Obj.magic : Obj.t -> int) -let coerce_to_ints = (Obj.magic : Obj.t -> int array) - -let to_ints n = - if Obj.is_int n then ints_of_int (coerce_to_int n) - else coerce_to_ints n - -let int_of_ints = - let maxi = mkarray max_int and mini = mkarray min_int in - fun t -> - let l = Array.length t in - if (l > 3) || (Int.equal l 3 && (less_than maxi t || less_than t mini)) - then failwith "Bigint.to_int: too large"; - let sum = ref 0 in - let pow = ref 1 in - for i = l-1 downto 0 do - sum := !sum + t.(i) * !pow; - pow := !pow*base; - done; - !sum - -let to_int n = - if Obj.is_int n then coerce_to_int n - else int_of_ints (coerce_to_ints n) - -let app_pair f (m, n) = - (f m, f n) - -let add m n = - if Obj.is_int m && Obj.is_int n - then of_int (coerce_to_int m + coerce_to_int n) - else of_ints (add (to_ints m) (to_ints n)) - -let sub m n = - if Obj.is_int m && Obj.is_int n - then of_int (coerce_to_int m - coerce_to_int n) - else of_ints (sub (to_ints m) (to_ints n)) - -let mult m n = - if Obj.is_int m && Obj.is_int n - then of_int (coerce_to_int m * coerce_to_int n) - else of_ints (mult (to_ints m) (to_ints n)) - -let euclid m n = - if Obj.is_int m && Obj.is_int n - then app_pair of_int - (coerce_to_int m / coerce_to_int n, coerce_to_int m mod coerce_to_int n) - else app_pair of_ints (euclid (to_ints m) (to_ints n)) - -let less_than m n = - if Obj.is_int m && Obj.is_int n - then coerce_to_int m < coerce_to_int n - else less_than (to_ints m) (to_ints n) - -let neg n = - if Obj.is_int n then of_int (- (coerce_to_int n)) - else of_ints (neg (to_ints n)) - -let of_string m = of_ints (of_string m) -let to_string m = to_string (to_ints m) - -let zero = of_int 0 -let one = of_int 1 -let two = of_int 2 -let sub_1 n = sub n one -let add_1 n = add n one -let mult_2 n = add n n - -let div2_with_rest n = - let (q,b) = euclid n two in - (q, b == one) - -let is_strictly_neg n = is_strictly_neg (to_ints n) -let is_strictly_pos n = is_strictly_pos (to_ints n) -let is_neg_or_zero n = is_neg_or_zero (to_ints n) -let is_pos_or_zero n = is_pos_or_zero (to_ints n) - -let equal m n = - if Obj.is_block m && Obj.is_block n then - ArrayInt.equal (Obj.obj m) (Obj.obj n) - else m == n - -(* spiwack: computes n^m *) -(* The basic idea of the algorithm is that n^(2m) = (n^2)^m *) -(* In practice the algorithm performs : - k*n^0 = k - k*n^(2m) = k*(n*n)^m - k*n^(2m+1) = (n*k)*(n*n)^m *) -let pow = - let rec pow_aux odd_rest n m = (* odd_rest is the k from above *) - if m<=0 then - odd_rest - else - let quo = m lsr 1 (* i.e. m/2 *) - and odd = not (Int.equal (m land 1) 0) in - pow_aux - (if odd then mult n odd_rest else odd_rest) - (mult n n) - quo - in - pow_aux one - -(** Testing suite w.r.t. OCaml's Big_int *) - -(* -module B = struct - open Big_int - let zero = zero_big_int - let to_string = string_of_big_int - let of_string = big_int_of_string - let add = add_big_int - let opp = minus_big_int - let sub = sub_big_int - let mul = mult_big_int - let abs = abs_big_int - let sign = sign_big_int - let euclid n m = - let n' = abs n and m' = abs m in - let q',r' = quomod_big_int n' m' in - (if sign (mul n m) < 0 && sign q' <> 0 then opp q' else q'), - (if sign n < 0 then opp r' else r') -end - -let check () = - let roots = [ 1; 100; base; 100*base; base*base ] in - let rands = [ 1234; 5678; 12345678; 987654321 ] in - let nums = (List.flatten (List.map (fun x -> [x-1;x;x+1]) roots)) @ rands in - let numbers = - List.map string_of_int nums @ - List.map (fun n -> string_of_int (-n)) nums - in - let i = ref 0 in - let compare op x y n n' = - incr i; - let s = Printf.sprintf "%30s" (to_string n) in - let s' = Printf.sprintf "%30s" (B.to_string n') in - if s <> s' then Printf.printf "%s%s%s: %s <> %s\n" x op y s s' in - let test x y = - let n = of_string x and m = of_string y in - let n' = B.of_string x and m' = B.of_string y in - let a = add n m and a' = B.add n' m' in - let s = sub n m and s' = B.sub n' m' in - let p = mult n m and p' = B.mul n' m' in - let q,r = try euclid n m with Division_by_zero -> zero,zero - and q',r' = try B.euclid n' m' with Division_by_zero -> B.zero, B.zero - in - compare "+" x y a a'; - compare "-" x y s s'; - compare "*" x y p p'; - compare "/" x y q q'; - compare "%" x y r r' - in - List.iter (fun a -> List.iter (test a) numbers) numbers; - Printf.printf "%i tests done\n" !i -*) diff --git a/clib/bigint.mli b/clib/bigint.mli deleted file mode 100644 index 9677c93873..0000000000 --- a/clib/bigint.mli +++ /dev/null @@ -1,53 +0,0 @@ -(************************************************************************) -(* * The Coq Proof Assistant / The Coq Development Team *) -(* v * Copyright INRIA, CNRS and contributors *) -(* <O___,, * (see version control and CREDITS file for authors & dates) *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(* * (see LICENSE file for the text of the license) *) -(************************************************************************) - -(** Arbitrary large integer numbers *) - -type bigint - -val of_string : string -> bigint -(** May raise a Failure just as [int_of_string] on non-numerical strings *) - -val to_string : bigint -> string - -val of_int : int -> bigint -val to_int : bigint -> int (** May raise a Failure on oversized numbers *) - -val zero : bigint -val one : bigint -val two : bigint - -val div2_with_rest : bigint -> bigint * bool (** true=odd; false=even *) - -val add_1 : bigint -> bigint -val sub_1 : bigint -> bigint -val mult_2 : bigint -> bigint - -val add : bigint -> bigint -> bigint -val sub : bigint -> bigint -> bigint -val mult : bigint -> bigint -> bigint - -(** Euclid division m/d = (q,r), with m = q*d+r and |r|<|q|. - This is the "Trunc" variant (a.k.a "Truncated-Toward-Zero"), - as with ocaml's / (but not as ocaml's Big_int.quomod_big_int). - We have sign r = sign m *) - -val euclid : bigint -> bigint -> bigint * bigint - -val less_than : bigint -> bigint -> bool -val equal : bigint -> bigint -> bool - -val is_strictly_pos : bigint -> bool -val is_strictly_neg : bigint -> bool -val is_pos_or_zero : bigint -> bool -val is_neg_or_zero : bigint -> bool -val neg : bigint -> bigint - -val pow : bigint -> int -> bigint diff --git a/clib/dyn.ml b/clib/dyn.ml index 1ddbe5a7c2..8ef90a366e 100644 --- a/clib/dyn.ml +++ b/clib/dyn.ml @@ -49,6 +49,13 @@ sig module Map(Value : ValueS) : MapS with type 'a key = 'a tag and type 'a value = 'a Value.t + + module HMap (V1 : ValueS)(V2 : ValueS) : + sig + type map = { map : 'a. 'a tag -> 'a V1.t -> 'a V2.t } + val map : map -> Map(V1).t -> Map(V2).t + end + end module type S = @@ -132,6 +139,16 @@ module Self : PreS = struct let iter f m = Int.Map.iter (fun k v -> f (Any (k, v))) m let fold f m accu = Int.Map.fold (fun k v accu -> f (Any (k, v)) accu) m accu end + + module HMap (V1 : ValueS) (V2 : ValueS) = + struct + type map = { map : 'a. 'a tag -> 'a V1.t -> 'a V2.t } + + let map (f : map) (m : Map(V1).t) : Map(V2).t = + Int.Map.mapi f.map m + + end + end include Self diff --git a/clib/dyn.mli b/clib/dyn.mli index 926d0f3135..4fd33b5242 100644 --- a/clib/dyn.mli +++ b/clib/dyn.mli @@ -75,6 +75,12 @@ sig MapS with type 'a key = 'a tag and type 'a value = 'a Value.t (** Map from type tags to values parameterized by the tag type *) + module HMap (V1 : ValueS)(V2 : ValueS) : + sig + type map = { map : 'a. 'a tag -> 'a V1.t -> 'a V2.t } + val map : map -> Map(V1).t -> Map(V2).t + end + module Easy : sig (* To create a dynamic type on the fly *) val make_dyn_tag : string -> ('a -> t) * (t -> 'a) * 'a tag diff --git a/clib/option.ml b/clib/option.ml index c335e836c2..d1775ae3ae 100644 --- a/clib/option.ml +++ b/clib/option.ml @@ -55,6 +55,8 @@ let make x = Some x (** [bind x f] is [f y] if [x] is [Some y] and [None] otherwise *) let bind x f = match x with Some y -> f y | None -> None +let filter f x = bind x (fun v -> if f v then x else None) + (** [init b x] returns [Some x] if [b] is [true] and [None] otherwise. *) let init b x = if b then diff --git a/clib/option.mli b/clib/option.mli index 4c5df30179..4672780cab 100644 --- a/clib/option.mli +++ b/clib/option.mli @@ -46,6 +46,9 @@ val make : 'a -> 'a option (** [bind x f] is [f y] if [x] is [Some y] and [None] otherwise *) val bind : 'a option -> ('a -> 'b option) -> 'b option +(** [filter f x] is [x] if [x] [Some y] and [f y] is true, [None] otherwise *) +val filter : ('a -> bool) -> 'a option -> 'a option + (** [init b x] returns [Some x] if [b] is [true] and [None] otherwise. *) val init : bool -> 'a -> 'a option diff --git a/config/dune b/config/dune index bf1aa4f471..a30fdce9aa 100644 --- a/config/dune +++ b/config/dune @@ -2,8 +2,14 @@ (name config) (synopsis "Coq Configuration Variables") (public_name coq.config) + (modules :standard \ list_plugins) (wrapped false)) +(executable (name list_plugins) (modules list_plugins)) +(rule (targets plugin_list) + (deps (source_tree %{project_root}/plugins)) + (action (with-stdout-to %{targets} (chdir %{project_root} (run config/list_plugins.exe))))) + ; Dune doesn't use configure's output, but it is still necessary for ; some Coq files to work; will be fixed in the future. (rule @@ -13,7 +19,7 @@ %{project_root}/configure.ml %{project_root}/dev/ocamldebug-coq.run %{project_root}/dev/header.c - ; Needed to generate include lists for coq_makefile - (source_tree %{project_root}/plugins) + ; Needed to generate include lists for coq_makefile + plugin_list (env_var COQ_CONFIGURE_PREFIX)) (action (chdir %{project_root} (run %{ocaml} configure.ml -no-ask -native-compiler no)))) diff --git a/config/list_plugins.ml b/config/list_plugins.ml new file mode 100644 index 0000000000..5e2827bfe0 --- /dev/null +++ b/config/list_plugins.ml @@ -0,0 +1,10 @@ +let plugins = + try Sys.readdir "plugins" + with _ -> [||] + +let () = Array.sort compare plugins + +let () =Array.iter (fun f -> + let f' = "plugins/"^f in + if Sys.is_directory f' && f.[0] <> '.' then print_endline f) + plugins diff --git a/configure.ml b/configure.ml index c05844198b..2dbc01651e 100644 --- a/configure.ml +++ b/configure.ml @@ -64,8 +64,7 @@ let rec waitpid_non_intr pid = (** Below, we'd better read all lines on a channel before closing it, otherwise a SIGPIPE could be encountered by the sub-process *) -let read_lines_and_close fd = - let cin = Unix.in_channel_of_descr fd in +let read_lines_and_close cin = let lines = ref [] in begin try @@ -78,6 +77,9 @@ let read_lines_and_close fd = let lines = List.rev !lines in try List.hd lines, lines with Failure _ -> "", [] +let read_lines_and_close_fd fd = + read_lines_and_close (Unix.in_channel_of_descr fd) + (** Run some unix command and read the first line of its output. We avoid Unix.open_process and its non-fully-portable /bin/sh, especially when it comes to quoting the filenames. @@ -109,8 +111,8 @@ let run ?(fatal=true) ?(err=StdErr) prog args = let pid = Unix.create_process prog argv Unix.stdin out_w fd_err in let () = Unix.close out_w in let () = Unix.close nul_w in - let line, all = read_lines_and_close out_r in - let _ = read_lines_and_close nul_r in + let line, all = read_lines_and_close_fd out_r in + let _ = read_lines_and_close_fd nul_r in let () = check_exit_code (waitpid_non_intr pid) in line, all with @@ -686,19 +688,20 @@ let operating_system = else (try Sys.getenv "OS" with Not_found -> "") -(** Num library *) - -(* since 4.06, the Num library is no longer distributed with OCaml (replaced - by Zarith) -*) +(** Zarith and num libraries *) let check_for_numlib () = - if caml_version_nums >= [4;6;0] then + (if caml_version_nums >= [4;6;0] then let numlib,_ = tryrun camlexec.find ["query";"num"] in match numlib with | "" -> - die "Num library not installed, required for OCaml 4.06 or later" - | _ -> cprintf "You have the Num library installed. Good!" + die "Num library not installed, required for OCaml 4.06 or later" + | _ -> cprintf "You have the Num library installed. Good!"); + let zarith,_ = tryrun camlexec.find ["query";"zarith"] in + match zarith with + | "" -> + die "Zarith library not installed, required" + | _ -> cprintf "You have the Zarith library installed. Good!" let numlib = check_for_numlib () @@ -1108,11 +1111,16 @@ let write_configml f = pr "\nlet core_src_dirs = [\n%s]\n" core_src_dirs; pr "\nlet plugins_dirs = [\n"; - let plugins = - try Sys.readdir "plugins" - with _ -> [||] + let plugins = match open_in "config/plugin_list" with + | exception Sys_error _ -> + let plugins = + try Sys.readdir "plugins" + with _ -> [||] + in + Array.sort compare plugins; + plugins + | ch -> Array.of_list (snd (read_lines_and_close ch)) in - Array.sort compare plugins; Array.iter (fun f -> let f' = "plugins/"^f in @@ -25,6 +25,7 @@ depends: [ "dune" { >= "2.5.0" } "ocamlfind" { build } "num" + "zarith" { >= "1.9.1" } ] build: [ diff --git a/coq.opam.docker b/coq.opam.docker index 229a47a87b..ac1869f344 100644 --- a/coq.opam.docker +++ b/coq.opam.docker @@ -24,6 +24,7 @@ depends: [ "ocaml" { >= "4.05.0" } "ocamlfind" { build } "num" + "zarith" { >= "1.9.1" } "conf-findutils" {build} ] diff --git a/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index 2735c5b5eb..5e3199e8a6 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -201,8 +201,8 @@ function | "IDENT", s -> fprintf fmt "Tok.PIDENT (%a)" print_pat s | "PATTERNIDENT", s -> fprintf fmt "Tok.PPATTERNIDENT (%a)" print_pat s | "FIELD", s -> fprintf fmt "Tok.PFIELD (%a)" print_pat s -| "NUMERAL", None -> fprintf fmt "Tok.PNUMERAL None" -| "NUMERAL", Some s -> fprintf fmt "Tok.PNUMERAL (Some (NumTok.Unsigned.of_string %a))" print_string s +| "NUMBER", None -> fprintf fmt "Tok.PNUMBER None" +| "NUMBER", Some s -> fprintf fmt "Tok.PNUMBER (Some (NumTok.Unsigned.of_string %a))" print_string s | "STRING", s -> fprintf fmt "Tok.PSTRING (%a)" print_pat s | "LEFTQMARK", None -> fprintf fmt "Tok.PLEFTQMARK" | "BULLET", s -> fprintf fmt "Tok.PBULLET (%a)" print_pat s diff --git a/default.nix b/default.nix index 6b0e396d23..ef969acd31 100644 --- a/default.nix +++ b/default.nix @@ -43,7 +43,7 @@ stdenv.mkDerivation rec { hostname python3 time # coq-makefile timing tools ] - ++ (with ocamlPackages; [ ocaml findlib num ]) + ++ (with ocamlPackages; [ ocaml findlib num zarith ]) ++ optionals buildIde [ ocamlPackages.lablgtk3-sourceview3 glib gnome3.defaultIconTheme wrapGAppsHook @@ -69,6 +69,12 @@ stdenv.mkDerivation rec { ++ [ dune_2 ] # Maybe the next build system ); + # Since #12604, ocamlfind looks for num when building plugins + # This follows a similar change in the nixpkgs repo (cf. NixOS/nixpkgs#94230) + propagatedBuildInputs = [ + ocamlPackages.num + ]; + src = if shell then null else diff --git a/dev/README.md b/dev/README.md index 0c6b8020f1..0a6b196ec0 100644 --- a/dev/README.md +++ b/dev/README.md @@ -22,14 +22,12 @@ | [`dev/doc/changes.md`](doc/changes.md) | (partial) Per-version summary of the evolution of Coq ML source | | [`dev/doc/style.txt`](doc/style.txt) | A few style recommendations for writing Coq ML files | | [`dev/doc/debugging.md`](doc/debugging.md) | Help for debugging or profiling | -| [`dev/doc/universes.txt`](doc/universes.txt) | Help for debugging universes | -| [`dev/doc/extensions.txt`](doc/extensions.txt) | Some help about TACTIC EXTEND | -| [`dev/doc/perf-analysis`](doc/perf-analysis)| Analysis of perfs measured on the compilation of user contribs | +| [`dev/doc/universes.md`](doc/universes.md) | Help for debugging universes | | [`dev/doc/econstr.md`](doc/econstr.md) | Describes `Econstr`, implementation of treatment of `evar` in the engine | | [`dev/doc/primproj.md`](doc/primproj.md) | Describes primitive projections | +| [`dev/doc/parsing.md`](doc/parsing.md) | Grammar and parsing overview | | [`dev/doc/proof-engine.md`](doc/proof-engine.md) | Tutorial on new proof engine | | [`dev/doc/xml-protocol.md`](doc/xml-protocol.md) | XML protocol that coqtop and IDEs use to communicate | -| [`dev/doc/MERGING.md`](doc/MERGING.md) | How pull requests should be merged into `master` | | [`dev/doc/release-process.md`](doc/release-process.md) | Process of creating a new Coq release | diff --git a/dev/base_include b/dev/base_include index 1f14fc2941..daee2d97c5 100644 --- a/dev/base_include +++ b/dev/base_include @@ -29,7 +29,6 @@ #install_printer ppatom;; #install_printer ppwhd;; #install_printer ppvblock;; -#install_printer (* bigint *) ppbigint;; #install_printer (* loc *) pploc;; #install_printer (* substitution *) ppsubst;; diff --git a/dev/bench/gitlab-bench.yml b/dev/bench/gitlab-bench.yml new file mode 100644 index 0000000000..4275e3d121 --- /dev/null +++ b/dev/bench/gitlab-bench.yml @@ -0,0 +1,37 @@ + +bench: + stage: stage-1 + when: manual + before_script: + - printenv -0 | sort -z | tr '\0' '\n' + script: + - . ~/.opam/opam-init/init.sh + - ./dev/bench/gitlab.sh + tags: + - timing + variables: + GIT_DEPTH: "" + coq_pr_number: "" + coq_pr_comment_id: "" + new_ocaml_switch: "ocaml-base-compiler.4.07.1" + old_ocaml_switch: "ocaml-base-compiler.4.07.1" + new_coq_repository: "https://gitlab.com/coq/coq.git" + old_coq_repository: "https://gitlab.com/coq/coq.git" + new_coq_opam_archive_git_uri: "https://github.com/coq/opam-coq-archive.git" + old_coq_opam_archive_git_uri: "https://github.com/coq/opam-coq-archive.git" + new_coq_opam_archive_git_branch: "master" + old_coq_opam_archive_git_branch: "master" + num_of_iterations: 1 + coq_opam_packages: "coq-performance-tests-lite coq-engine-bench-lite coq-hott coq-bignums coq-mathcomp-ssreflect coq-mathcomp-fingroup coq-mathcomp-algebra coq-mathcomp-solvable coq-mathcomp-field coq-mathcomp-character coq-mathcomp-odd-order coq-math-classes coq-corn coq-flocq coq-compcert coq-geocoq coq-color coq-coqprime coq-coqutil coq-bedrock2 coq-rewriter coq-fiat-core coq-fiat-parsers coq-fiat-crypto coq-unimath coq-sf-plf coq-coquelicot coq-lambda-rust coq-verdi coq-verdi-raft coq-fourcolor coq-rewriter-perf-SuperFast" + artifacts: + name: "$CI_JOB_NAME" + paths: + - _bench/html/**/*.v.html + - _bench/logs + - _bench/files.listing + - _bench/opam.NEW/**/*.log + - _bench/opam.NEW/**/*.timing + - _bench/opam.OLD/**/*.log + - _bench/opam.OLD/**/*.timing + when: always + expire_in: 1 year diff --git a/dev/bench/gitlab.sh b/dev/bench/gitlab.sh new file mode 100755 index 0000000000..7625e4e7f7 --- /dev/null +++ b/dev/bench/gitlab.sh @@ -0,0 +1,497 @@ +#! /usr/bin/env bash + +# ASSUMPTIONS: +# - the OPAM packages, specified by the user, are topologically sorted wrt. to the dependency relationship. +# - all the variables below are set. + +set -e + +BENCH_DEBUG=1 + +r='\033[0m' # reset (all attributes off) +b='\033[1m' # bold +u='\033[4m' # underline +nl=$'\n' +bt='`' # backtick +start_code_block='```' +end_code_block='```' + +number_of_processors=$(cat /proc/cpuinfo | grep '^processor *' | wc -l) + +program_name="$0" +program_path=$(readlink -f "${program_name%/*}") + +coqbot_url_prefix="https://coqbot.herokuapp.com/pendulum/" + +# Check that the required arguments are provided + +check_variable () { + if [ ! -v "$1" ] + then + echo "Variable $1 should be set" + exit 1 + fi +} + +echo $PWD + +#check_variable "BUILD_ID" +#check_variable "BUILD_URL" +#check_variable "JOB_NAME" +#check_variable "JENKINS_URL" +check_variable "CI_JOB_URL" +check_variable "coq_pr_number" +check_variable "coq_pr_comment_id" +check_variable "new_ocaml_switch" +check_variable "new_coq_repository" +check_variable "new_coq_opam_archive_git_uri" +check_variable "new_coq_opam_archive_git_branch" +check_variable "old_ocaml_switch" +check_variable "old_coq_repository" +check_variable "old_coq_opam_archive_git_uri" +check_variable "old_coq_opam_archive_git_branch" +check_variable "num_of_iterations" +check_variable "coq_opam_packages" + +new_coq_commit=$(git rev-parse HEAD^2) +old_coq_commit=$(git merge-base HEAD^1 $new_coq_commit) + +if echo "$num_of_iterations" | grep '^[1-9][0-9]*$' 2> /dev/null > /dev/null; then + : +else + echo + echo "ERROR: num_of_iterations \"$num_of_iterations\" is not a positive integer." > /dev/stderr + print_man_page_hint + exit 1 +fi + +bench_dirname="_bench" +mkdir -p "${bench_dirname}" +working_dir="$PWD/${bench_dirname}" + +log_dir=$working_dir/logs +mkdir "$log_dir" + +if [ ! -z "$BENCH_DEBUG" ] +then + echo "DEBUG: ocaml -version = `ocaml -version`" + echo "DEBUG: working_dir = $working_dir" + echo "DEBUG: new_ocaml_switch = $new_ocaml_switch" + echo "DEBUG: new_coq_repository = $new_coq_repository" + echo "DEBUG: new_coq_commit = $new_coq_commit" + echo "DEBUG: new_coq_opam_archive_git_uri = $new_coq_opam_archive_git_uri" + echo "DEBUG: new_coq_opam_archive_git_branch = $new_coq_opam_archive_git_branch" + echo "DEBUG: old_ocaml_switch = $old_ocaml_switch" + echo "DEBUG: old_coq_repository = $old_coq_repository" + echo "DEBUG: old_coq_commit = $old_coq_commit" + echo "DEBUG: old_coq_opam_archive_git_uri = $old_coq_opam_archive_git_uri" + echo "DEBUG: old_coq_opam_archive_git_branch = $old_coq_opam_archive_git_branch" + echo "DEBUG: num_of_iterations = $num_of_iterations" + echo "DEBUG: coq_opam_packages = $coq_opam_packages" + echo "DEBUG: coq_pr_number = $coq_pr_number" + echo "DEBUG: coq_pr_comment_id = $coq_pr_comment_id" +fi + +# -------------------------------------------------------------------------------- + +# Some sanity checks of command-line arguments provided by the user that can be done right now. + +if which perf > /dev/null; then + echo -n +else + echo > /dev/stderr + echo "ERROR: \"perf\" program is not available." > /dev/stderr + echo > /dev/stderr + exit 1 +fi + +if which curl > /dev/null; then + : +else + echo > /dev/stderr + echo "ERROR: \"curl\" program is not available." > /dev/stderr + echo > /dev/stderr + exit 1 +fi + +if which du > /dev/null; then + : +else + echo > /dev/stderr + echo "ERROR: \"du\" program is not available." > /dev/stderr + echo > /dev/stderr + exit 1 +fi + +if [ ! -e "$working_dir" ]; then + echo > /dev/stderr + echo "ERROR: \"$working_dir\" does not exist." > /dev/stderr + echo > /dev/stderr + exit 1 +fi + +if [ ! -d "$working_dir" ]; then + echo > /dev/stderr + echo "ERROR: \"$working_dir\" is not a directory." > /dev/stderr + echo > /dev/stderr + exit 1 +fi + +if [ ! -w "$working_dir" ]; then + echo > /dev/stderr + echo "ERROR: \"$working_dir\" is not writable." > /dev/stderr + echo > /dev/stderr + exit 1 +fi + +coq_opam_packages_on_separate_lines=$(echo "$coq_opam_packages" | sed 's/ /\n/g') +if [ $(echo "$coq_opam_packages_on_separate_lines" | wc -l) != $(echo "$coq_opam_packages_on_separate_lines" | sort | uniq | wc -l) ]; then + echo "ERROR: The provided set of OPAM packages contains duplicates." + exit 1 +fi + +# -------------------------------------------------------------------------------- + +# Tell coqbot to update the initial comment, if we know which one to update +function coqbot_update_comment() { + is_done="$1" + comment_body="$2" + uninstallable_packages="$3" + + if [ ! -z "${coq_pr_number}" ]; then + comment_text="" + artifact_text="" + + if [ -z "${is_done}" ]; then + comment_text="in progress, " + artifact_text="eventually " + else + comment_text="" + artifact_text="" + fi + comment_text="Benchmarking ${comment_text}log available [here](${CI_JOB_URL}) ([raw log here](${CI_JOB_URL}/raw)), artifacts ${artifact_text}available for [download](${CI_JOB_URL}/artifacts/download) and [browsing](${CI_JOB_URL}/artifacts/browse)" + + if [ ! -z "${comment_body}" ]; then + comment_text="${comment_text}${nl}${start_code_block}${nl}${comment_body}${nl}${end_code_block}" + fi + + if [ ! -z "${uninstallable_packages}" ]; then + comment_text="${comment_text}${nl}The following packages failed to install: ${uninstallable_packages}" + fi + + comment_text="${comment_text}${nl}${nl}<details><summary>Old Coq version ${old_coq_commit}</summary>" + comment_text="${comment_text}${nl}${nl}${start_code_block}${nl}$(git log -n 1 "${old_coq_commit}")${nl}${end_code_block}${nl}</details>" + comment_text="${comment_text}${nl}${nl}<details><summary>New Coq version ${new_coq_commit}</summary>" + comment_text="${comment_text}${nl}${nl}${start_code_block}${nl}$(git log -n 1 "${new_coq_commit}")${nl}${end_code_block}${nl}</details>" + comment_text="${comment_text}${nl}${nl}[Diff: ${bt}${old_coq_commit}..${new_coq_commit}${bt}](https://github.com/coq/coq/compare/${old_coq_commit}..${new_coq_commit})" + + # if there's a comment id, we update the comment while we're + # in progress; otherwise, we wait until the end to post a new + # comment + if [ ! -z "${coq_pr_comment_id}" ]; then + # Tell coqbot to update the in-progress comment + curl -X POST --data-binary "${coq_pr_number}${nl}${coq_pr_comment_id}${nl}${comment_text}" "${coqbot_url_prefix}/update-comment" + elif [ ! -z "${is_done}" ]; then + # Tell coqbot to post a new comment that we're done benchmarking + curl -X POST --data-binary "${coq_pr_number}${nl}${comment_text}" "${coqbot_url_prefix}/new-comment" + fi + if [ ! -z "${is_done}" ]; then + # Tell coqbot to remove the `needs: benchmarking` label + curl -X POST --data-binary "${coq_pr_number}" "${coqbot_url_prefix}/benchmarking-done" + fi + fi +} + +# initial update to the comment, to say that we're in progress +coqbot_update_comment "" "" "" + +# -------------------------------------------------------------------------------- + +# Clone the indicated git-repository. + +coq_dir="$working_dir/coq" +git clone -q "$new_coq_repository" "$coq_dir" +cd "$coq_dir" +git remote rename origin new_coq_repository +git remote add old_coq_repository "$old_coq_repository" +git fetch -q "$old_coq_repository" +git checkout -q $new_coq_commit + +official_coq_branch=master +coq_opam_version=dev + +# -------------------------------------------------------------------------------- + +new_opam_root="$working_dir/opam.NEW" +old_opam_root="$working_dir/opam.OLD" + +# -------------------------------------------------------------------------------- + +old_coq_opam_archive_dir="$working_dir/old_coq_opam_archive" +git clone -q --depth 1 -b "$old_coq_opam_archive_git_branch" "$old_coq_opam_archive_git_uri" "$old_coq_opam_archive_dir" +new_coq_opam_archive_dir="$working_dir/new_coq_opam_archive" +git clone -q --depth 1 -b "$new_coq_opam_archive_git_branch" "$new_coq_opam_archive_git_uri" "$new_coq_opam_archive_dir" + +initial_opam_packages="num ocamlfind dune" + +# Create an opam root and install Coq +# $1 = root_name {ex: NEW / OLD} +# $2 = compiler name +# $3 = git hash of Coq to be installed +# $4 = directory of coq opam archive +create_opam() { + + local RUNNER="$1" + local OPAM_DIR="$working_dir/opam.$RUNNER" + local OPAM_COMP="$2" + local COQ_HASH="$3" + local OPAM_COQ_DIR="$4" + + export OPAMROOT="$OPAM_DIR" + + opam init --disable-sandboxing -qn -j$number_of_processors --bare + # Allow beta compiler switches + opam repo add -q --set-default beta https://github.com/ocaml/ocaml-beta-repository.git + # Allow experimental compiler switches + opam repo add -q --set-default ocaml-pr https://github.com/ejgallego/ocaml-pr-repository.git + # Rest of default switches + opam repo add -q --set-default iris-dev "https://gitlab.mpi-sws.org/FP/opam-dev.git" + + opam switch create -qy -j$number_of_processors "$OPAM_COMP" + eval $(opam env) + + # For some reason opam guesses an incorrect upper bound on the + # number of jobs available on Travis, so we set it here manually: + opam config set-global jobs $number_of_processors + if [ ! -z "$BENCH_DEBUG" ]; then opam config list; fi + + opam repo add -q --this-switch coq-extra-dev "$OPAM_COQ_DIR/extra-dev" + opam repo add -q --this-switch coq-released "$OPAM_COQ_DIR/released" + + opam install -qy -j$number_of_processors $initial_opam_packages + if [ ! -z "$BENCH_DEBUG" ]; then opam repo list; fi + + cd "$coq_dir" + if [ ! -z "$BENCH_DEBUG" ]; then echo "DEBUG: $1_coq_commit = $COQ_HASH"; fi + + git checkout -q $COQ_HASH + COQ_HASH_LONG=$(git log --pretty=%H | head -n 1) + + echo "$1_coq_commit_long = $COQ_HASH_LONG" + + _RES=0 + /usr/bin/time -o "$log_dir/coq.$RUNNER.1.time" --format="%U %M %F" \ + perf stat -e instructions:u,cycles:u -o "$log_dir/coq.$RUNNER.1.perf" \ + opam pin add -y -b -j "$number_of_processors" --kind=path coq.dev . \ + 3>$log_dir/coq.$RUNNER.opam_install.1.stdout 1>&3 \ + 4>$log_dir/coq.$RUNNER.opam_install.1.stderr 2>&4 || \ + _RES=$? + if [ $_RES = 0 ]; then + echo "Coq ($RUNNER) installed successfully" + else + echo "ERROR: \"opam install coq.$coq_opam_version\" has failed (for the $RUNNER commit = $COQ_HASH_LONG)." + exit 1 + fi + + # we don't multi compile coq for now (TODO some other time) + # the render needs all the files so copy them around + for it in $(seq 2 $num_of_iterations); do + cp "$log_dir/coq.$RUNNER.1.time" "$log_dir/coq.$RUNNER.$it.time" + cp "$log_dir/coq.$RUNNER.1.perf" "$log_dir/coq.$RUNNER.$it.perf" + done + +} + +# Create an OPAM-root to which we will install the NEW version of Coq. +create_opam "NEW" "$new_ocaml_switch" "$new_coq_commit" "$new_coq_opam_archive_dir" +new_coq_commit_long="$COQ_HASH_LONG" + +# Create an OPAM-root to which we will install the OLD version of Coq. +create_opam "OLD" "$old_ocaml_switch" "$old_coq_commit" "$old_coq_opam_archive_dir" +old_coq_commit_long="$COQ_HASH_LONG" +# -------------------------------------------------------------------------------- +# Measure the compilation times of the specified OPAM packages in both switches + +# Sort the opam packages +sorted_coq_opam_packages=$("${program_path}/sort-by-deps.sh" ${coq_opam_packages}) +if [ ! -z "$BENCH_DEBUG" ] +then + echo "DEBUG: sorted_coq_opam_packages = ${sorted_coq_opam_packages}" +fi + +# Generate per line timing info in devs that use coq_makefile +export TIMING=1 + +# The following variable will be set in the following cycle: +installable_coq_opam_packages=coq + +for coq_opam_package in $sorted_coq_opam_packages; do + + if [ ! -z "$BENCH_DEBUG" ]; then + opam list + echo "DEBUG: coq_opam_package = $coq_opam_package" + opam show $coq_opam_package || continue 2 + else + # cause to skip with error if unknown package + opam show $coq_opam_package >/dev/null || continue 2 + fi + + for RUNNER in NEW OLD; do + + # perform measurements for the NEW/OLD commit (provided by the user) + if [ $RUNNER = "NEW" ]; then + export OPAMROOT="$new_opam_root" + echo "Testing NEW commit: $(date)" + else + export OPAMROOT="$old_opam_root" + echo "Testing OLD commit: $(date)" + fi + + eval $(opam env) + + # If a given OPAM-package was already installed (as a + # dependency of some OPAM-package that we have benchmarked + # before), remove it. + opam uninstall -q $coq_opam_package + + # OPAM 2.0 likes to ignore the -j when it feels like :S so we + # workaround that here. + opam config set-global jobs $number_of_processors + + opam install $coq_opam_package -v -b -j$number_of_processors --deps-only -y \ + 3>$log_dir/$coq_opam_package.$RUNNER.opam_install.deps_only.stdout 1>&3 \ + 4>$log_dir/$coq_opam_package.$RUNNER.opam_install.deps_only.stderr 2>&4 || continue 2 + + opam config set-global jobs 1 + + if [ ! -z "$BENCH_DEBUG" ]; then ls -l $working_dir; fi + + for iteration in $(seq $num_of_iterations); do + _RES=0 + /usr/bin/time -o "$log_dir/$coq_opam_package.$RUNNER.$iteration.time" --format="%U %M %F" \ + perf stat -e instructions:u,cycles:u -o "$log_dir/$coq_opam_package.$RUNNER.$iteration.perf" \ + opam install -v -b -j1 $coq_opam_package \ + 3>$log_dir/$coq_opam_package.$RUNNER.opam_install.$iteration.stdout 1>&3 \ + 4>$log_dir/$coq_opam_package.$RUNNER.opam_install.$iteration.stderr 2>&4 || \ + _RES=$? + if [ $_RES = 0 ]; + then + echo $_RES > $log_dir/$coq_opam_package.$RUNNER.opam_install.$iteration.exit_status + # "opam install" was successful. + + # Remove the benchmarked OPAM-package, unless this is the + # very last iteration (we want to keep this OPAM-package + # because other OPAM-packages we will benchmark later + # might depend on it --- it would be a waste of time to + # remove it now just to install it later) + if [ $iteration != $num_of_iterations ]; then + opam uninstall -q $coq_opam_package + fi + else + # "opam install" failed. + echo $_RES > $log_dir/$coq_opam_package.$RUNNER.opam_install.$iteration.exit_status + continue 3 + fi + done + done + + installable_coq_opam_packages="$installable_coq_opam_packages $coq_opam_package" + + # -------------------------------------------------------------- + + # Print the intermediate results after we finish benchmarking each OPAM package + if [ "$coq_opam_package" = "$(echo $sorted_coq_opam_packages | sed 's/ /\n/g' | tail -n 1)" ]; then + + # It does not make sense to print the intermediate results when + # we finished bechmarking the very last OPAM package because the + # next thing will do is that we will print the final results. + # It would look lame to print the same table twice. + : + else + + echo "DEBUG: $program_path/render_results "$log_dir" $num_of_iterations $new_coq_commit_long $old_coq_commit_long 0 user_time_pdiff $installable_coq_opam_packages" + if [ ! -z "$BENCH_DEBUG" ]; then + cat $log_dir/$coq_opam_package.$RUNNER.1.time || true + cat $log_dir/$coq_opam_package.$RUNNER.1.perf || true + fi + rendered_results="$($program_path/render_results "$log_dir" $num_of_iterations $new_coq_commit_long $old_coq_commit_long 0 user_time_pdiff $installable_coq_opam_packages)" + echo "${rendered_results}" + # update the comment + coqbot_update_comment "" "${rendered_results}" "" + fi + + # Generate HTML report for LAST run + + # N.B. Not all packages end in .dev, e.g., coq-lambda-rust uses .dev.timestamp. + # So we use a wildcard to catch such packages. This will have to be updated if + # ever there is a package that uses some different naming scheme. + new_base_path=$new_ocaml_switch/.opam-switch/build/$coq_opam_package.dev*/ + old_base_path=$old_ocaml_switch/.opam-switch/build/$coq_opam_package.dev*/ + for vo in `cd $new_opam_root/$new_base_path/; find -name '*.vo'`; do + if [ -e $old_opam_root/$old_base_path/${vo%%o}.timing -a \ + -e $new_opam_root/$new_base_path/${vo%%o}.timing ]; then + mkdir -p $working_dir/html/$coq_opam_package/`dirname $vo`/ + $program_path/timelog2html $new_opam_root/$new_base_path/${vo%%o} \ + $old_opam_root/$old_base_path/${vo%%o}.timing \ + $new_opam_root/$new_base_path/${vo%%o}.timing > \ + $working_dir/html/$coq_opam_package/${vo%%o}.html + fi + done +done + +# Since we do not upload all files, store a list of the files +# available so that if we at some point want to tweak which files we +# upload, we'll know which ones are available for upload +du -ha "$working_dir" > "$working_dir/files.listing" + +# The following directories in $working_dir are no longer used: +# +# - coq, opam.OLD, opam.NEW + +# Measured data for each `$coq_opam_package`, `$iteration`, `status \in {NEW,OLD}`: +# +# - $working_dir/$coq_opam_package.$status.$iteration.time +# => output of /usr/bin/time --format="%U" ... +# +# - $working_dir/$coq_opam_package.NEW.$iteration.perf +# => output of perf stat -e instructions:u,cycles:u ... +# +# The next script processes all these files and prints results in a table. + +echo "INFO: workspace = ${CI_JOB_URL}/artifacts/browse/${bench_dirname}" + +# Print the final results. +if [ -z "$installable_coq_opam_packages" ]; then + # Tell the user that none of the OPAM-package(s) the user provided + # /are installable. + printf "\n\nINFO: failed to install: $sorted_coq_opam_packages" + coqbot_update_comment "done" "" "$sorted_coq_opam_packages" + exit 1 +else + echo "DEBUG: $program_path/render_results "$log_dir" $num_of_iterations $new_coq_commit_long $old_coq_commit_long 0 user_time_pdiff $installable_coq_opam_packages" + rendered_results="$($program_path/render_results "$log_dir" $num_of_iterations $new_coq_commit_long $old_coq_commit_long 0 user_time_pdiff $installable_coq_opam_packages)" + echo "${rendered_results}" + + echo "INFO: per line timing: ${CI_JOB_URL}/artifacts/browse/${bench_dirname}/html/" + + cd "$coq_dir" + echo INFO: Old Coq version + git log -n 1 "$old_coq_commit" + echo INFO: New Coq version + git log -n 1 "$new_coq_commit" + + not_installable_coq_opam_packages=`comm -23 <(echo $sorted_coq_opam_packages | sed 's/ /\n/g' | sort | uniq) <(echo $installable_coq_opam_packages | sed 's/ /\n/g' | sort | uniq) | sed 's/\t//g'` + + coqbot_update_comment "done" "${rendered_results}" "${not_installable_coq_opam_packages}" + + exit_code=0 + + if [ ! -z "$not_installable_coq_opam_packages" ]; then + # Tell the user that some of the provided OPAM-package(s) + # is/are not installable. + printf '\n\nINFO: failed to install %s\n' "$not_installable_coq_opam_packages" + exit_code=1 + fi + + exit 0 +fi diff --git a/dev/bench/render_results b/dev/bench/render_results new file mode 100755 index 0000000000..72affd70b2 --- /dev/null +++ b/dev/bench/render_results @@ -0,0 +1,434 @@ +#! /usr/bin/env ocaml + +(* ASSUMPTIONS: + - the 1-st command line argument (working directory): + - designates an existing readable directory + - which contains *.time and *.perf files produced by bench.sh script + - the 2-nd command line argument (number of iterations): + - is a positive integer + - the 3-rd command line argument (minimal user time): + - is a positive floating point number + - the 4-th command line argument determines the name of the column according to which the resulting table will be sorted. + Valid values are: + - package_name + - user_time_pdiff + - the rest of the command line-arguments + - are names of benchamarked Coq OPAM packages for which bench.sh script generated *.time and *.perf files + *) + +#use "topfind";; +#require "unix";; +#print_depth 100000000;; +#print_length 100000000;; + +open Printf +open Unix +;; + +let _ = Printexc.record_backtrace true +;; + +type ('a,'b) pkg_timings = { + user_time : 'a; + num_instr : 'b; + num_cycles : 'b; + num_mem : 'b; + num_faults : 'b; +} +;; + +let reduce_pkg_timings (m_f : 'a list -> 'c) (m_a : 'b list -> 'd) (t : ('a,'b) pkg_timings list) : ('c,'d) pkg_timings = + { user_time = m_f @@ List.map (fun x -> x.user_time) t + ; num_instr = m_a @@ List.map (fun x -> x.num_instr) t + ; num_cycles = m_a @@ List.map (fun x -> x.num_cycles) t + ; num_mem = m_a @@ List.map (fun x -> x.num_mem) t + ; num_faults = m_a @@ List.map (fun x -> x.num_faults) t + } +;; + +(******************************************************************************) +(* BEGIN Copied from batteries, to remove *) +(******************************************************************************) +let run_and_read cmd = + (* This code is before the open of BatInnerIO + to avoid using batteries' wrapped IOs *) + let string_of_file fn = + let buff_size = 1024 in + let buff = Buffer.create buff_size in + let ic = open_in fn in + let line_buff = Bytes.create buff_size in + begin + let was_read = ref (input ic line_buff 0 buff_size) in + while !was_read <> 0 do + Buffer.add_subbytes buff line_buff 0 !was_read; + was_read := input ic line_buff 0 buff_size; + done; + close_in ic; + end; + Buffer.contents buff + in + let tmp_fn = Filename.temp_file "" "" in + let cmd_to_run = cmd ^ " > " ^ tmp_fn in + let status = Unix.system cmd_to_run in + let output = string_of_file tmp_fn in + Unix.unlink tmp_fn; + (status, output) +;; + +let ( %> ) f g x = g (f x) +;; + +let run = run_and_read %> snd +;; + +module Float = struct + let nan = Pervasives.nan +end + +module Tuple4 = struct + + let first (x,_,_,_) = x + let second (_,y,_,_) = y + let third (_,_,z,_) = z + let fourth (_,_,_,z) = z + +end +;; + +module List = struct + include List + + let rec init_tailrec_aux acc i n f = + if i >= n then acc + else init_tailrec_aux (f i :: acc) (i+1) n f + + let rec init_aux i n f = + if i >= n then [] + else + let r = f i in + r :: init_aux (i+1) n f + + let rev_init_threshold = + match Sys.backend_type with + | Sys.Native | Sys.Bytecode -> 10_000 + (* We don't known the size of the stack, better be safe and assume it's small. *) + | Sys.Other _ -> 50 + + let init len f = + if len < 0 then invalid_arg "List.init" else + if len > rev_init_threshold then rev (init_tailrec_aux [] 0 len f) + else init_aux 0 len f + + let rec drop n = function + | _ :: l when n > 0 -> drop (n-1) l + | l -> l + + let reduce f = function + | [] -> + invalid_arg "List.reduce: Empty List" + | h :: t -> + fold_left f h t + + let min l = reduce Pervasives.min l + let max l = reduce Pervasives.max l + +end +;; + +module String = struct + + include String + + let rchop ?(n = 1) s = + if n < 0 then + invalid_arg "String.rchop: number of characters to chop is negative" + else + let slen = length s in + if slen <= n then "" else sub s 0 (slen - n) + +end +;; + +(******************************************************************************) +(* END Copied from batteries, to remove *) +(******************************************************************************) + +let mk_pkg_timings work_dir pkg_name suffix iteration = + let command_prefix = "cat " ^ work_dir ^ "/" ^ pkg_name ^ suffix ^ string_of_int iteration in + let time_command_output = command_prefix ^ ".time" |> run |> String.rchop ~n:1 |> String.split_on_char ' ' in + + let nth x i = List.nth i x in + + { user_time = time_command_output |> nth 0 |> float_of_string + (* Perf can indeed be not supported in some systems, so we must fail gracefully *) + ; num_instr = + (try command_prefix ^ ".perf | grep instructions:u | awk '{print $1}' | sed 's/,//g'" |> + run |> String.rchop ~n:1 |> int_of_string + with Failure _ -> 0) + ; num_cycles = + (try command_prefix ^ ".perf | grep cycles:u | awk '{print $1}' | sed 's/,//g'" |> + run |> String.rchop ~n:1 |> int_of_string + with Failure _ -> 0) + ; num_mem = time_command_output |> nth 1 |> int_of_string + ; num_faults = time_command_output |> nth 2 |> int_of_string + } +;; + +(* process command line paramters *) +assert (Array.length Sys.argv > 5); +let work_dir = Sys.argv.(1) in +let num_of_iterations = int_of_string Sys.argv.(2) in +let new_coq_version = Sys.argv.(3) in +let old_coq_version = Sys.argv.(4) in +let minimal_user_time = float_of_string Sys.argv.(5) in +let sorting_column = Sys.argv.(6) in +let coq_opam_packages = Sys.argv |> Array.to_list |> List.drop 7 in + +(* ASSUMPTIONS: + + "working_dir" contains all the files produced by the following command: + + two_points_on_the_same_branch.sh $working_directory $coq_repository $coq_branch[:$new:$old] $num_of_iterations coq_opam_package_1 coq_opam_package_2 ... coq_opam_package_N +-sf +*) + +(* Run a given bash command; + wait until it termines; + check if its exit status is 0; + return its whole stdout as a string. *) + +let proportional_difference_of_integers new_value old_value = + if old_value = 0 + then Float.nan + else float_of_int (new_value - old_value) /. float_of_int old_value *. 100.0 +in + +let count_number_of_digits_before_decimal_point = + log10 %> floor %> int_of_float %> succ %> max 1 +in + +(* parse the *.time and *.perf files *) +coq_opam_packages +|> List.map + (fun package_name -> + package_name,(* compilation_results_for_NEW : (float * int * int * int) list *) + List.init num_of_iterations succ |> List.map (mk_pkg_timings work_dir package_name ".NEW."), + List.init num_of_iterations succ |> List.map (mk_pkg_timings work_dir package_name ".OLD.")) + +(* from the list of measured values, select just the minimal ones *) + +|> List.map + (fun ((package_name : string), + (new_measurements : (float, int) pkg_timings list), + (old_measurements : (float, int) pkg_timings list)) -> + let f_min : float list -> float = List.min in + let i_min : int list -> int = List.min in + package_name, + reduce_pkg_timings f_min i_min new_measurements, + reduce_pkg_timings f_min i_min old_measurements + ) + +(* compute the "proportional differences in % of the NEW measurement and the OLD measurement" of all measured values *) +|> List.map + (fun (package_name, new_t, old_t) -> + package_name, new_t, old_t, + { user_time = (new_t.user_time -. old_t.user_time) /. old_t.user_time *. 100.0 + ; num_instr = proportional_difference_of_integers new_t.num_instr old_t.num_instr + ; num_cycles = proportional_difference_of_integers new_t.num_cycles old_t.num_cycles + ; num_mem = proportional_difference_of_integers new_t.num_mem old_t.num_mem + ; num_faults = proportional_difference_of_integers new_t.num_faults old_t.num_faults + }) + +(* sort the table with results *) +|> List.sort + (match sorting_column with + | "user_time_pdiff" -> + fun (_,_,_,perf1) (_,_,_,perf2) -> + compare perf1.user_time perf2.user_time + | "package_name" -> + fun (n1,_,_,_) (n2,_,_,_) -> compare n1 n2 + | _ -> + assert false + ) + +(* Keep only measurements that took at least "minimal_user_time" (in seconds). *) + +|> List.filter + (fun (_, new_t, old_t, _) -> + minimal_user_time <= new_t.user_time && minimal_user_time <= old_t.user_time) + +(* Below we take the measurements and format them to stdout. *) + +|> fun measurements -> + + let precision = 2 in + + (* the labels that we will print *) + let package_name__label = "package_name" in + let new__label = "NEW" in + let old__label = "OLD" in + let proportional_difference__label = "PDIFF" in + + (* the lengths of labels that we will print *) + let new__label__length = String.length new__label in + let proportional_difference__label__length = String.length proportional_difference__label in + + (* widths of individual columns of the table *) + let package_name__width = + max (measurements |> List.map (Tuple4.first %> String.length) |> List.max) + (String.length package_name__label) in + + let llf proj = + let lls = count_number_of_digits_before_decimal_point (List.max proj) + 1 + precision in + max lls new__label__length in + + let lli proj = + let lls = count_number_of_digits_before_decimal_point (float_of_int (List.(max proj))) + 1 + precision in + max lls new__label__length in + + let new_timing_width = reduce_pkg_timings llf lli @@ List.map Tuple4.second measurements in + let old_timing_width = reduce_pkg_timings llf lli @@ List.map Tuple4.third measurements in + + let llp proj = + let lls = + count_number_of_digits_before_decimal_point List.(max List.(map abs_float proj)) + 2 + precision in + max lls proportional_difference__label__length in + + let perc_timing_width = reduce_pkg_timings llp llp @@ List.map Tuple4.fourth measurements in + + (* print the table *) + let rec make_dashes = function + | 0 -> "" + | count -> "─" ^ make_dashes (pred count) + in + + let vertical_separator left_glyph middle_glyph right_glyph = + sprintf "%s─%s─%s─%s─%s─%s───%s─%s─%s─%s───%s─%s─%s─%s───%s─%s─%s─%s───%s─%s─%s─%s───%s\n" + left_glyph + (make_dashes package_name__width) + middle_glyph + (make_dashes new_timing_width.user_time) + (make_dashes old_timing_width.user_time) + (make_dashes perc_timing_width.user_time) + middle_glyph + (make_dashes new_timing_width.num_cycles) + (make_dashes old_timing_width.num_cycles) + (make_dashes perc_timing_width.num_cycles) + middle_glyph + (make_dashes new_timing_width.num_instr) + (make_dashes old_timing_width.num_instr) + (make_dashes perc_timing_width.num_instr) + middle_glyph + (make_dashes new_timing_width.num_mem) + (make_dashes old_timing_width.num_mem) + (make_dashes perc_timing_width.num_mem) + middle_glyph + (make_dashes new_timing_width.num_faults) + (make_dashes old_timing_width.num_faults) + (make_dashes perc_timing_width.num_faults) + right_glyph + in + + let center_string string width = + let string_length = String.length string in + let width = max width string_length in + let left_hfill = (width - string_length) / 2 in + let right_hfill = width - left_hfill - string_length in + String.make left_hfill ' ' ^ string ^ String.make right_hfill ' ' + in + printf "\n"; + print_string (vertical_separator "┌" "┬" "┐"); + "│" ^ String.make (1 + package_name__width + 1) ' ' ^ "│" + ^ center_string "user time [s]" (1 + new_timing_width.user_time + 1 + old_timing_width.user_time + 1 + perc_timing_width.user_time + 3) ^ "│" + ^ center_string "CPU cycles" (1 + new_timing_width.num_cycles + 1 + old_timing_width.num_cycles + 1 + perc_timing_width.num_cycles + 3) ^ "│" + ^ center_string "CPU instructions" (1 + new_timing_width.num_instr + 1 + old_timing_width.num_instr + 1 + perc_timing_width.num_instr + 3) ^ "│" + ^ center_string "max resident mem [KB]" (1 + new_timing_width.num_mem + 1 + old_timing_width.num_mem + 1 + perc_timing_width.num_mem + 3) ^ "│" + ^ center_string "mem faults" (1 + new_timing_width.num_faults + 1 + old_timing_width.num_faults + 1 + perc_timing_width.num_faults + 3) + ^ "│\n" |> print_string; + printf "│%*s │ %*s│ %*s│ %*s│ %*s│ %*s│\n" + (1 + package_name__width) "" + (new_timing_width.user_time + 1 + old_timing_width.user_time + 1 + perc_timing_width.user_time + 3) "" + (new_timing_width.num_cycles + 1 + old_timing_width.num_cycles + 1 + perc_timing_width.num_cycles + 3) "" + (new_timing_width.num_instr + 1 + old_timing_width.num_instr + 1 + perc_timing_width.num_instr + 3) "" + (new_timing_width.num_mem + 1 + old_timing_width.num_mem + 1 + perc_timing_width.num_mem + 3) "" + (new_timing_width.num_faults + 1 + old_timing_width.num_faults + 1 + perc_timing_width.num_faults + 3) ""; + printf "│ %*s │ %*s %*s %*s │ %*s %*s %*s │ %*s %*s %*s │ %*s %*s %*s │ %*s %*s %*s │\n" + package_name__width package_name__label + new_timing_width.user_time new__label + old_timing_width.user_time old__label + perc_timing_width.user_time proportional_difference__label + new_timing_width.num_cycles new__label + old_timing_width.num_cycles old__label + perc_timing_width.num_cycles proportional_difference__label + new_timing_width.num_instr new__label + old_timing_width.num_instr old__label + perc_timing_width.num_instr proportional_difference__label + new_timing_width.num_mem new__label + old_timing_width.num_mem old__label + perc_timing_width.num_mem proportional_difference__label + new_timing_width.num_faults new__label + old_timing_width.num_faults old__label + perc_timing_width.num_faults proportional_difference__label; + measurements |> List.iter + (fun (package_name, new_t, old_t, perc) -> + print_string (vertical_separator "├" "┼" "┤"); + printf "│ %*s │ %*.*f %*.*f %+*.*f %% │ %*d %*d %+*.*f %% │ %*d %*d %+*.*f %% │ %*d %*d %+*.*f %% │ %*d %*d %+*.*f %% │\n" + package_name__width package_name + new_timing_width.user_time precision new_t.user_time + old_timing_width.user_time precision old_t.user_time + perc_timing_width.user_time precision perc.user_time + new_timing_width.num_cycles new_t.num_cycles + old_timing_width.num_cycles old_t.num_cycles + perc_timing_width.num_cycles precision perc.num_cycles + new_timing_width.num_instr new_t.num_instr + old_timing_width.num_instr old_t.num_instr + perc_timing_width.num_instr precision perc.num_instr + new_timing_width.num_mem new_t.num_mem + old_timing_width.num_mem old_t.num_mem + perc_timing_width.num_mem precision perc.num_mem + new_timing_width.num_faults new_t.num_faults + old_timing_width.num_faults old_t.num_faults + perc_timing_width.num_faults precision perc.num_faults); + +print_string (vertical_separator "└" "┴" "┘"); + +(* ejgallego: disable this as it is very verbose and brings up little info in the log. *) +if false then begin +printf " + +PDIFF = proportional difference between measurements done for the NEW and the OLD Coq version + = (NEW_measurement - OLD_measurement) / OLD_measurement * 100%% + +NEW = %s +OLD = %s + +Columns: + + 1. user time [s] + + Total number of CPU-seconds that the process used directly (in user mode), in seconds. + (In other words, \"%%U\" quantity provided by the \"/usr/bin/time\" command.) + + 2. CPU cycles + + Total number of CPU-cycles that the process used directly (in user mode). + (In other words, \"cycles:u\" quantity provided by the \"/usr/bin/perf\" command.) + + 3. CPU instructions + + Total number of CPU-instructions that the process used directly (in user mode). + (In other words, \"instructions:u\" quantity provided by the \"/usr/bin/perf\" command.) + + 4. max resident mem [KB] + + Maximum resident set size of the process during its lifetime, in Kilobytes. + (In other words, \"%%M\" quantity provided by the \"/usr/bin/time\" command.) + + 5. mem faults + + Number of major, or I/O-requiring, page faults that occurred while the process was running. + These are faults where the page has actually migrated out of primary memory. + (In other words, \"%%F\" quantity provided by the \"/usr/bin/time\" command.) + +" new_coq_version old_coq_version; +end diff --git a/dev/bench/sort-by-deps b/dev/bench/sort-by-deps new file mode 100644 index 0000000000..e1da4e0ed5 --- /dev/null +++ b/dev/bench/sort-by-deps @@ -0,0 +1,33 @@ +#!/usr/bin/env ocaml + +let get_pkg_name arg = + List.nth (String.split_on_char ':' arg) 0 + +let get_pkg_deps arg = + String.split_on_char ',' (List.nth (String.split_on_char ':' arg) 1) + +let split_pkg arg = get_pkg_name arg, get_pkg_deps arg + +let depends_on arg1 arg2 = + let pkg1, deps1 = split_pkg arg1 in + let pkg2, deps2 = split_pkg arg2 in + pkg1 != pkg2 && List.mem pkg2 deps1 + +let rec sort = function + | [], [] -> [] + | [], deferred -> sort (List.rev deferred, []) + | arg :: rest, deferred -> + (* check if any remaining package reverse-depends on this one *) + if List.exists (fun other_arg -> depends_on arg other_arg) rest + then (* defer this package *) + sort (rest, arg :: deferred) + else (* emit this package, and then try again with any deferred packages *) + arg :: sort (List.rev deferred @ rest, []) + +let main () = + let args = Array.to_list Sys.argv in + let pkgs = List.tl args in + let sorted_pkgs = sort (pkgs, []) in + Printf.printf "%s\n%!" (String.concat " " (List.map get_pkg_name sorted_pkgs)) + +let () = main () diff --git a/dev/bench/sort-by-deps.sh b/dev/bench/sort-by-deps.sh new file mode 100755 index 0000000000..075976c17d --- /dev/null +++ b/dev/bench/sort-by-deps.sh @@ -0,0 +1,15 @@ +#!/usr/bin/env bash + +program_name="$0" +program_path=$(readlink -f "${program_name%/*}") + +# We add || true (which may not be needed without set -e) to be +# explicit about the fact that this script does not fail even if `opam +# install --show-actions` does, e.g., because of a non-existent +# package +# +# TODO: Figure out how to use the OPAM API +# (https://opam.ocaml.org/doc/api/) to call this from OCaml. +for i in "$@"; do + echo -n "$i:"; ((echo -n "$(opam install --show-actions "$i" | grep -o '∗\s*install\s*[^ ]*' | sed 's/∗\s*install\s*//g')" | tr '\n' ',') || true); echo +done | xargs ocaml "${program_path}/sort-by-deps" diff --git a/dev/bench/timelog2html b/dev/bench/timelog2html new file mode 100755 index 0000000000..abbeb5936d --- /dev/null +++ b/dev/bench/timelog2html @@ -0,0 +1,141 @@ +#!/usr/bin/env lua5.1 + +args = {...} + +vfile = assert(args[1], "arg1 missing: .v file") +table.remove(args,1) +assert(#args > 0, "arg missing: at lease one aux file") +data_files = args + +source = assert(io.open(vfile), "unable to open "..vfile):read("*a") + +function htmlescape(s) + return (s:gsub("&","&"):gsub("<","<"):gsub(">",">")) +end + +colors = { + '#F08080', '#EEE8AA', '#98FB98' +} + +assert(#data_files <= #colors, "only ".. #colors .." data files are supported") + +vname = vfile:match("([^/]+.v)$") + +print([[ +<html> +<head> +<title>]]..vname..[[</title> +<style>]]) +for i,k in ipairs(colors) do + print( + ".time" .. i .. " {".. + "background-color: " .. k .. ";".. + "height: ".. 100 / #data_files .."%;".. + "top: " .. 100 / #data_files * (i - 1) .. "%;".. + "z-index: -1; position: absolute; opacity: 50%; }") +end +print([[.code { + z-index: 0; + position: relative; + border-style: solid; + border-color: transparent; + border-width: 1px; +} +.code:hover { + border-color: black; +} +pre { + display: inline; +} +</style> +</head> +<body> +<h1>Timings for ]]..vname..[[</h1> +<ol> +]]) +for i,data_file in ipairs(data_files) do + print('<li style="background-color: '..colors[i]..'">' .. data_file .. "</li>") +end +print("</ol>") + +all_data = {} + +for _, data_file in ipairs(data_files) do + local data = {} + local last_end = -1 + local lines = 1 + for l in io.lines(data_file) do + local b,e,t = l:match('^Chars ([%d]+) %- ([%d]+) %S+ ([%d%.]+) secs') + if b then + if tonumber(b) > last_end + 1 then + local text = string.sub(source,last_end+1,b-1) + if not text:match('^%s+$') then + local _, n = text:gsub('\n','') + data[#data+1] = { + start = last_end+1; stop = b-1; time = 0; + text = text; lines = lines + } + lines = lines + n + last_end = b + end + end + local text = string.sub(source,last_end+1,e) + local _, n = text:gsub('\n','') + local _, eoln = text:match('^[%s\n]*'):gsub('\n','') + data[#data+1] = { + start = b; stop = e; time = tonumber(t); text = text; + lines = lines + } + lines = lines + n + last_end = tonumber(e) + end + end + if last_end + 1 <= string.len(source) then + local text = string.sub(source,last_end+1,string.len(source)) + data[#data+1] = { + start = last_end+1; stop = string.len(source); time = 0; + text = text; lines = lines+1 + } + end +all_data[#all_data+1] = data +end + +max = 0; +for _, data in ipairs(all_data) do + for _,d in ipairs(data) do + max = math.max(max,d.time) + end +end + +data = all_data[1] +for j,d in ipairs(data) do + print('<div class="code" title="File: '..vname.. + '\nLine: '..d.lines..'\n') + for k=1,#all_data do + print('Time'..k..': '..all_data[k][j].time..'s') + end + print('">') + for k=1,#all_data do + print('<div class="time'..k..'" style="width: '.. + all_data[k][j].time * 100 / max ..'%"></div>') + end + if d.text == '\n' then + print('<pre>\n\n</pre>') + elseif d.text:match('\n$') then + print('<pre>'..htmlescape(d.text)..'\n</pre>') + else + print('<pre>'..htmlescape(d.text)..'</pre>') + end + print("</div>") +end + +print [[ +</body> +</html> +]] + +-- vim: set ts=4: + +--for i = 1,#data do +-- io.stderr:write(data[i].text) +--end diff --git a/dev/build/windows/MakeCoq_MinGW.bat b/dev/build/windows/MakeCoq_MinGW.bat index 577ce35aae..8eff2cf577 100755 --- a/dev/build/windows/MakeCoq_MinGW.bat +++ b/dev/build/windows/MakeCoq_MinGW.bat @@ -55,7 +55,7 @@ IF DEFINED HTTP_PROXY ( )
REM see -cygrepo in ReadMe.txt
-SET CYGWIN_REPOSITORY=http://mirror.easyname.at/cygwin
+SET CYGWIN_REPOSITORY=https://mirrors.kernel.org/sourceware/cygwin
REM see -cygcache in ReadMe.txt
SET CYGWIN_LOCAL_CACHE_WFMT=%BATCHDIR%cygwin_cache
@@ -389,6 +389,7 @@ IF "%RUNSETUP%"=="Y" ( -P libfontconfig1 ^
-P gtk-update-icon-cache ^
-P libtool,automake ^
+ -P libgmp-devel ^
-P intltool ^
-P bison,flex ^
%EXTRAPACKAGES% ^
diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh index cc9fd13fdc..cde1d798a0 100755 --- a/dev/build/windows/makecoq_mingw.sh +++ b/dev/build/windows/makecoq_mingw.sh @@ -1006,6 +1006,7 @@ function make_ocaml_tools { function make_ocaml_libs { make_num + make_zarith make_findlib make_lablgtk } @@ -1023,6 +1024,16 @@ function make_num { fi } +function make_zarith { + make_ocaml + if build_prep https://github.com/ocaml/Zarith/archive release-1.9.1 tar.gz 1 zarith-1.9.1; then + logn configure ./configure + log1 make + log2 make install + build_post + fi +} + ##### OCAMLBUILD ##### function make_ocamlbuild { diff --git a/dev/ci/azure-opam.sh b/dev/ci/azure-opam.sh index 64936cd236..f2397cdcee 100755 --- a/dev/ci/azure-opam.sh +++ b/dev/ci/azure-opam.sh @@ -2,7 +2,7 @@ set -e -x -OPAM_VARIANT=ocaml-variants.4.10.0+mingw64c +OPAM_VARIANT=ocaml-variants.4.11.1+mingw64c 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 @@ -10,4 +10,4 @@ bash opam64/install.sh opam init default -a -y "https://github.com/fdopen/opam-repository-mingw.git#opam2" -c $OPAM_VARIANT --disable-sandboxing eval "$(opam env)" -opam install -y num ocamlfind dune ounit +opam install -y num ocamlfind dune ounit zarith diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 2725e6b56c..75d9efaadc 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -62,9 +62,17 @@ : "${iris_CI_GITURL:=https://gitlab.mpi-sws.org/iris/iris}" : "${iris_CI_ARCHIVEURL:=${iris_CI_GITURL}/-/archive}" -: "${lambda_rust_CI_REF:=master}" -: "${lambda_rust_CI_GITURL:=https://gitlab.mpi-sws.org/iris/lambda-rust}" -: "${lambda_rust_CI_ARCHIVEURL:=${lambda_rust_CI_GITURL}/-/archive}" +: "${autosubst_CI_REF:=coq86-devel}" +: "${autosubst_CI_GITURL:=https://github.com/RalfJung/autosubst}" +: "${autosubst_CI_ARCHIVEURL:=${autosubst_CI_GITURL}/archive}" + +: "${iris_string_ident_CI_REF:=master}" +: "${iris_string_ident_CI_GITURL:=https://gitlab.mpi-sws.org/iris/string-ident}" +: "${iris_string_ident_CI_ARCHIVEURL:=${iris_string_ident_CI_GITURL}/-/archive}" + +: "${iris_examples_CI_REF:=master}" +: "${iris_examples_CI_GITURL:=https://gitlab.mpi-sws.org/iris/examples}" +: "${iris_examples_CI_ARCHIVEURL:=${iris_examples_CI_GITURL}/-/archive}" ######################################################################## # HoTT diff --git a/dev/ci/ci-coqtail.sh b/dev/ci/ci-coqtail.sh index b8b5c6c724..ab538ecc07 100755 --- a/dev/ci/ci-coqtail.sh +++ b/dev/ci/ci-coqtail.sh @@ -5,4 +5,4 @@ ci_dir="$(dirname "$0")" git_download coqtail -( cd "${CI_BUILD_DIR}/coqtail" && PYTHONPATH=python python3 -m pytest tests/test_coqtop.py ) +( cd "${CI_BUILD_DIR}/coqtail" && PYTHONPATH=python python3 -m pytest tests/coq ) diff --git a/dev/ci/ci-iris.sh b/dev/ci/ci-iris.sh new file mode 100755 index 0000000000..0256906112 --- /dev/null +++ b/dev/ci/ci-iris.sh @@ -0,0 +1,36 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +. "${ci_dir}/ci-common.sh" + +# Setup iris_examples and separate dependencies first +git_download autosubst +git_download iris_string_ident +git_download iris_examples + +# Extract required version of Iris (avoiding "+" which does not work on MacOS :( *) +iris_CI_REF=$(grep -F '"coq-iris"' < "${CI_BUILD_DIR}/iris_examples/opam" | sed 's/.*"dev\.[0-9][0-9.-]*\.\([0-9a-z][0-9a-z]*\)".*/\1/') + +# Setup Iris +git_download iris + +# Extract required version of std++ +stdpp_CI_REF=$(grep -F '"coq-stdpp"' < "${CI_BUILD_DIR}/iris/opam" | sed 's/.*"dev\.[0-9][0-9.-]*\.\([0-9a-z][0-9a-z]*\)".*/\1/') + +# Setup std++ +git_download stdpp + +# Build std++ +( cd "${CI_BUILD_DIR}/stdpp" && make && make install ) + +# Build and validate Iris +( cd "${CI_BUILD_DIR}/iris" && make && make validate && make install ) + +# Build autosubst +( cd "${CI_BUILD_DIR}/autosubst" && make && make install ) + +# Build iris-string-ident +( cd "${CI_BUILD_DIR}/iris_string_ident" && make && make install ) + +# Build Iris examples +( cd "${CI_BUILD_DIR}/iris_examples" && make && make install ) diff --git a/dev/ci/ci-lambda_rust.sh b/dev/ci/ci-lambda_rust.sh deleted file mode 100755 index 1ef0c2cb8f..0000000000 --- a/dev/ci/ci-lambda_rust.sh +++ /dev/null @@ -1,30 +0,0 @@ -#!/usr/bin/env bash - -ci_dir="$(dirname "$0")" -. "${ci_dir}/ci-common.sh" - -install_ssreflect - -# Setup lambda_rust first -git_download lambda_rust - -# Extract required version of Iris (avoiding "+" which does not work on MacOS :( *) -iris_CI_REF=$(grep -F coq-iris < "${CI_BUILD_DIR}/lambda_rust/opam" | sed 's/.*"dev\.[0-9][0-9.-]*\.\([0-9a-z][0-9a-z]*\)".*/\1/') - -# Setup Iris -git_download iris - -# Extract required version of std++ -stdpp_CI_REF=$(grep -F coq-stdpp < "${CI_BUILD_DIR}/iris/opam" | sed 's/.*"dev\.[0-9][0-9.-]*\.\([0-9a-z][0-9a-z]*\)".*/\1/') - -# Setup std++ -git_download stdpp - -# Build std++ -( cd "${CI_BUILD_DIR}/stdpp" && make && make install ) - -# Build and validate Iris -( cd "${CI_BUILD_DIR}/iris" && make && make validate && make install ) - -# Build lambda_rust -( cd "${CI_BUILD_DIR}/lambda_rust" && make && make install ) diff --git a/dev/ci/ci-mathcomp.sh b/dev/ci/ci-mathcomp.sh index cae127ee7b..b1aa56ec4e 100755 --- a/dev/ci/ci-mathcomp.sh +++ b/dev/ci/ci-mathcomp.sh @@ -6,7 +6,7 @@ ci_dir="$(dirname "$0")" git_download mathcomp -( cd "${CI_BUILD_DIR}/mathcomp/mathcomp" && make && make install ) +( cd "${CI_BUILD_DIR}/mathcomp/mathcomp" && make && make test-suite && make install ) git_download fourcolor diff --git a/dev/ci/ci-metacoq.sh b/dev/ci/ci-metacoq.sh index 1302065961..27876d68de 100755 --- a/dev/ci/ci-metacoq.sh +++ b/dev/ci/ci-metacoq.sh @@ -5,4 +5,4 @@ ci_dir="$(dirname "$0")" git_download metacoq -( cd "${CI_BUILD_DIR}/metacoq" && ./configure.sh local && make ci-local && make install ) +( cd "${CI_BUILD_DIR}/metacoq" && ./configure.sh local && make .merlin && make ci-local && make install ) diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index 7570b17095..ee50d25318 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -1,4 +1,4 @@ -# CACHEKEY: "bionic_coq-V2020-07-21-V38" +# CACHEKEY: "bionic_coq-V2020-09-07-V22" # ^^ Update when modifying this file. FROM ubuntu:bionic @@ -6,9 +6,14 @@ LABEL maintainer="e@x80.org" ENV DEBIAN_FRONTEND="noninteractive" +# We need libgmp-dev:i386 for zarith; maybe we could also install GTK +RUN dpkg --add-architecture i386 + RUN apt-get update -qq && apt-get install --no-install-recommends -y -qq \ # Dependencies of the image, the test-suite and external projects m4 automake autoconf time wget rsync git gcc-multilib build-essential unzip jq \ + # Dependencies of ZArith + perl libgmp-dev libgmp-dev:i386 \ # Dependencies of lablgtk (for CoqIDE) libgtksourceview-3.0-dev \ # Dependencies of stdlib and sphinx doc @@ -35,10 +40,10 @@ ENV NJOBS="2" \ # Base opam is the set of base packages required by Coq ENV COMPILER="4.05.0" -# Common OPAM packages. -# `num` does not have a version number as the right version to install varies -# with the compiler version. -ENV BASE_OPAM="num ocamlfind.1.8.1 ounit.2.2.2 odoc.1.5.0" \ +# Common OPAM packages, num to be removed once the migration to +# micromega is complete, `num` also does not have a version number as +# the right version to install varies with the compiler version. +ENV BASE_OPAM="num zarith.1.9.1 ocamlfind.1.8.1 ounit2.2.2.3 odoc.1.5.1" \ CI_OPAM="menhir.20190626 ocamlgraph.1.8.8" \ BASE_ONLY_OPAM="elpi.1.11.0" @@ -52,13 +57,14 @@ ENV COQIDE_OPAM="cairo2.0.6.1 lablgtk3-sourceview3.3.1.0" RUN opam init -a --disable-sandboxing --compiler="$COMPILER" default https://opam.ocaml.org && eval $(opam env) && opam update && \ opam install $BASE_OPAM $COQIDE_OPAM $CI_OPAM $BASE_ONLY_OPAM -# base+32bit switch +# base+32bit switch, note the zarith hack RUN opam switch create "${COMPILER}+32bit" && eval $(opam env) && \ - opam install $BASE_OPAM + i386 env CC='gcc -m32' opam install zarith.1.9.1 && \ + opam install $BASE_OPAM # EDGE switch -ENV COMPILER_EDGE="4.10.0" \ - BASE_OPAM_EDGE="dune.2.5.1 dune-release.1.3.3 ocamlformat.0.14.2" +ENV COMPILER_EDGE="4.11.1" \ + BASE_OPAM_EDGE="dune.2.5.1 dune-release.1.3.3 ocamlformat.0.15.0" # EDGE+flambda switch, we install CI_OPAM as to be able to use # `ci-template-flambda` with everything. diff --git a/dev/ci/nix/default.nix b/dev/ci/nix/default.nix index 05624ff4a1..741cb89eed 100644 --- a/dev/ci/nix/default.nix +++ b/dev/ci/nix/default.nix @@ -114,6 +114,7 @@ let projects = { mtac2 = callPackage ./mtac2.nix {}; oddorder = callPackage ./oddorder.nix {}; quickchick = callPackage ./quickchick.nix {}; + simple-io = callPackage ./simple-io.nix {}; verdi-raft = callPackage ./verdi-raft.nix {}; VST = callPackage ./VST.nix {}; }; in diff --git a/dev/ci/nix/simple-io.nix b/dev/ci/nix/simple-io.nix new file mode 100644 index 0000000000..3b7b6c09b1 --- /dev/null +++ b/dev/ci/nix/simple-io.nix @@ -0,0 +1,5 @@ +{ ocamlPackages, ssreflect, coq-ext-lib, simple-io }: +{ + buildInputs = with ocamlPackages; [ ocaml findlib ocamlbuild num ]; + coqBuildInputs = [ ssreflect coq-ext-lib ]; +} diff --git a/dev/ci/user-overlays/08743-ejgallego-zarith.sh b/dev/ci/user-overlays/08743-ejgallego-zarith.sh new file mode 100644 index 0000000000..da1d30c1e9 --- /dev/null +++ b/dev/ci/user-overlays/08743-ejgallego-zarith.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "11742" ] || [ "$CI_BRANCH" = "zarith+core" ]; then + + bignums_CI_REF=zarith + bignums_CI_GITURL=https://github.com/ejgallego/bignums + +fi diff --git a/dev/ci/user-overlays/12565-ppedrot-fix-tc-search-opacity.sh b/dev/ci/user-overlays/12565-ppedrot-fix-tc-search-opacity.sh new file mode 100644 index 0000000000..7c04608403 --- /dev/null +++ b/dev/ci/user-overlays/12565-ppedrot-fix-tc-search-opacity.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "12565" ] || [ "$CI_BRANCH" = "fix-tc-search-opacity" ]; then + + coqhammer_CI_REF=fix-tc-search-opacity + coqhammer_CI_GITURL=https://github.com/ppedrot/coqhammer + +fi diff --git a/dev/ci/user-overlays/12709-ppedrot-hint-pattern-out.sh b/dev/ci/user-overlays/12709-ppedrot-hint-pattern-out.sh new file mode 100644 index 0000000000..56a69abbf7 --- /dev/null +++ b/dev/ci/user-overlays/12709-ppedrot-hint-pattern-out.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "12709" ] || [ "$CI_BRANCH" = "hint-pattern-out" ]; then + + coqhammer_CI_REF=hint-pattern-out + coqhammer_CI_GITURL=https://github.com/ppedrot/coqhammer + +fi diff --git a/dev/ci/user-overlays/12720-ppedrot-factor-class-hint-clenv.sh b/dev/ci/user-overlays/12720-ppedrot-factor-class-hint-clenv.sh new file mode 100644 index 0000000000..e57f95ef19 --- /dev/null +++ b/dev/ci/user-overlays/12720-ppedrot-factor-class-hint-clenv.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "12720" ] || [ "$CI_BRANCH" = "factor-class-hint-clenv" ]; then + + coqhammer_CI_REF=factor-class-hint-clenv + coqhammer_CI_GITURL=https://github.com/ppedrot/coqhammer + +fi diff --git a/dev/ci/user-overlays/12756-jashug-dont-refresh-argument-names.sh b/dev/ci/user-overlays/12756-jashug-dont-refresh-argument-names.sh new file mode 100644 index 0000000000..54fdd87566 --- /dev/null +++ b/dev/ci/user-overlays/12756-jashug-dont-refresh-argument-names.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "12756" ] || [ "$CI_BRANCH" = "dont-refresh-argument-names" ]; then + + mathcomp_CI_REF=dont-refresh-argument-names-overlay + mathcomp_CI_GITURL=https://github.com/jashug/math-comp + + oddorder_CI_REF=dont-refresh-argument-names-overlay + oddorder_CI_GITURL=https://github.com/jashug/odd-order + +fi diff --git a/dev/ci/user-overlays/12801-VincentSe-CyclicSet.sh b/dev/ci/user-overlays/12801-VincentSe-CyclicSet.sh new file mode 100644 index 0000000000..6a9cf78687 --- /dev/null +++ b/dev/ci/user-overlays/12801-VincentSe-CyclicSet.sh @@ -0,0 +1,8 @@ +if [ "$CI_PULL_REQUEST" = "12801" ] || [ "$CI_BRANCH" = "CyclicSet" ]; then + + bignums_CI_REF=CyclicSet + bignums_CI_GITURL=https://github.com/VincentSe/bignums + + coqprime_CI_REF=CyclicSet + coqprime_CI_GITURL=https://github.com/VincentSe/coqprime +fi diff --git a/dev/ci/user-overlays/12875-herbelin-master+about-print-all-arguments-names.sh b/dev/ci/user-overlays/12875-herbelin-master+about-print-all-arguments-names.sh new file mode 100644 index 0000000000..bb08c13ef3 --- /dev/null +++ b/dev/ci/user-overlays/12875-herbelin-master+about-print-all-arguments-names.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "12875" ] || [ "$CI_BRANCH" = "master+about-print-all-arguments-names" ]; then + + elpi_CI_REF=coq-master+adapt-coq12875-arguments-pass-name-impargs + elpi_CI_GITURL=https://github.com/herbelin/coq-elpi + +fi diff --git a/dev/ci/user-overlays/12892-SkySkimmer-update-s-univs.sh b/dev/ci/user-overlays/12892-SkySkimmer-update-s-univs.sh new file mode 100644 index 0000000000..f0878202d3 --- /dev/null +++ b/dev/ci/user-overlays/12892-SkySkimmer-update-s-univs.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "12892" ] || [ "$CI_BRANCH" = "update-s-univs" ]; then + + elpi_CI_REF=update-s-univs + elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi + + equations_CI_REF=update-s-univs + equations_CI_GITURL=https://github.com/SkySkimmer/Coq-Equations + +fi diff --git a/dev/ci/user-overlays/12968-maximedenes-delay-frozen-evarconv.sh b/dev/ci/user-overlays/12968-maximedenes-delay-frozen-evarconv.sh new file mode 100644 index 0000000000..ee75944a52 --- /dev/null +++ b/dev/ci/user-overlays/12968-maximedenes-delay-frozen-evarconv.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "12968" ] || [ "$CI_BRANCH" = "delay-frozen-evarconv" ]; then + + equations_CI_REF=delay-frozen-evarconv + equations_CI_GITURL=https://github.com/maximedenes/Coq-Equations + +fi diff --git a/dev/core.dbg b/dev/core.dbg index ec946e2df0..6d52bae773 100644 --- a/dev/core.dbg +++ b/dev/core.dbg @@ -1,5 +1,6 @@ load_printer threads.cma load_printer str.cma +load_printer zarith.cma load_printer config.cma load_printer clib.cma load_printer dynlink.cma diff --git a/dev/core_dune.dbg b/dev/core_dune.dbg index 4e1035f7b6..3f73cf126a 100644 --- a/dev/core_dune.dbg +++ b/dev/core_dune.dbg @@ -1,5 +1,6 @@ load_printer threads.cma load_printer str.cma +load_printer zarith.cma load_printer config.cma load_printer clib.cma load_printer dynlink.cma diff --git a/dev/doc/parsing.md b/dev/doc/parsing.md new file mode 100644 index 0000000000..f8b4537e77 --- /dev/null +++ b/dev/doc/parsing.md @@ -0,0 +1,397 @@ +# Parsing + +Coq's parser is based on Camlp5 using an extensible grammar. Somewhat helpful +Camlp5 documentation is available [here](http://camlp5.github.io/doc/htmlc/grammars.html). +However, the Camlp5 code has been copied into the Coq source tree and may differ +from the Camlp5 release. + +Notable attributes of the parser include: + +* The grammar is extensible at run time. This is essential for supporting notations + and optionally-loaded plugins that extend the grammar. + +* The grammar is split into multiple source files. Nonterminals can be local to a file + or global. + +* While 95% of the nonterminals and almost all the productions are defined in the grammar, + a few are defined directly in OCaml code. Since many developers have worked on the parser + over the years, this code can be idiosyncratic, reflecting various coding styles. + +* The parser is a recursive descent parser that, by default, only looks at the next token + to make a parsing decision. It's possible to hand-code additional lookahead where + necessary by writing OCaml code. + +* There's no code that checks whether a grammar is ambiguous or whether every production + can be recognized. Developers who modify the grammar may, in some cases, need to structure their + added productions in specific ways to ensure that their additions are parsable and that they + don't break existing productions. + +## Contents ## + +- [Grammars: `*.mlg` File Structure](#grammars-mlg-file-structure) +- [Grammars: Nonterminals and Productions](#grammars-nonterminals-and-productions) + - [Alternate production syntax](#alternate-production-syntax) +- [Usage notes](#usage-notes) + - [Other components](#other-components) + - [Parsing productions](#parsing-productions) + - [Lookahead](#lookahead) + +## Grammars: `*.mlg` File Structure ## + +Grammars are defined in `*.mlg` files, which `coqpp` compiles into `*.ml` files at build time. +`coqpp` code is in the `coqpp` directory. `coqpp` uses yacc and lex to parse the grammar files. +You can examine its yacc and lex input files in `coqpp_lex.mll` and `coqpp_parse.mly` for +details not fully covered here. + +In addition, there is a `doc_grammar` build utility that uses the `coqpp` parser to extract the +grammar, then edits and inserts it into the documentation. This is described in +[`doc/tools/docgram/README.md`](../../doc/tools/docgram/README.md). +`doc_grammar` generates +[`doc/tools/docgram/fullGrammar`](../../doc/tools/docgram/fullGrammar), +which has the full grammar for Coq +(not including some optionally-loaded plugins). This may be easier to read since everything is +in one file and the parser action routines and other OCaml code are omitted. + +`*.mlg` files contain the following types of nodes (See `node` in the yacc grammar). This part is +very specific to Coq (not so similar to Camlp5): + +* OCaml code - OCaml code enclosed in curly braces, which is copied verbatim to the generated `*.ml` file + +* Comments - comments in the `*.mlg` file in the form `(* … *)`, which are not copied + to the generated `*.ml` file. Comments in OCaml code are preserved. + +* `DECLARE_PLUGIN "*_plugin"` - associates the file with a specific plugin, for example "ltac_plugin" + +* `GRAMMAR EXTEND` - adds additional nonterminals and productions to the grammar and declares global + nonterminals referenced in the `GRAMMAR EXTEND`: + + ``` + GRAMMAR EXTEND Gram + GLOBAL: + bignat bigint …; + <nonterminal definitions> + END + ``` + + Global nonterminals are declared in `pcoq.ml`, e.g. `let bignat = Entry.create "Prim.bignat"`. + All the `*.mlg` files include `open Pcoq` and often its modules, e.g. `open Pcoq.Prim`. + + `GRAMMAR EXTEND` should be used only for large syntax additions. To add new commands + and tactics, use these instead: + + - `VERNAC COMMAND EXTEND` to add new commands + - `TACTIC EXTEND` to add new tactics + - `ARGUMENT EXTEND` to add new nonterminals + + These constructs provide essential semantic information that's provided in a more complex, + less readable way with `GRAMMAR EXTEND`. + +* `VERNAC COMMAND EXTEND` - adds new command syntax by adding productions to the + `command` nonterminal. For example: + + ``` + VERNAC COMMAND EXTEND ExtractionLibrary CLASSIFIED AS QUERY + | [ "Extraction" "Library" ident(m) ] + -> { extraction_library false m } + END + ``` + + Productions here are represented with alternate syntax, described later. + + New commands should be added using this construct rather than `GRAMMAR EXTEND` so + they are correctly registered, such as having the correct command classifier. + + TODO: explain "ExtractionLibrary", CLASSIFIED AS, CLASSIFIED BY, "{ tactic_mode }", STATE + +* `VERNAC { … } EXTEND` - TODO. A variant. The `{ … }` is a block of OCaml code. + +* `TACTIC EXTEND` - adds new tactic syntax by adding productions to `simple_tactic`. + For example: + + ``` + TACTIC EXTEND btauto + | [ "btauto" ] -> { Refl_btauto.Btauto.tac } + END + ``` + + adds a new nonterminal `btauto`. + + New tactics should be added using this construct rather than `GRAMMAR EXTEND`. + + TODO: explain DEPRECATED, LEVEL (not shown) + +* `ARGUMENT EXTEND` - defines a new nonterminal + + ``` + ARGUMENT EXTEND ast_closure_term + PRINTED BY { pp_ast_closure_term } + INTERPRETED BY { interp_ast_closure_term } + GLOBALIZED BY { glob_ast_closure_term } + SUBSTITUTED BY { subst_ast_closure_term } + RAW_PRINTED BY { pp_ast_closure_term } + GLOB_PRINTED BY { pp_ast_closure_term } + | [ term_annotation(a) constr(c) ] -> { mk_ast_closure_term a c } + END + ``` + + See comments in `tacentries.mli` for partial information on the various + arguments. + +* `VERNAC ARGUMENT EXTEND` - (part of `argument_extend` in the yacc grammar) defines + productions for a single nonterminal. For example: + + ``` + VERNAC ARGUMENT EXTEND language + PRINTED BY { pr_language } + | [ "Ocaml" ] -> { let _ = warn_deprecated_ocaml_spelling () in Ocaml } + | [ "OCaml" ] -> { Ocaml } + | [ "Haskell" ] -> { Haskell } + | [ "Scheme" ] -> { Scheme } + | [ "JSON" ] -> { JSON } + END + ``` + + TODO: explain PRINTED BY, CODE + +* DOC_GRAMMAR - Used in `doc_grammar`-generated files to permit simplified syntax + +Note that you can reverse engineer many details by comparing the `.mlg` input file with +the `.ml` generated by `coqpp`. + +## Grammars: Nonterminals and Productions + +Here's a simple nonterminal definition in the Camlp5 format: + + ``` + universe: + [ [ IDENT "max"; "("; ids = LIST1 universe_expr SEP ","; ")" -> { ids } + | u = universe_expr -> { [u] } ] ] + ; + ``` + +In which: +* `universe` is the nonterminal being defined +* productions are separated by `|` and, as a group, are enclosed in `[ [ … ] ];` +* `u = universe_expr` refers to the `universe_expr` nonterminal. `u` is bound to + the value returned by that nonterminal's action routine, which can be + referred to in the action routine. For `ids = LIST1 universe_expr SEP ","`, + `ids` is bound to the list of values returned by `universe_expr`. +* `-> { … }` contains the OCaml action routine, which is executed when the production is recognized + and returns a value +* Semicolons separate adjacent grammatical elements (nonterminals, strings or other constructs) + +Grammatical elements that appear in productions are: + +- nonterminal names - identifiers in the form `[a-zA-Z0-9_]*`. These correspond to variables in + the generated `.ml` code. In some cases a qualified name, such as `Prim.name`, is used. +- `"…"` - a literal string that becomes a keyword and cannot be used as an `ident`. + The string doesn't have to be a valid identifier; frequently the string will contain only + punctuation characters. Generally we try to avoid adding new keywords that are also valid + identifiers--though there is an unresolved debate among the developers about whether having more + such keywords in general is good (e.g. it makes it easier to highlight keywords in GUIs) + or bad (more keywords for the user to avoid and new keywords may require changes to existing + proof files). +- `IDENT "…"` - a literal string that has the form of an `ident` that doesn't become + a keyword +- `OPT element` - optionally include `element` (e.g. a nonterminal, IDENT "…" or "…"). + The value is of type `'a option`. +- `LIST1 element` - a list of one or more `element`s. The value is of type `'a list`. +- `LIST0 element` - an optional list of `element`s +- `LIST1 element SEP sep` - a list of `element`s separated by `sep` +- `LIST0 element SEP sep` - an optional list of `element`s separated by `sep` +- `( elements )` - grouping to represent a series of elements as a unit, + useful within `OPT` and `LIST*`. +- `[ elements1 | elements2 | … ]` - alternatives (either `elements1` or `elements2` or …), + actually nested productions, each of which can have its own action routines + +Nonterminals can also be defined with multiple levels to specify precedence and associativity +of its productions. This is described in the Coq documentation under the `Print Grammar` +command. The first square bracket around a nonterminal definition is for grouping +level definitions, which are separated with `|`, for example: + + ``` + tactic_expr: + [ "5" RIGHTA + [ te = binder_tactic -> { te } ] + | "4" LEFTA + : + ``` + +Grammar extensions can specify what level they are modifying, for example: + + ``` + tactic_expr: LEVEL "1" [ RIGHTA + [ tac = tactic_expr; intros = ssrintros_ne -> { tclintros_expr ~loc tac intros } + ] ]; + ``` + +### Alternate production syntax ### + +Except for `GRAMMAR EXTEND`, the `EXTEND` nodes in the `*.mlg`s use simplified syntax in +productions that's similar to what's used in the `Tactic Notation` and +`Ltac2 Notation` commands. For example: + + ``` + TACTIC EXTEND cc + | [ "congruence" ] -> { congruence_tac 1000 [] } + | [ "congruence" integer(n) ] -> { congruence_tac n [] } + | [ "congruence" "with" ne_constr_list(l) ] -> { congruence_tac 1000 l } + | [ "congruence" integer(n) "with" ne_constr_list(l) ] -> + { congruence_tac n l } + END + ``` + +Nonterminals appearing in the alternate production syntax are accessed through `wit_*` symbols +defined in the OCaml code. Some commonly used symbols are defined in `stdarg.ml`. +Others are defined in the code generated by `ARGUMENT EXTEND` and `VERNAC ARGUMENT EXTEND` +constructs. References to nonterminals that don't have `wit_*` symbols cause +compilation errors. + +The differences are: +* The outer `: [ … ];` is omitted. Each production is enclosed in `| [ … ]`. +* The action routine is outside the square brackets +* Literal strings that are valid identifiers don't become reserved keywords +* No semicolons separating elements of the production +* `integer(n)` is used to bind a nonterminal value to a variable instead of `n = integer` +* Alternate forms of constructs are used: + * `ne_entry_list` for `LIST1 entry` + * `entry_list` for `LIST0 entry` + * `ne_entry_list_sep(var, sep)` for `LIST1 entry SEP sep` where the list is bound to `var` + * `entry_list_sep(var, sep)` for `LIST0 entry SEP sep` where the list is bound to `var` + * `entry_opt` for OPT entry +* There's no way to define `LEVEL`s +* There's no equivalent to `( elements )` or `[ elements1 | elements2 | … ]`, which may + require repeating similar syntax several times. For example, this single production + is equivalent to 8 productions in `TACTIC EXTEND` representing all possible expansions of + three `OPT`s: + + ``` + | IDENT "Add"; IDENT "Parametric"; IDENT "Relation"; LIST0 binder; ":"; constr; constr; + OPT [ IDENT "reflexivity"; IDENT "proved"; IDENT "by"; constr -> { … } ]; + OPT [ IDENT "symmetry"; IDENT "proved"; IDENT "by"; constr -> { … } ]; + OPT [ IDENT "transitivity"; IDENT "proved"; IDENT "by"; constr -> { … } ]; + IDENT "as"; ident -> { … } + ``` + +## Usage notes + +### Other components + +Coq's lexer is in `clexer.ml`. Its 10 token types are defined in `tok.ml`. + +The parser is in `grammar.ml`. The extensive use of GADT (generalized algebraic datatypes) +makes it harder for the uninitiated to understand it. + +When the parser is invoked, the call tells the parser which nonterminal to parse. `vernac_control` +is the start symbol for commands. `tactic_mode` is the start symbol for tactics. +Tactics give syntax errors if Coq is not in proof mode. There are additional details +not mentioned here. + +### Parsing productions + +Some thoughts, not to be taken as identifying all the issues: + +Since the parser examines only the next token to make a parsing decision (and perhaps +because of other potentially fixable limitations), some productions have to be ordered +or structured in a particular way to parse correctly in all cases. + +For example, consider these productions: + + ``` + command: [ [ + | IDENT "Print"; p = printable -> { VernacPrint p } + | IDENT "Print"; qid = smart_global; l = OPT univ_name_list -> { VernacPrint (PrintName (qid,l)) } + | IDENT "Print"; IDENT "Module"; "Type"; qid = global -> + { VernacPrint (PrintModuleType qid) } + | IDENT "Print"; IDENT "Module"; qid = global -> + { VernacPrint (PrintModule qid) } + | IDENT "Print"; IDENT "Namespace" ; ns = dirpath -> + { VernacPrint (PrintNamespace ns) } + : + + printable: + [ [ IDENT "Term"; qid = smart_global; l = OPT univ_name_list -> { PrintName (qid,l) } + | IDENT "All" -> { PrintFullContext } + | IDENT "Section"; s = global -> { PrintSectionContext s } + : + ``` + +Reversing the order of the first two productions in `command` causes the `All` in `Print All` to +be parsed incorrectly as a `smart_global`, making that command unavailable. `Print Namespace nat.` +still works correctly, though. + +Similarly, the production for `Print Module Type` has to appear before `Print Module <global>` +in order to be reachable. + +Internally, the parser generates a tree that represents the possible prefixes for the +productions of a nonterminal as described in +[the Camlp5 documentation](http://camlp5.github.io/doc/htmlc/grammars.html#b:Rules-insertion). + +Here's another example in which the way the productions are written matters. `OPT` at +the beginning of a production doesn't always work well: + + ``` + command: [ [ + | IDENT "Foo"; n = natural -> { VernacBack 1 } + | OPT (IDENT "ZZ"); IDENT "Foo" -> { VernacBack 1 } + : + ``` + +`Foo.` looks like it should be accepted, but it gives a parse error: + + ``` + Unnamed_thm < Foo. + Toplevel input, characters 3-4: + > Foo. + > ^ + Error: + Syntax error: [prim:natural] expected after 'Foo' (in [vernac:command]). + ``` + +Reversing the order of the productions doesn't help, but splitting +the 'OPT' production into 2 productions works: + + ``` + | IDENT "Foo" -> { VernacBack 1 } + | IDENT "ZZ"; IDENT "Foo" -> { VernacBack 1 } + | IDENT "Foo"; n = natural -> { VernacBack 1 } + + ``` + +On the other hand, `OPT` works just fine when the parser has already found the +right production. For example `Back` and `Back <natural>` can be combined using +an `OPT`: + + ``` + | IDENT "Back"; n = OPT natural -> { VernacBack (Option.default 1 n) } + ``` + +### Lookahead + +It's possible to look ahead more than one symbol using OCaml code. Generally we +avoid doing this unless there's a strong reason to do so. For example, this +code defines a new nonterminal `local_test_lpar_id_colon` that checks that +the next 3 tokens are `"("` `ident` and `":"` without consuming any input: + + ``` + let local_test_lpar_id_colon = + let open Pcoq.Lookahead in + to_entry "lpar_id_colon" begin + lk_kw "(" >> lk_ident >> lk_kw ":" + end + ``` + +This one checks that the next 2 tokens are `"["` and `"|"` with no space between. +This is a special case: intropatterns can have sequences like `"[|]"` that are +3 different tokens with empty nonterminals between them. Making `"[|"` a keyword +would break existing code with "[|]": + + ``` + let test_array_opening = + let open Pcoq.Lookahead in + to_entry "test_array_opening" begin + lk_kw "[" >> lk_kw "|" >> check_no_space + end + ``` + +TODO: how to add a tactic or command diff --git a/dev/dune-workspace.all b/dev/dune-workspace.all index d6348a3624..679b3d1f79 100644 --- a/dev/dune-workspace.all +++ b/dev/dune-workspace.all @@ -3,5 +3,5 @@ ; Add custom flags here. Default developer profile is `dev` (context (opam (switch 4.05.0))) (context (opam (switch 4.05.0+32bit))) -(context (opam (switch 4.10.0))) -(context (opam (switch 4.10.0+flambda))) +(context (opam (switch 4.11.1))) +(context (opam (switch 4.11.1+flambda))) diff --git a/dev/dune_db_408 b/dev/dune_db_408 index 3bf13da62d..5f826fe383 100644 --- a/dev/dune_db_408 +++ b/dev/dune_db_408 @@ -1,5 +1,6 @@ load_printer threads.cma load_printer str.cma +load_printer zarith.cma load_printer config.cma load_printer clib.cma load_printer dynlink.cma diff --git a/dev/dune_db_409 b/dev/dune_db_409 index 1267fd5393..2e58272c75 100644 --- a/dev/dune_db_409 +++ b/dev/dune_db_409 @@ -1,5 +1,6 @@ load_printer threads.cma load_printer str.cma +load_printer zarith.cma load_printer config.cma load_printer clib.cma load_printer lib.cma diff --git a/dev/nixpkgs.nix b/dev/nixpkgs.nix index bfb25e72dd..e798645ed0 100644 --- a/dev/nixpkgs.nix +++ b/dev/nixpkgs.nix @@ -1,4 +1,4 @@ import (fetchTarball { - url = "https://github.com/NixOS/nixpkgs/archive/17812e653d89c46d68b7b10e290b1c16758f4e47.tar.gz"; - sha256 = "1zcb70dyfqc8l2ywpbvxmpfshapdi0g365m3rhmwpagqg47pnyxs"; + url = "https://github.com/NixOS/nixpkgs/archive/3c0e3697520cbe7d9eb3a64bfd87de840bf4aa77.tar.gz"; + sha256 = "1vx7kyaq0i287dragjgfdj94ggwr3ky2b7bq32l8rkd2k3vc3gl5"; }) diff --git a/dev/ocamldebug-coq.run b/dev/ocamldebug-coq.run index a11269e059..91cb6168e1 100644 --- a/dev/ocamldebug-coq.run +++ b/dev/ocamldebug-coq.run @@ -34,4 +34,5 @@ exec $OCAMLDEBUG \ -I $COQTOP/plugins/subtac -I $COQTOP/plugins/syntax \ -I $COQTOP/plugins/xml -I $COQTOP/plugins/ltac \ -I $COQTOP/ide \ + $(ocamlfind query -recursive -i-format zarith) \ "$@" diff --git a/dev/top_printers.dbg b/dev/top_printers.dbg index 63071bba72..60618f6491 100644 --- a/dev/top_printers.dbg +++ b/dev/top_printers.dbg @@ -23,7 +23,6 @@ install_printer Top_printers.ppconstr_expr install_printer Top_printers.ppglob_constr install_printer Top_printers.pppattern install_printer Top_printers.ppfconstr -install_printer Top_printers.ppbigint install_printer Top_printers.ppnumtokunsigned install_printer Top_printers.ppnumtokunsignednat install_printer Top_printers.ppintset diff --git a/dev/top_printers.ml b/dev/top_printers.ml index ea90e83a83..773170207e 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -80,7 +80,6 @@ let pppattern = (fun x -> pp(envpp pr_constr_pattern_env x)) let pptype = (fun x -> try pp(envpp (fun env evm t -> pr_ltype_env env evm t) x) with e -> pp (str (Printexc.to_string e))) let ppfconstr c = ppconstr (CClosure.term_of_fconstr c) -let ppbigint n = pp (str (Bigint.to_string n));; let ppnumtokunsigned n = pp (NumTok.Unsigned.print n) let ppnumtokunsignednat n = pp (NumTok.UnsignedNat.print n) diff --git a/dev/top_printers.mli b/dev/top_printers.mli index 65eab8daa3..b1bb5e4702 100644 --- a/dev/top_printers.mli +++ b/dev/top_printers.mli @@ -53,7 +53,6 @@ val ppglob_constr : 'a Glob_term.glob_constr_g -> unit val pppattern : Pattern.constr_pattern -> unit val ppfconstr : CClosure.fconstr -> unit -val ppbigint : Bigint.bigint -> unit val ppnumtokunsigned : NumTok.Unsigned.t -> unit val ppnumtokunsignednat : NumTok.UnsignedNat.t -> unit diff --git a/dev/vm_printers.ml b/dev/vm_printers.ml index ac4972ed0d..1eacfa0fd6 100644 --- a/dev/vm_printers.ml +++ b/dev/vm_printers.ml @@ -1,7 +1,7 @@ open Format open Term open Names -open Cemitcodes +open Vmemitcodes open Vmvalues let ppripos (ri,pos) = diff --git a/doc/README.md b/doc/README.md index 99d285320d..79d1e1b756 100644 --- a/doc/README.md +++ b/doc/README.md @@ -28,10 +28,9 @@ Dependencies To produce the complete documentation in HTML, you will need Coq dependencies listed in [`INSTALL.md`](../INSTALL.md). Additionally, the Sphinx-based -reference manual requires Python 3, and the following Python packages -(note the version constraints on Sphinx): +reference manual requires Python 3, and the following Python packages: - - sphinx >= 2.3.1 & < 3.0.0 + - sphinx >= 2.3.1 - sphinx_rtd_theme >= 0.4.3 - beautifulsoup4 >= 4.0.6 - antlr4-python3-runtime >= 4.7.1 @@ -41,7 +40,7 @@ reference manual requires Python 3, and the following Python packages To install them, you should first install pip and setuptools (for instance, with `apt install python3-pip python3-setuptools` on Debian / Ubuntu) then run: - pip3 install sphinx==2.3.1 sphinx_rtd_theme beautifulsoup4 \ + pip3 install sphinx sphinx_rtd_theme beautifulsoup4 \ antlr4-python3-runtime==4.7.1 pexpect sphinxcontrib-bibtex Nix users should get the correct development environment to build the diff --git a/doc/changelog/01-kernel/12738-fix-sr-cumul-inds.rst b/doc/changelog/01-kernel/12738-fix-sr-cumul-inds.rst new file mode 100644 index 0000000000..1bf62de3fd --- /dev/null +++ b/doc/changelog/01-kernel/12738-fix-sr-cumul-inds.rst @@ -0,0 +1,5 @@ +- **Fixed:** Incompleteness of conversion checking on problems + involving :ref:`eta-expansion` and :ref:`cumulative universe + polymorphic inductive types <cumulative>` (`#12738 + <https://github.com/coq/coq/pull/12738>`_, fixes `#7015 + <https://github.com/coq/coq/issues/7015>`_, by Gaëtan Gilbert). diff --git a/doc/changelog/02-specification-language/07825-rechable-from-evars.rst b/doc/changelog/02-specification-language/07825-rechable-from-evars.rst new file mode 100644 index 0000000000..e57d5a7bc5 --- /dev/null +++ b/doc/changelog/02-specification-language/07825-rechable-from-evars.rst @@ -0,0 +1,9 @@ +- **Changed:** + In :tacn:`refine`, new existential variables unified with existing ones are no + longer considered as fresh. The behavior of :tacn:`simple refine` no longer depends on + the orientation of evar-evar unification problems, and new existential variables + are always turned into (unshelved) goals. This can break compatibility in + some cases (`#7825 <https://github.com/coq/coq/pull/7825>`_, by Matthieu + Sozeau, with help from Maxime Dénès, review by Pierre-Marie Pédrot and + Enrico Tassi, fixes `#4095 <https://github.com/coq/coq/issues/4095>`_ and + `#4413 <https://github.com/coq/coq/issues/4413>`_). diff --git a/doc/changelog/02-specification-language/12756-dont-refresh-argument-names.rst b/doc/changelog/02-specification-language/12756-dont-refresh-argument-names.rst new file mode 100644 index 0000000000..b0cf4ca4e3 --- /dev/null +++ b/doc/changelog/02-specification-language/12756-dont-refresh-argument-names.rst @@ -0,0 +1,9 @@ +- **Changed:** + Tweaked the algorithm giving default names to arguments. + Should reduce the frequency that argument names get an + unexpected suffix. + Also makes :flag:`Mangle Names` not mess up argument names. + (`#12756 <https://github.com/coq/coq/pull/12756>`_, + fixes `#12001 <https://github.com/coq/coq/issues/12001>`_ + and `#6785 <https://github.com/coq/coq/issues/6785>`_, + by Jasper Hugunin). diff --git a/doc/changelog/03-notations/12979-doc-numbers.rst b/doc/changelog/03-notations/12979-doc-numbers.rst new file mode 100644 index 0000000000..631bd6ec69 --- /dev/null +++ b/doc/changelog/03-notations/12979-doc-numbers.rst @@ -0,0 +1,4 @@ +- **Deprecated:** + :n:`Numeral Notation`, please use :ref:`Number Notation <number-notations>` instead. + (`#12979 <https://github.com/coq/coq/pull/12979>`_, + by Pierre Roux). diff --git a/doc/changelog/04-tactics/12816-master+fix12787-K-redex-injection-anomaly.rst b/doc/changelog/04-tactics/12816-master+fix12787-K-redex-injection-anomaly.rst new file mode 100644 index 0000000000..289d17167d --- /dev/null +++ b/doc/changelog/04-tactics/12816-master+fix12787-K-redex-injection-anomaly.rst @@ -0,0 +1,6 @@ +- **Fixed:** + Anomaly with :tacn:`injection` involving artificial + dependencies disappearing by reduction + (`#12816 <https://github.com/coq/coq/pull/12816>`_, + fixes `#12787 <https://github.com/coq/coq/issues/12787>`_, + by Hugo Herbelin). diff --git a/doc/changelog/04-tactics/12993-remove-cutrewrite.rst b/doc/changelog/04-tactics/12993-remove-cutrewrite.rst new file mode 100644 index 0000000000..b719c5618e --- /dev/null +++ b/doc/changelog/04-tactics/12993-remove-cutrewrite.rst @@ -0,0 +1,4 @@ +- **Removed:** + Deprecated ``cutrewrite`` tactic. Use :tacn:`replace` instead + (`#12993 <https://github.com/coq/coq/pull/12993>`_, + by Théo Zimmermann). diff --git a/doc/changelog/06-ssreflect/12857-changelog-for-12857.rst b/doc/changelog/06-ssreflect/12857-changelog-for-12857.rst new file mode 100644 index 0000000000..4350fd0238 --- /dev/null +++ b/doc/changelog/06-ssreflect/12857-changelog-for-12857.rst @@ -0,0 +1,8 @@ +- **Fixed:** + Regression in error reporting after :tacn:`case <case (ssreflect)>`. + A generic error message "Could not fill dependent hole in apply" was + reported for any error following :tacn:`case <case (ssreflect)>` or + :tacn:`elim <elim (ssreflect)>` + (`#12857 <https://github.com/coq/coq/pull/12857>`_, + fixes `#12837 <https://github.com/coq/coq/issues/12837>`_, + by Enrico Tassi). diff --git a/doc/changelog/08-tools/12772-fix-details.rst b/doc/changelog/08-tools/12772-fix-details.rst new file mode 100644 index 0000000000..67ee061285 --- /dev/null +++ b/doc/changelog/08-tools/12772-fix-details.rst @@ -0,0 +1,5 @@ +- **Fixed:** + The `details` environment added in the 8.12 release can now be used + as advertised in the reference manual + (`#12772 <https://github.com/coq/coq/pull/12772>`_, + by Thomas Letan). diff --git a/doc/changelog/08-tools/12862-more-mod-checking.rst b/doc/changelog/08-tools/12862-more-mod-checking.rst new file mode 100644 index 0000000000..bb1bf9e789 --- /dev/null +++ b/doc/changelog/08-tools/12862-more-mod-checking.rst @@ -0,0 +1,4 @@ +- **Fixed:** + ``coqchk`` no longer reports names from inner modules of opaque modules as + axioms (`#12862 <https://github.com/coq/coq/pull/12862>`_, fixes `#12845 + <https://github.com/coq/coq/issues/12845>`_, by Jason Gross). diff --git a/doc/changelog/10-standard-library/12094-app_inj_tail.rst b/doc/changelog/10-standard-library/12094-app_inj_tail.rst new file mode 100644 index 0000000000..702fbb3d64 --- /dev/null +++ b/doc/changelog/10-standard-library/12094-app_inj_tail.rst @@ -0,0 +1,5 @@ +- **Added:** + Extend some list lemmas to both directions: `app_inj_tail_iff`, `app_inv_head_iff`, `app_inv_tail_iff`. + (`#12094 <https://github.com/coq/coq/pull/12094>`_, + fixes `#12093 <https://github.com/coq/coq/issues/12093>`_, + by Edward Wang). diff --git a/doc/changelog/10-standard-library/12479-fix-int-ltb-notations.rst b/doc/changelog/10-standard-library/12479-fix-int-ltb-notations.rst new file mode 100644 index 0000000000..208855b4c8 --- /dev/null +++ b/doc/changelog/10-standard-library/12479-fix-int-ltb-notations.rst @@ -0,0 +1,9 @@ +- **Changed:** + Int63 notations now match up with the rest of the standard library: :g:`a \% + m`, :g:`m == n`, :g:`m < n`, :g:`m <= n`, and :g:`m ≤ n` have been replaced + with :g:`a mod m`, :g:`m =? n`, :g:`m <? n`, :g:`m <=? n`, and :g:`m ≤? n`. + The old notations are still available as deprecated notations. Additionally, + there is now a ``Coq.Numbers.Cyclic.Int63.Int63.Int63Notations`` module that + users can import to get the ``Int63`` notations without unqualifying the + various primitives (`#12479 <https://github.com/coq/coq/pull/12479>`_, fixes + `#12454 <https://github.com/coq/coq/issues/12454>`_, by Jason Gross). diff --git a/doc/changelog/10-standard-library/12556-fix-float-ltb-notations.rst b/doc/changelog/10-standard-library/12556-fix-float-ltb-notations.rst new file mode 100644 index 0000000000..1709cf1eae --- /dev/null +++ b/doc/changelog/10-standard-library/12556-fix-float-ltb-notations.rst @@ -0,0 +1,9 @@ +- **Changed:** + PrimFloat notations now match up with the rest of the standard library: :g:`m + == n`, :g:`m < n`, and :g:`m <= n` have been replaced with :g:`m =? n`, :g:`m + <? n`, and :g:`m <=? n`. The old notations are still available as deprecated + notations. Additionally, there is now a + ``Coq.Floats.PrimFloat.PrimFloatNotations`` module that users can import to + get the ``PrimFloat`` notations without unqualifying the various primitives + (`#12556 <https://github.com/coq/coq/pull/12556>`_, fixes `#12454 + <https://github.com/coq/coq/issues/12454>`_, by Jason Gross). diff --git a/doc/changelog/10-standard-library/12716-curry.rst b/doc/changelog/10-standard-library/12716-curry.rst new file mode 100644 index 0000000000..51b59e4a94 --- /dev/null +++ b/doc/changelog/10-standard-library/12716-curry.rst @@ -0,0 +1,4 @@ +- **Deprecated:** + ``prod_curry`` and ``prod_uncurry``, in favor of ``uncurry`` and ``curry`` + (`#12716 <https://github.com/coq/coq/pull/12716>`_, + by Yishuai Li). diff --git a/doc/changelog/10-standard-library/12799-list-repeat.rst b/doc/changelog/10-standard-library/12799-list-repeat.rst new file mode 100644 index 0000000000..adfc48f67b --- /dev/null +++ b/doc/changelog/10-standard-library/12799-list-repeat.rst @@ -0,0 +1,4 @@ +- **Added:** + New lemmas about ``repeat`` in ``List`` and ``Permutation``: ``repeat_app``, ``repeat_eq_app``, ``repeat_eq_cons``, ``repeat_eq_elt``, ``Forall_eq_repeat``, ``Permutation_repeat`` + (`#12799 <https://github.com/coq/coq/pull/12799>`_, + by Olivier Laurent). diff --git a/doc/changelog/10-standard-library/12801-cyclic-set.rst b/doc/changelog/10-standard-library/12801-cyclic-set.rst new file mode 100644 index 0000000000..9a07d78144 --- /dev/null +++ b/doc/changelog/10-standard-library/12801-cyclic-set.rst @@ -0,0 +1,5 @@ +- **Changed:** + Change the sort of cyclic numbers from Type to Set. For backward compatibility, a dynamic sort was defined in the 3 packages bignums, coqprime and color. + See for example commit 6f62bda in bignums. + (`#12801 <https://github.com/coq/coq/pull/12801>`_, + by Vincent Semeria). diff --git a/doc/changelog/10-standard-library/12861-nsatz-tactic-instances.rst b/doc/changelog/10-standard-library/12861-nsatz-tactic-instances.rst new file mode 100644 index 0000000000..41359098e3 --- /dev/null +++ b/doc/changelog/10-standard-library/12861-nsatz-tactic-instances.rst @@ -0,0 +1,7 @@ +- **Changed:** + ``Require Import Coq.nsatz.NsatzTactic`` now allows using :tacn:`nsatz` + with `Z` and `Q` without having to supply instances or using ``Require Import Coq.nsatz.Nsatz``, which + transitively requires unneeded files declaring axioms used in the reals + (`#12861 <https://github.com/coq/coq/pull/12861>`_, + fixes `#12860 <https://github.com/coq/coq/issues/12860>`_, + by Jason Gross). diff --git a/doc/changelog/11-infrastructure-and-dependencies/11742-zarith+core.rst b/doc/changelog/11-infrastructure-and-dependencies/11742-zarith+core.rst new file mode 100644 index 0000000000..3b34e11ff8 --- /dev/null +++ b/doc/changelog/11-infrastructure-and-dependencies/11742-zarith+core.rst @@ -0,0 +1,8 @@ +- **Changed:** + Coq's core system now uses the `zarith <https://github.com/ocaml/Zarith>`_ + library, based on GNU's gmp instead of ``num`` which is + deprecated upstream. The custom ``bigint`` module is + not longer provided; note that the ``micromega`` still uses + ``num`` + (`#11742 <https://github.com/coq/coq/pull/11742>`_, + by Emilio Jesus Gallego Arias and Vicent Laporte). diff --git a/doc/changelog/11-infrastructure-and-dependencies/12864-fix-approve-output.rst b/doc/changelog/11-infrastructure-and-dependencies/12864-fix-approve-output.rst new file mode 100644 index 0000000000..c754826e62 --- /dev/null +++ b/doc/changelog/11-infrastructure-and-dependencies/12864-fix-approve-output.rst @@ -0,0 +1,5 @@ +- **Fixed:** + ``make approve-output`` in the test-suite now correctly handles + ``output-coqtop`` and ``output-coqchk`` tests (`#12864 + <https://github.com/coq/coq/pull/12864>`_, fixes `#12863 + <https://github.com/coq/coq/issues/12863>`_, by Jason Gross). diff --git a/doc/changelog/11-infrastructure-and-dependencies/12972-ocaml+4_11.rst b/doc/changelog/11-infrastructure-and-dependencies/12972-ocaml+4_11.rst new file mode 100644 index 0000000000..855aa360f1 --- /dev/null +++ b/doc/changelog/11-infrastructure-and-dependencies/12972-ocaml+4_11.rst @@ -0,0 +1,4 @@ +- **Added:** + Coq is now tested against OCaml 4.11.1 + (`#12972 <https://github.com/coq/coq/pull/12972>`_, + by Emilio Jesus Gallego Arias). diff --git a/doc/changelog/11-infrastructure-and-dependencies/13011-sphinx-3.rst b/doc/changelog/11-infrastructure-and-dependencies/13011-sphinx-3.rst new file mode 100644 index 0000000000..d17a2dff6b --- /dev/null +++ b/doc/changelog/11-infrastructure-and-dependencies/13011-sphinx-3.rst @@ -0,0 +1,5 @@ +- **Fixed:** + The reference manual can now build with Sphinx 3 + (`#13011 <https://github.com/coq/coq/pull/13011>`_, + fixes `#12332 <https://github.com/coq/coq/issues/12332>`_, + by Théo Zimmermann and Jim Fehrle). diff --git a/doc/sphinx/README.rst b/doc/sphinx/README.rst index f91874d74d..4461ff9240 100644 --- a/doc/sphinx/README.rst +++ b/doc/sphinx/README.rst @@ -15,10 +15,10 @@ Coq objects Our Coq domain define multiple `objects`_. Each object has a *signature* (think *type signature*), followed by an optional body (a description of that object). The following example defines two objects: a variant of the ``simpl`` tactic, and an error that it may raise:: - .. tacv:: simpl @pattern at {+ @num} + .. tacv:: simpl @pattern at {+ @natural} :name: simpl_at - This applies ``simpl`` only to the :n:`{+ @num}` occurrences of the subterms + This applies ``simpl`` only to the :n:`{+ @natural}` occurrences of the subterms matching :n:`@pattern` in the current goal. .. exn:: Too few occurrences @@ -46,10 +46,10 @@ Most objects should have a body (i.e. a block of indented text following the sig Notations --------- -The signatures of most objects can be written using a succinct DSL for Coq notations (think regular expressions written with a Lispy syntax). A typical signature might look like ``Hint Extern @num {? @pattern} => @tactic``, which means that the ``Hint Extern`` command takes a number (``num``), followed by an optional pattern, and a mandatory tactic. The language has the following constructs (the full grammar is in `TacticNotations.g </doc/tools/coqrst/notations/TacticNotations.g>`_): +The signatures of most objects can be written using a succinct DSL for Coq notations (think regular expressions written with a Lispy syntax). A typical signature might look like ``Hint Extern @natural {? @pattern} => @tactic``, which means that the ``Hint Extern`` command takes a number (``natural``), followed by an optional pattern, and a mandatory tactic. The language has the following constructs (the full grammar is in `TacticNotations.g </doc/tools/coqrst/notations/TacticNotations.g>`_): ``@…`` - A placeholder (``@ident``, ``@num``, ``@tactic``\ …) + A placeholder (``@ident``, ``@natural``, ``@tactic``\ …) ``{? …}`` an optional block @@ -80,9 +80,9 @@ As an exercise, what do the following patterns mean? .. code:: - pattern {+, @term {? at {+ @num}}} - generalize {+, @term at {+ @num} as @ident} - fix @ident @num with {+ (@ident {+ @binder} {? {struct @ident'}} : @type)} + pattern {+, @term {? at {+ @natural}}} + generalize {+, @term at {+ @natural} as @ident} + fix @ident @natural with {+ (@ident {+ @binder} {? {struct @ident'}} : @type)} Objects ------- @@ -141,7 +141,7 @@ Here is the list of all objects of the Coq domain (The symbol :black_nib: indica ``.. opt::`` :black_nib: A Coq option (a setting with non-boolean value, e.g. a string or numeric value). Example:: - .. opt:: Hyps Limit @num + .. opt:: Hyps Limit @natural :name Hyps Limit Controls the maximum number of hypotheses displayed in goals after @@ -157,7 +157,7 @@ Here is the list of all objects of the Coq domain (The symbol :black_nib: indica Example:: - .. prodn:: occ_switch ::= { {? {| + | - } } {* @num } } + .. prodn:: occ_switch ::= { {? {| + | - } } {* @natural } } term += let: @pattern := @term in @term | second_production @@ -178,7 +178,7 @@ Here is the list of all objects of the Coq domain (The symbol :black_nib: indica ``.. tacn::`` :black_nib: A tactic, or a tactic notation. Example:: - .. tacn:: do @num @expr + .. tacn:: do @natural @expr :token:`expr` is evaluated to ``v`` which must be a tactic value. … @@ -346,17 +346,15 @@ In addition to the objects and directives above, the ``coqrst`` Sphinx plugin de creates a link to that. When referring to a placeholder that happens to be a grammar production, ``:token:`…``` is typically preferable to ``:n:`@…```. -``:production:`` A grammar production not included in a ``productionlist`` directive. +``:production:`` A grammar production not included in a ``prodn`` directive. Useful to informally introduce a production, as part of running text. Example:: :production:`string` indicates a quoted string. - You're not likely to use this role very commonly; instead, use a - `production list - <http://www.sphinx-doc.org/en/stable/markup/para.html#directive-productionlist>`_ - and reference its tokens using ``:token:`…```. + You're not likely to use this role very commonly; instead, use a ``prodn`` + directive and reference its tokens using ``:token:`…```. ``:gdef:`` Marks the definition of a glossary term inline in the text. Matching :term:`XXX` constructs will link to it. Use the form :gdef:`text <term>` to display "text" diff --git a/doc/sphinx/README.template.rst b/doc/sphinx/README.template.rst index 5762967c36..b4e21aa14a 100644 --- a/doc/sphinx/README.template.rst +++ b/doc/sphinx/README.template.rst @@ -15,10 +15,10 @@ Coq objects Our Coq domain define multiple `objects`_. Each object has a *signature* (think *type signature*), followed by an optional body (a description of that object). The following example defines two objects: a variant of the ``simpl`` tactic, and an error that it may raise:: - .. tacv:: simpl @pattern at {+ @num} + .. tacv:: simpl @pattern at {+ @natural} :name: simpl_at - This applies ``simpl`` only to the :n:`{+ @num}` occurrences of the subterms + This applies ``simpl`` only to the :n:`{+ @natural}` occurrences of the subterms matching :n:`@pattern` in the current goal. .. exn:: Too few occurrences @@ -46,10 +46,10 @@ Most objects should have a body (i.e. a block of indented text following the sig Notations --------- -The signatures of most objects can be written using a succinct DSL for Coq notations (think regular expressions written with a Lispy syntax). A typical signature might look like ``Hint Extern @num {? @pattern} => @tactic``, which means that the ``Hint Extern`` command takes a number (``num``), followed by an optional pattern, and a mandatory tactic. The language has the following constructs (the full grammar is in `TacticNotations.g </doc/tools/coqrst/notations/TacticNotations.g>`_): +The signatures of most objects can be written using a succinct DSL for Coq notations (think regular expressions written with a Lispy syntax). A typical signature might look like ``Hint Extern @natural {? @pattern} => @tactic``, which means that the ``Hint Extern`` command takes a number (``natural``), followed by an optional pattern, and a mandatory tactic. The language has the following constructs (the full grammar is in `TacticNotations.g </doc/tools/coqrst/notations/TacticNotations.g>`_): ``@…`` - A placeholder (``@ident``, ``@num``, ``@tactic``\ …) + A placeholder (``@ident``, ``@natural``, ``@tactic``\ …) ``{? …}`` an optional block @@ -80,9 +80,9 @@ As an exercise, what do the following patterns mean? .. code:: - pattern {+, @term {? at {+ @num}}} - generalize {+, @term at {+ @num} as @ident} - fix @ident @num with {+ (@ident {+ @binder} {? {struct @ident'}} : @type)} + pattern {+, @term {? at {+ @natural}}} + generalize {+, @term at {+ @natural} as @ident} + fix @ident @natural with {+ (@ident {+ @binder} {? {struct @ident'}} : @type)} Objects ------- diff --git a/doc/sphinx/_static/coqnotations.sty b/doc/sphinx/_static/coqnotations.sty index 3dfe4db439..2b1678e7ef 100644 --- a/doc/sphinx/_static/coqnotations.sty +++ b/doc/sphinx/_static/coqnotations.sty @@ -79,7 +79,7 @@ \newcssclass{prodn-table}{% \begin{savenotes} \sphinxattablestart - \begin{tabulary}{\linewidth}[t]{lLL} + \begin{tabulary}{\linewidth}[t]{lLLL} #1 \end{tabulary} \par @@ -89,4 +89,5 @@ \newcssclass{prodn-target}{\raisebox{\dimexpr \nscriptsize \relax}{#1}} \newcssclass{prodn-cell-nonterminal}{#1 &} \newcssclass{prodn-cell-op}{#1 &} -\newcssclass{prodn-cell-production}{#1\\} +\newcssclass{prodn-cell-production}{#1 &} +\newcssclass{prodn-cell-tag}{#1\\} diff --git a/doc/sphinx/_static/notations.css b/doc/sphinx/_static/notations.css index 9546f7107e..8c3f7ac3c1 100644 --- a/doc/sphinx/_static/notations.css +++ b/doc/sphinx/_static/notations.css @@ -192,7 +192,8 @@ .prodn-cell-nonterminal, .prodn-cell-op, -.prodn-cell-production +.prodn-cell-production, +.prodn-cell-tag { display: table-cell; } @@ -206,6 +207,17 @@ font-weight: normal; } +.prodn-cell-production { + width: 99%; +} + +.prodn-cell-tag { + text-align: right; + font-weight: normal; + font-size: 75%; + font-family: "Lato","proxima-nova","Helvetica Neue",Arial,sans-serif; +} + .prodn-table .notation > .repeat-wrapper { margin-top: 0.28em; } diff --git a/doc/sphinx/addendum/extraction.rst b/doc/sphinx/addendum/extraction.rst index 41b726b069..c2249b8e57 100644 --- a/doc/sphinx/addendum/extraction.rst +++ b/doc/sphinx/addendum/extraction.rst @@ -99,12 +99,15 @@ Extraction Options Setting the target language ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. cmd:: Extraction Language {| OCaml | Haskell | Scheme } +.. cmd:: Extraction Language {| OCaml | Haskell | Scheme | JSON } :name: Extraction Language The ability to fix target language is the first and more important of the extraction options. Default is ``OCaml``. + The JSON output is mostly for development or debugging: + it contains the raw ML term produced as an intermediary target. + Inlining and optimizations ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -426,11 +429,11 @@ Additional settings Provides a comment that is included at the beginning of the output files. -.. opt:: Extraction Flag @num +.. opt:: Extraction Flag @natural :name: Extraction Flag Controls which optimizations are used during extraction, providing a finer-grained - control than :flag:`Extraction Optimize`. The bits of :token:`num` are used as a bit mask. + control than :flag:`Extraction Optimize`. The bits of :token:`natural` are used as a bit mask. Keeping an option off keeps the extracted ML more similar to the Coq term. Values are: diff --git a/doc/sphinx/addendum/micromega.rst b/doc/sphinx/addendum/micromega.rst index c01e6a5aa6..ba5bac6489 100644 --- a/doc/sphinx/addendum/micromega.rst +++ b/doc/sphinx/addendum/micromega.rst @@ -61,19 +61,23 @@ tactics for solving arithmetic goals over :math:`\mathbb{Q}`, The tactics solve propositional formulas parameterized by atomic arithmetic expressions interpreted over a domain :math:`D \in \{\mathbb{Z},\mathbb{Q},\mathbb{R}\}`. -The syntax of the formulas is the following: +The syntax for formulas over :math:`\mathbb{Z}` is: - .. productionlist:: F - F : A ∣ P | True ∣ False ∣ F ∧ F ∣ F ∨ F ∣ F ↔ F ∣ F → F ∣ ¬ F | F = F - A : p = p ∣ p > p ∣ p < p ∣ p ≥ p ∣ p ≤ p - p : c ∣ x ∣ −p ∣ p − p ∣ p + p ∣ p × p ∣ p ^ n + .. note the following is not an insertprodn -where :math:`F` is interpreted over either `Prop` or `bool`, -:math:`c` is a numeric constant, :math:`x \in D` is a numeric variable, the -operators :math:`−, +, ×` are respectively subtraction, addition, and product; -:math:`p ^ n` is exponentiation by a constant :math:`n`, :math:`P` is an arbitrary proposition. -For :math:`\mathbb{Q}`, equality is not Leibniz equality ``=`` but the equality of -rationals ``==``. + .. prodn:: + F ::= {| @A | P | True | False | @F /\\ @F | @F \\/ @F | @F <-> @F | @F -> @F | ~ @F | @F = @F } + A ::= {| @p = @p | @p > @p | @p < @p | @p >= @p | @p <= @p } + p ::= {| c | x | −@p | @p − @p | @p + @p | @p * @p | @p ^ n } + +where + + - :token:`F` is interpreted over either `Prop` or `bool` + - :n:`P` is an arbitrary proposition + - :n:`c` is a numeric constant of :math:`D` + - :n:`x` :math:`\in D` is a numeric variable + - :n:`−`, :n:`+` and :n:`*` are respectively subtraction, addition and product + - :n:`p ^ n` is exponentiation by a constant :math:`n` When :math:`F` is interpreted over `bool`, the boolean operators are `&&`, `||`, `Bool.eqb`, `Bool.implb`, `Bool.negb` and the comparisons @@ -81,6 +85,9 @@ in :math:`A` are also interpreted over the booleans (e.g., for :math:`\mathbb{Z}`, we have `Z.eqb`, `Z.gtb`, `Z.ltb`, `Z.geb`, `Z.leb`). +For :math:`\mathbb{Q}`, use the equality of rationals ``==`` rather than +Leibniz equality ``=``. + For :math:`\mathbb{Z}` (resp. :math:`\mathbb{Q}`), :math:`c` ranges over integer constants (resp. rational constants). For :math:`\mathbb{R}`, the tactic recognizes as real constants the following expressions: @@ -159,7 +166,7 @@ High level view of `lia` Over :math:`\mathbb{R}`, *positivstellensatz* refutations are a complete proof principle [#mayfail]_. However, this is not the case over :math:`\mathbb{Z}`. Actually, *positivstellensatz* refutations are not even sufficient to decide -linear *integer* arithmetic. The canonical example is :math:`2 * x = 1 -> \mathtt{False}` +linear *integer* arithmetic. The canonical example is :math:`2 * x = 1 \to \mathtt{False}` which is a theorem of :math:`\mathbb{Z}` but not a theorem of :math:`{\mathbb{R}}`. To remedy this weakness, the :tacn:`lia` tactic is using recursively a combination of: @@ -180,7 +187,7 @@ are a way to take into account the discreteness of :math:`\mathbb{Z}` by roundin Let :math:`p` be an integer and :math:`c` a rational constant. Then :math:`p \ge c \rightarrow p \ge \lceil{c}\rceil`. -For instance, from 2 x = 1 we can deduce +For instance, from :math:`2 x = 1` we can deduce + :math:`x \ge 1/2` whose cut plane is :math:`x \ge \lceil{1/2}\rceil = 1`; + :math:`x \le 1/2` whose cut plane is :math:`x \le \lfloor{1/2}\rfloor = 0`. diff --git a/doc/sphinx/addendum/nsatz.rst b/doc/sphinx/addendum/nsatz.rst index ed2e1ea58c..8a64a7ed4b 100644 --- a/doc/sphinx/addendum/nsatz.rst +++ b/doc/sphinx/addendum/nsatz.rst @@ -34,6 +34,12 @@ Nsatz: tactics for proving equalities in integral domains You can load the ``Nsatz`` module with the command ``Require Import Nsatz``. + Alternatively, if you prefer not to transitively depend on the + files declaring the axioms used to define the real numbers, you can + ``Require Import NsatzTactic`` instead; this will still allow + :tacn:`nsatz` to solve goals defined about :math:`\mathbb{Z}`, + :math:`\mathbb{Q}` and any user-registered rings. + More about `nsatz` --------------------- @@ -58,7 +64,7 @@ Buchberger algorithm. This computation is done after a step of *reification*, which is performed using :ref:`typeclasses`. -.. tacv:: nsatz with radicalmax:=@num%N strategy:=@num%Z parameters:=[{*, @ident}] variables:=[{*, @ident}] +.. tacv:: nsatz with radicalmax:=@natural%N strategy:=@natural%Z parameters:=[{*, @ident}] variables:=[{*, @ident}] Most complete syntax for `nsatz`. @@ -85,4 +91,4 @@ performed using :ref:`typeclasses`. then `lvar` is replaced by all the variables which are not in `parameters`. -See the file `Nsatz.v` for many examples, especially in geometry. +See the test-suite file `Nsatz.v <https://github.com/coq/coq/blob/master/test-suite/success/Nsatz.v>`_ for many examples, especially in geometry. diff --git a/doc/sphinx/addendum/program.rst b/doc/sphinx/addendum/program.rst index b5618c5721..c6a4b4fe1a 100644 --- a/doc/sphinx/addendum/program.rst +++ b/doc/sphinx/addendum/program.rst @@ -196,12 +196,9 @@ Program Definition Program Fixpoint ~~~~~~~~~~~~~~~~ -.. cmd:: Program Fixpoint @ident {* @binder } {? {@order}} : @type := @term +.. cmd:: Program Fixpoint @fix_definition {* with @fix_definition } - The optional order annotation follows the grammar: - - .. productionlist:: orderannot - order : measure `term` [ `term` ] | wf `term` `ident` + The optional :n:`@fixannot` annotation can be one of: + :g:`measure f R` where :g:`f` is a value of type :g:`X` computed on any subset of the arguments and the optional term @@ -306,9 +303,9 @@ optional tactic is replaced by the default one if not specified. Displays all remaining obligations. -.. cmd:: Obligation @num {? of @ident} +.. cmd:: Obligation @natural {? of @ident} - Start the proof of obligation :token:`num`. + Start the proof of obligation :token:`natural`. .. cmd:: Next Obligation {? of @ident} diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index 903aa266e2..11162ec96b 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -330,7 +330,7 @@ Summary of the commands This command has no effect when used on a typeclass. -.. cmd:: Instance @ident {* @binder } : @term__0 {+ @term} {? | @num} := { {*; @field_def} } +.. cmd:: Instance @ident {* @binder } : @term__0 {+ @term} {? | @natural} := { {*; @field_def} } This command is used to declare a typeclass instance named :token:`ident` of the class :n:`@term__0` with parameters :token:`term` and @@ -340,7 +340,7 @@ Summary of the commands An arbitrary context of :token:`binders` can be put after the name of the instance and before the colon to declare a parameterized instance. An optional priority can be declared, 0 being the highest priority as for - :tacn:`auto` hints. If the priority :token:`num` is not specified, it defaults to the number + :tacn:`auto` hints. If the priority :token:`natural` is not specified, it defaults to the number of non-dependent binders of the instance. This command supports the :attr:`global` attribute that can be @@ -362,7 +362,7 @@ Summary of the commands to fill them. It works exactly as if no body had been given and the :tacn:`refine` tactic has been used first. - .. cmdv:: Instance @ident {* @binder } : forall {* @binder }, @term__0 {+ @term} {? | @num } := @term + .. cmdv:: Instance @ident {* @binder } : forall {* @binder }, @term__0 {+ @term} {? | @natural } := @term This syntax is used for declaration of singleton class instances or for directly giving an explicit term of type :n:`forall {* @binder }, @term__0 @@ -381,11 +381,11 @@ Summary of the commands Besides the :cmd:`Class` and :cmd:`Instance` vernacular commands, there are a few other commands related to typeclasses. -.. cmd:: Existing Instance {+ @ident} {? | @num} +.. cmd:: Existing Instance {+ @ident} {? | @natural} This command adds an arbitrary list of constants whose type ends with an applied typeclass to the instance database with an optional - priority :token:`num`. It can be used for redeclaring instances at the end of + priority :token:`natural`. It can be used for redeclaring instances at the end of sections, or declaring structure projections as instances. This is equivalent to ``Hint Resolve ident : typeclass_instances``, except it registers instances for :cmd:`Print Instances`. @@ -446,10 +446,10 @@ few other commands related to typeclasses. + When considering local hypotheses, we use the union of all the modes declared in the given databases. - .. tacv:: typeclasses eauto @num + .. tacv:: typeclasses eauto @natural .. warning:: - The semantics for the limit :n:`@num` + The semantics for the limit :n:`@natural` is different than for auto. By default, if no limit is given, the search is unbounded. Contrary to :tacn:`auto`, introduction steps are counted, which might result in larger limits being necessary when @@ -581,7 +581,7 @@ Settings Otherwise, the search strategy is depth-first search. The default is off. :cmd:`Typeclasses eauto` is another way to set this flag. -.. opt:: Typeclasses Depth @num +.. opt:: Typeclasses Depth @natural :name: Typeclasses Depth Sets the maximum proof search depth. The default is unbounded. @@ -593,7 +593,7 @@ Settings also sets :opt:`Typeclasses Debug Verbosity` to 1. :cmd:`Typeclasses eauto` is another way to set this flag. -.. opt:: Typeclasses Debug Verbosity @num +.. opt:: Typeclasses Debug Verbosity @natural :name: Typeclasses Debug Verbosity Determines how much information is shown for typeclass resolution steps during search. @@ -604,7 +604,7 @@ Settings Typeclasses eauto `:=` ~~~~~~~~~~~~~~~~~~~~~~ -.. cmd:: Typeclasses eauto := {? debug} {? {| (dfs) | (bfs) } } @num +.. cmd:: Typeclasses eauto := {? debug} {? {| (dfs) | (bfs) } } @natural :name: Typeclasses eauto This command allows more global customization of the typeclass @@ -618,5 +618,5 @@ Typeclasses eauto `:=` search (the default) or breadth-first search. The search strategy can also be set with :flag:`Typeclasses Iterative Deepening`. - + :token:`num` This sets the depth limit of the search. The depth + + :token:`natural` This sets the depth limit of the search. The depth limit can also be set with :opt:`Typeclasses Depth`. diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 0f501382e7..af66efa95e 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -484,7 +484,7 @@ Tactic language (`#11882 <https://github.com/coq/coq/pull/11882>`_, by Hugo Herbelin). - **Added:** - Ltac2 notations for reductions in terms: :n:`eval @red_expr in @ltac2_term` + Ltac2 notations for reductions in terms: :n:`eval @red_expr in @term` (`#11981 <https://github.com/coq/coq/pull/11981>`_, by Michael Soegtrop). - **Fixed:** @@ -2009,7 +2009,7 @@ reference manual. Here are the most important user-visible changes: inductive types (`#8965 <https://github.com/coq/coq/pull/8965>`_, by Jason Gross). - - Experimental: :ref:`Numeral Notations <numeral-notations>` now parse decimal + - Experimental: :ref:`Number Notations <number-notations>` now parse decimal constants such as ``1.02e+01`` or ``10.2``. Parsers added for :g:`Q` and :g:`R`. In the rare case when such numeral notations were used in a development along with :g:`Q` or :g:`R`, they may have to be removed or @@ -2281,7 +2281,7 @@ Other changes in 8.10+beta1 parentheses on abbreviations shortening a strict prefix of an application, by Hugo Herbelin). - - :cmd:`Numeral Notation` now support inductive types in the input to + - :cmd:`Number Notation` now support inductive types in the input to printing functions (e.g., numeral notations can be defined for terms containing things like :g:`@cons nat O O`), and parsing functions now fully normalize terms including parameters of constructors (so that, @@ -2782,7 +2782,7 @@ changes: next version of |Coq|, see the next subsection for a script to ease porting, by Jason Gross and Jean-Christophe Léchenet. - - Added the :cmd:`Numeral Notation` command for registering decimal + - Added the :cmd:`Number Notation` command for registering decimal numeral notations for custom types, by Daniel de Rauglaudre, Pierre Letouzey and Jason Gross. diff --git a/doc/sphinx/conf.py b/doc/sphinx/conf.py index 99762c7a0e..ee8784fc02 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -187,6 +187,16 @@ nitpick_ignore = [ ('token', token) for token in [ 'collection', 'modpath', 'tactic', + 'destruction_arg', + 'bindings', + 'induction_clause', + 'conversion', + 'where', + 'oriented_rewriter', + 'hintbases', + 'bindings_with_parameters', + 'destruction_arg', + 'clause_dft_concl' ]] # -- Options for HTML output ---------------------------------------------- diff --git a/doc/sphinx/language/coq-library.rst b/doc/sphinx/language/coq-library.rst index f9d24fde0e..765373619f 100644 --- a/doc/sphinx/language/coq-library.rst +++ b/doc/sphinx/language/coq-library.rst @@ -40,7 +40,7 @@ in the |Coq| root directory; this includes the modules ``Datatypes``, ``Specif``, ``Peano``, -``Wf`` and +``Wf`` and ``Tactics``. Module ``Logic_Type`` also makes it in the initial state. @@ -175,7 +175,7 @@ Quantifiers Then we find first-order quantifiers: .. coqtop:: in - + Definition all (A:Set) (P:A -> Prop) := forall x:A, P x. Inductive ex (A: Set) (P:A -> Prop) : Prop := ex_intro (x:A) (_:P x). @@ -256,12 +256,12 @@ Finally, a few easy lemmas are provided. single: f_equal2 ... f_equal5 (term) The theorem ``f_equal`` is extended to functions with two to five -arguments. The theorem are names ``f_equal2``, ``f_equal3``, +arguments. The theorem are names ``f_equal2``, ``f_equal3``, ``f_equal4`` and ``f_equal5``. For instance ``f_equal3`` is defined the following way. .. coqtop:: in abort - + Theorem f_equal3 : forall (A1 A2 A3 B:Type) (f:A1 -> A2 -> A3 -> B) (x1 y1:A1) (x2 y2:A2) (x3 y3:A3), @@ -324,7 +324,7 @@ Programming Note that zero is the letter ``O``, and *not* the numeral ``0``. -The predicate ``identity`` is logically +The predicate ``identity`` is logically equivalent to equality but it lives in sort ``Type``. It is mainly maintained for compatibility. @@ -367,7 +367,7 @@ infix notation ``||``), ``xorb``, ``implb`` and ``negb``. Specification ~~~~~~~~~~~~~ -The following notions defined in module ``Specif.v`` allow to build new data-types and specifications. +The following notions defined in module ``Specif.v`` allow to build new data-types and specifications. They are available with the syntax shown in the previous section :ref:`datatypes`. For instance, given :g:`A:Type` and :g:`P:A->Prop`, the construct @@ -393,11 +393,11 @@ provided. .. coqtop:: in Inductive sig (A:Set) (P:A -> Prop) : Set := exist (x:A) (_:P x). - Inductive sig2 (A:Set) (P Q:A -> Prop) : Set := + Inductive sig2 (A:Set) (P Q:A -> Prop) : Set := exist2 (x:A) (_:P x) (_:Q x). A *strong (dependent) sum* :g:`{x:A & P x}` may be also defined, -when the predicate ``P`` is now defined as a +when the predicate ``P`` is now defined as a constructor of types in ``Type``. .. index:: @@ -556,7 +556,7 @@ section :tacn:`refine`). This scope is opened by default. Now comes the content of module ``Peano``: .. coqdoc:: - + Theorem eq_S : forall x y:nat, x = y -> S x = S y. Definition pred (n:nat) : nat := match n with @@ -628,7 +628,7 @@ induction principle. .. coqdoc:: Theorem nat_case : - forall (n:nat) (P:nat -> Prop), + forall (n:nat) (P:nat -> Prop), P 0 -> (forall m:nat, P (S m)) -> P n. Theorem nat_double_ind : forall R:nat -> nat -> Prop, @@ -640,7 +640,7 @@ induction principle. Well-founded recursion ~~~~~~~~~~~~~~~~~~~~~~ -The basic library contains the basics of well-founded recursion and +The basic library contains the basics of well-founded recursion and well-founded induction, in module ``Wf.v``. .. index:: @@ -669,7 +669,7 @@ well-founded induction, in module ``Wf.v``. forall P:A -> Prop, (forall x:A, (forall y:A, R y x -> P y) -> P x) -> forall a:A, P a. -The automatically generated scheme ``Acc_rect`` +The automatically generated scheme ``Acc_rect`` can be used to define functions by fixpoints using well-founded relations to justify termination. Assuming extensionality of the functional used for the recursive call, the @@ -741,7 +741,7 @@ The standard library Survey ~~~~~~ -The rest of the standard library is structured into the following +The rest of the standard library is structured into the following subdirectories: * **Logic** : Classical logic and dependent equality @@ -751,8 +751,8 @@ subdirectories: * **ZArith** : Basic relative integer arithmetic * **Numbers** : Various approaches to natural, integer and cyclic numbers (currently axiomatically and on top of 2^31 binary words) * **Bool** : Booleans (basic functions and results) - * **Lists** : Monomorphic and polymorphic lists (basic functions and results), Streams (infinite sequences defined with co-inductive types) - * **Sets** : Sets (classical, constructive, finite, infinite, power set, etc.) + * **Lists** : Monomorphic and polymorphic lists (basic functions and results), Streams (infinite sequences defined with co-inductive types) + * **Sets** : Sets (classical, constructive, finite, infinite, power set, etc.) * **FSets** : Specification and implementations of finite sets and finite maps (by lists and by AVL trees) * **Reals** : Axiomatization of real numbers (classical, basic functions, integer part, fractional part, limit, derivative, Cauchy series, power series and results,...) * **Floats** : Machine implementation of floating-point arithmetic (for the binary64 format) @@ -903,7 +903,7 @@ tactics (see Chapter :ref:`tactics`), there are also: .. tacn:: discrR :name: discrR - + Proves that two real integer constants are different. .. example:: @@ -931,7 +931,7 @@ tactics (see Chapter :ref:`tactics`), there are also: .. tacn:: split_Rmult :name: split_Rmult - + Splits a condition that a product is non null into subgoals corresponding to the condition on each operand of the product. @@ -963,7 +963,7 @@ List library single: fold_left (term) single: fold_right (term) -Some elementary operations on polymorphic lists are defined here. +Some elementary operations on polymorphic lists are defined here. They can be accessed by requiring module ``List``. It defines the following notions: @@ -1052,9 +1052,9 @@ Notation Interpretation ``_ + _`` ``add`` ``_ * _`` ``mul`` ``_ / _`` ``div`` -``_ == _`` ``eqb`` -``_ < _`` ``ltb`` -``_ <= _`` ``leb`` +``_ =? _`` ``eqb`` +``_ <? _`` ``ltb`` +``_ <=? _`` ``leb`` ``_ ?= _`` ``compare`` =========== ============== @@ -1062,7 +1062,7 @@ Floating-point constants are parsed and pretty-printed as (17-digit) decimal constants. This ensures that the composition :math:`\text{parse} \circ \text{print}` amounts to the identity. -.. warn:: The constant @numeral is not a binary64 floating-point value. A closest value @numeral will be used and unambiguously printed @numeral. [inexact-float,parsing] +.. warn:: The constant @number is not a binary64 floating-point value. A closest value @number will be used and unambiguously printed @number. [inexact-float,parsing] Not all decimal constants are floating-point values. This warning is generated when parsing such a constant (for instance ``0.1``). diff --git a/doc/sphinx/language/core/assumptions.rst b/doc/sphinx/language/core/assumptions.rst index 955f48b772..fe10e345cd 100644 --- a/doc/sphinx/language/core/assumptions.rst +++ b/doc/sphinx/language/core/assumptions.rst @@ -125,7 +125,7 @@ has type :n:`@type`. .. _Axiom: -.. cmd:: @assumption_token {? Inline {? ( @num ) } } {| {+ ( @assumpt ) } | @assumpt } +.. cmd:: @assumption_token {? Inline {? ( @natural ) } } {| {+ ( @assumpt ) } | @assumpt } :name: Axiom; Axioms; Conjecture; Conjectures; Hypothesis; Hypotheses; Parameter; Parameters; Variable; Variables .. insertprodn assumption_token of_type diff --git a/doc/sphinx/language/core/basic.rst b/doc/sphinx/language/core/basic.rst index 64b29c1c0b..45bdc019ac 100644 --- a/doc/sphinx/language/core/basic.rst +++ b/doc/sphinx/language/core/basic.rst @@ -111,33 +111,46 @@ Identifiers symbols and non-breaking space. :production:`unicode_id_part` non-exhaustively includes symbols for prime letters and subscripts. -Numerals - Numerals are sequences of digits with an optional fractional part +Numbers + Numbers are sequences of digits with an optional fractional part and exponent, optionally preceded by a minus sign. Hexadecimal numerals - start with ``0x`` or ``0X``. :n:`@int` is an integer; - a numeral without fractional nor exponent parts. :n:`@num` is a non-negative - integer. Underscores embedded in the digits are ignored, for example + start with ``0x`` or ``0X``. :n:`@bigint` are integers; + numbers without fractional nor exponent parts. :n:`@bignat` are non-negative + integers. Underscores embedded in the digits are ignored, for example ``1_000_000`` is the same as ``1000000``. - .. insertprodn numeral hexdigit + .. insertprodn number hexdigit .. prodn:: - numeral ::= {? - } @decnum {? . {+ {| @digit | _ } } } {? {| e | E } {? {| + | - } } @decnum } - | {? - } @hexnum {? . {+ {| @hexdigit | _ } } } {? {| p | P } {? {| + | - } } @decnum } - int ::= {? - } @num - num ::= {| @decnum | @hexnum } - decnum ::= @digit {* {| @digit | _ } } + number ::= {? - } @decnat {? . {+ {| @digit | _ } } } {? {| e | E } {? {| + | - } } @decnat } + | {? - } @hexnat {? . {+ {| @hexdigit | _ } } } {? {| p | P } {? {| + | - } } @decnat } + integer ::= {? - } @natural + natural ::= @bignat + bigint ::= {? - } @bignat + bignat ::= {| @decnat | @hexnat } + decnat ::= @digit {* {| @digit | _ } } digit ::= 0 .. 9 - hexnum ::= {| 0x | 0X } @hexdigit {* {| @hexdigit | _ } } + hexnat ::= {| 0x | 0X } @hexdigit {* {| @hexdigit | _ } } hexdigit ::= {| 0 .. 9 | a .. f | A .. F } - .. todo PR need some code fixes for hex, see PR 11948 + :n:`@integer` and :n:`@natural` are limited to the range that fits + into an OCaml integer (63-bit integers on most architectures). + :n:`@bigint` and :n:`@bignat` have no range limitation. + + The :ref:`standard library <thecoqlibrary>` provides some + :ref:`interpretations <notation-scopes>` for :n:`@number`. The + :cmd:`Number Notation` mechanism offers the user + a way to define custom parsers and printers for :n:`@number`. Strings Strings begin and end with ``"`` (double quote). Use ``""`` to represent a double quote character within a string. In the grammar, strings are identified with :production:`string`. + The :cmd:`String Notation` mechanism offers the + user a way to define custom parsers and printers for + :token:`string`. + Keywords The following character sequences are keywords defined in the main Coq grammar that cannot be used as identifiers (even when starting Coq with the `-noinit` @@ -227,6 +240,7 @@ rest of the |Coq| manual: :term:`terms <term>` and :term:`types | @term_match | @term_record | @term_generalizing + | [| {*; @term } %| @term {? : @type } |] {? @univ_annot } | @term_ltac | ( @term ) qualid_annotated ::= @qualid {? @univ_annot } @@ -291,7 +305,7 @@ rest of the |Coq| manual: :term:`terms <term>` and :term:`types .. prodn:: document ::= {* @sentence } sentence ::= {? @attributes } @command . - | {? @attributes } {? @num : } @query_command . + | {? @attributes } {? @natural : } @query_command . | {? @attributes } {? @toplevel_selector : } @ltac_expr {| . | ... } | @control_command @@ -433,7 +447,7 @@ gray boxes after the labels "Flag", "Option" and "Table". In the pdf, they appear after a boldface label. They are listed in the :ref:`options_index`. -.. cmd:: Set @setting_name {? {| @int | @string } } +.. cmd:: Set @setting_name {? {| @integer | @string } } :name: Set If :n:`@setting_name` is a flag, no value may be provided; the flag diff --git a/doc/sphinx/language/core/conversion.rst b/doc/sphinx/language/core/conversion.rst index 0f27b65107..6b031cfea3 100644 --- a/doc/sphinx/language/core/conversion.rst +++ b/doc/sphinx/language/core/conversion.rst @@ -5,8 +5,14 @@ Conversion rules In |Cic|, there is an internal reduction mechanism. In particular, it can decide if two programs are *intentionally* equal (one says -*convertible*). Convertibility is described in this section. +:term:`convertible`). Convertibility is described in this section. +α-conversion +~~~~~~~~~~~~ + +Two terms are :gdef:`α-convertible <alpha-convertible>` if they are syntactically +equal ignoring differences in the names of variables bound within the expression. +For example `forall x, x + 0 = x` is α-convertible with `forall y, y + 0 = y`. .. _beta-reduction: @@ -153,7 +159,7 @@ relation :math:`t` reduces to :math:`u` in the global environment reductions β, δ, ι or ζ. We say that two terms :math:`t_1` and :math:`t_2` are -*βδιζη-convertible*, or simply *convertible*, or *equivalent*, in the +*βδιζη-convertible*, or simply :gdef:`convertible`, or *equivalent*, in the global environment :math:`E` and local context :math:`Γ` iff there exist terms :math:`u_1` and :math:`u_2` such that :math:`E[Γ] ⊢ t_1 \triangleright … \triangleright u_1` and :math:`E[Γ] ⊢ t_2 \triangleright … \triangleright u_2` and either :math:`u_1` and diff --git a/doc/sphinx/language/core/modules.rst b/doc/sphinx/language/core/modules.rst index 29e703c223..866104d5d1 100644 --- a/doc/sphinx/language/core/modules.rst +++ b/doc/sphinx/language/core/modules.rst @@ -67,7 +67,7 @@ together, as well as a means of massive abstraction. module_binder ::= ( {? {| Import | Export } } {+ @ident } : @module_type_inl ) module_type_inl ::= ! @module_type | @module_type {? @functor_app_annot } - functor_app_annot ::= [ inline at level @num ] + functor_app_annot ::= [ inline at level @natural ] | [ no inline ] module_type ::= @qualid | ( @module_type ) diff --git a/doc/sphinx/language/core/records.rst b/doc/sphinx/language/core/records.rst index 0080f1d052..cd44d06e67 100644 --- a/doc/sphinx/language/core/records.rst +++ b/doc/sphinx/language/core/records.rst @@ -19,7 +19,7 @@ expressions. In this sense, the :cmd:`Record` construction allows defining .. prodn:: record_definition ::= {? > } @ident_decl {* @binder } {? : @type } {? @ident } %{ {*; @record_field } %} {? @decl_notations } - record_field ::= {* #[ {*, @attribute } ] } @name {? @field_body } {? %| @num } {? @decl_notations } + record_field ::= {* #[ {*, @attribute } ] } @name {? @field_body } {? %| @natural } {? @decl_notations } field_body ::= {* @binder } @of_type | {* @binder } @of_type := @term | {* @binder } := @term diff --git a/doc/sphinx/language/core/sorts.rst b/doc/sphinx/language/core/sorts.rst index 3517d70005..98dd9a5426 100644 --- a/doc/sphinx/language/core/sorts.rst +++ b/doc/sphinx/language/core/sorts.rst @@ -20,7 +20,7 @@ Sorts | Type @%{ @universe %} universe ::= max ( {+, @universe_expr } ) | @universe_expr - universe_expr ::= @universe_name {? + @num } + universe_expr ::= @universe_name {? + @natural } The types of types are called :gdef:`sorts <sort>`. diff --git a/doc/sphinx/language/core/variants.rst b/doc/sphinx/language/core/variants.rst index d00a2f4100..2904250e41 100644 --- a/doc/sphinx/language/core/variants.rst +++ b/doc/sphinx/language/core/variants.rst @@ -22,7 +22,7 @@ Variants :attr:`universes(noncumulative)` and :attr:`private(matching)` attributes. - .. exn:: The @num th argument of @ident must be @ident in @type. + .. exn:: The @natural th argument of @ident must be @ident in @type. :undocumented: Private (matching) inductive types @@ -57,6 +57,11 @@ Private (matching) inductive types Definition by cases: match -------------------------- +Objects of inductive types can be destructured by a case-analysis +construction called *pattern matching* expression. A pattern matching +expression is used to analyze the structure of an inductive object and +to apply specific treatments accordingly. + .. insertprodn term_match pattern0 .. prodn:: @@ -74,13 +79,15 @@ Definition by cases: match | %{%| {* @qualid := @pattern } %|%} | _ | ( {+| @pattern } ) - | @numeral + | @number | @string -Objects of inductive types can be destructured by a case-analysis -construction called *pattern matching* expression. A pattern matching -expression is used to analyze the structure of an inductive object and -to apply specific treatments accordingly. +Note that the :n:`@pattern ::= @pattern10 : @term` production +is not supported in :n:`match` patterns. Trying to use it will give this error: + +.. exn:: Casts are not supported in this pattern. + :undocumented: + This paragraph describes the basic form of pattern matching. See Section :ref:`Mult-match` and Chapter :ref:`extendedpatternmatching` for the description diff --git a/doc/sphinx/language/extensions/evars.rst b/doc/sphinx/language/extensions/evars.rst index 40e0898871..20f4310d13 100644 --- a/doc/sphinx/language/extensions/evars.rst +++ b/doc/sphinx/language/extensions/evars.rst @@ -13,13 +13,13 @@ Existential variables | ?[ ?@ident ] | ?@ident {? @%{ {+; @ident := @term } %} } -|Coq| terms can include existential variables which represents unknown -subterms to eventually be replaced by actual subterms. +|Coq| terms can include existential variables that represent unknown +subterms that are eventually replaced with actual subterms. -Existential variables are generated in place of unsolvable implicit +Existential variables are generated in place of unsolved implicit arguments or “_” placeholders when using commands such as ``Check`` (see Section :ref:`requests-to-the-environment`) or when using tactics such as -:tacn:`refine`, as well as in place of unsolvable instances when using +:tacn:`refine`, as well as in place of unsolved instances when using tactics such that :tacn:`eapply`. An existential variable is defined in a context, which is the context of variables of the placeholder which generated the existential variable, and a type, @@ -43,22 +43,18 @@ existential variable is represented by “?” followed by an identifier. Check identity _ (fun x => _). In the general case, when an existential variable :n:`?@ident` appears -outside of its context of definition, its instance, written under the -form :n:`{ {*; @ident := @term} }` is appending to its name, indicating +outside its context of definition, its instance, written in the +form :n:`{ {*; @ident := @term} }`, is appended to its name, indicating how the variables of its defining context are instantiated. -The variables of the context of the existential variables which are -instantiated by themselves are not written, unless the :flag:`Printing Existential Instances` flag -is on (see Section :ref:`explicit-display-existentials`), and this is why an -existential variable used in the same context as its context of definition is written with no instance. +Only the variables that are defined in another context are displayed: +this is why an existential variable used in the same context as its +context of definition is written with no instance. +This behaviour may be changed: see :ref:`explicit-display-existentials`. .. coqtop:: all Check (fun x y => _) 0 1. - Set Printing Existential Instances. - - Check (fun x y => _) 0 1. - Existential variables can be named by the user upon creation using the syntax :n:`?[@ident]`. This is useful when the existential variable needs to be explicitly handled later in the script (e.g. @@ -88,6 +84,14 @@ Explicit displaying of existential instances for pretty-printing context of an existential variable is instantiated at each of the occurrences of the existential variable. +.. coqtop:: all + + Check (fun x y => _) 0 1. + + Set Printing Existential Instances. + + Check (fun x y => _) 0 1. + .. _tactics-in-terms: Solving existential variables using tactics diff --git a/doc/sphinx/language/extensions/implicit-arguments.rst b/doc/sphinx/language/extensions/implicit-arguments.rst index bbd486e3ba..ca69072cb9 100644 --- a/doc/sphinx/language/extensions/implicit-arguments.rst +++ b/doc/sphinx/language/extensions/implicit-arguments.rst @@ -70,7 +70,7 @@ is said *contextual* if it can be inferred only from the knowledge of the type of the context of the current expression. For instance, the only argument of:: - nil : forall A:Set, list A` + nil : forall A:Set, list A is contextual. Similarly, both arguments of a term of type:: @@ -539,7 +539,7 @@ with free variables into a closed statement where these variables are quantified explicitly. Use the :cmd:`Generalizable` command to designate which variables should be generalized. -It is activated for a binder by prefixing a \`, and for terms by +It is activated within a binder by prefixing it with \`, and for terms by surrounding it with \`{ }, or \`[ ] or \`( ). Terms surrounded by \`{ } introduce their free variables as maximally diff --git a/doc/sphinx/language/extensions/match.rst b/doc/sphinx/language/extensions/match.rst index b4558ef07f..c36b9deef3 100644 --- a/doc/sphinx/language/extensions/match.rst +++ b/doc/sphinx/language/extensions/match.rst @@ -90,11 +90,15 @@ constructions. There are two variants of them. First destructuring let syntax ++++++++++++++++++++++++++++++ +.. todo explain that this applies to all of the "let" constructs (Gallina, Ltac1 and Ltac2) + also add "irrefutable pattern" to the glossary + note that in Ltac2 an upper case ident is a constructor, lower case is a variable + The expression :n:`let ( {*, @ident__i } ) := @term__0 in @term__1` performs case analysis on :n:`@term__0` whose type must be an inductive type with exactly one constructor. The number of variables :n:`@ident__i` must correspond to the number of arguments of this -contrustor. Then, in :n:`@term__1`, these variables are bound to the +constructor. Then, in :n:`@term__1`, these variables are bound to the arguments of the constructor in :n:`@term__0`. For instance, the definition @@ -875,19 +879,19 @@ generated expression and the original. Here is a summary of the error messages corresponding to each situation: -.. exn:: The constructor @ident expects @num arguments. +.. exn:: The constructor @ident expects @natural arguments. + The variable ident is bound several times in pattern term + Found a constructor of inductive type term while a constructor of term is expected - The variable ident is bound several times in pattern termFound a constructor - of inductive type term while a constructor of term is expectedPatterns are - incorrect (because constructors are not applied to the correct number of the + Patterns are incorrect (because constructors are not applied to the correct number of arguments, because they are not linear or they are wrongly typed). .. exn:: Non exhaustive pattern matching. The pattern matching is not exhaustive. -.. exn:: The elimination predicate term should be of arity @num (for non \ - dependent case) or @num (for dependent case). +.. exn:: The elimination predicate term should be of arity @natural (for non \ + dependent case) or @natural (for dependent case). The elimination predicate provided to match has not the expected arity. diff --git a/doc/sphinx/practical-tools/coq-commands.rst b/doc/sphinx/practical-tools/coq-commands.rst index 058b8ccd5c..ec182ce08f 100644 --- a/doc/sphinx/practical-tools/coq-commands.rst +++ b/doc/sphinx/practical-tools/coq-commands.rst @@ -81,8 +81,7 @@ loading of the resource file with the option ``-q``. By environment variables ~~~~~~~~~~~~~~~~~~~~~~~~~ -Load path can be specified to the |Coq| system by setting up ``$COQPATH`` -environment variable. It is a list of directories separated by +``$COQPATH`` can be used to specify the load path. It is a list of directories separated by ``:`` (``;`` on Windows). |Coq| will also honor ``$XDG_DATA_HOME`` and ``$XDG_DATA_DIRS`` (see Section :ref:`libraries-and-filesystem`). @@ -92,7 +91,7 @@ not set, they look for the commands in the executable path. .. _COQ_COLORS: -The ``$COQ_COLORS`` environment variable can be used to specify the set +``$COQ_COLORS`` can be used to specify the set of colors used by ``coqtop`` to highlight its output. It uses the same syntax as the ``$LS_COLORS`` variable from GNU’s ls, that is, a colon-separated list of assignments of the form :n:`name={*; attr}` where @@ -108,6 +107,22 @@ sets the highlights for added text in diffs to underlined (the 4) with a backgro color (0, 0, 240) and for removed text in diffs to a red background. Note that if you specify ``COQ_COLORS``, the predefined attributes are ignored. +.. _OCAMLRUNPARAM: + +``$OCAMLRUNPARAM``, described +`here <https://caml.inria.fr/pub/docs/manual-ocaml/runtime.html#s:ocamlrun-options>`_, +can be used to specify certain runtime and memory usage parameters. In most cases, +experimenting with these settings will likely not cause a significant performance difference +and should be harmless. + +If the variable is not set, |Coq| uses the +`default values <https://caml.inria.fr/pub/docs/manual-ocaml/libref/Gc.html#TYPEcontrol>`_, +except that ``space_overhead`` is set to 120 and ``minor_heap_size`` is set to 32Mwords +(256MB with 64-bit executables or 128MB with 32-bit executables). + +.. todo: Using the same text "here" for both of the links in the last 2 paragraphs generates + an incorrect warning: coq-commands.rst:4: WARNING: Duplicate explicit target name: "here". + The warning doesn't even have the right line number. :-( .. _command-line-options: diff --git a/doc/sphinx/practical-tools/utilities.rst b/doc/sphinx/practical-tools/utilities.rst index d9992029ba..daae46ad11 100644 --- a/doc/sphinx/practical-tools/utilities.rst +++ b/doc/sphinx/practical-tools/utilities.rst @@ -89,10 +89,11 @@ invoking ``coq_makefile`` is the following one: Such command generates the following files: CoqMakefile - is a generic makefile for ``GNU Make`` that provides - targets to build the project (both ``.v`` and ``.ml*`` files), to install it - system-wide in the ``coq-contrib`` directory (i.e. where |Coq| is installed) - as well as to invoke coqdoc to generate HTML documentation. + is a makefile for ``GNU Make`` with targets to build the project + (e.g. generate .vo or .html files from .v or compile .ml* files) + and install it in the ``user-contrib`` directory where the |Coq| + library is installed. Run ``make`` with the ``-f CoqMakefile`` + option to use ``CoqMakefile``. CoqMakefile.conf contains make variables assignments that reflect diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index b0b0367d6d..f18569c7fd 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -74,7 +74,7 @@ The constructs in :token:`ltac_expr` are :term:`left associative`. ltac_expr0 ::= ( @ltac_expr ) | [> @for_each_goal ] | @tactic_atom - tactic_atom ::= @int + tactic_atom ::= @integer | @qualid | () @@ -188,7 +188,7 @@ examining the part at the end under "Entry tactic:tactic_arg". - * - ``integer`` - - :token:`int` + - :token:`integer` - an integer - @@ -375,8 +375,14 @@ behavior.) | ! | par - Applies :token:`ltac_expr` to the selected goals. It can only be used at the top - level of a tactic expression; it cannot be used within a tactic expression. + Reorders the goals and applies :token:`ltac_expr` to the selected goals. It can + only be used at the top level of a tactic expression; it cannot be used within a + tactic expression. The selected goals are reordered so they appear after the + lowest-numbered selected goal, ordered by goal number. :ref:`Example + <reordering_goals_ex>`. If the selector applies + to a single goal or to all goals, the reordering will not be apparent. The order of + the goals in the :token:`selector` is irrelevant. (This may not be what you expect; + see `#8481 <https://github.com/coq/coq/issues/8481>`_.) .. todo why shouldn't "all" and "!" be accepted anywhere a @selector is accepted? It would be simpler to explain. @@ -391,7 +397,7 @@ behavior.) `par` Applies :n:`@ltac_expr` to all focused goals in parallel. The number of workers can be controlled via the command line option - :n:`-async-proofs-tac-j @num` to specify the desired number of workers. + :n:`-async-proofs-tac-j @natural` to specify the desired number of workers. Limitations: ``par:`` only works on goals that don't contain existential variables. :n:`@ltac_expr` must either solve the goal completely or do nothing (i.e. it cannot make some progress). @@ -406,8 +412,8 @@ Selectors can also be used nested within a tactic expression with the .. prodn:: selector ::= {+, @range_selector } | [ @ident ] - range_selector ::= @num - @num - | @num + range_selector ::= @natural - @natural + | @natural Applies :token:`ltac_expr3` to the selected goals. @@ -420,16 +426,29 @@ Selectors can also be used nested within a tactic expression with the Limits the application of :token:`ltac_expr3` to the goal previously named :token:`ident` by the user (see :ref:`existential-variables`). - :n:`@num__1 - @num__2` - Selects the goals :n:`@num__1` through :n:`@num__2`, inclusive. + :n:`@natural__1 - @natural__2` + Selects the goals :n:`@natural__1` through :n:`@natural__2`, inclusive. - :n:`@num` + :n:`@natural` Selects a single goal. .. exn:: No such goal. :name: No such goal. (Goal selector) :undocumented: +.. _reordering_goals_ex: + +.. example:: Selector reordering goals + + .. coqtop:: reset in + + Goal 1=0 /\ 2=0 /\ 3=0. + + .. coqtop:: all + + repeat split. + 1,3: idtac. + .. TODO change error message index entry @@ -857,7 +876,7 @@ Print/identity tactic: idtac ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -.. tacn:: idtac {* {| @ident | @string | @int } } +.. tacn:: idtac {* {| @ident | @string | @natural } } :name: idtac Leaves the proof unchanged and prints the given tokens. Strings and integers are printed @@ -869,7 +888,7 @@ Print/identity tactic: idtac Failing ~~~~~~~ -.. tacn:: {| fail | gfail } {? @int_or_var } {* {| @ident | @string | @int } } +.. tacn:: {| fail | gfail } {? @int_or_var } {* {| @ident | @string | @integer } } :name: fail; gfail :tacn:`fail` is the always-failing tactic: it does not solve any @@ -897,17 +916,17 @@ Failing (backtracking). If nonzero, the current :tacn:`match goal` block, :tacn:`try`, :tacn:`repeat`, or branching command is aborted and the level is decremented. In the case of :n:`+`, a nonzero level skips the first backtrack point, even if - the call to :tacn:`fail` :n:`@num` is not enclosed in a :n:`+` construct, + the call to :tacn:`fail` :n:`@natural` is not enclosed in a :n:`+` construct, respecting the algebraic identity. - :n:`{* {| @ident | @string | @int } }` + :n:`{* {| @ident | @string | @integer } }` The given tokens are used for printing the failure message. If :token:`ident` is an |Ltac| variable, its contents are printed; if not, it is an error. .. exn:: Tactic failure. :undocumented: - .. exn:: Tactic failure (level @num). + .. exn:: Tactic failure (level @natural). :undocumented: .. exn:: No such goal. @@ -957,7 +976,7 @@ amount of time: :name: timeout :n:`@ltac_expr3` is evaluated to ``v`` which must be a tactic value. The tactic value - ``v`` is applied normally, except that it is interrupted after :n:`@num` seconds + ``v`` is applied normally, except that it is interrupted after :n:`@natural` seconds if it is still running. In this case the outcome is a failure. :tacn:`timeout` is an :token:`l3_tactic`. @@ -1122,12 +1141,14 @@ Pattern matching on terms: match then the :token:`ltac_expr` can't use `S` to refer to the constructor of `nat` without qualifying the constructor as `Datatypes.S`. - .. todo below: is matching non-linear unification? is it the same or different - from unification elsewhere in Coq? + .. todo how does this differ from the 1-2 other unification routines elsewhere in Coq? + Does it use constr_eq or eq_constr_nounivs? Matching is non-linear: if a metavariable occurs more than once, each occurrence must match the same - expression. Matching is first-order except on variables of the form :n:`@?@ident` + expression. Expressions match if they are syntactically equal or are + :term:`α-convertible <alpha-convertible>`. + Matching is first-order except on variables of the form :n:`@?@ident` that occur in the head position of an application. For these variables, matching is second-order and returns a functional term. @@ -1305,20 +1326,20 @@ Pattern matching on terms: match .. example:: Multiple matches for a "context" pattern. - Internally "x <> y" is represented as "(not x y)", which produces the + Internally "x <> y" is represented as "(~ (x = y))", which produces the first match. .. coqtop:: in reset Ltac f t := match t with - | context [ (not ?t) ] => idtac "?t = " t; fail + | context [ (~ ?t) ] => idtac "?t = " t; fail | _ => idtac end. Goal True. .. coqtop:: all - f ((not True) <> (not False)). + f ((~ True) <> (~ False)). .. _ltac-match-goal: @@ -1345,6 +1366,13 @@ Pattern matching on goals and hypotheses: match goal differences noted below, this works the same as the corresponding :n:`@match_key @ltac_expr` construct (see :tacn:`match`). Each current goal is processed independently. + Matching is non-linear: if a + metavariable occurs more than once, each occurrence must match the same + expression. Within a single term, expressions match if they are syntactically equal or + :term:`α-convertible <alpha-convertible>`. When a metavariable is used across + multiple hypotheses or across a hypothesis and the current goal, the expressions match if + they are :term:`convertible`. + :n:`{*, @match_hyp }` Patterns to match with hypotheses. Each pattern must match a distinct hypothesis in order for the branch to match. @@ -1381,7 +1409,7 @@ Pattern matching on goals and hypotheses: match goal :cmd:`Import` `ListNotations`) must be parenthesized or, for the fourth form, use double brackets: `[ [ ?l ] ]`. - :n:`@term__binder`\s in the form `[?x ; ?y]` for a list is not parsed correctly. The workaround is + :n:`@term__binder`\s in the form `[?x ; ?y]` for a list are not parsed correctly. The workaround is to add parentheses or to use the underlying term instead of the notation, i.e. `(cons ?x ?y)`. If there are multiple :token:`match_hyp`\s in a branch, there may be multiple ways to match them to hypotheses. @@ -1647,8 +1675,8 @@ Proving a subgoal as a separate lemma: abstract Does a :tacn:`solve` :n:`[ @ltac_expr2 ]` and saves the subproof as an auxiliary lemma. if :n:`@ident__name` is specified, the lemma is saved with that name; otherwise - the lemma is saved with the name :n:`@ident`\ `_subproof`\ :n:`{? @num }` where - :token:`ident` is the name of the current goal (e.g. the theorem name) and :token:`num` + the lemma is saved with the name :n:`@ident`\ `_subproof`\ :n:`{? @natural }` where + :token:`ident` is the name of the current goal (e.g. the theorem name) and :token:`natural` is chosen to get a fresh name. If the proof is closed with :cmd:`Qed`, the auxiliary lemma is inlined in the final proof term. @@ -1681,7 +1709,7 @@ Proving a subgoal as a separate lemma: abstract .. tacn:: transparent_abstract @ltac_expr3 {? using @ident } Like :tacn:`abstract`, but save the subproof in a transparent lemma with a name in - the form :n:`@ident`\ :n:`_subterm`\ :n:`{? @num }`. + the form :n:`@ident`\ :n:`_subterm`\ :n:`{? @natural }`. .. warning:: @@ -2169,7 +2197,7 @@ Backtraces Tracing execution ~~~~~~~~~~~~~~~~~ -.. cmd:: Info @num @ltac_expr +.. cmd:: Info @natural @ltac_expr Applies :token:`ltac_expr` and prints a trace of the tactics that were successfully applied, discarding branches that failed. @@ -2177,7 +2205,7 @@ Tracing execution This command is valid only in proof mode. It accepts :ref:`goal-selectors`. - The number :n:`@num` is the unfolding level of tactics in the trace. At level + The number :n:`@natural` is the unfolding level of tactics in the trace. At level 0, the trace contains a sequence of tactics in the actual script, at level 1, the trace will be the concatenation of the traces of these tactics, etc… @@ -2209,12 +2237,12 @@ Tracing execution position in the script. In particular, the calls to idtac in branches which failed are not printed. - .. opt:: Info Level @num + .. opt:: Info Level @natural :name: Info Level This option is an alternative to the :cmd:`Info` command. - This will automatically print the same trace as :n:`Info @num` at each + This will automatically print the same trace as :n:`Info @natural` at each tactic call. The unfolding level can be overridden by a call to the :cmd:`Info` command. @@ -2274,11 +2302,11 @@ performance issue. This flag enables and disables the profiler. -.. cmd:: Show Ltac Profile {? {| CutOff @int | @string } } +.. cmd:: Show Ltac Profile {? {| CutOff @integer | @string } } Prints the profile. - :n:`CutOff @int` + :n:`CutOff @integer` By default, tactics that account for less than 2% of the total time are not displayed. `CutOff` lets you specify a different percentage. @@ -2345,7 +2373,7 @@ performance issue. Equivalent to the :cmd:`Reset Ltac Profile` command, which allows resetting the profile from tactic scripts for benchmarking purposes. -.. tacn:: show ltac profile {? {| cutoff @int | @string } } +.. tacn:: show ltac profile {? {| cutoff @integer | @string } } :name: show ltac profile Equivalent to the :cmd:`Show Ltac Profile` command, diff --git a/doc/sphinx/proof-engine/ltac2.rst b/doc/sphinx/proof-engine/ltac2.rst index 1e35160205..773e393eb6 100644 --- a/doc/sphinx/proof-engine/ltac2.rst +++ b/doc/sphinx/proof-engine/ltac2.rst @@ -27,6 +27,50 @@ especially wherever an advanced tactic language is needed. The previous implementation of Ltac, described in the previous chapter, will be referred to as Ltac1. +Current limitations include: + +- There are a number of tactics that are not yet supported in Ltac2 because + the interface OCaml and/or Ltac2 notations haven't been written. See + :ref:`defining_tactics`. + +- Missing usability features such as: + + - Printing functions are limited and awkward to use. Only a few data types are + printable. + - Deep pattern matching and matching on tuples don't work. + - If statements on Ltac2 boolean values + - A convenient way to build terms with casts through the low-level API. Because the + cast type is opaque, building terms with casts currently requires an awkward construction like the + following, which also incurs extra overhead to repeat typechecking for each + call to `get_vm_cast`: + + .. coqdoc:: + + Constr.Unsafe.make (Constr.Unsafe.Cast 'I (get_vm_cast ()) 'True) + + with: + + .. coqtop:: none + + From Ltac2 Require Import Ltac2. + + .. coqtop:: in + + Ltac2 get_vm_cast () := + match Constr.Unsafe.kind '(I <: True) with + | Constr.Unsafe.Cast _ cst _ => cst + | _ => Control.throw Not_found + end. + +- Missing low-level primitives that are convenient for writing automation, such as: + + - An easy way to get the number of constructors of an inductive type. + Currently only way to do this is to destruct a variable of the inductive type + and count the number of goals that result. +- The :attr:`deprecated` attribute is not supported for Ltac2 definitions. + +- Error messages may be cryptic. + .. _ltac2_design: General design @@ -49,7 +93,7 @@ In particular, Ltac2 is: Coq-side terms - a language featuring notation facilities to help write palatable scripts -We describe more in details each point in the remainder of this document. +We describe these in more detail in the remainder of this document. ML component ------------ @@ -84,7 +128,7 @@ which allows to ensure that Ltac2 satisfies the same equations as a generic ML with unspecified effects would do, e.g. function reduction is substitution by a value. -To import Ltac2, use the following command: +Use the following command to import Ltac2: .. coqtop:: in @@ -96,17 +140,20 @@ Type Syntax At the level of terms, we simply elaborate on Ltac1 syntax, which is quite close to OCaml. Types follow the simply-typed syntax of OCaml. -The non-terminal :production:`lident` designates identifiers starting with a -lowercase. +.. insertprodn ltac2_type ltac2_typevar -.. productionlist:: coq - ltac2_type : ( `ltac2_type`, ... , `ltac2_type` ) `ltac2_typeconst` - : ( `ltac2_type` * ... * `ltac2_type` ) - : `ltac2_type` -> `ltac2_type` - : `ltac2_typevar` - ltac2_typeconst : ( `modpath` . )* `lident` - ltac2_typevar : '`lident` - ltac2_typeparams : ( `ltac2_typevar`, ... , `ltac2_typevar` ) +.. prodn:: + ltac2_type ::= @ltac2_type2 -> @ltac2_type + | @ltac2_type2 + ltac2_type2 ::= @ltac2_type1 * {+* @ltac2_type1 } + | @ltac2_type1 + ltac2_type1 ::= @ltac2_type0 @qualid + | @ltac2_type0 + ltac2_type0 ::= ( {+, @ltac2_type } ) {? @qualid } + | @ltac2_typevar + | _ + | @qualid + ltac2_typevar ::= ' @ident The set of base types can be extended thanks to the usual ML type declarations such as algebraic datatypes and records. @@ -126,114 +173,156 @@ Type declarations One can define new types with the following commands. -.. cmd:: Ltac2 Type {? @ltac2_typeparams } @lident +.. cmd:: Ltac2 Type {? rec } @tac2typ_def {* with @tac2typ_def } :name: Ltac2 Type - This command defines an abstract type. It has no use for the end user and - is dedicated to types representing data coming from the OCaml world. + .. insertprodn tac2typ_def tac2rec_field -.. cmdv:: Ltac2 Type {? rec} {? @ltac2_typeparams } @lident := @ltac2_typedef + .. prodn:: + tac2typ_def ::= {? @tac2typ_prm } @qualid {? {| := | ::= } @tac2typ_knd } + tac2typ_prm ::= @ltac2_typevar + | ( {+, @ltac2_typevar } ) + tac2typ_knd ::= @ltac2_type + | [ {? {? %| } {+| @tac2alg_constructor } } ] + | [ .. ] + | %{ {? {+; @tac2rec_field } {? ; } } %} + tac2alg_constructor ::= @ident + | @ident ( {*, @ltac2_type } ) + tac2rec_field ::= {? mutable } @ident : @ltac2_type - This command defines a type with a manifest. There are four possible - kinds of such definitions: alias, variant, record and open variant types. + :n:`:=` + Defines a type with with an explicit set of constructors - .. productionlist:: coq - ltac2_typedef : `ltac2_type` - : [ `ltac2_constructordef` | ... | `ltac2_constructordef` ] - : { `ltac2_fielddef` ; ... ; `ltac2_fielddef` } - : [ .. ] - ltac2_constructordef : `uident` [ ( `ltac2_type` , ... , `ltac2_type` ) ] - ltac2_fielddef : [ mutable ] `ident` : `ltac2_type` + :n:`::=` + Extends an existing open variant type, a special kind of variant type whose constructors are not + statically defined, but can instead be extended dynamically. A typical example + is the standard `exn` type for exceptions. Pattern matching on open variants must always + include a catch-all clause. They can be extended with this form, in which case + :token:`tac2typ_knd` should be in the form :n:`[ {? {? %| } {+| @tac2alg_constructor } } ]`. - Aliases are just a name for a given type expression and are transparently - unfoldable to it. They cannot be recursive. The non-terminal - :production:`uident` designates identifiers starting with an uppercase. + Without :n:`{| := | ::= }` + Defines an abstract type for use representing data from OCaml. Not for + end users. + + :n:`with @tac2typ_def` + Permits definition of mutually recursive type definitions. + + Each production of :token:`tac2typ_knd` defines one of four possible kinds + of definitions, respectively: alias, variant, open variant and record types. + + Aliases are names for a given type expression and are transparently + unfoldable to that expression. They cannot be recursive. + + .. The non-terminal :token:`uident` designates identifiers starting with an uppercase. Variants are sum types defined by constructors and eliminated by pattern-matching. They can be recursive, but the `rec` flag must be explicitly set. Pattern matching must be exhaustive. + Open variants can be extended with additional constructors using the `::=` form. + Records are product types with named fields and eliminated by projection. Likewise they can be recursive if the `rec` flag is set. - .. cmdv:: Ltac2 Type {? @ltac2_typeparams } @ltac2_qualid ::= [ @ltac2_constructordef ] +.. cmd:: Ltac2 @ external @ident : @ltac2_type := @string @string + :name: Ltac2 external + + Declares abstract terms. Frequently, these declare OCaml functions + defined in |Coq| and give their type information. They can also declare + data structures from OCaml. This command has no use for the end user. + +APIs +~~~~ + +Ltac2 provides over 150 API functions that provide various capabilities. These +are declared with :cmd:`Ltac2 external` in :n:`lib/coq/user-contrib/Ltac2/*.v`. +For example, `Message.print` defined in `Message.v` is used to print messages: - Open variants are a special kind of variant types whose constructors are not - statically defined, but can instead be extended dynamically. A typical example - is the standard `exn` type. Pattern matching on open variants must always include a catch-all - clause. They can be extended with this command. +.. coqtop:: none + + Goal True. + +.. coqtop:: all abort + + Message.print (Message.of_string "fully qualified calls"). + From Ltac2 Require Import Message. + print (of_string "unqualified calls"). Term Syntax ~~~~~~~~~~~ -The syntax of the functional fragment is very close to the one of Ltac1, except +The syntax of the functional fragment is very close to that of Ltac1, except that it adds a true pattern-matching feature, as well as a few standard constructs from ML. -.. productionlist:: coq - ltac2_var : `lident` - ltac2_qualid : ( `modpath` . )* `lident` - ltac2_constructor: `uident` - ltac2_term : `ltac2_qualid` - : `ltac2_constructor` - : `ltac2_term` `ltac2_term` ... `ltac2_term` - : fun `ltac2_var` => `ltac2_term` - : let `ltac2_var` := `ltac2_term` in `ltac2_term` - : let rec `ltac2_var` := `ltac2_term` in `ltac2_term` - : match `ltac2_term` with `ltac2_branch` ... `ltac2_branch` end - : `int` - : `string` - : `ltac2_term` ; `ltac2_term` - : [| `ltac2_term` ; ... ; `ltac2_term` |] - : ( `ltac2_term` , ... , `ltac2_term` ) - : { `ltac2_field` `ltac2_field` ... `ltac2_field` } - : `ltac2_term` . ( `ltac2_qualid` ) - : `ltac2_term` . ( `ltac2_qualid` ) := `ltac2_term` - : [; `ltac2_term` ; ... ; `ltac2_term` ] - : `ltac2_term` :: `ltac2_term` - : ... - ltac2_branch : `ltac2_pattern` => `ltac2_term` - ltac2_pattern : `ltac2_var` - : _ - : ( `ltac2_pattern` , ... , `ltac2_pattern` ) - : `ltac2_constructor` `ltac2_pattern` ... `ltac2_pattern` - : [ ] - : `ltac2_pattern` :: `ltac2_pattern` - ltac2_field : `ltac2_qualid` := `ltac2_term` - -In practice, there is some additional syntactic sugar that allows e.g. to -bind a variable and match on it at the same time, in the usual ML style. +In practice, there is some additional syntactic sugar that allows the +user to bind a variable and match on it at the same time, in the usual ML style. There is dedicated syntax for list and array literals. -.. note:: +.. insertprodn ltac2_expr ltac2_tactic_atom + +.. prodn:: + ltac2_expr ::= @ltac2_expr5 ; @ltac2_expr + | @ltac2_expr5 + ltac2_expr5 ::= fun {+ @tac2pat0 } => @ltac2_expr + | let {? rec } @ltac2_let_clause {* with @ltac2_let_clause } in @ltac2_expr + | @ltac2_expr3 + ltac2_let_clause ::= {+ @tac2pat0 } := @ltac2_expr + ltac2_expr3 ::= {+, @ltac2_expr2 } + ltac2_expr2 ::= @ltac2_expr1 :: @ltac2_expr2 + | @ltac2_expr1 + ltac2_expr1 ::= @ltac2_expr0 {+ @ltac2_expr0 } + | @ltac2_expr0 .( @qualid ) + | @ltac2_expr0 .( @qualid ) := @ltac2_expr5 + | @ltac2_expr0 + tac2rec_fieldexpr ::= @qualid := @ltac2_expr1 + ltac2_expr0 ::= ( @ltac2_expr ) + | ( @ltac2_expr : @ltac2_type ) + | () + | [ {*; @ltac2_expr5 } ] + | %{ {? {+ @tac2rec_fieldexpr } {? ; } } %} + | @ltac2_tactic_atom + ltac2_tactic_atom ::= @integer + | @string + | @qualid + | @ @ident + | & @lident + | ' @term + | @ltac2_quotations + +The non-terminal :production:`lident` designates identifiers starting with a +lowercase letter. + +:n:`'@term` is equivalent to :n:`open_constr:(@term)`. - For now, deep pattern matching is not implemented. -Ltac Definitions -~~~~~~~~~~~~~~~~ -.. cmd:: Ltac2 {? mutable} {? rec} @lident := @ltac2_value +Ltac2 Definitions +~~~~~~~~~~~~~~~~~ + +.. cmd:: Ltac2 {? mutable } {? rec } @tac2def_body {* with @tac2def_body } :name: Ltac2 - This command defines a new global Ltac2 value. + .. insertprodn tac2def_body tac2def_body + + .. prodn:: + tac2def_body ::= {| _ | @ident } {* @tac2pat0 } := @ltac2_expr + + This command defines a new global Ltac2 value. If one or more :token:`tac2pat0` + are specified, the new value is a function. This is a shortcut for one of the + :token:`ltac2_expr5` productions. For example: :n:`Ltac2 foo a b := …` is equivalent + to :n:`Ltac2 foo := fun a b => …`. The body of an Ltac2 definition is required to be a syntactical value that is, a function, a constant, a pure constructor recursively applied to values or a (non-recursive) let binding of a value in a value. - .. productionlist:: coq - ltac2_value: fun `ltac2_var` => `ltac2_term` - : `ltac2_qualid` - : `ltac2_constructor` `ltac2_value` ... `ltac2_value` - : `ltac2_var` - : let `ltac2_var` := `ltac2_value` in `ltac2_value` - If ``rec`` is set, the tactic is expanded into a recursive binding. If ``mutable`` is set, the definition can be redefined at a later stage (see below). -.. cmd:: Ltac2 Set @qualid {? as @lident} := @ltac2_term +.. cmd:: Ltac2 Set @qualid {? as @ident } := @ltac2_expr :name: Ltac2 Set This command redefines a previous ``mutable`` definition. @@ -254,7 +343,6 @@ Ltac Definitions .. example:: Interaction with recursive calls - .. coqtop:: all Ltac2 mutable rec f b := match b with true => 0 | _ => f true end. @@ -334,7 +422,7 @@ Intuitively a thunk of type :n:`unit -> 'a` can do the following: i.e. thunks can produce a lazy list of results where each tail is waiting for a continuation exception. - It can access a backtracking proof state, consisting among other things of - the current evar assignation and the list of goals under focus. + the current evar assignment and the list of goals under focus. We now describe more thoroughly the various effects in Ltac2. @@ -348,8 +436,8 @@ Mutable fields of records can be modified using the set syntax. Likewise, built-in types like `string` and `array` feature imperative assignment. See modules `String` and `Array` respectively. -A few printing primitives are provided in the `Message` module, allowing to -display information to the user. +A few printing primitives are provided in the `Message` module for +displaying information to the user. Fatal errors ++++++++++++ @@ -458,20 +546,27 @@ Ltac2 makes these explicit using quoting and unquoting notation, although there are notations to do it in a short and elegant way so as not to be too cumbersome to the user. -Generic Syntax for Quotations -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In general, quotations can be introduced in terms using the following syntax, where -:production:`quotentry` is some parsing entry. - -.. prodn:: - ltac2_term += @ident : ( @quotentry ) +Quotations +~~~~~~~~~~ .. _ltac2_built-in-quotations: Built-in quotations +++++++++++++++++++ +.. insertprodn ltac2_quotations ltac1_expr_in_env + +.. prodn:: + ltac2_quotations ::= ident : ( @lident ) + | constr : ( @term ) + | open_constr : ( @term ) + | pattern : ( @cpattern ) + | reference : ( {| & @ident | @qualid } ) + | ltac1 : ( @ltac1_expr_in_env ) + | ltac1val : ( @ltac1_expr_in_env ) + ltac1_expr_in_env ::= @ltac_expr + | {* @ident } |- @ltac_expr + The current implementation recognizes the following built-in quotations: - ``ident``, which parses identifiers (type ``Init.ident``). @@ -481,16 +576,17 @@ The current implementation recognizes the following built-in quotations: holes at runtime (type ``Init.constr`` as well). - ``pattern``, which parses Coq patterns and produces a pattern used for term matching (type ``Init.pattern``). -- ``reference``, which parses either a :n:`@qualid` or :n:`&@ident`. Qualified names +- ``reference`` Qualified names are globalized at internalization into the corresponding global reference, while ``&id`` is turned into ``Std.VarRef id``. This produces at runtime a - ``Std.reference``. There shall be no white space between the ampersand - symbol (``&``) and the identifier (:n:`@ident`). + ``Std.reference``. +- ``ltac1``, for calling Ltac1 code, described in :ref:`simple_api`. +- ``ltac1val``, for manipulating Ltac1 values, described in :ref:`low_level_api`. -The following syntactic sugar is provided for two common cases. +The following syntactic sugar is provided for two common cases: - ``@id`` is the same as ``ident:(id)`` -- ``'t`` is the same as ``open_constr:(t)`` +- :n:`'@term` is the same as :n:`open_constr:(@term)` Strict vs. non-strict mode ++++++++++++++++++++++++++ @@ -521,11 +617,11 @@ Term Antiquotations Syntax ++++++ -One can also insert Ltac2 code into Coq terms, similarly to what is possible in +One can also insert Ltac2 code into Coq terms, similar to what is possible in Ltac1. .. prodn:: - term += ltac2:( @ltac2_term ) + term += ltac2:( @ltac2_expr ) Antiquoted terms are expected to have type ``unit``, as they are only evaluated for their side-effects. @@ -659,168 +755,473 @@ insert in a concise way an Ltac2 variable of type :n:`constr` into a Coq term. Match over terms ~~~~~~~~~~~~~~~~ -Ltac2 features a construction similar to Ltac1 :n:`match` over terms, although +Ltac2 features a construction similar to Ltac1 :tacn:`match` over terms, although in a less hard-wired way. -.. productionlist:: coq - ltac2_term : match! `ltac2_term` with `constrmatching` .. `constrmatching` end - : lazy_match! `ltac2_term` with `constrmatching` .. `constrmatching` end - : multi_match! `ltac2_term` with `constrmatching` .. `constrmatching` end - constrmatching : | `constrpattern` => `ltac2_term` - constrpattern : `term` - : context [ `term` ] - : context `lident` [ `term` ] - -This construction is not primitive and is desugared at parsing time into -calls to term matching functions from the `Pattern` module. Internally, it is -implemented thanks to a specific scope accepting the :n:`@constrmatching` syntax. - -Variables from the :n:`@constrpattern` are statically bound in the body of the branch, to -values of type `constr` for the variables from the :n:`@term` pattern and to a -value of type `Pattern.context` for the variable :n:`@lident`. - -Note that unlike Ltac, only lowercase identifiers are valid as Ltac2 -bindings, so that there will be a syntax error if one of the bound variables +.. tacn:: @ltac2_match_key @ltac2_expr__term with @ltac2_match_list end + :name: lazy_match!; match!; multi_match! + + .. insertprodn ltac2_match_key ltac2_match_pattern + + .. prodn:: + ltac2_match_key ::= lazy_match! + | match! + | multi_match! + ltac2_match_list ::= {? %| } {+| @ltac2_match_rule } + ltac2_match_rule ::= @ltac2_match_pattern => @ltac2_expr + ltac2_match_pattern ::= @cpattern + | context {? @ident } [ @cpattern ] + + Evaluates :n:`@ltac2_expr__term`, which must yield a term, and matches it + sequentially with the :token:`ltac2_match_pattern`\s, which may contain + metavariables. When a match is found, metavariable values are substituted + into :n:`@ltac2_expr`, which is then applied. + + Matching may continue depending on whether `lazy_match!`, `match!` or `multi_match!` + is specified. + + In the :token:`ltac2_match_pattern`\s, metavariables have the form :n:`?@ident`, whereas + in the :n:`@ltac2_expr`\s, the question mark is omitted. + + .. todo how does this differ from the 1-2 other unification routines elsewhere in Coq? + + Matching is non-linear: if a + metavariable occurs more than once, each occurrence must match the same + expression. Expressions match if they are syntactically equal or are + :term:`α-convertible <alpha-convertible>`. + Matching is first-order except on variables of the form :n:`@?@ident` + that occur in the head position of an application. For these variables, + matching is second-order and returns a functional term. + + .. todo the `@?ident` form is in dangling_pattern_extension_rule, not included in the doc yet + maybe belongs with "Applications" + + `lazy_match!` + Causes the match to commit to the first matching branch + rather than trying a new match if :n:`@ltac2_expr` fails. + :ref:`Example<ltac2_match_vs_lazymatch_ex>`. + + `match!` + If :n:`@ltac2_expr` fails, continue matching with the next branch. + Failures in subsequent tactics (after the `match!`) will not cause selection + of a new branch. Examples :ref:`here<ltac2_match_vs_lazymatch_ex>` and + :ref:`here<ltac2_match_vs_multimatch_ex>`. + + `multi_match!` + If :n:`@ltac2_expr` fails, continue matching with the next branch. + When a :n:`@ltac2_expr` succeeds for a branch, subsequent failures + (after the `multi_match!`) causing consumption of all the successes + of :n:`@ltac2_expr` trigger selection of a new matching branch. + :ref:`Example<ltac2_match_vs_multimatch_ex>`. + + :n:`@cpattern` + The syntax of :token:`cpattern` is + the same as that of :token:`term`\s, but it can contain pattern matching + metavariables in the form :n:`?@ident` and :n:`@?@ident`. :g:`_` can be used to match + irrelevant terms. + + .. todo more on @?@ident here: https://github.com/coq/coq/pull/12085#discussion_r467504046 + .. todo Example is broken :ref:`Example<ltac2_match_with_holes_ex>`. + + .. todo Didn't understand the following 2 paragraphs well enough to revise + see https://github.com/coq/coq/pull/12103#discussion_r436297754 for a + possible example + + Unlike Ltac1, Ltac2 :n:`?id` metavariables only match closed terms. + + There is also a special notation for second-order pattern matching: in an + applicative pattern of the form :n:`@?@ident @ident__1 … @ident__n`, + the variable :token:`ident` matches any complex expression with (possible) + dependencies in the variables :n:`@ident__i` and returns a functional term + of the form :n:`fun @ident__1 … @ident__n => @term`. + + .. _match_term_context: + + :n:`context {? @ident } [ @cpattern ]` + Matches any term with a subterm matching :token:`cpattern`. If there is a match + and :n:`@ident` is present, it is assigned the "matched + context", i.e. the initial term where the matched subterm is replaced by a + hole. This hole in the matched context can be filled with the expression + :n:`Pattern.instantiate @ident @cpattern`. + + For :tacn:`match!` and :tacn:`multi_match!`, if the evaluation of the :token:`ltac2_expr` + fails, the next matching subterm is tried. If no further subterm matches, the next branch + is tried. Matching subterms are considered from top to bottom and from left to + right (with respect to the raw printing obtained by setting the + :flag:`Printing All` flag). :ref:`Example<ltac2_match_term_context_ex>`. + + .. todo There's a more realistic example from @JasonGross here: + https://github.com/coq/coq/pull/12103#discussion_r432996954 + + :n:`@ltac2_expr` + The tactic to apply if the construct matches. Metavariable values from the pattern + match are statically bound as Ltac2 variables in :n:`@ltac2_expr` before + it is applied. + + If :n:`@ltac2_expr` is a tactic with backtracking points, then subsequent + failures after a :tacn:`lazy_match!` or :tacn:`multi_match!` (but not :tacn:`match!`) can cause + backtracking into :n:`@ltac2_expr` to select its next success. + + Variables from the :n:`@tac2pat1` are statically bound in the body of the branch. + Variables from the :n:`@term` pattern have values of type `constr`. + Variables from the :n:`@ident` in the `context` construct have values of type + `Pattern.context` (defined in `Pattern.v`). + +Note that unlike Ltac1, only lowercase identifiers are valid as Ltac2 +bindings. Ltac2 will report an error if one of the bound variables starts with an uppercase character. -The semantics of this construction is otherwise the same as the corresponding +The semantics of this construction are otherwise the same as the corresponding one from Ltac1, except that it requires the goal to be focused. +.. _ltac2_match_vs_lazymatch_ex: + +.. example:: Ltac2 Comparison of lazy_match! and match! + + (Equivalent to this :ref:`Ltac1 example<match_vs_lazymatch_ex>`.) + + These lines define a `msg` tactic that's used in several examples as a more-succinct + alternative to `print (to_string "...")`: + + .. coqtop:: in + + From Ltac2 Require Import Message. + Ltac2 msg x := print (of_string x). + + .. coqtop:: none + + Goal True. + + In :tacn:`lazy_match!`, if :token:`ltac2_expr` fails, the :tacn:`lazy_match!` fails; + it doesn't look for further matches. In :tacn:`match!`, if :token:`ltac2_expr` fails + in a matching branch, it will try to match on subsequent branches. Note that + :n:`'@term` below is equivalent to :n:`open_constr:(@term)`. + + .. coqtop:: all + + Fail lazy_match! 'True with + | True => msg "branch 1"; fail + | _ => msg "branch 2" + end. + + match! 'True with + | True => msg "branch 1"; fail + | _ => msg "branch 2" + end. + +.. _ltac2_match_vs_multimatch_ex: + +.. example:: Ltac2 Comparison of match! and multi_match! + + (Equivalent to this :ref:`Ltac1 example<match_vs_multimatch_ex>`.) + + :tacn:`match!` tactics are only evaluated once, whereas :tacn:`multi_match!` + tactics may be evaluated more than once if the following constructs trigger backtracking: + + .. coqtop:: all + + Fail match! 'True with + | True => msg "branch 1" + | _ => msg "branch 2" + end ; + msg "branch A"; fail. + + .. coqtop:: all + + Fail multi_match! 'True with + | True => msg "branch 1" + | _ => msg "branch 2" + end ; + msg "branch A"; fail. + +.. _ltac2_match_with_holes_ex: + +.. todo EXAMPLE DOESN'T WORK: Ltac2 does not (yet?) handle pattern variables matching open terms. + Matching a pattern with holes + + (Equivalent to this :ref:`Ltac1 example<match_with_holes_ex>`.) + + Notice the :tacn:`idtac` prints ``(z + 1)`` while the :tacn:`pose` substitutes + ``(x + 1)``. + + .. coqtop:: all + + match! constr:(fun x => (x + 1) * 3) with + | fun z => ?y * 3 => print (of_constr y); pose (fun z: nat => $y * 5) + end. + +.. _ltac2_match_term_context_ex: + +.. example:: Ltac2 Multiple matches for a "context" pattern. + + (Equivalent to this :ref:`Ltac1 example<match_term_context_ex>`.) + + Internally "x <> y" is represented as "(~ (x = y))", which produces the + first match. + + .. coqtop:: in + + Ltac2 f2 t := match! t with + | context [ (~ ?t) ] => print (of_constr t); fail + | _ => () + end. + + .. coqtop:: all abort + + f2 constr:((~ True) <> (~ False)). + Match over goals ~~~~~~~~~~~~~~~~ -Similarly, there is a way to match over goals in an elegant way, which is -just a notation desugared at parsing time. +.. tacn:: @ltac2_match_key {? reverse } goal with @goal_match_list end + :name: lazy_match! goal; match! goal; multi_match! goal -.. productionlist:: coq - ltac2_term : match! [ reverse ] goal with `goalmatching` ... `goalmatching` end - : lazy_match! [ reverse ] goal with `goalmatching` ... `goalmatching` end - : multi_match! [ reverse ] goal with `goalmatching` ... `goalmatching` end - goalmatching : | [ `hypmatching` ... `hypmatching` |- `constrpattern` ] => `ltac2_term` - hypmatching : `lident` : `constrpattern` - : _ : `constrpattern` + .. insertprodn goal_match_list gmatch_hyp_pattern -Variables from :n:`@hypmatching` and :n:`@constrpattern` are bound in the body of the -branch. Their types are: + .. prodn:: + goal_match_list ::= {? %| } {+| @gmatch_rule } + gmatch_rule ::= @gmatch_pattern => @ltac2_expr + gmatch_pattern ::= [ {*, @gmatch_hyp_pattern } |- @ltac2_match_pattern ] + gmatch_hyp_pattern ::= @name : @ltac2_match_pattern -- ``constr`` for pattern variables appearing in a :n:`@term` -- ``Pattern.context`` for variables binding a context -- ``ident`` for variables binding a hypothesis name. + Matches over goals, similar to Ltac1 :tacn:`match goal`. + Use this form to match hypotheses and/or goals in the proof context. These patterns have zero or + more subpatterns to match hypotheses followed by a subpattern to match the conclusion. Except for the + differences noted below, this works the same as the corresponding :n:`@ltac2_match_key @ltac2_expr` construct + (see :tacn:`match!`). Each current goal is processed independently. -The same identifier caveat as in the case of matching over constr applies, and -this features has the same semantics as in Ltac1. In particular, a ``reverse`` -flag can be specified to match hypotheses from the more recently introduced to -the least recently introduced one. + Matching is non-linear: if a + metavariable occurs more than once, each occurrence must match the same + expression. Within a single term, expressions match if they are syntactically equal or + :term:`α-convertible <alpha-convertible>`. When a metavariable is used across + multiple hypotheses or across a hypothesis and the current goal, the expressions match if + they are :term:`convertible`. -.. _ltac2_notations: + .. more detail here: https://github.com/coq/coq/pull/12085#discussion_r470406466 -Notations ---------- + :n:`{*, @gmatch_pattern }` + Patterns to match with hypotheses. Each pattern must match a distinct hypothesis in order + for the branch to match. -Notations are the crux of the usability of Ltac1. We should be able to recover -a feeling similar to the old implementation by using and abusing notations. + Hypotheses have the form :n:`@name {? := @term__binder } : @type`. Currently Ltac2 doesn't + allow matching on or capturing the value of :n:`@term__binder`. It only supports matching on + the :token:`name` and the :token:`type`, for example `n : ?t`. -Scopes -~~~~~~ + .. currently only supports the first row + :list-table:: + :widths: 2 1 + :header-rows: 1 -A scope is a name given to a grammar entry used to produce some Ltac2 expression -at parsing time. Scopes are described using a form of S-expression. + * - Pattern syntax + - Example pattern -.. prodn:: - ltac2_scope ::= {| @string | @int | @lident ({+, @ltac2_scope}) } + * - :n:`@name : @ltac2_match_pattern` + - `n : ?t` -A few scopes contain antiquotation features. For the sake of uniformity, all -antiquotations are introduced by the syntax :n:`$@lident`. + * - :n:`@name := @match_pattern__binder` + - `n := ?b` -The following scopes are built-in. + * - :n:`@name := @term__binder : @type` + - `n := ?b : ?t` -- :n:`constr`: + * - :n:`@name := [ @match_pattern__binder ] : @ltac2_match_pattern` + - `n := [ ?b ] : ?t` - + parses :n:`c = @term` and produces :n:`constr:(c)` + :token:`name` can't have a `?`. Note that the last two forms are equivalent except that: - This scope can be parameterized by a list of delimiting keys of notation - scopes (as described in :ref:`LocalInterpretationRulesForNotations`), - describing how to interpret the parsed term. For instance, :n:`constr(A, B)` - parses :n:`c = @term` and produces :n:`constr:(c%A%B)`. + - if the `:` in the third form has been bound to something else in a notation, you must use the fourth form. + Note that cmd:`Require Import` `ssreflect` loads a notation that does this. + - a :n:`@term__binder` such as `[ ?l ]` (e.g., denoting a singleton list after + :cmd:`Import` `ListNotations`) must be parenthesized or, for the fourth form, + use double brackets: `[ [ ?l ] ]`. -- :n:`ident`: + If there are multiple :token:`gmatch_hyp_pattern`\s in a branch, there may be multiple ways to match them to hypotheses. + For :tacn:`match! goal` and :tacn:`multi_match! goal`, if the evaluation of the :token:`ltac2_expr` fails, + matching will continue with the next hypothesis combination. When those are exhausted, + the next alternative from any `context` construct in the :token:`ltac2_match_pattern`\s is tried and then, + when the context alternatives are exhausted, the next branch is tried. + :ref:`Example<ltac2_match_goal_multiple_hyps_ex>`. - + parses :n:`id = @ident` and produces :n:`ident:(id)` - + parses :n:`$(x = @ident)` and produces the variable :n:`x` + `reverse` + Hypothesis matching for :token:`gmatch_hyp_pattern`\s normally begins by matching them from left to right, + to hypotheses, last to first. Specifying `reverse` begins matching in the reverse order, from + first to last. :ref:`Normal<ltac2_match_goal_hyps_ex>` and :ref:`reverse<ltac2_match_goal_hyps_rev_ex>` examples. -- :n:`list0(@ltac2_scope)`: + :n:`|- @ltac2_match_pattern` + A pattern to match with the current goal - + if :n:`@ltac2_scope` parses :n:`@quotentry`, - then it parses :n:`(@quotentry__0, ..., @quotentry__n)` and produces - :n:`[@quotentry__0; ...; @quotentry__n]`. + Note that unlike Ltac1, only lowercase identifiers are valid as Ltac2 + bindings. Ltac2 will report an error if you try to use a bound variable + that starts with an uppercase character. -- :n:`list0(@ltac2_scope, sep = @string__sep)`: + Variables from :n:`@gmatch_hyp_pattern` and :n:`@ltac2_match_pattern` are + bound in the body of the branch. Their types are: - + if :n:`@ltac2_scope` parses :n:`@quotentry`, - then it parses :n:`(@quotentry__0 @string__sep ... @string__sep @quotentry__n)` - and produce :n:`[@quotentry__0; ...; @quotentry__n]`. + - ``constr`` for pattern variables appearing in a :n:`@term` + - ``Pattern.context`` for variables binding a context + - ``ident`` for variables binding a hypothesis name. -- :n:`list1`: same as :n:`list0` (with or without separator) but parses :n:`{+ @quotentry}` instead - of :n:`{* @quotentry}`. + The same identifier caveat as in the case of matching over constr applies, and + this feature has the same semantics as in Ltac1. -- :n:`opt(@ltac2_scope)` +.. _ltac2_match_goal_hyps_ex: - + if :n:`@ltac2_scope` parses :n:`@quotentry`, parses :n:`{? @quotentry}` and produces either :n:`None` or - :n:`Some x` where :n:`x` is the parsed expression. +.. example:: Ltac2 Matching hypotheses -- :n:`self`: + (Equivalent to this :ref:`Ltac1 example<match_goal_hyps_ex>`.) - + parses a Ltac2 expression at the current level and returns it as is. + Hypotheses are matched from the last hypothesis (which is by default the newest + hypothesis) to the first until the :tacn:`apply` succeeds. -- :n:`next`: + .. coqtop:: all abort - + parses a Ltac2 expression at the next level and returns it as is. + Goal forall A B : Prop, A -> B -> (A->B). + intros. + match! goal with + | [ h : _ |- _ ] => let h := Control.hyp h in print (of_constr h); apply $h + end. -- :n:`tactic(n = @int)`: +.. _ltac2_match_goal_hyps_rev_ex: - + parses a Ltac2 expression at the provided level :n:`n` and returns it as is. +.. example:: Matching hypotheses with reverse -- :n:`thunk(@ltac2_scope)`: + (Equivalent to this :ref:`Ltac1 example<match_goal_hyps_rev_ex>`.) - + parses the same as :n:`scope`, and if :n:`e` is the parsed expression, returns - :n:`fun () => e`. + Hypotheses are matched from the first hypothesis to the last until the :tacn:`apply` succeeds. -- :n:`STRING`: + .. coqtop:: all abort - + parses the corresponding string as an identifier and returns :n:`()`. + Goal forall A B : Prop, A -> B -> (A->B). + intros. + match! reverse goal with + | [ h : _ |- _ ] => let h := Control.hyp h in print (of_constr h); apply $h + end. -- :n:`keyword(s = @string)`: +.. _ltac2_match_goal_multiple_hyps_ex: - + parses the string :n:`s` as a keyword and returns `()`. +.. example:: Multiple ways to match a hypotheses -- :n:`terminal(s = @string)`: + (Equivalent to this :ref:`Ltac1 example<match_goal_multiple_hyps_ex>`.) - + parses the string :n:`s` as a keyword, if it is already a - keyword, otherwise as an :n:`@ident`. Returns `()`. + Every possible match for the hypotheses is evaluated until the right-hand + side succeeds. Note that `h1` and `h2` are never matched to the same hypothesis. + Observe that the number of permutations can grow as the factorial + of the number of hypotheses and hypothesis patterns. -- :n:`seq(@ltac2_scope__1, ..., @ltac2_scope__2)`: + .. coqtop:: all abort - + parses :n:`scope__1`, ..., :n:`scope__n` in this order, and produces a tuple made - out of the parsed values in the same order. As an optimization, all - subscopes of the form :n:`STRING` are left out of the returned tuple, instead - of returning a useless unit value. It is forbidden for the various - subscopes to refer to the global entry using :n:`self` or :n:`next`. + Goal forall A B : Prop, A -> B -> (A->B). + intros A B H. + match! goal with + | [ h1 : _, h2 : _ |- _ ] => + print (concat (of_string "match ") + (concat (of_constr (Control.hyp h1)) + (concat (of_string " ") + (of_constr (Control.hyp h2))))); + fail + | [ |- _ ] => () + end. -A few other specific scopes exist to handle Ltac1-like syntax, but their use is -discouraged and they are thus not documented. -For now there is no way to declare new scopes from Ltac2 side, but this is -planned. +Match on values +~~~~~~~~~~~~~~~ -Notations -~~~~~~~~~ +.. tacn:: match @ltac2_expr5 with {? @ltac2_branches } end + :name: match (Ltac2) + + Matches a value, akin to the OCaml `match` construct. By itself, it doesn't cause backtracking + as do the `*match*!` and `*match*! goal` constructs. + + .. insertprodn ltac2_branches atomic_tac2pat -The Ltac2 parser can be extended with syntactic notations. + .. prodn:: + ltac2_branches ::= {? %| } {+| @tac2pat1 => @ltac2_expr } + tac2pat1 ::= @qualid {+ @tac2pat0 } + | @qualid + | [ ] + | @tac2pat0 :: @tac2pat0 + | @tac2pat0 + tac2pat0 ::= _ + | () + | @qualid + | ( {? @atomic_tac2pat } ) + atomic_tac2pat ::= @tac2pat1 : @ltac2_type + | @tac2pat1 , {*, @tac2pat1 } + | @tac2pat1 -.. cmd:: Ltac2 Notation {+ {| @lident (@ltac2_scope) | @string } } {? : @int} := @ltac2_term +.. note:: + + For now, deep pattern matching is not implemented. + + +.. _ltac2_notations: + +Notations +--------- + +.. cmd:: Ltac2 Notation {+ @ltac2_scope } {? : @natural } := @ltac2_expr :name: Ltac2 Notation - A Ltac2 notation adds a parsing rule to the Ltac2 grammar, which is expanded + .. todo seems like name maybe should use lident rather than ident, considering: + + Ltac2 Notation "ex1" X(constr) := print (of_constr X). + ex1 1. + + Unbound constructor X + + This works fine with lower-case "x" in place of "X" + + .. todo Ltac2 Notation := permits redefining same symbol (no warning) + Also allows defining a symbol beginning with uppercase, which is prohibited + in similar constructs. + + :cmd:`Ltac2 Notation` provides a way to extend the syntax of Ltac2 tactics. The left-hand + side (before the `:=`) defines the syntax to recognize and gives formal parameter + names for the syntactic values. :n:`@integer` is the level of the notation. + When the notation is used, the values are substituted + into the right-hand side. The right-hand side is typechecked when the notation is used, + not when it is defined. In the following example, `x` is the formal parameter name and + `constr` is its :ref:`syntactic class<syntactic_classes>`. `print` and `of_constr` are + functions provided by |Coq| through `Message.v`. + + .. todo "print" doesn't seem to pay attention to "Set Printing All" + + .. example:: Printing a :n:`@term` + + .. coqtop:: none + + Goal True. + + .. coqtop:: all + + From Ltac2 Require Import Message. + Ltac2 Notation "ex1" x(constr) := print (of_constr x). + ex1 (1 + 2). + + You can also print terms with a regular Ltac2 definition, but then the :n:`@term` must be in + the quotation `constr:( … )`: + + .. coqtop:: all + + Ltac2 ex2 x := print (of_constr x). + ex2 constr:(1+2). + + There are also metasyntactic classes described :ref:`here<syntactic_classes>` + that combine other items. For example, `list1(constr, ",")` + recognizes a comma-separated list of one or more :token:`term`\s. + + .. example:: Parsing a list of :n:`@term`\s + + .. coqtop:: abort all + + Ltac2 rec print_list x := match x with + | a :: t => print (of_constr a); print_list t + | [] => () + end. + Ltac2 Notation "ex2" x(list1(constr, ",")) := print_list x. + ex2 1, 2, 3. + + An Ltac2 notation adds a parsing rule to the Ltac2 grammar, which is expanded to the provided body where every token from the notation is let-bound to the corresponding generated expression. @@ -848,37 +1249,432 @@ The Ltac2 parser can be extended with syntactic notations. Abbreviations ~~~~~~~~~~~~~ -.. cmdv:: Ltac2 Notation @lident := @ltac2_term +.. cmd:: Ltac2 Notation {| @string | @lident } := @ltac2_expr + :name: Ltac2 Notation (abbreviation) - This command introduces a special kind of notation, called an abbreviation, - that is designed so that it does not add any parsing rules. It is similar in - spirit to Coq abbreviations, insofar as its main purpose is to give an - absolute name to a piece of pure syntax, which can be transparently referred to - by this name as if it were a proper definition. + Introduces a special kind of notation, called an abbreviation, + that does not add any parsing rules. It is similar in + spirit to Coq abbreviations (see :cmd:`Notation (abbreviation)`, + insofar as its main purpose is to give an + absolute name to a piece of pure syntax, which can be transparently referred to + by this name as if it were a proper definition. - The abbreviation can then be manipulated just as a normal Ltac2 definition, - except that it is expanded at internalization time into the given expression. - Furthermore, in order to make this kind of construction useful in practice in - an effectful language such as Ltac2, any syntactic argument to an abbreviation - is thunked on-the-fly during its expansion. + The abbreviation can then be manipulated just like a normal Ltac2 definition, + except that it is expanded at internalization time into the given expression. + Furthermore, in order to make this kind of construction useful in practice in + an effectful language such as Ltac2, any syntactic argument to an abbreviation + is thunked on-the-fly during its expansion. -For instance, suppose that we define the following. + For instance, suppose that we define the following. -:n:`Ltac2 Notation foo := fun x => x ().` + :n:`Ltac2 Notation foo := fun x => x ().` -Then we have the following expansion at internalization time. + Then we have the following expansion at internalization time. -:n:`foo 0 ↦ (fun x => x ()) (fun _ => 0)` + :n:`foo 0 ↦ (fun x => x ()) (fun _ => 0)` -Note that abbreviations are not typechecked at all, and may result in typing -errors after expansion. + Note that abbreviations are not type checked at all, and may result in typing + errors after expansion. + +.. _defining_tactics: + +Defining tactics +~~~~~~~~~~~~~~~~ + +Built-in tactics (those defined in OCaml code in the |Coq| executable) and Ltac1 tactics, +which are defined in `.v` files, must be defined through notations. (Ltac2 tactics can be +defined with :cmd:`Ltac2`. + +Notations for many but not all built-in tactics are defined in `Notations.v`, which is automatically +loaded with Ltac2. The Ltac2 syntax for these tactics is often identical or very similar to the +tactic syntax described in other chapters of this documentation. These notations rely on tactic functions +declared in `Std.v`. Functions corresponding to some built-in tactics may not yet be defined in the +|Coq| executable or declared in `Std.v`. Adding them may require code changes to |Coq| or defining +workarounds through Ltac1 (described below). + +Two examples of syntax differences: + +- There is no notation defined that's equivalent to :n:`intros until {| @ident | @natural }`. There is, + however, already an ``intros_until`` tactic function defined ``Std.v``, so it may be possible for a user + to add the necessary notation. +- The built-in `simpl` tactic in Ltac1 supports the use of scope keys in delta flags, e.g. :n:`simpl ["+"%nat]` + which is not accepted by Ltac2. This is because Ltac2 uses a different + definition for :token:`delta_flag`; compare it to :token:`ltac2_delta_flag`. This also affects + :tacn:`compute`. + +Ltac1 tactics are not automatically available in Ltac2. (Note that some of the tactics described +in the documentation are defined with Ltac1.) +You can make them accessible in Ltac2 with commands similar to the following: + +.. coqtop:: in + + From Coq Require Import Lia. + Local Ltac2 lia_ltac1 () := ltac1:(lia). + Ltac2 Notation "lia" := lia_ltac1 (). + +A similar approach can be used to access missing built-in tactics. See :ref:`simple_api` for an +example that passes two parameters to a missing build-in tactic. + +.. _syntactic_classes: + +Syntactic classes +~~~~~~~~~~~~~~~~~ + +The simplest syntactic classes in Ltac2 notations represent individual nonterminals +from the |Coq| grammar. Only a few selected nonterminals are available as syntactic classes. +In addition, there are metasyntactic operations for describing +more complex syntax, such as making an item optional or representing a list of items. +When parsing, each syntactic class expression returns a value that's bound to a name in the +notation definition. + +Syntactic classes are described with a form of S-expression: + + .. insertprodn ltac2_scope ltac2_scope + + .. prodn:: + ltac2_scope ::= @string + | @integer + | @name + | @name ( {+, @ltac2_scope } ) + +.. todo no syn class for ints or strings? + parm names are not reserved (e.g the var can be named "list1") + +Metasyntactic operations that can be applied to other syntactic classes are: + + :n:`opt(@ltac2_scope)` + Parses an optional :token:`ltac2_scope`. The associated value is either :n:`None` or + enclosed in :n:`Some` + + :n:`list1(@ltac2_scope {? , @string })` + Parses a list of one or more :token:`ltac2_scope`\s. If :token:`string` is specified, + items must be separated by :token:`string`. + + :n:`list0(@ltac2_scope {? , @string })` + Parses a list of zero or more :token:`ltac2_scope`\s. If :token:`string` is specified, + items must be separated by :token:`string`. For zero items, the associated value + is an empty list. + + :n:`seq({+, @ltac2_scope })` + Parses the :token:`ltac2_scope`\s in order. The associated value is a tuple, + omitting :token:`ltac2_scope`\s that are :token:`string`\s. + `self` and `next` are not permitted within `seq`. + +The following classes represent nonterminals with some special handling. The +table further down lists the classes that that are handled plainly. + + :n:`constr {? ( {+, @scope_key } ) }` + Parses a :token:`term`. If specified, the :token:`scope_key`\s are used to interpret + the term (as described in :ref:`LocalInterpretationRulesForNotations`). The last + :token:`scope_key` is the top of the scope stack that's applied to the :token:`term`. + + :n:`open_constr` + Parses an open :token:`term`. + + :n:`ident` + Parses :token:`ident` or :n:`$@ident`. The first form returns :n:`ident:(@ident)`, + while the latter form returns the variable :n:`@ident`. + + :n:`@string` + Accepts the specified string that is not a keyword, returning a value of `()`. + + :n:`keyword(@string)` + Accepts the specified string that is a keyword, returning a value of `()`. + + :n:`terminal(@string)` + Accepts the specified string whether it's a keyword or not, returning a value of `()`. + + :n:`tactic {? (@integer) }` + Parses an :token:`ltac2_expr`. If :token:`integer` is specified, the construct + parses a :n:`ltac2_expr@integer`, for example `tactic(5)` parses :token:`ltac2_expr5`. + `tactic(6)` parses :token:`ltac2_expr`. + :token:`integer` must be in the range `0 .. 6`. + + You can also use `tactic` to accept an :token:`integer` or a :token:`string`, but there's + no syntactic class that accepts *only* an :token:`integer` or a :token:`string`. + + .. todo this doesn't work as expected: "::" is in ltac2_expr1 + Ltac2 Notation "ex4" x(tactic(0)) := x. + ex4 auto :: [auto]. + + .. not sure "self" and "next" do anything special. I get the same error + message for both from constructs like + + Ltac2 Notation "ex5" x(self) := auto. + ex5 match. + + Syntax error: [tactic:tac2expr level 5] expected after 'match' (in [tactic:tac2expr]). + + :n:`self` + parses an Ltac2 expression at the current level and returns it as is. + + :n:`next` + parses an Ltac2 expression at the next level and returns it as is. + + :n:`thunk(@ltac2_scope)` + Used for semantic effect only, parses the same as :token:`ltac2_scope`. + If :n:`e` is the parsed expression for :token:`ltac2_scope`, `thunk` + returns :n:`fun () => e`. + + :n:`pattern` + parses a :token:`cpattern` + +A few syntactic classes contain antiquotation features. For the sake of uniformity, all +antiquotations are introduced by the syntax :n:`$@lident`. + +A few other specific syntactic classes exist to handle Ltac1-like syntax, but their use is +discouraged and they are thus not documented. + +For now there is no way to declare new syntactic classes from the Ltac2 side, but this is +planned. + +Other nonterminals that have syntactic classes are listed here. + + .. list-table:: + :header-rows: 1 + + * - Syntactic class name + - Nonterminal + - Similar non-Ltac2 syntax + + * - :n:`intropatterns` + - :token:`ltac2_intropatterns` + - :token:`intropattern_list` + + * - :n:`intropattern` + - :token:`ltac2_simple_intropattern` + - :token:`simple_intropattern` + + * - :n:`ident` + - :token:`ident_or_anti` + - :token:`ident` + + * - :n:`destruction_arg` + - :token:`ltac2_destruction_arg` + - :token:`destruction_arg` + + * - :n:`with_bindings` + - :token:`q_with_bindings` + - :n:`{? with @bindings }` + + * - :n:`bindings` + - :token:`ltac2_bindings` + - :token:`bindings` + + * - :n:`strategy` + - :token:`ltac2_strategy_flag` + - :token:`strategy_flag` + + * - :n:`reference` + - :token:`refglobal` + - :token:`reference` + + * - :n:`clause` + - :token:`ltac2_clause` + - :token:`clause_dft_concl` + + * - :n:`occurrences` + - :token:`q_occurrences` + - :n:`{? at @occs_nums }` + + * - :n:`induction_clause` + - :token:`ltac2_induction_clause` + - :token:`induction_clause` + + * - :n:`conversion` + - :token:`ltac2_conversion` + - :token:`conversion` + + * - :n:`rewriting` + - :token:`ltac2_oriented_rewriter` + - :token:`oriented_rewriter` + + * - :n:`dispatch` + - :token:`ltac2_for_each_goal` + - :token:`for_each_goal` + + * - :n:`hintdb` + - :token:`hintdb` + - :token:`hintbases` + + * - :n:`move_location` + - :token:`move_location` + - :token:`where` + + * - :n:`pose` + - :token:`pose` + - :token:`bindings_with_parameters` + + * - :n:`assert` + - :token:`assertion` + - :n:`( @ident := @term )` + + * - :n:`constr_matching` + - :token:`ltac2_match_list` + - See :tacn:`match` + + * - :n:`goal_matching` + - :token:`goal_match_list` + - See :tacn:`match goal` + +Here is the syntax for the :n:`q_*` nonterminals: + +.. insertprodn ltac2_intropatterns nonsimple_intropattern + +.. prodn:: + ltac2_intropatterns ::= {* @nonsimple_intropattern } + nonsimple_intropattern ::= * + | ** + | @ltac2_simple_intropattern + +.. insertprodn ltac2_simple_intropattern ltac2_naming_intropattern + +.. prodn:: + ltac2_simple_intropattern ::= @ltac2_naming_intropattern + | _ + | @ltac2_or_and_intropattern + | @ltac2_equality_intropattern + ltac2_or_and_intropattern ::= [ {+| @ltac2_intropatterns } ] + | () + | ( {+, @ltac2_simple_intropattern } ) + | ( {+& @ltac2_simple_intropattern } ) + ltac2_equality_intropattern ::= -> + | <- + | [= @ltac2_intropatterns ] + ltac2_naming_intropattern ::= ? @lident + | ?$ @lident + | ? + | @ident_or_anti + +.. insertprodn ident_or_anti ident_or_anti + +.. prodn:: + ident_or_anti ::= @lident + | $ @ident + +.. insertprodn ltac2_destruction_arg ltac2_constr_with_bindings + +.. prodn:: + ltac2_destruction_arg ::= @natural + | @lident + | @ltac2_constr_with_bindings + ltac2_constr_with_bindings ::= @term {? with @ltac2_bindings } + +.. insertprodn q_with_bindings qhyp + +.. prodn:: + q_with_bindings ::= {? with @ltac2_bindings } + ltac2_bindings ::= {+ @ltac2_simple_binding } + | {+ @term } + ltac2_simple_binding ::= ( @qhyp := @term ) + qhyp ::= $ @ident + | @natural + | @lident + +.. insertprodn ltac2_strategy_flag ltac2_delta_flag + +.. prodn:: + ltac2_strategy_flag ::= {+ @ltac2_red_flag } + | {? @ltac2_delta_flag } + ltac2_red_flag ::= beta + | iota + | match + | fix + | cofix + | zeta + | delta {? @ltac2_delta_flag } + ltac2_delta_flag ::= {? - } [ {+ @refglobal } ] + +.. insertprodn refglobal refglobal + +.. prodn:: + refglobal ::= & @ident + | @qualid + | $ @ident + +.. insertprodn ltac2_clause ltac2_in_clause + +.. prodn:: + ltac2_clause ::= in @ltac2_in_clause + | at @ltac2_occs_nums + ltac2_in_clause ::= * {? @ltac2_occs } + | * |- {? @ltac2_concl_occ } + | {*, @ltac2_hypident_occ } {? |- {? @ltac2_concl_occ } } + +.. insertprodn q_occurrences ltac2_hypident + +.. prodn:: + q_occurrences ::= {? @ltac2_occs } + ltac2_occs ::= at @ltac2_occs_nums + ltac2_occs_nums ::= {? - } {+ {| @natural | $ @ident } } + ltac2_concl_occ ::= * {? @ltac2_occs } + ltac2_hypident_occ ::= @ltac2_hypident {? @ltac2_occs } + ltac2_hypident ::= @ident_or_anti + | ( type of @ident_or_anti ) + | ( value of @ident_or_anti ) + +.. insertprodn ltac2_induction_clause ltac2_eqn_ipat + +.. prodn:: + ltac2_induction_clause ::= @ltac2_destruction_arg {? @ltac2_as_or_and_ipat } {? @ltac2_eqn_ipat } {? @ltac2_clause } + ltac2_as_or_and_ipat ::= as @ltac2_or_and_intropattern + ltac2_eqn_ipat ::= eqn : @ltac2_naming_intropattern + +.. insertprodn ltac2_conversion ltac2_conversion + +.. prodn:: + ltac2_conversion ::= @term + | @term with @term + +.. insertprodn ltac2_oriented_rewriter ltac2_rewriter + +.. prodn:: + ltac2_oriented_rewriter ::= {| -> | <- } @ltac2_rewriter + ltac2_rewriter ::= {? @natural } {? {| ? | ! } } @ltac2_constr_with_bindings + +.. insertprodn ltac2_for_each_goal ltac2_goal_tactics + +.. prodn:: + ltac2_for_each_goal ::= @ltac2_goal_tactics + | {? @ltac2_goal_tactics %| } {? @ltac2_expr } .. {? %| @ltac2_goal_tactics } + ltac2_goal_tactics ::= {*| {? @ltac2_expr } } + +.. insertprodn hintdb hintdb + +.. prodn:: + hintdb ::= * + | {+ @ident_or_anti } + +.. insertprodn move_location move_location + +.. prodn:: + move_location ::= at top + | at bottom + | after @ident_or_anti + | before @ident_or_anti + +.. insertprodn pose ltac2_as_name + +.. prodn:: + pose ::= ( @ident_or_anti := @term ) + | @term {? @ltac2_as_name } + ltac2_as_name ::= as @ident_or_anti + +.. insertprodn assertion ltac2_by_tactic + +.. prodn:: + assertion ::= ( @ident_or_anti := @term ) + | ( @ident_or_anti : @term ) {? @ltac2_by_tactic } + | @term {? @ltac2_as_ipat } {? @ltac2_by_tactic } + ltac2_as_ipat ::= as @ltac2_simple_intropattern + ltac2_by_tactic ::= by @ltac2_expr Evaluation ---------- Ltac2 features a toplevel loop that can be used to evaluate expressions. -.. cmd:: Ltac2 Eval @ltac2_term +.. cmd:: Ltac2 Eval @ltac2_expr :name: Ltac2 Eval This command evaluates the term in the current proof if there is one, or in the @@ -899,22 +1695,26 @@ Compatibility layer with Ltac1 Ltac1 from Ltac2 ~~~~~~~~~~~~~~~~ +.. _simple_api: + Simple API ++++++++++ -One can call Ltac1 code from Ltac2 by using the :n:`ltac1` quotation. It parses +One can call Ltac1 code from Ltac2 by using the :n:`ltac1:(@ltac1_expr_in_env)` quotation. +See :ref:`ltac2_built-in-quotations`. It parses a Ltac1 expression, and semantics of this quotation is the evaluation of the corresponding code for its side effects. In particular, it cannot return values, and the quotation has type :n:`unit`. -.. productionlist:: coq - ltac2_term : ltac1 : ( `ltac_expr` ) - Ltac1 **cannot** implicitly access variables from the Ltac2 scope, but this can -be done with an explicit annotation on the :n:`ltac1` quotation. +be done with an explicit annotation on the :n:`ltac1:({* @ident } |- @ltac_expr)` +quotation. See :ref:`ltac2_built-in-quotations`. For example: -.. productionlist:: coq - ltac2_term : ltac1 : ( `ident` ... `ident` |- `ltac_expr` ) +.. coqtop:: in + + Local Ltac2 replace_with (lhs: constr) (rhs: constr) := + ltac1:(lhs rhs |- replace lhs with rhs) (Ltac1.of_constr lhs) (Ltac1.of_constr rhs). + Ltac2 Notation "replace" lhs(constr) "with" rhs(constr) := replace_with lhs rhs. The return type of this expression is a function of the same arity as the number of identifiers, with arguments of type `Ltac2.Ltac1.t` (see below). This syntax @@ -922,6 +1722,8 @@ will bind the variables in the quoted Ltac1 code as if they had been bound from Ltac1 itself. Similarly, the arguments applied to the quotation will be passed at runtime to the Ltac1 code. +.. _low_level_api: + Low-level API +++++++++++++ @@ -948,8 +1750,8 @@ Same as above by switching Ltac1 by Ltac2 and using the `ltac2` quotation instead. .. prodn:: - ltac_expr += ltac2 : ( `ltac2_term` ) - | ltac2 : ( `ident` ... `ident` |- `ltac2_term` ) + ltac_expr += ltac2 : ( @ltac2_expr ) + | ltac2 : ( {+ @ident } |- @ltac2_expr ) The typing rules are dual, that is, the optional identifiers are bound with type `Ltac2.Ltac1.t` in the Ltac2 expression, which is expected to have @@ -992,7 +1794,7 @@ Transition from Ltac1 Owing to the use of a lot of notations, the transition should not be too difficult. In particular, it should be possible to do it incrementally. That -said, we do *not* guarantee you it is going to be a blissful walk either. +said, we do *not* guarantee it will be a blissful walk either. Hopefully, owing to the fact Ltac2 is typed, the interactive dialogue with Coq will help you. diff --git a/doc/sphinx/proof-engine/proof-handling.rst b/doc/sphinx/proof-engine/proof-handling.rst index 00aafe1266..f90ebadb3a 100644 --- a/doc/sphinx/proof-engine/proof-handling.rst +++ b/doc/sphinx/proof-engine/proof-handling.rst @@ -156,6 +156,10 @@ list of assertion commands is given in :ref:`Assertions`. The command ``T``, then the commands ``Proof using a`` and ``Proof using T a`` are equivalent. + The set of declared variables always includes the variables used by + the statement. In other words ``Proof using e`` is equivalent to + ``Proof using Type + e`` for any declaration expression ``e``. + .. cmdv:: Proof using {+ @ident } with @tactic Combines in a single line :cmd:`Proof with` and :cmd:`Proof using`. @@ -255,9 +259,9 @@ Name a set of section hypotheses for ``Proof using`` -.. cmd:: Existential @num := @term +.. cmd:: Existential @natural := @term - This command instantiates an existential variable. :token:`num` is an index in + This command instantiates an existential variable. :token:`natural` is an index in the list of uninstantiated existential variables displayed by :cmd:`Show Existentials`. This command is intended to be used to instantiate existential @@ -309,9 +313,9 @@ Navigation in the proof tree This command cancels the effect of the last command. Thus, it backtracks one step. -.. cmdv:: Undo @num +.. cmdv:: Undo @natural - Repeats Undo :token:`num` times. + Repeats Undo :token:`natural` times. .. cmdv:: Restart :name: Restart @@ -332,9 +336,9 @@ Navigation in the proof tree Prefer the use of bullets or focusing brackets (see below). -.. cmdv:: Focus @num +.. cmdv:: Focus @natural - This focuses the attention on the :token:`num` th subgoal to prove. + This focuses the attention on the :token:`natural` th subgoal to prove. .. deprecated:: 8.8 @@ -369,9 +373,9 @@ Navigation in the proof tree together with a suggestion about the right bullet or ``}`` to unfocus it or focus the next one. - .. cmdv:: @num: %{ + .. cmdv:: @natural: %{ - This focuses on the :token:`num`\-th subgoal to prove. + This focuses on the :token:`natural`\-th subgoal to prove. .. cmdv:: [@ident]: %{ @@ -435,7 +439,7 @@ Navigation in the proof tree You are trying to use ``}`` but the current subproof has not been fully solved. - .. exn:: No such goal (@num). + .. exn:: No such goal (@natural). :undocumented: .. exn:: No such goal (@ident). @@ -555,9 +559,9 @@ Requesting information .. exn:: No focused proof. :undocumented: - .. cmdv:: Show @num + .. cmdv:: Show @natural - Displays only the :token:`num`\-th subgoal. + Displays only the :token:`natural`\-th subgoal. .. exn:: No such goal. :undocumented: @@ -645,7 +649,7 @@ Requesting information its normalized form at the current stage of the proof, useful for debugging universe inconsistencies. - .. cmdv:: Show Goal @num at @num + .. cmdv:: Show Goal @natural at @natural :name: Show Goal This command is only available in coqtop. Displays a goal at a @@ -834,7 +838,7 @@ Controlling the effect of proof editing commands ------------------------------------------------ -.. opt:: Hyps Limit @num +.. opt:: Hyps Limit @natural :name: Hyps Limit This option controls the maximum number of hypotheses displayed in goals @@ -858,19 +862,28 @@ Controlling the effect of proof editing commands Controlling memory usage ------------------------ +.. cmd:: Print Debug GC + + Prints heap usage statistics, which are values from the `stat` type of the `Gc` module + described + `here <https://caml.inria.fr/pub/docs/manual-ocaml/libref/Gc.html#TYPEstat>`_ + in the OCaml documentation. + The `live_words`, `heap_words` and `top_heap_words` values give the basic information. + Words are 8 bytes or 4 bytes, respectively, for 64- and 32-bit executables. + When experiencing high memory usage the following commands can be used to force |Coq| to optimize some of its internal data structures. - .. cmd:: Optimize Proof - This command forces |Coq| to shrink the data structure used to represent - the ongoing proof. + Shrink the data structure used to represent the current proof. .. cmd:: Optimize Heap - This command forces the |OCaml| runtime to perform a heap compaction. - This is in general an expensive operation. - See: `OCaml Gc <http://caml.inria.fr/pub/docs/manual-ocaml/libref/Gc.html#VALcompact>`_ + Perform a heap compaction. This is generally an expensive operation. + See: `OCaml Gc.compact <http://caml.inria.fr/pub/docs/manual-ocaml/libref/Gc.html#VALcompact>`_ There is also an analogous tactic :tacn:`optimize_heap`. + +Memory usage parameters can be set through the :ref:`OCAMLRUNPARAM <OCAMLRUNPARAM>` +environment variable. diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index 3b4b80ca21..ca50a02562 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -617,7 +617,7 @@ Abbreviations selected occurrences of a term. .. prodn:: - occ_switch ::= { {? {| + | - } } {* @num } } + occ_switch ::= { {? {| + | - } } {* @natural } } where: @@ -1211,6 +1211,8 @@ The move tactic. :tacn:`revert`, :tacn:`rename`, :tacn:`clear` and :tacn:`pattern` tactics. +.. _the_case_tactic_ssr: + The case tactic ``````````````` @@ -1235,7 +1237,17 @@ The case tactic x = 1 -> y = 2 -> G. - Note also that the case of |SSR| performs :g:`False` elimination, even + The :tacn:`case` can generate the following warning: + + .. warn:: SSReflect: cannot obtain new equations out of ... + + The tactic was run on an equation that cannot generate simpler equations, + for example `x = 1`. + + The warning can be silenced or made fatal by using the :opt:`Warnings` option + and the `spurious-ssr-injection` key. + + Finally the :tacn:`case` tactic of |SSR| performs :g:`False` elimination, even if no branch is generated by this case operation. Hence the tactic :tacn:`case` on a goal of the form :g:`False -> G` will succeed and prove the goal. @@ -1568,7 +1580,7 @@ whose general syntax is i_pattern ::= {| @ident | > | _ | ? | * | + | {? @occ_switch } {| -> | <- } | [ {?| @i_item } ] | - | [: {+ @ident } ] } .. prodn:: - i_block ::= {| [^ @ident ] | [^~ {| @ident | @num } ] } + i_block ::= {| [^ @ident ] | [^~ {| @ident | @natural } ] } The ``=>`` tactical first executes :token:`tactic`, then the :token:`i_item`\s, left to right. An :token:`s_item` specifies a @@ -1830,8 +1842,8 @@ Block introduction :n:`[^~ @ident ]` *block destructing* using :token:`ident` as a suffix. -:n:`[^~ @num ]` - *block destructing* using :token:`num` as a suffix. +:n:`[^~ @natural ]` + *block destructing* using :token:`natural` as a suffix. Only a :token:`s_item` is allowed between the elimination tactic and the block destructing. @@ -2224,17 +2236,17 @@ tactics to *permute* the subgoals generated by a tactic. These two equivalent tactics invert the order of the subgoals in focus. - .. tacv:: last @num first + .. tacv:: last @natural first - If :token:`num`\'s value is :math:`k`, + If :token:`natural`\'s value is :math:`k`, this tactic rotates the :math:`n` subgoals :math:`G_1` , …, :math:`G_n` in focus. Subgoal :math:`G_{n + 1 − k}` becomes the first, and the circular order of subgoals remains unchanged. - .. tacn:: first @num last + .. tacn:: first @natural last :name: first (ssreflect) - If :token:`num`\'s value is :math:`k`, + If :token:`natural`\'s value is :math:`k`, this tactic rotates the :math:`n` subgoals :math:`G_1` , …, :math:`G_n` in focus. Subgoal :math:`G_{k + 1 \bmod n}` becomes the first, and the circular order of subgoals remains unchanged. @@ -2307,7 +2319,7 @@ tactic should be repeated on the current subgoal. There are four kinds of multipliers: .. prodn:: - mult ::= {| @num ! | ! | @num ? | ? } + mult ::= {| @natural ! | ! | @natural ? | ? } Their meaning is: @@ -3098,7 +3110,7 @@ An :token:`r_item` can be: + A list of terms ``(t1 ,…,tn)``, each ``ti`` having a type above. The tactic: ``rewrite r_prefix (t1 ,…,tn ).`` is equivalent to: ``do [rewrite r_prefix t1 | … | rewrite r_prefix tn ].`` - + An anonymous rewrite lemma ``(_ : term)``, where term has a type as above. tactic: ``rewrite (_ : term)`` is in fact synonym of: ``cutrewrite (term).``. + + An anonymous rewrite lemma ``(_ : term)``, where term has a type as above. .. example:: @@ -4074,7 +4086,7 @@ will generally fail to perform congruence simplification, even on rather simple cases. We therefore provide a more robust alternative in which the function is supplied: -.. tacn:: congr {? @num } @term +.. tacn:: congr {? @natural } @term :name: congr This tactic: @@ -4108,7 +4120,7 @@ which the function is supplied: Lemma test (x y z : nat) : x = y -> x = z. congr (_ = _). - The optional :token:`num` forces the number of arguments for which the + The optional :token:`natural` forces the number of arguments for which the tactic should generate equality proof obligations. This tactic supports equalities between applications with dependent @@ -5380,8 +5392,8 @@ In this context, the identity view can be used when no view has to be applied: Declaring new Hint Views ~~~~~~~~~~~~~~~~~~~~~~~~ -.. cmd:: Hint View for move / @ident {? | @num } - Hint View for apply / @ident {? | @num } +.. cmd:: Hint View for move / @ident {? | @natural } + Hint View for apply / @ident {? | @natural } This command can be used to extend the database of hints for the view mechanism. @@ -5398,7 +5410,7 @@ Declaring new Hint Views views. The optional natural number is the number of implicit arguments to be considered for the declared hint view lemma. - .. cmdv:: Hint View for apply//@ident {? | @num } + .. cmdv:: Hint View for apply//@ident {? | @natural } This variant with a double slash ``//``, declares hint views for right hand sides of double views. @@ -5559,9 +5571,9 @@ Module name Natural number -.. prodn:: natural ::= {| @num | @ident } +.. prodn:: nat_or_ident ::= {| @natural | @ident } -where :token:`ident` is an Ltac variable denoting a standard |Coq| numeral +where :token:`ident` is an Ltac variable denoting a standard |Coq| number (should not be the name of a tactic which can be followed by a bracket ``[``, like ``do``, ``have``,…) @@ -5584,11 +5596,11 @@ context pattern see :ref:`contextual_patterns_ssr` discharge item see :ref:`discharge_ssr` -.. prodn:: gen_item ::= {| {? @ } @ident | ( @ident ) | ( {? @ } @ident := @c_pattern ) } +.. prodn:: gen_item ::= {| {? @ } @ident | ( @ident ) | ( {? @ } @ident := @c_pattern ) } generalization item see :ref:`structure_ssr` -.. prodn:: i_pattern ::= {| @ident | > | _ | ? | * | + | {? @occ_switch } {| -> | <- } | [ {?| @i_item } ] | - | [: {+ @ident } ] } +.. prodn:: i_pattern ::= {| @ident | > | _ | ? | * | + | {? @occ_switch } {| -> | <- } | [ {?| @i_item } ] | - | [: {+ @ident } ] } intro pattern :ref:`introduction_ssr` @@ -5602,19 +5614,19 @@ view :ref:`introduction_ssr` intro block :ref:`introduction_ssr` .. prodn:: - i_block ::= {| [^ @ident ] | [^~ {| @ident | @num } ] } + i_block ::= {| [^ @ident ] | [^~ {| @ident | @natural } ] } intro item see :ref:`introduction_ssr` -.. prodn:: int_mult ::= {? @num } @mult_mark +.. prodn:: int_mult ::= {? @natural } @mult_mark multiplier see :ref:`iteration_ssr` -.. prodn:: occ_switch ::= { {? {| + | - } } {* @num } } +.. prodn:: occ_switch ::= { {? {| + | - } } {* @natural } } occur. switch see :ref:`occurrence_selection_ssr` -.. prodn:: mult ::= {? @num } @mult_mark +.. prodn:: mult ::= {? @natural } @mult_mark multiplier see :ref:`iteration_ssr` @@ -5729,7 +5741,7 @@ respectively. unlock (see :ref:`locking_ssr`) -.. tacn:: congr {? @num } @term +.. tacn:: congr {? @natural } @term congruence (see :ref:`congruence_ssr`) @@ -5753,11 +5765,11 @@ localization see :ref:`localization_ssr` iteration see :ref:`iteration_ssr` -.. prodn:: tactic += @tactic ; {| first | last } {? @num } {| @tactic | [ {+| @tactic } ] } +.. prodn:: tactic += @tactic ; {| first | last } {? @natural } {| @tactic | [ {+| @tactic } ] } selector see :ref:`selectors_ssr` -.. prodn:: tactic += @tactic ; {| first | last } {? @num } +.. prodn:: tactic += @tactic ; {| first | last } {? @natural } rotation see :ref:`selectors_ssr` @@ -5768,11 +5780,11 @@ closing see :ref:`terminators_ssr` Commands ~~~~~~~~ -.. cmd:: Hint View for {| move | apply } / @ident {? | @num } +.. cmd:: Hint View for {| move | apply } / @ident {? | @natural } view hint declaration (see :ref:`declaring_new_hints_ssr`) -.. cmd:: Hint View for apply // @ident {? @num } +.. cmd:: Hint View for apply // @ident {? @natural } right hand side double , view hint declaration (see :ref:`declaring_new_hints_ssr`) diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 25c4de7389..2f505e7448 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -54,14 +54,14 @@ Invocation of tactics ~~~~~~~~~~~~~~~~~~~~~ A tactic is applied as an ordinary command. It may be preceded by a -goal selector (see Section :ref:`ltac-semantics`). If no selector is +goal selector (see Section :ref:`goal-selectors`). If no selector is specified, the default selector is used. .. _tactic_invocation_grammar: - .. productionlist:: sentence - tactic_invocation : `toplevel_selector` : `tactic`. - : `tactic`. + .. prodn:: + tactic_invocation ::= @toplevel_selector : @tactic. + | @tactic. .. todo: fully describe selectors. At the moment, ltac has a fairly complete description @@ -98,14 +98,14 @@ The general form of a term with a bindings list is .. _bindings_list_grammar: - .. productionlist:: bindings_list - ref : `ident` - : `num` - bindings_list : (`ref` := `term`) ... (`ref` := `term`) - : `term` ... `term` + .. prodn:: + ref ::= @ident + | @natural + bindings_list ::= {+ (@ref := @term) } + | {+ @term } + In a bindings list of the form :n:`{+ (@ref:= @term)}`, :n:`@ref` is either an - :n:`@ident` or a :n:`@num`. The references are determined according to the type of + :n:`@ident` or a :n:`@natural`. The references are determined according to the type of :n:`@term`. If :n:`@ref` is an identifier, this identifier has to be bound in the type of :n:`@term` and the binding provides the tactic with an instance for the parameter of this name. If :n:`@ref` is a number ``n``, it refers to @@ -137,30 +137,28 @@ introduced by tactics. They also let you split an introduced hypothesis into multiple hypotheses or subgoals. Common tactics that accept intro patterns include :tacn:`assert`, :tacn:`intros` and :tacn:`destruct`. -.. productionlist:: coq - intropattern_list : `intropattern` ... `intropattern` - : `empty` - empty : - intropattern : * - : ** - : `simple_intropattern` - simple_intropattern : `simple_intropattern_closed` [ % `term` ... % `term` ] - simple_intropattern_closed : `naming_intropattern` - : _ - : `or_and_intropattern` - : `rewriting_intropattern` - : `injection_intropattern` - naming_intropattern : `ident` - : ? - : ?`ident` - or_and_intropattern : [ `intropattern_list` | ... | `intropattern_list` ] - : ( `simple_intropattern` , ... , `simple_intropattern` ) - : ( `simple_intropattern` & ... & `simple_intropattern` ) - rewriting_intropattern : -> - : <- - injection_intropattern : [= `intropattern_list` ] - or_and_intropattern_loc : `or_and_intropattern` - : `ident` +.. prodn:: + intropattern_list ::= {* @intropattern } + intropattern ::= * + | ** + | @simple_intropattern + simple_intropattern ::= @simple_intropattern_closed {* % @term0 } + simple_intropattern_closed ::= @naming_intropattern + | _ + | @or_and_intropattern + | @rewriting_intropattern + | @injection_intropattern + naming_intropattern ::= @ident + | ? + | ?@ident + or_and_intropattern ::= [ {*| @intropattern_list } ] + | ( {*, @simple_intropattern } ) + | ( {*& @simple_intropattern } ) + rewriting_intropattern ::= -> + | <- + injection_intropattern ::= [= @intropattern_list ] + or_and_intropattern_loc ::= @or_and_intropattern + | ident Note that the intro pattern syntax varies between tactics. Most tactics use :n:`@simple_intropattern` in the grammar. @@ -480,13 +478,13 @@ Occurrence sets and occurrence clauses An occurrence clause is a modifier to some tactics that obeys the following syntax: - .. productionlist:: coq - occurrence_clause : in `goal_occurrences` - goal_occurrences : [`ident` [`at_occurrences`], ... , `ident` [`at_occurrences`] [|- [* [`at_occurrences`]]]] - : * |- [* [`at_occurrences`]] - : * - at_occurrences : at `occurrences` - occurrences : [-] `num` ... `num` + .. prodn:: + occurrence_clause ::= in @goal_occurrences + goal_occurrences ::= {*, @ident {? @at_occurrences } } {? |- {? * {? @at_occurrences } } } + | * |- {? * {? @at_occurrences } } + | * + at_occurrences ::= at @occurrences + occurrences ::= {? - } {* @natural } The role of an occurrence clause is to select a set of occurrences of a term in a goal. In the first case, the :n:`@ident {? at {* num}}` parts indicate @@ -923,11 +921,11 @@ Applying theorems This summarizes the different syntactic variants of :n:`apply @term in @ident` and :n:`eapply @term in @ident`. -.. tacn:: constructor @num +.. tacn:: constructor @natural :name: constructor This tactic applies to a goal such that its conclusion is an inductive - type (say :g:`I`). The argument :token:`num` must be less or equal to the + type (say :g:`I`). The argument :token:`natural` must be less or equal to the numbers of constructor(s) of :g:`I`. Let :n:`c__i` be the i-th constructor of :g:`I`, then :g:`constructor i` is equivalent to :n:`intros; apply c__i`. @@ -944,7 +942,7 @@ Applying theorems :g:`constructor n` where ``n`` is the number of constructors of the head of the goal. - .. tacv:: constructor @num with @bindings_list + .. tacv:: constructor @natural with @bindings_list Let ``c`` be the i-th constructor of :g:`I`, then :n:`constructor i with @bindings_list` is equivalent to @@ -1075,9 +1073,9 @@ Managing the local context .. exn:: No such hypothesis in current goal. :undocumented: - .. tacv:: intros until @num + .. tacv:: intros until @natural - This repeats :tacn:`intro` until the :token:`num`\-th non-dependent + This repeats :tacn:`intro` until the :token:`natural`\-th non-dependent product. .. example:: @@ -1093,7 +1091,7 @@ Managing the local context .. exn:: No such hypothesis in current goal. - This happens when :token:`num` is 0 or is greater than the number of + This happens when :token:`natural` is 0 or is greater than the number of non-dependent products of the goal. .. tacv:: intro {? @ident__1 } after @ident__2 @@ -1578,7 +1576,7 @@ name of the variable (here :g:`n`) is chosen based on :g:`T`. This is equivalent to :n:`generalize @term; ... ; generalize @term`. Note that the sequence of term :sub:`i` 's are processed from n to 1. -.. tacv:: generalize @term at {+ @num} +.. tacv:: generalize @term at {+ @natural} This is equivalent to :n:`generalize @term` but it generalizes only over the specified occurrences of :n:`@term` (counting from left to right on the @@ -1589,7 +1587,7 @@ name of the variable (here :g:`n`) is chosen based on :g:`T`. This is equivalent to :n:`generalize @term` but it uses :n:`@ident` to name the generalized hypothesis. -.. tacv:: generalize {+, @term at {+ @num} as @ident} +.. tacv:: generalize {+, @term at {+ @natural} as @ident} This is the most general form of :n:`generalize` that combines the previous behaviors. @@ -1621,16 +1619,16 @@ name of the variable (here :g:`n`) is chosen based on :g:`T`. name the variable in the current goal and in the context of the existential variable. This can lead to surprising behaviors. -.. tacv:: instantiate (@num := @term) +.. tacv:: instantiate (@natural := @term) This variant allows to refer to an existential variable which was not named - by the user. The :n:`@num` argument is the position of the existential variable + by the user. The :n:`@natural` argument is the position of the existential variable from right to left in the goal. Because this variant is not robust to slight changes in the goal, its use is strongly discouraged. -.. tacv:: instantiate ( @num := @term ) in @ident - instantiate ( @num := @term ) in ( value of @ident ) - instantiate ( @num := @term ) in ( type of @ident ) +.. tacv:: instantiate ( @natural := @term ) in @ident + instantiate ( @natural := @term ) in ( value of @ident ) + instantiate ( @natural := @term ) in ( type of @ident ) These allow to refer respectively to existential variables occurring in a hypothesis or in the body or the type of a local definition. @@ -1730,13 +1728,13 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) of :tacn:`destruct`, it is erased (to avoid erasure, use parentheses, as in :n:`destruct (@ident)`). - .. tacv:: destruct @num + .. tacv:: destruct @natural - :n:`destruct @num` behaves as :n:`intros until @num` + :n:`destruct @natural` behaves as :n:`intros until @natural` followed by destruct applied to the last introduced hypothesis. .. note:: - For destruction of a numeral, use syntax :n:`destruct (@num)` (not + For destruction of a number, use syntax :n:`destruct (@natural)` (not very interesting anyway). .. tacv:: destruct @pattern @@ -1829,10 +1827,10 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) This tactic behaves as :n:`intros until @ident; case @ident` when :n:`@ident` is a quantified variable of the goal. -.. tacv:: simple destruct @num +.. tacv:: simple destruct @natural - This tactic behaves as :n:`intros until @num; case @ident` where :n:`@ident` - is the name given by :n:`intros until @num` to the :n:`@num` -th + This tactic behaves as :n:`intros until @natural; case @ident` where :n:`@ident` + is the name given by :n:`intros until @natural` to the :n:`@natural` -th non-dependent premise of the goal. .. tacv:: case_eq @term @@ -1863,12 +1861,12 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) @ident; induction @ident`. If :n:`@ident` is not anymore dependent in the goal after application of :n:`induction`, it is erased (to avoid erasure, use parentheses, as in :n:`induction (@ident)`). - + If :n:`@term` is a :n:`@num`, then :n:`induction @num` behaves as - :n:`intros until @num` followed by :n:`induction` applied to the last + + If :n:`@term` is a :n:`@natural`, then :n:`induction @natural` behaves as + :n:`intros until @natural` followed by :n:`induction` applied to the last introduced hypothesis. .. note:: - For simple induction on a numeral, use syntax induction (num) + For simple induction on a number, use syntax induction (number) (not very interesting anyway). + In case term is a hypothesis :n:`@ident` of the context, and :n:`@ident` @@ -2026,10 +2024,10 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) This tactic behaves as :n:`intros until @ident; elim @ident` when :n:`@ident` is a quantified variable of the goal. -.. tacv:: simple induction @num +.. tacv:: simple induction @natural - This tactic behaves as :n:`intros until @num; elim @ident` where :n:`@ident` - is the name given by :n:`intros until @num` to the :n:`@num`-th non-dependent + This tactic behaves as :n:`intros until @natural; elim @ident` where :n:`@ident` + is the name given by :n:`intros until @natural` to the :n:`@natural`-th non-dependent premise of the goal. .. tacn:: double induction @ident @ident @@ -2039,7 +2037,7 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) :n:`induction @ident; induction @ident` (or :n:`induction @ident ; destruct @ident` depending on the exact needs). -.. tacv:: double induction @num__1 @num__2 +.. tacv:: double induction @natural__1 @natural__2 This tactic is deprecated and should be replaced by :n:`induction num1; induction num3` where :n:`num3` is the result @@ -2148,9 +2146,9 @@ and an explanation of the underlying technique. .. exn:: Not a discriminable equality. :undocumented: -.. tacv:: discriminate @num +.. tacv:: discriminate @natural - This does the same thing as :n:`intros until @num` followed by + This does the same thing as :n:`intros until @natural` followed by :n:`discriminate @ident` where :n:`@ident` is the identifier for the last introduced hypothesis. @@ -2159,12 +2157,12 @@ and an explanation of the underlying technique. This does the same thing as :n:`discriminate @term` but using the given bindings to instantiate parameters or hypotheses of :n:`@term`. -.. tacv:: ediscriminate @num +.. tacv:: ediscriminate @natural ediscriminate @term {? with @bindings_list} :name: ediscriminate; _ This works the same as :tacn:`discriminate` but if the type of :token:`term`, or the - type of the hypothesis referred to by :token:`num`, has uninstantiated + type of the hypothesis referred to by :token:`natural`, has uninstantiated parameters, these parameters are left as existential variables. .. tacv:: discriminate @@ -2227,9 +2225,6 @@ and an explanation of the underlying technique. then :n:`injection @ident` first introduces the hypothesis in the local context using :n:`intros until @ident`. - .. exn:: Not a projectable equality but a discriminable one. - :undocumented: - .. exn:: Nothing to do, it is an equality between convertible terms. :undocumented: @@ -2237,11 +2232,12 @@ and an explanation of the underlying technique. :undocumented: .. exn:: Nothing to inject. - :undocumented: - .. tacv:: injection @num + This error is given when one side of the equality is not a constructor. - This does the same thing as :n:`intros until @num` followed by + .. tacv:: injection @natural + + This does the same thing as :n:`intros until @natural` followed by :n:`injection @ident` where :n:`@ident` is the identifier for the last introduced hypothesis. @@ -2250,12 +2246,12 @@ and an explanation of the underlying technique. This does the same as :n:`injection @term` but using the given bindings to instantiate parameters or hypotheses of :n:`@term`. - .. tacv:: einjection @num + .. tacv:: einjection @natural einjection @term {? with @bindings_list} :name: einjection; _ This works the same as :n:`injection` but if the type of :n:`@term`, or the - type of the hypothesis referred to by :n:`@num`, has uninstantiated + type of the hypothesis referred to by :n:`@natural`, has uninstantiated parameters, these parameters are left as existential variables. .. tacv:: injection @@ -2267,10 +2263,10 @@ and an explanation of the underlying technique. :undocumented: .. tacv:: injection @term {? with @bindings_list} as {+ @simple_intropattern} - injection @num as {+ @simple_intropattern} + injection @natural as {+ @simple_intropattern} injection as {+ @simple_intropattern} einjection @term {? with @bindings_list} as {+ @simple_intropattern} - einjection @num as {+ @simple_intropattern} + einjection @natural as {+ @simple_intropattern} einjection as {+ @simple_intropattern} These variants apply :n:`intros {+ @simple_intropattern}` after the call to @@ -2282,10 +2278,10 @@ and an explanation of the underlying technique. corresponds to a hypothesis. .. tacv:: injection @term {? with @bindings_list} as @injection_intropattern - injection @num as @injection_intropattern + injection @natural as @injection_intropattern injection as @injection_intropattern einjection @term {? with @bindings_list} as @injection_intropattern - einjection @num as @injection_intropattern + einjection @natural as @injection_intropattern einjection as @injection_intropattern These are equivalent to the previous variants but using instead the @@ -2334,9 +2330,9 @@ and an explanation of the underlying technique. :g:`Prop`). This behavior can be turned off by using the :flag:`Keep Proof Equalities` setting. -.. tacv:: inversion @num +.. tacv:: inversion @natural - This does the same thing as :n:`intros until @num` then :n:`inversion @ident` + This does the same thing as :n:`intros until @natural` then :n:`inversion @ident` where :n:`@ident` is the identifier for the last introduced hypothesis. .. tacv:: inversion_clear @ident @@ -2379,9 +2375,9 @@ and an explanation of the underlying technique. Goal forall l:list nat, contains0 (1 :: l) -> contains0 l. intros l H; inversion H as [ | l' p Hl' [Heqp Heql'] ]. -.. tacv:: inversion @num as @or_and_intropattern_loc +.. tacv:: inversion @natural as @or_and_intropattern_loc - This allows naming the hypotheses introduced by :n:`inversion @num` in the + This allows naming the hypotheses introduced by :n:`inversion @natural` in the context. .. tacv:: inversion_clear @ident as @or_and_intropattern_loc @@ -2629,7 +2625,7 @@ and an explanation of the underlying technique. .. seealso:: :tacn:`functional inversion` -.. tacn:: fix @ident @num +.. tacn:: fix @ident @natural :name: fix This tactic is a primitive tactic to start a proof by induction. In @@ -2637,11 +2633,11 @@ and an explanation of the underlying technique. as the ones described in :tacn:`induction`. In the syntax of the tactic, the identifier :n:`@ident` is the name given to - the induction hypothesis. The natural number :n:`@num` tells on which + the induction hypothesis. The natural number :n:`@natural` tells on which premise of the current goal the induction acts, starting from 1, counting both dependent and non dependent products, but skipping local definitions. Especially, the current lemma must be composed of at - least :n:`@num` products. + least :n:`@natural` products. Like in a fix expression, the induction hypotheses have to be used on structurally smaller arguments. The verification that inductive proof @@ -2650,7 +2646,7 @@ and an explanation of the underlying technique. is correct at some time of the interactive development of a proof, use the command ``Guarded`` (see Section :ref:`requestinginformation`). -.. tacv:: fix @ident @num with {+ (@ident {+ @binder} [{struct @ident}] : @type)} +.. tacv:: fix @ident @natural with {+ (@ident {+ @binder} [{struct @ident}] : @type)} This starts a proof by mutual induction. The statements to be simultaneously proved are respectively :g:`forall binder ... binder, type`. @@ -2760,11 +2756,11 @@ simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. + `?` : the tactic :n:`rewrite ?@term` performs the rewrite of :token:`term` as many times as possible (perhaps zero time). This form never fails. - + :n:`@num?` : works similarly, except that it will do at most :token:`num` rewrites. + + :n:`@natural?` : works similarly, except that it will do at most :token:`natural` rewrites. + `!` : works as `?`, except that at least one rewrite should succeed, otherwise the tactic fails. - + :n:`@num!` (or simply :n:`@num`) : precisely :token:`num` rewrites of :token:`term` will be done, - leading to failure if these :token:`num` rewrites are not possible. + + :n:`@natural!` (or simply :n:`@natural`) : precisely :token:`natural` rewrites of :token:`term` will be done, + leading to failure if these :token:`natural` rewrites are not possible. .. tacv:: erewrite @term :name: erewrite @@ -2821,20 +2817,6 @@ simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. only in the conclusion of the goal. The clause argument must not contain any ``type of`` nor ``value of``. - .. tacv:: cutrewrite <- (@term = @term’) - :name: cutrewrite - - .. deprecated:: 8.5 - - This tactic can be replaced by :n:`enough (@term = @term’) as <-`. - - .. tacv:: cutrewrite -> (@term = @term’) - - .. deprecated:: 8.5 - - This tactic can be replaced by :n:`enough (@term = @term’) as ->`. - - .. tacn:: subst @ident :name: subst @@ -2955,15 +2937,15 @@ simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. This replaces the occurrences of :n:`@term` by :n:`@term’` in the current goal. The term :n:`@term` and :n:`@term’` must be convertible. - .. tacv:: change @term at {+ @num} with @term’ + .. tacv:: change @term at {+ @natural} with @term’ - This replaces the occurrences numbered :n:`{+ @num}` of :n:`@term` by :n:`@term’` + This replaces the occurrences numbered :n:`{+ @natural}` of :n:`@term` by :n:`@term’` in the current goal. The terms :n:`@term` and :n:`@term’` must be convertible. .. exn:: Too few occurrences. :undocumented: - .. tacv:: change @term {? {? at {+ @num}} with @term} in @ident + .. tacv:: change @term {? {? at {+ @natural}} with @term} in @ident This applies the :tacn:`change` tactic not to the goal but to the hypothesis :n:`@ident`. @@ -2997,9 +2979,9 @@ Performing computations | pattern {+, @pattern_occ } | @ident delta_flag ::= {? - } [ {+ @reference } ] - strategy_flag ::= {+ @red_flags } + strategy_flag ::= {+ @red_flag } | @delta_flag - red_flags ::= beta + red_flag ::= beta | iota | match | fix @@ -3008,9 +2990,9 @@ Performing computations | delta {? @delta_flag } ref_or_pattern_occ ::= @reference {? at @occs_nums } | @one_term {? at @occs_nums } - occs_nums ::= {+ {| @num | @ident } } - | - {| @num | @ident } {* @int_or_var } - int_or_var ::= @int + occs_nums ::= {+ {| @natural | @ident } } + | - {| @natural | @ident } {* @int_or_var } + int_or_var ::= @integer | @ident unfold_occ ::= @reference {? at @occs_nums } pattern_occ ::= @one_term {? at @occs_nums } @@ -3246,9 +3228,9 @@ the conversion in hypotheses :n:`{+ @ident}`. This applies :tacn:`simpl` only to the subterms matching :n:`@pattern` in the current goal. -.. tacv:: simpl @pattern at {+ @num} +.. tacv:: simpl @pattern at {+ @natural} - This applies :tacn:`simpl` only to the :n:`{+ @num}` occurrences of the subterms + This applies :tacn:`simpl` only to the :n:`{+ @natural}` occurrences of the subterms matching :n:`@pattern` in the current goal. .. exn:: Too few occurrences. @@ -3261,10 +3243,10 @@ the conversion in hypotheses :n:`{+ @ident}`. is the unfoldable constant :n:`@qualid` (the constant can be referred to by its notation using :n:`@string` if such a notation exists). -.. tacv:: simpl @qualid at {+ @num} - simpl @string at {+ @num} +.. tacv:: simpl @qualid at {+ @natural} + simpl @string at {+ @natural} - This applies :tacn:`simpl` only to the :n:`{+ @num}` applicative subterms whose + This applies :tacn:`simpl` only to the :n:`{+ @natural}` applicative subterms whose head occurrence is :n:`@qualid` (or :n:`@string`). .. flag:: Debug RAKAM @@ -3392,14 +3374,14 @@ the conversion in hypotheses :n:`{+ @ident}`. :g:`(fun x:A =>` :math:`\varphi`:g:`(x)) t`. This tactic can be used, for instance, when the tactic ``apply`` fails on matching. -.. tacv:: pattern @term at {+ @num} +.. tacv:: pattern @term at {+ @natural} - Only the occurrences :n:`{+ @num}` of :n:`@term` are considered for + Only the occurrences :n:`{+ @natural}` of :n:`@term` are considered for :math:`\beta`-expansion. Occurrences are located from left to right. -.. tacv:: pattern @term at - {+ @num} +.. tacv:: pattern @term at - {+ @natural} - All occurrences except the occurrences of indexes :n:`{+ @num }` + All occurrences except the occurrences of indexes :n:`{+ @natural }` of :n:`@term` are considered for :math:`\beta`-expansion. Occurrences are located from left to right. @@ -3412,12 +3394,12 @@ the conversion in hypotheses :n:`{+ @ident}`. If :g:`t`:sub:`i` occurs in one of the generated types :g:`A`:sub:`j` these occurrences will also be considered and possibly abstracted. -.. tacv:: pattern {+, @term at {+ @num}} +.. tacv:: pattern {+, @term at {+ @natural}} - This behaves as above but processing only the occurrences :n:`{+ @num}` of + This behaves as above but processing only the occurrences :n:`{+ @natural}` of :n:`@term` starting from :n:`@term`. -.. tacv:: pattern {+, @term {? at {? -} {+, @num}}} +.. tacv:: pattern {+, @term {? at {? -} {+, @natural}}} This is the most general syntax that combines the different variants. @@ -3574,9 +3556,9 @@ Automation :tacn:`simple apply` so it is expected that sometimes :tacn:`auto` will fail even if applying manually one of the hints would succeed. - .. tacv:: auto @num + .. tacv:: auto @natural - Forces the search depth to be :token:`num`. The maximal search depth + Forces the search depth to be :token:`natural`. The maximal search depth is 5 by default. .. tacv:: auto with {+ @ident} @@ -3627,7 +3609,7 @@ Automation Behaves like :tacn:`auto` but shows the tactics it tries to solve the goal, including failing paths. - .. tacv:: {? info_}auto {? @num} {? using {+ @qualid}} {? with {+ @ident}} + .. tacv:: {? info_}auto {? @natural} {? using {+ @qualid}} {? with {+ @ident}} This is the most general form, combining the various options. @@ -3682,7 +3664,7 @@ Automation Note that ``ex_intro`` should be declared as a hint. - .. tacv:: {? info_}eauto {? @num} {? using {+ @qualid}} {? with {+ @ident}} + .. tacv:: {? info_}eauto {? @natural} {? using {+ @qualid}} {? with {+ @ident}} The various options for :tacn:`eauto` are the same as for :tacn:`auto`. @@ -3845,12 +3827,12 @@ automatically created. .. deprecated:: 8.10 - .. cmdv:: Hint Resolve @qualid {? | {? @num} {? @pattern}} : @ident + .. cmdv:: Hint Resolve @qualid {? | {? @natural} {? @pattern}} : @ident :name: Hint Resolve This command adds :n:`simple apply @qualid` to the hint list with the head symbol of the type of :n:`@qualid`. The cost of that hint is the number of - subgoals generated by :n:`simple apply @qualid` or :n:`@num` if specified. The + subgoals generated by :n:`simple apply @qualid` or :n:`@natural` if specified. The associated :n:`@pattern` is inferred from the conclusion of the type of :n:`@qualid` or the given :n:`@pattern` if specified. In case the inferred type of :n:`@qualid` does not start with a product the tactic added in the hint list @@ -3948,7 +3930,7 @@ automatically created. overwriting the existing settings of opacity. It is advised to use this just after a :cmd:`Create HintDb` command. - .. cmdv:: Hint Extern @num {? @pattern} => @tactic : @ident + .. cmdv:: Hint Extern @natural {? @pattern} => @tactic : @ident :name: Hint Extern This hint type is to extend :tacn:`auto` with tactics other than :tacn:`apply` and @@ -3991,15 +3973,15 @@ automatically created. the following. Beware, there is no operator precedence during parsing, one can check with :cmd:`Print HintDb` to verify the current cut expression: - .. productionlist:: regexp - regexp : `ident` (hint or instance identifier) - : _ (any hint) - : `regexp` | `regexp` (disjunction) - : `regexp` `regexp` (sequence) - : `regexp` * (Kleene star) - : emp (empty) - : eps (epsilon) - : ( `regexp` ) + .. prodn:: + regexp ::= @ident (hint or instance identifier) + | _ (any hint) + | @regexp | @regexp (disjunction) + | @regexp @regexp (sequence) + | @regexp * (Kleene star) + | emp (empty) + | eps (epsilon) + | ( @regexp ) The `emp` regexp does not match any search path while `eps` matches the empty path. During proof search, the path of @@ -4377,7 +4359,7 @@ some incompatibilities. This combines the effects of the different variants of :tacn:`firstorder`. -.. opt:: Firstorder Depth @num +.. opt:: Firstorder Depth @natural :name: Firstorder Depth This option controls the proof-search depth bound. @@ -4414,10 +4396,10 @@ some incompatibilities. congruence. Qed. -.. tacv:: congruence @num +.. tacv:: congruence @natural - Tries to add at most :token:`num` instances of hypotheses stating quantified equalities - to the problem in order to solve it. A bigger value of :token:`num` does not make + Tries to add at most :token:`natural` instances of hypotheses stating quantified equalities + to the problem in order to solve it. A bigger value of :token:`natural` does not make success slower, only failure. You might consider adding some lemmas as hypotheses using assert in order for :tacn:`congruence` to use them. @@ -4616,9 +4598,9 @@ symbol :g:`=`. then :n:`simplify_eq @ident` first introduces the hypothesis in the local context using :n:`intros until @ident`. -.. tacv:: simplify_eq @num +.. tacv:: simplify_eq @natural - This does the same thing as :n:`intros until @num` then + This does the same thing as :n:`intros until @natural` then :n:`simplify_eq @ident` where :n:`@ident` is the identifier for the last introduced hypothesis. @@ -4627,12 +4609,12 @@ symbol :g:`=`. This does the same as :n:`simplify_eq @term` but using the given bindings to instantiate parameters or hypotheses of :n:`@term`. -.. tacv:: esimplify_eq @num +.. tacv:: esimplify_eq @natural esimplify_eq @term {? with @bindings_list} :name: esimplify_eq; _ This works the same as :tacn:`simplify_eq` but if the type of :n:`@term`, or the - type of the hypothesis referred to by :n:`@num`, has uninstantiated + type of the hypothesis referred to by :n:`@natural`, has uninstantiated parameters, these parameters are left as existential variables. .. tacv:: simplify_eq @@ -4688,17 +4670,15 @@ Automating tautologies. It solves goals of the form :g:`t = u` where `t` and `u` are constructed over the following grammar: - .. _btauto_grammar: - - .. productionlist:: sentence - btauto_term : `ident` - : true - : false - : orb `btauto_term` `btauto_term` - : andb `btauto_term` `btauto_term` - : xorb `btauto_term` `btauto_term` - : negb `btauto_term` - : if `btauto_term` then `btauto_term` else `btauto_term` + .. prodn:: + btauto_term ::= @ident + | true + | false + | orb @btauto_term @btauto_term + | andb @btauto_term @btauto_term + | xorb @btauto_term @btauto_term + | negb @btauto_term + | if @btauto_term then @btauto_term else @btauto_term Whenever the formula supplied is not a tautology, it also provides a counter-example. @@ -4757,12 +4737,16 @@ Non-logical tactics ------------------------ -.. tacn:: cycle @num +.. tacn:: cycle @integer :name: cycle - This tactic puts the :n:`@num` first goals at the end of the list of goals. - If :n:`@num` is negative, it will put the last :math:`|num|` goals at the + Reorders the selected goals so that the first :n:`@integer` goals appear after the + other selected goals. + If :n:`@integer` is negative, it puts the last :n:`@integer` goals at the beginning of the list. + The tactic is only useful with a goal selector, most commonly `all:`. + Note that other selectors reorder goals; `1,3: cycle 1` is not equivalent + to `all: cycle 1`. See :tacn:`… : … (goal selector)`. .. example:: @@ -4777,13 +4761,15 @@ Non-logical tactics all: cycle 2. all: cycle -3. -.. tacn:: swap @num @num +.. tacn:: swap @integer @integer :name: swap - This tactic switches the position of the goals of indices :n:`@num` and - :n:`@num`. Negative values for:n:`@num` indicate counting goals - backward from the end of the focused goal list. Goals are indexed from 1, - there is no goal with position 0. + Exchanges the position of the specified goals. + Negative values for :n:`@integer` indicate counting goals + backward from the end of the list of selected goals. Goals are indexed from 1. + The tactic is only useful with a goal selector, most commonly `all:`. + Note that other selectors reorder goals; `1,3: swap 1 3` is not equivalent + to `all: swap 1 3`. See :tacn:`… : … (goal selector)`. .. example:: @@ -4797,7 +4783,9 @@ Non-logical tactics .. tacn:: revgoals :name: revgoals - This tactics reverses the list of the focused goals. + Reverses the order of the selected goals. The tactic is only useful with a goal + selector, most commonly `all :`. Note that other selectors reorder goals; + `1,3: revgoals` is not equivalent to `all: revgoals`. See :tacn:`… : … (goal selector)`. .. example:: @@ -4925,10 +4913,10 @@ Performance-oriented tactic variants .. tacv:: change_no_check @term with @term’ :undocumented: - .. tacv:: change_no_check @term at {+ @num} with @term’ + .. tacv:: change_no_check @term at {+ @natural} with @term’ :undocumented: - .. tacv:: change_no_check @term {? {? at {+ @num}} with @term} in @ident + .. tacv:: change_no_check @term {? {? at {+ @natural}} with @term} in @ident .. example:: diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index ad0aab19b5..6c07253bce 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -32,7 +32,7 @@ Displaying .. exn:: @qualid not a defined object. :undocumented: - .. exn:: Universe instance should have length @num. + .. exn:: Universe instance should have length @natural. :undocumented: .. exn:: This object does not support universe names. @@ -44,9 +44,9 @@ Displaying This command displays information about the current state of the environment, including sections and modules. -.. cmd:: Inspect @num +.. cmd:: Inspect @natural - This command displays the :n:`@num` last objects of the + This command displays the :n:`@natural` last objects of the current environment, including sections and modules. .. cmd:: Print Section @qualid @@ -60,7 +60,7 @@ Query commands -------------- Unlike other commands, :production:`query_command`\s may be prefixed with -a goal selector (:n:`@num:`) to specify which goal context it applies to. +a goal selector (:n:`@natural:`) to specify which goal context it applies to. If no selector is provided, the command applies to the current goal. If no proof is open, then the command only applies to accessible objects. (see Section :ref:`invocation-of-tactics`). @@ -757,10 +757,10 @@ interactively, they cannot be part of a vernacular file loaded via of the interactive session. -.. cmd:: Back {? @num } +.. cmd:: Back {? @natural } - Undoes all the effects of the last :n:`@num @sentence`\s. If - :n:`@num` is not specified, the command undoes one sentence. + Undoes all the effects of the last :n:`@natural @sentence`\s. If + :n:`@natural` is not specified, the command undoes one sentence. Sentences read from a `.v` file via a :cmd:`Load` are considered a single sentence. While :cmd:`Back` can undo tactics and commands executed within proof mode, once you exit proof mode, such as with :cmd:`Qed`, all @@ -772,14 +772,14 @@ interactively, they cannot be part of a vernacular file loaded via The user wants to undo more commands than available in the history. -.. cmd:: BackTo @num +.. cmd:: BackTo @natural - This command brings back the system to the state labeled :n:`@num`, + This command brings back the system to the state labeled :n:`@natural`, forgetting the effect of all commands executed after this state. The state label is an integer which grows after each successful command. It is displayed in the prompt when in -emacs mode. Just as :cmd:`Back` (see above), the :cmd:`BackTo` command now handles proof states. For that, it may - have to undo some extra commands and end on a state :n:`@num′ ≤ @num` if + have to undo some extra commands and end on a state :n:`@natural′ ≤ @natural` if necessary. .. _quitting-and-debugging: @@ -834,16 +834,16 @@ Quitting and debugging output to the file ":n:`@string`.out". -.. cmd:: Timeout @num @sentence +.. cmd:: Timeout @natural @sentence Executes :n:`@sentence`. If the operation - has not terminated after :n:`@num` seconds, then it is interrupted and an error message is + has not terminated after :n:`@natural` seconds, then it is interrupted and an error message is displayed. - .. opt:: Default Timeout @num + .. opt:: Default Timeout @natural :name: Default Timeout - If set, each :n:`@sentence` is treated as if it was prefixed with :cmd:`Timeout` :n:`@num`, + If set, each :n:`@sentence` is treated as if it was prefixed with :cmd:`Timeout` :n:`@natural`, except for :cmd:`Timeout` commands themselves. If unset, no timeout is applied. @@ -890,14 +890,14 @@ Controlling display interpreted from left to right, so in case of an overlap, the flags on the right have higher priority, meaning that `A,-A` is equivalent to `-A`. -.. opt:: Printing Width @num +.. opt:: Printing Width @natural :name: Printing Width This command sets which left-aligned part of the width of the screen is used for display. At the time of writing this documentation, the default value is 78. -.. opt:: Printing Depth @num +.. opt:: Printing Depth @natural :name: Printing Depth This option controls the nesting depth of the formatter used for pretty- @@ -1028,7 +1028,7 @@ described first. .. prodn:: strategy_level ::= opaque - | @int + | @integer | expand | transparent strategy_level_or_var ::= @strategy_level @@ -1052,7 +1052,7 @@ described first. + ``opaque`` : level of opaque constants. They cannot be expanded by tactics (behaves like +∞, see next item). - + :n:`@int` : levels indexed by an integer. Level 0 corresponds to the + + :n:`@integer` : levels indexed by an integer. Level 0 corresponds to the default behavior, which corresponds to transparent constants. This level can also be referred to as ``transparent``. Negative levels correspond to constants to be expanded before normal transparent @@ -1265,9 +1265,9 @@ Inlining hints for the fast reduction machines Registering primitive operations ```````````````````````````````` -.. cmd:: Primitive @ident {? : @term } := #@ident__prim +.. cmd:: Primitive @ident_decl {? : @term } := #@ident - Makes the primitive type or primitive operator :n:`#@ident__prim` defined in OCaml + Makes the primitive type or primitive operator :n:`#@ident` defined in OCaml accessible in |Coq| commands and tactics. For internal use by implementors of |Coq|'s standard library or standard library replacements. No space is allowed after the `#`. Invalid values give a syntax diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index 18149a690a..6ba53b581b 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -241,12 +241,12 @@ notation is the insertion of spaces at some places of the notation. This is performed by adding extra spaces between the symbols and parameters: each extra space (other than the single space needed to separate the components) is interpreted as a space to be inserted by -the printer. Here is an example showing how to add spaces around the -bar of the notation. +the printer. Here is an example showing how to add spaces next to the +curly braces. .. coqtop:: in - Notation "{{ x : A | P }}" := (sig (fun x : A => P)) (at level 0, x at level 99). + Notation "{{ x : A | P }}" := (sig (fun x : A => P)) (at level 0, x at level 99). .. coqtop:: all @@ -425,16 +425,98 @@ Displaying information about notations (corresponding to :token:`ltac_expr` in the documentation). - `vernac` - for :token:`command`\s - The first three of these give the precedence and associativity for each construct. - For example, these lines printed by `Print Grammar tactic` indicates that the `try` construct - is at level 3 and right-associative. `SELF` represents the `tactic_expr` nonterminal - at level 5 (the top level):: - + This command doesn't display all nonterminals of the grammar. For example, + productions shown by `Print Grammar tactic` refer to nonterminals `tactic_then_locality` + and `tactic_then_gen` which are not shown and can't be printed. + + The prefixes `tactic:`, `prim:`, `constr:` appearing in the output are meant to identify + what part of the grammar a nonterminal is from. If you examine nonterminal definitions + in the source code, they are identified only by the name following the colon. + + Most of the grammar in the documentation was updated in 8.12 to make it accurate and + readable. This was done using a new developer tool that extracts the grammar from the + source code, edits it and inserts it into the documentation files. While the + edited grammar is equivalent to the original, for readability some nonterminals + have been renamed and others have been eliminated by substituting the nonterminal + definition where the nonterminal was referenced. This command shows the original grammar, + so it won't exactly match the documentation. + + The |Coq| parser is based on Camlp5. The documentation for + `Extensible grammars <http://camlp5.github.io/doc/htmlc/grammars.html>`_ is the + most relevant but it assumes considerable knowledge. Here are the essentials: + + Productions can contain the following elements: + + - nonterminal names - identifiers in the form `[a-zA-Z0-9_]*` + - `"…"` - a literal string that becomes a keyword and cannot be used as an :token:`ident`. + The string doesn't have to be a valid identifier; frequently the string will contain only + punctuation characters. + - `IDENT "…"` - a literal string that has the form of an :token:`ident` + - `OPT element` - optionally include `element` (e.g. a nonterminal, IDENT "…" or "…") + - `LIST1 element` - a list of one or more `element`\s + - `LIST0 element` - an optional list of `element`\s + - `LIST1 element SEP sep` - a list of `element`\s separated by `sep` + - `LIST0 element SEP sep` - an optional list of `element`\s separated by `sep` + - `[ elements1 | elements2 | … ]` - alternatives (either `elements1` or `elements2` or …) + + Nonterminals can have multiple **levels** to specify precedence and associativity + of its productions. This feature of grammars makes it simple to parse input + such as `1+2*3` in the usual way as `1+(2*3)`. However, most nonterminals have a single level. + + For example, this output from `Print Grammar tactic` shows the first 3 levels for + `tactic_expr`, designated as "5", "4" and "3". Level 3 is right-associative, + which applies to the productions within it, such as the `try` construct:: + + Entry tactic:tactic_expr is + [ "5" RIGHTA + [ tactic:binder_tactic ] + | "4" LEFTA + [ SELF; ";"; tactic:binder_tactic + | SELF; ";"; SELF + | SELF; ";"; tactic_then_locality; tactic_then_gen; "]" ] | "3" RIGHTA [ IDENT "try"; SELF + : + + The interpretation of `SELF` depends on its position in the production and the + associativity of the level: + + - At the beginning of a production, `SELF` means the next level. In the + fragment shown above, the next level for `try` is "2". (This is defined by the order + of appearance in the grammar or output; the levels could just as well be + named "foo" and "bar".) + - In the middle of a production, `SELF` means the top level ("5" in the fragment) + - At the end of a production, `SELF` means the next level within + `LEFTA` levels and the current level within `RIGHTA` levels. + + `NEXT` always means the next level. `nonterminal LEVEL "…"` is a reference to the specified level + for `nonterminal`. + + `Associativity <http://camlp5.github.io/doc/htmlc/grammars.html#b:Associativity>`_ + explains `SELF` and `NEXT` in somewhat more detail. + + The output for `Print Grammar constr` includes :cmd:`Notation` definitions, + which are dynamically added to the grammar at run time. + For example, in the definition for `operconstr`, the production on the second line shown + here is defined by a :cmd:`Reserved Notation` command in `Notations.v`:: + + | "50" LEFTA + [ SELF; "||"; NEXT - Note that the productions printed by this command are represented in the form used by - |Coq|'s parser (coqpp), which differs from how productions are shown in the documentation. + Similarly, `Print Grammar tactic` includes :cmd:`Tactic Notation`\s, such as :tacn:`dintuition`. + + The file + `doc/tools/docgram/fullGrammar <http://github.com/coq/coq/blob/master/doc/tools/docgram/fullGrammar>`_ + in the source tree extracts the full grammar for + |Coq| (not including notations and tactic notations defined in `*.v` files nor some optionally-loaded plugins) + in a single file with minor changes to handle nonterminals using multiple levels (described in + `doc/tools/docgram/README.md <http://github.com/coq/coq/blob/master/doc/tools/docgram/README.md>`_). + This is complete and much easier to read than the grammar source files. + `doc/tools/docgram/orderedGrammar <http://github.com/coq/coq/blob/master/doc/tools/docgram/orderedGrammar>`_ + has the edited grammar that's used in the documentation. + + Developer documentation for parsing is in + `dev/doc/parsing.md <http://github.com/coq/coq/blob/master/dev/doc/parsing.md>`_. .. _locating-notations: @@ -849,7 +931,7 @@ of patterns have. The lower level is 0 and this is the level used by default to put rules delimited with tokens on both ends. The level is left to be inferred by Coq when using :n:`in custom @ident`. The level is otherwise given explicitly by using the syntax -:n:`in custom @ident at level @num`, where :n:`@num` refers to the level. +:n:`in custom @ident at level @natural`, where :n:`@natural` refers to the level. Levels are cumulative: a notation at level ``n`` of which the left end is a term shall use rules at level less than ``n`` to parse this @@ -872,7 +954,7 @@ where ``x`` is any expression parsed in entry the given rule) and ``y`` is any expression parsed in entry ``expr`` at level strictly less than ``2``. -Rules associated to an entry can refer different sub-entries. The +Rules associated with an entry can refer different sub-entries. The grammar entry name ``constr`` can be used to refer to the main grammar of term as in the rule @@ -958,7 +1040,7 @@ up to the insertion of a pair of curly brackets. .. cmd:: Print Custom Grammar @ident :name: Print Custom Grammar - This displays the state of the grammar for terms associated to + This displays the state of the grammar for terms associated with the custom entry :token:`ident`. .. _NotationSyntax: @@ -971,8 +1053,8 @@ Here are the syntax elements used by the various notation commands. .. insertprodn syntax_modifier level .. prodn:: - syntax_modifier ::= at level @num - | in custom @ident {? at level @num } + syntax_modifier ::= at level @natural + | in custom @ident {? at level @natural } | {+, @ident } at @level | @ident at @level {? @binder_interp } | @ident @explicit_subentry @@ -986,16 +1068,16 @@ Here are the syntax elements used by the various notation commands. explicit_subentry ::= ident | global | bigint - | strict pattern {? at level @num } + | strict pattern {? at level @natural } | binder | closed binder | constr {? at @level } {? @binder_interp } | custom @ident {? at @level } {? @binder_interp } - | pattern {? at level @num } + | pattern {? at level @natural } binder_interp ::= as ident | as pattern | as strict pattern - level ::= level @num + level ::= level @natural | next level .. note:: No typing of the denoted expression is performed at definition @@ -1042,8 +1124,8 @@ refer to different definitions depending on which notation scopes are currently open. For instance, the infix symbol ``+`` can be used to refer to distinct definitions of the addition operator, such as for natural numbers, integers or reals. -Notation scopes can include an interpretation for numerals and -strings with the :cmd:`Numeral Notation` and :cmd:`String Notation` commands. +Notation scopes can include an interpretation for numbers and +strings with the :cmd:`Number Notation` and :cmd:`String Notation` commands. .. insertprodn scope scope_key @@ -1211,6 +1293,8 @@ recognized to be a ``Funclass`` instance, i.e., of type :g:`forall x:A, B` or :g:`A -> B`. +.. _notation-scopes: + Notation scopes used in the standard library of Coq ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1229,31 +1313,31 @@ Scopes` or :cmd:`Print Scope`. ``nat_scope`` This scope includes the standard arithmetical operators and relations on type - nat. Positive integer numerals in this scope are mapped to their canonical + nat. Positive integer numbers in this scope are mapped to their canonical representent built from :g:`O` and :g:`S`. The scope is delimited by the key ``nat``, and bound to the type :g:`nat` (see above). ``N_scope`` This scope includes the standard arithmetical operators and relations on type :g:`N` (binary natural numbers). It is delimited by the key ``N`` and comes - with an interpretation for numerals as closed terms of type :g:`N`. + with an interpretation for numbers as closed terms of type :g:`N`. ``Z_scope`` This scope includes the standard arithmetical operators and relations on type :g:`Z` (binary integer numbers). It is delimited by the key ``Z`` and comes - with an interpretation for numerals as closed terms of type :g:`Z`. + with an interpretation for numbers as closed terms of type :g:`Z`. ``positive_scope`` This scope includes the standard arithmetical operators and relations on type :g:`positive` (binary strictly positive numbers). It is delimited by - key ``positive`` and comes with an interpretation for numerals as closed + key ``positive`` and comes with an interpretation for numbers as closed terms of type :g:`positive`. ``Q_scope`` This scope includes the standard arithmetical operators and relations on type :g:`Q` (rational numbers defined as fractions of an integer and a strictly positive integer modulo the equality of the numerator- - denominator cross-product) and comes with an interpretation for numerals + denominator cross-product) and comes with an interpretation for numbers as closed terms of type :g:`Q`. ``Qc_scope`` @@ -1264,7 +1348,7 @@ Scopes` or :cmd:`Print Scope`. ``R_scope`` This scope includes the standard arithmetical operators and relations on type :g:`R` (axiomatic real numbers). It is delimited by the key ``R`` and comes - with an interpretation for numerals using the :g:`IZR` morphism from binary + with an interpretation for numbers using the :g:`IZR` morphism from binary integer numbers to :g:`R` and :g:`Z.pow_pos` for potential exponent parts. ``bool_scope`` @@ -1432,68 +1516,68 @@ Abbreviations .. extracted from Gallina chapter -Numerals and strings --------------------- +Numbers and strings +------------------- .. insertprodn primitive_notations primitive_notations .. prodn:: - primitive_notations ::= @numeral + primitive_notations ::= @number | @string -Numerals and strings have no predefined semantics in the calculus. They are +Numbers and strings have no predefined semantics in the calculus. They are merely notations that can be bound to objects through the notation mechanism. -Initially, numerals are bound to Peano’s representation of natural +Initially, numbers are bound to Peano’s representation of natural numbers (see :ref:`datatypes`). .. note:: - Negative integers are not at the same level as :n:`@num`, for this + Negative integers are not at the same level as :n:`@natural`, for this would make precedence unnatural. -.. _numeral-notations: +.. _number-notations: -Numeral notations -~~~~~~~~~~~~~~~~~ +Number notations +~~~~~~~~~~~~~~~~ -.. cmd:: Numeral Notation @qualid @qualid__parse @qualid__print : @scope_name {? @numeral_modifier } - :name: Numeral Notation +.. cmd:: Number Notation @qualid__type @qualid__parse @qualid__print : @scope_name {? @numeral_modifier } + :name: Number Notation .. insertprodn numeral_modifier numeral_modifier .. prodn:: - numeral_modifier ::= ( warning after @numeral ) - | ( abstract after @numeral ) + numeral_modifier ::= ( warning after @bignat ) + | ( abstract after @bignat ) This command allows the user to customize the way numeral literals are parsed and printed. - :n:`@qualid` + :n:`@qualid__type` the name of an inductive type, while :n:`@qualid__parse` and :n:`@qualid__print` should be the names of the parsing and printing functions, respectively. The parsing function :n:`@qualid__parse` should have one of the following types: - * :n:`Numeral.int -> @qualid` - * :n:`Numeral.int -> option @qualid` - * :n:`Numeral.uint -> @qualid` - * :n:`Numeral.uint -> option @qualid` - * :n:`Z -> @qualid` - * :n:`Z -> option @qualid` - * :n:`Numeral.numeral -> @qualid` - * :n:`Numeral.numeral -> option @qualid` + * :n:`Numeral.int -> @qualid__type` + * :n:`Numeral.int -> option @qualid__type` + * :n:`Numeral.uint -> @qualid__type` + * :n:`Numeral.uint -> option @qualid__type` + * :n:`Z -> @qualid__type` + * :n:`Z -> option @qualid__type` + * :n:`Numeral.numeral -> @qualid__type` + * :n:`Numeral.numeral -> option @qualid__type` And the printing function :n:`@qualid__print` should have one of the following types: - * :n:`@qualid -> Numeral.int` - * :n:`@qualid -> option Numeral.int` - * :n:`@qualid -> Numeral.uint` - * :n:`@qualid -> option Numeral.uint` - * :n:`@qualid -> Z` - * :n:`@qualid -> option Z` - * :n:`@qualid -> Numeral.numeral` - * :n:`@qualid -> option Numeral.numeral` + * :n:`@qualid__type -> Numeral.int` + * :n:`@qualid__type -> option Numeral.int` + * :n:`@qualid__type -> Numeral.uint` + * :n:`@qualid__type -> option Numeral.uint` + * :n:`@qualid__type -> Z` + * :n:`@qualid__type -> option Z` + * :n:`@qualid__type -> Numeral.numeral` + * :n:`@qualid__type -> option Numeral.numeral` .. deprecated:: 8.12 Numeral notations on :g:`Decimal.uint`, :g:`Decimal.int` and @@ -1509,59 +1593,59 @@ Numeral notations function application, constructors, inductive type families, sorts, and primitive integers) will be considered for printing. - :n:`( warning after @numeral )` + :n:`( warning after @bignat )` displays a warning message about a possible stack - overflow when calling :n:`@qualid__parse` to parse a literal larger than :n:`@numeral`. + overflow when calling :n:`@qualid__parse` to parse a literal larger than :n:`@bignat`. .. warn:: Stack overflow or segmentation fault happens when working with large numbers in @type (threshold may vary depending on your system limits and on the command executed). - When a :cmd:`Numeral Notation` is registered in the current scope - with :n:`(warning after @numeral)`, this warning is emitted when - parsing a numeral greater than or equal to :token:`numeral`. + When a :cmd:`Number Notation` is registered in the current scope + with :n:`(warning after @bignat)`, this warning is emitted when + parsing a number greater than or equal to :token:`bignat`. - :n:`( abstract after @numeral )` + :n:`( abstract after @bignat )` returns :n:`(@qualid__parse m)` when parsing a literal - :n:`m` that's greater than :n:`@numeral` rather than reducing it to a normal form. + :n:`m` that's greater than :n:`@bignat` rather than reducing it to a normal form. Here :g:`m` will be a - :g:`Numeral.int` or :g:`Numeral.uint` or :g:`Z`, depending on the + :g:`Numeral.int`, :g:`Numeral.uint`, :g:`Z` or :g:`Numeral.numeral`, depending on the type of the parsing function :n:`@qualid__parse`. This allows for a more compact representation of literals in types such as :g:`nat`, and limits parse failures due to stack overflow. Note that a - warning will be emitted when an integer larger than :token:`numeral` - is parsed. Note that :n:`(abstract after @numeral)` has no effect + warning will be emitted when an integer larger than :token:`bignat` + is parsed. Note that :n:`(abstract after @bignat)` has no effect when :n:`@qualid__parse` lands in an :g:`option` type. .. warn:: To avoid stack overflow, large numbers in @type are interpreted as applications of @qualid__parse. - When a :cmd:`Numeral Notation` is registered in the current scope - with :n:`(abstract after @numeral)`, this warning is emitted when - parsing a numeral greater than or equal to :token:`numeral`. + When a :cmd:`Number Notation` is registered in the current scope + with :n:`(abstract after @bignat)`, this warning is emitted when + parsing a number greater than or equal to :token:`bignat`. Typically, this indicates that the fully computed representation - of numerals can be so large that non-tail-recursive OCaml + of numbers can be so large that non-tail-recursive OCaml functions run out of stack space when trying to walk them. .. warn:: The 'abstract after' directive has no effect when the parsing function (@qualid__parse) targets an option type. - As noted above, the :n:`(abstract after @num)` directive has no + As noted above, the :n:`(abstract after @natural)` directive has no effect when :n:`@qualid__parse` lands in an :g:`option` type. .. exn:: Cannot interpret this number as a value of type @type The numeral notation registered for :token:`type` does not support - the given numeral. This error is given when the interpretation + the given number. This error is given when the interpretation function returns :g:`None`, or if the interpretation is registered - only for integers or non-negative integers, and the given numeral + only for integers or non-negative integers, and the given number has a fractional or exponent part or is negative. .. exn:: @qualid__parse should go from Numeral.int to @type or (option @type). Instead of Numeral.int, the types Numeral.uint or Z or Int63.int or Numeral.numeral could be used (you may need to require BinNums or Numeral or Int63 first). - The parsing function given to the :cmd:`Numeral Notation` + The parsing function given to the :cmd:`Number Notation` vernacular is not of the right type. .. exn:: @qualid__print should go from @type to Numeral.int or (option Numeral.int). Instead of Numeral.int, the types Numeral.uint or Z or Int63.int or Numeral.numeral could be used (you may need to require BinNums or Numeral or Int63 first). - The printing function given to the :cmd:`Numeral Notation` + The printing function given to the :cmd:`Number Notation` vernacular is not of the right type. .. exn:: Unexpected term @term while parsing a numeral notation. @@ -1575,9 +1659,11 @@ Numeral notations Parsing functions expected to return an :g:`option` must always return a concrete :g:`Some` or :g:`None` when applied to a - concrete numeral expressed as a (hexa)decimal. They may not return + concrete number expressed as a (hexa)decimal. They may not return opaque constants. +.. _string-notations: + String notations ~~~~~~~~~~~~~~~~ @@ -1663,19 +1749,19 @@ The following errors apply to both string and numeral notations: .. exn:: Syntax error: [prim:reference] expected after 'Notation' (in [vernac:command]). - The type passed to :cmd:`String Notation` or :cmd:`Numeral Notation` must be a single qualified + The type passed to :cmd:`String Notation` or :cmd:`Number Notation` must be a single qualified identifier. .. exn:: Syntax error: [prim:reference] expected after [prim:reference] (in [vernac:command]). - Both functions passed to :cmd:`String Notation` or :cmd:`Numeral Notation` must be single qualified + Both functions passed to :cmd:`String Notation` or :cmd:`Number Notation` must be single qualified identifiers. .. todo: generally we don't document syntax errors. Is this a good execption? .. exn:: @qualid is bound to a notation that does not denote a reference. - Identifiers passed to :cmd:`String Notation` or :cmd:`Numeral Notation` must be global + Identifiers passed to :cmd:`String Notation` or :cmd:`Number Notation` must be global references, or notations which evaluate to single qualified identifiers. .. todo note on "single qualified identifiers" https://github.com/coq/coq/pull/11718#discussion_r415076703 @@ -1694,7 +1780,7 @@ Tactic notations allow customizing the syntax of tactics. can you run into problems if you shadow another tactic or tactic notation? If so, how to avoid ambiguity? -.. cmd:: Tactic Notation {? ( at level @num ) } {+ @ltac_production_item } := @ltac_expr +.. cmd:: Tactic Notation {? ( at level @natural ) } {+ @ltac_production_item } := @ltac_expr .. insertprodn ltac_production_item ltac_production_item @@ -1707,7 +1793,7 @@ Tactic notations allow customizing the syntax of tactics. This command supports the :attr:`local` attribute, which limits the notation to the current module. - :token:`num` + :token:`natural` The parsing precedence to assign to the notation. This information is particularly relevant for notations for tacticals. Levels can be in the range 0 .. 5 (default is 5). @@ -1805,7 +1891,7 @@ Tactic notations allow customizing the syntax of tactics. - :tacn:`refine` * - ``integer`` - - :token:`int` + - :token:`integer` - an integer - diff --git a/doc/sphinx/using/libraries/funind.rst b/doc/sphinx/using/libraries/funind.rst index 3625eac4a5..738d64bfc3 100644 --- a/doc/sphinx/using/libraries/funind.rst +++ b/doc/sphinx/using/libraries/funind.rst @@ -243,16 +243,16 @@ Tactics Function. - .. tacv:: functional inversion @num + .. tacv:: functional inversion @natural - This does the same thing as :n:`intros until @num` followed by + This does the same thing as :n:`intros until @natural` followed by :n:`functional inversion @ident` where :token:`ident` is the identifier for the last introduced hypothesis. .. tacv:: functional inversion @ident @qualid - functional inversion @num @qualid + functional inversion @natural @qualid - If the hypothesis :token:`ident` (or :token:`num`) has a type of the form + If the hypothesis :token:`ident` (or :token:`natural`) has a type of the form :n:`@qualid__1 {+ @term__i } = @qualid__2 {+ @term__j }` where :n:`@qualid__1` and :n:`@qualid__2` are valid candidates to functional inversion, this variant allows choosing which :token:`qualid` diff --git a/doc/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index 284c5d585a..3fef3bcbd1 100644 --- a/doc/tools/coqrst/coqdomain.py +++ b/doc/tools/coqrst/coqdomain.py @@ -351,7 +351,7 @@ class TacticObject(NotationObject): Example:: - .. tacn:: do @num @expr + .. tacn:: do @natural @expr :token:`expr` is evaluated to ``v`` which must be a tactic value. … """ @@ -401,7 +401,7 @@ class OptionObject(NotationObject): Example:: - .. opt:: Hyps Limit @num + .. opt:: Hyps Limit @natural :name Hyps Limit Controls the maximum number of hypotheses displayed in goals after @@ -452,7 +452,7 @@ class ProductionObject(CoqObject): Example:: - .. prodn:: occ_switch ::= { {? {| + | - } } {* @num } } + .. prodn:: occ_switch ::= { {? {| + | - } } {* @natural } } term += let: @pattern := @term in @term | second_production @@ -494,7 +494,11 @@ class ProductionObject(CoqObject): loc = os.path.basename(get_node_location(signode)) raise ExtensionError(ProductionObject.SIG_ERROR.format(loc, signature)) - self.signatures.append((lhs, op, rhs)) + parts = rhs.split(" ", maxsplit=1) + rhs = parts[0].strip() + tag = parts[1].strip() if len(parts) == 2 else "" + + self.signatures.append((lhs, op, rhs, tag)) return [('token', lhs)] if op == '::=' else None def _add_index_entry(self, name, target): @@ -513,21 +517,21 @@ class ProductionObject(CoqObject): self.signatures = [] indexnode = super().run()[0] # makes calls to handle_signature - table = nodes.inline(classes=['prodn-table']) - tgroup = nodes.inline(classes=['prodn-column-group']) - for _ in range(3): - tgroup += nodes.inline(classes=['prodn-column']) + table = nodes.container(classes=['prodn-table']) + tgroup = nodes.container(classes=['prodn-column-group']) + for _ in range(4): + tgroup += nodes.container(classes=['prodn-column']) table += tgroup - tbody = nodes.inline(classes=['prodn-row-group']) + tbody = nodes.container(classes=['prodn-row-group']) table += tbody # create rows for signature in self.signatures: - lhs, op, rhs = signature + lhs, op, rhs, tag = signature position = self.state_machine.get_source_and_line(self.lineno) - row = nodes.inline(classes=['prodn-row']) - entry = nodes.inline(classes=['prodn-cell-nonterminal']) + row = nodes.container(classes=['prodn-row']) + entry = nodes.container(classes=['prodn-cell-nonterminal']) if lhs != "": target_name = 'grammar-token-' + nodes.make_id(lhs) target = nodes.target('', '', ids=[target_name], names=[target_name]) @@ -537,17 +541,21 @@ class ProductionObject(CoqObject): entry += inline entry += notation_to_sphinx('@'+lhs, *position) else: - entry += nodes.literal('', '') + entry += nodes.Text('') row += entry - entry = nodes.inline(classes=['prodn-cell-op']) - entry += nodes.literal(op, op) + entry = nodes.container(classes=['prodn-cell-op']) + entry += nodes.Text(op) row += entry - entry = nodes.inline(classes=['prodn-cell-production']) + entry = nodes.container(classes=['prodn-cell-production']) entry += notation_to_sphinx(rhs, *position) row += entry + entry = nodes.container(classes=['prodn-cell-tag']) + entry += nodes.Text(tag) + row += entry + tbody += row return [indexnode, table] # only this node goes into the doc @@ -1161,7 +1169,7 @@ class StdGlossaryIndex(Index): return content, False def GrammarProductionRole(typ, rawtext, text, lineno, inliner, options={}, content=[]): - """A grammar production not included in a ``productionlist`` directive. + """A grammar production not included in a ``prodn`` directive. Useful to informally introduce a production, as part of running text. @@ -1169,10 +1177,8 @@ def GrammarProductionRole(typ, rawtext, text, lineno, inliner, options={}, conte :production:`string` indicates a quoted string. - You're not likely to use this role very commonly; instead, use a - `production list - <http://www.sphinx-doc.org/en/stable/markup/para.html#directive-productionlist>`_ - and reference its tokens using ``:token:`…```. + You're not likely to use this role very commonly; instead, use a ``prodn`` + directive and reference its tokens using ``:token:`…```. """ #pylint: disable=dangerous-default-value, unused-argument env = inliner.document.settings.env diff --git a/doc/tools/docgram/README.md b/doc/tools/docgram/README.md index 2d29743d78..4d38955fa8 100644 --- a/doc/tools/docgram/README.md +++ b/doc/tools/docgram/README.md @@ -2,7 +2,6 @@ `doc_grammar` extracts Coq's grammar from `.mlg` files, edits it and inserts it into `.rst` files. The tool inserts `prodn` directives for grammar productions. -(`productionlist` are gradually being replaced by `prodn` in the manual.) It also updates `tacn` and `cmd` directives when they can be unambiguously matched to productions of the grammar (in practice, that's probably almost always). `tacv` and `cmdv` directives are not updated because matching them appears to require @@ -37,13 +36,16 @@ for documentation purposes: 1. The tool reads all the `mlg` files and generates `fullGrammar`, which includes all the grammar without the actions for each production or the OCaml code. This file is provided as a convenience to make it easier to examine the (mostly) - unprocessed grammar of the mlg files with less clutter. Nonterminals that use - levels (`"5" RIGHTA` below) are modified, for example: + unprocessed grammar of the mlg files with less clutter. This step includes two + transformations that rename some nonterminal symbols: + + First, nonterminals that use levels (`"5" RIGHTA` below) are modified, for example: ``` tactic_expr: [ "5" RIGHTA [ te = binder_tactic -> { te } ] + [ "4" ... ``` becomes @@ -55,6 +57,17 @@ for documentation purposes: ] ``` + Second, nonterminals that are local to an .mlg will be renamed, if necessary, to + make them unique. For example, `strategy_level` is defined as a local nonterminal + in both `g_prim.mlg` and in `extraargs.mlg`. The nonterminal defined in the former + remains `strategy_level` because it happens to be processed before the latter, + in which the nonterminal is renamed to `EXTRAARGS_strategy_level` to make the local + symbol unique. + + Nonterminals listed after `GLOBAL:` are global; otherwise they are local. + + References to renamed symbols are updated with the modified names. + 2. The tool applies grammar editing operations specified by `common.edit_mlg` to generate `editedGrammar`. @@ -227,9 +240,22 @@ to the grammar. The end of the existing `prodn` is recognized by a blank line. -### Other details +### Tagging productions + +`doc_grammar` tags the origin of productions from plugins that aren't automatically +loaded. In grammar files, they appear as `(* XXX plugin *)`. In rsts, productions +generated by `.. insertprodn` will include where relevant three spaces as (a delimiter) +and a tag name after each production, which Sphinx will show on the far right-hand side +of the production. + +The origin of a production can be specified explicitly in `common.edit_mlg` with the +`TAG name` appearing at the end of a production. `name` must be in quotes if it +contains whitespace characters. Some edit operations preserve the +tags, but others, such as `REPLACE ... WITH ...` do not. + +A mapping from filenames to tags (e.g. "g_ltac2.mlg" is "Ltac2") is hard-coded as is +filtering to avoid showing tags for, say, Ltac2 productions from appearing on every +production in that chapter. -The output identifies productions from plugins that aren't automatically loaded with -`(* XXX plugin *)` in grammar files and with `(XXX plugin)` in productionlists. If desired, this mechanism could be extended to tag certain productions as deprecated, perhaps in conjunction with a coqpp change. diff --git a/doc/tools/docgram/common.edit_mlg b/doc/tools/docgram/common.edit_mlg index 80f825358f..a22f7ae9f3 100644 --- a/doc/tools/docgram/common.edit_mlg +++ b/doc/tools/docgram/common.edit_mlg @@ -12,19 +12,98 @@ DOC_GRAMMAR +(* first, fixup symbols duplicated across files *) +lglob: [ +| lconstr +| DELETE EXTRAARGS_lconstr +] + +hint: [ +| "Extern" natural OPT constr_pattern "=>" tactic +] + +(* todo: does ARGUMENT EXTEND make the symbol global? It is in both extraargs and extratactics *) +strategy_level_or_var: [ +| DELETE EXTRAARGS_strategy_level +| strategy_level +] + +operconstr0: [ +| "ltac" ":" "(" tactic_expr5 ")" +] + +EXTRAARGS_natural: [ | DELETENT ] +EXTRAARGS_lconstr: [ | DELETENT ] +EXTRAARGS_strategy_level: [ | DELETENT ] +G_LTAC_hint: [ | DELETENT ] +G_LTAC_operconstr0: [ | DELETENT ] + +G_REWRITE_binders: [ +| DELETE Pcoq.Constr.binders +| binders +] + +G_TACTIC_in_clause: [ +| in_clause +| MOVEALLBUT in_clause +| in_clause +] + +SPLICE: [ +| G_REWRITE_binders +| G_TACTIC_in_clause +] + +RENAME: [ +| G_LTAC2_delta_flag ltac2_delta_flag +| G_LTAC2_strategy_flag ltac2_strategy_flag +| G_LTAC2_binder ltac2_binder +| G_LTAC2_branches ltac2_branches +| G_LTAC2_let_clause ltac2_let_clause +| G_LTAC2_tactic_atom ltac2_tactic_atom +| G_LTAC2_rewriter ltac2_rewriter +| G_LTAC2_constr_with_bindings ltac2_constr_with_bindings +| G_LTAC2_match_rule ltac2_match_rule +| G_LTAC2_match_pattern ltac2_match_pattern +| G_LTAC2_intropatterns ltac2_intropatterns +| G_LTAC2_simple_intropattern ltac2_simple_intropattern +| G_LTAC2_simple_intropattern_closed ltac2_simple_intropattern_closed +| G_LTAC2_or_and_intropattern ltac2_or_and_intropattern +| G_LTAC2_equality_intropattern ltac2_equality_intropattern +| G_LTAC2_naming_intropattern ltac2_naming_intropattern +| G_LTAC2_destruction_arg ltac2_destruction_arg +| G_LTAC2_with_bindings ltac2_with_bindings +| G_LTAC2_bindings ltac2_bindings +| G_LTAC2_simple_binding ltac2_simple_binding +| G_LTAC2_in_clause ltac2_in_clause +| G_LTAC2_occs ltac2_occs +| G_LTAC2_occs_nums ltac2_occs_nums +| G_LTAC2_concl_occ ltac2_concl_occ +| G_LTAC2_hypident_occ ltac2_hypident_occ +| G_LTAC2_hypident ltac2_hypident +| G_LTAC2_induction_clause ltac2_induction_clause +| G_LTAC2_as_or_and_ipat ltac2_as_or_and_ipat +| G_LTAC2_eqn_ipat ltac2_eqn_ipat +| G_LTAC2_conversion ltac2_conversion +| G_LTAC2_oriented_rewriter ltac2_oriented_rewriter +| G_LTAC2_tactic_then_gen ltac2_tactic_then_gen +| G_LTAC2_tactic_then_last ltac2_tactic_then_last +| G_LTAC2_as_name ltac2_as_name +| G_LTAC2_as_ipat ltac2_as_ipat +| G_LTAC2_by_tactic ltac2_by_tactic +| G_LTAC2_match_list ltac2_match_list +] + (* renames to eliminate qualified names put other renames at the end *) RENAME: [ (* map missing names for rhs *) | Constr.constr term -| Constr.constr_pattern constr_pattern | Constr.global global | Constr.lconstr lconstr | Constr.lconstr_pattern cpattern | G_vernac.query_command query_command | G_vernac.section_subset_expr section_subset_expr -| Pltac.tactic tactic -| Pltac.tactic_expr tactic_expr5 | Prim.ident ident | Prim.reference reference | Pvernac.Vernac_.main_entry vernac_control @@ -69,6 +148,8 @@ DELETE: [ | test_name_colon | test_pipe_closedcurly | ensure_fixannot +| test_array_opening +| test_array_closing (* SSR *) (* | ssr_null_entry *) @@ -125,6 +206,26 @@ tactic_then_last: [ | OPTINREF ] +ltac2_tactic_then_last: [ +| REPLACE "|" LIST0 ( OPT tac2expr6 ) SEP "|" (* Ltac2 plugin *) +| WITH LIST0 ( "|" OPT tac2expr6 ) TAG Ltac2 +] + +ltac2_goal_tactics: [ +| LIST0 ( OPT tac2expr6 ) SEP "|" TAG Ltac2 +] + +ltac2_tactic_then_gen: [ | DELETENT ] + +ltac2_tactic_then_gen: [ +| ltac2_goal_tactics TAG Ltac2 +| OPT ( ltac2_goal_tactics "|" ) OPT tac2expr6 ".." OPT ( "|" ltac2_goal_tactics ) TAG Ltac2 +] + +ltac2_tactic_then_last: [ +| OPTINREF +] + reference: [ | DELETENT ] reference: [ @@ -155,15 +256,6 @@ dirpath: [ | WITH LIST0 ( ident "." ) ident ] -binders: [ -| DELETE Pcoq.Constr.binders (* todo: not sure why there are 2 "binders:" *) -] - -lconstr: [ -| DELETE l_constr -] - - let_type_cstr: [ | DELETE OPT [ ":" lconstr ] | type_cstr @@ -208,7 +300,7 @@ term_let: [ atomic_constr: [ | MOVETO qualid_annotated global univ_instance -| MOVETO primitive_notations NUMERAL +| MOVETO primitive_notations NUMBER | MOVETO primitive_notations string | MOVETO term_evar "_" | REPLACE "?" "[" ident "]" @@ -309,6 +401,8 @@ operconstr0: [ | MOVETO term_generalizing "`{" operconstr200 "}" | MOVETO term_generalizing "`(" operconstr200 ")" | MOVETO term_ltac "ltac" ":" "(" tactic_expr5 ")" +| REPLACE "[" "|" array_elems "|" lconstr type_cstr "|" "]" univ_instance +| WITH "[|" array_elems "|" lconstr type_cstr "|]" univ_instance ] fix_decls: [ @@ -551,9 +645,28 @@ delta_flag: [ | OPTINREF ] +ltac2_delta_flag: [ +| EDIT ADD_OPT "-" "[" refglobals "]" (* Ltac2 plugin *) +] + +ltac2_branches: [ +| EDIT ADD_OPT "|" LIST1 branch SEP "|" (* Ltac2 plugin *) +| OPTINREF +] + +RENAME: [ +| red_flag ltac2_red_flag +| red_flags red_flag +] + +RENAME: [ +] + strategy_flag: [ | REPLACE OPT delta_flag | WITH delta_flag +(*| REPLACE LIST1 red_flags +| WITH LIST1 red_flag*) | (* empty *) | OPTINREF ] @@ -623,11 +736,6 @@ export_token: [ ] (* lexer stuff *) -integer: [ | DELETENT ] -RENAME: [ -| integer int (* todo: review uses in .mlg files, some should be "natural" *) -] - LEFTQMARK: [ | "?" ] @@ -636,7 +744,7 @@ digit: [ | "0" ".." "9" ] -decnum: [ +decnat: [ | digit LIST0 [ digit | "_" ] ] @@ -644,31 +752,29 @@ hexdigit: [ | [ "0" ".." "9" | "a" ".." "f" | "A" ".." "F" ] ] -hexnum: [ +hexnat: [ | [ "0x" | "0X" ] hexdigit LIST0 [ hexdigit | "_" ] ] -num: [ -| [ decnum | hexnum ] -] - -natural: [ | DELETENT ] -natural: [ -| num (* todo: or should it be "nat"? *) +bignat: [ +| REPLACE NUMBER +| WITH [ decnat | hexnat ] ] -int: [ -| OPT "-" num +integer: [ +| REPLACE bigint +| WITH OPT "-" natural ] -numeral: [ -| OPT "-" decnum OPT ( "." LIST1 [ digit | "_" ] ) OPT ( [ "e" | "E" ] OPT [ "+" | "-" ] decnum ) -| OPT "-" hexnum OPT ( "." LIST1 [ hexdigit | "_" ] ) OPT ( [ "p" | "P" ] OPT [ "+" | "-" ] decnum ) +number: [ +| OPT "-" decnat OPT ( "." LIST1 [ digit | "_" ] ) OPT ( [ "e" | "E" ] OPT [ "+" | "-" ] decnat ) +| OPT "-" hexnat OPT ( "." LIST1 [ hexdigit | "_" ] ) OPT ( [ "p" | "P" ] OPT [ "+" | "-" ] decnat ) ] bigint: [ -| DELETE NUMERAL -| num +| DELETE bignat +| REPLACE test_minus_nat "-" bignat +| WITH OPT "-" bignat ] first_letter: [ @@ -684,8 +790,8 @@ ident: [ | first_letter LIST0 subsequent_letter ] -NUMERAL: [ -| numeral +NUMBER: [ +| number ] (* todo: QUOTATION only used in a test suite .mlg files, is it documented/useful? *) @@ -841,7 +947,7 @@ simple_tactic: [ | DELETE "autorewrite" "with" LIST1 preident clause "using" tactic | DELETE "autorewrite" "*" "with" LIST1 preident clause | REPLACE "autorewrite" "*" "with" LIST1 preident clause "using" tactic -| WITH "autorewrite" OPT "*" "with" LIST1 preident clause_dft_concl OPT ( "using" tactic ) +| WITH "autorewrite" OPT "*" "with" LIST1 preident clause OPT ( "using" tactic ) | DELETE "cofix" ident | REPLACE "cofix" ident "with" LIST1 cofixdecl | WITH "cofix" ident OPT ( "with" LIST1 cofixdecl ) @@ -900,7 +1006,7 @@ simple_tactic: [ | DELETE "replace" "->" uconstr clause | DELETE "replace" "<-" uconstr clause | DELETE "replace" uconstr clause -| "replace" orient uconstr clause_dft_concl (* todo: fix 'clause' *) +| "replace" orient uconstr clause | REPLACE "rewrite" "*" orient uconstr "in" hyp "at" occurrences by_arg_tac | WITH "rewrite" "*" orient uconstr OPT ( "in" hyp ) OPT ( "at" occurrences by_arg_tac ) | DELETE "rewrite" "*" orient uconstr "in" hyp by_arg_tac @@ -920,9 +1026,6 @@ simple_tactic: [ | DELETE "unify" constr constr | REPLACE "unify" constr constr "with" preident | WITH "unify" constr constr OPT ( "with" preident ) -| DELETE "cutrewrite" orient constr -| REPLACE "cutrewrite" orient constr "in" hyp -| WITH "cutrewrite" orient constr OPT ( "in" hyp ) | DELETE "destauto" | REPLACE "destauto" "in" hyp | WITH "destauto" OPT ( "in" hyp ) @@ -984,13 +1087,13 @@ simple_tactic: [ | WITH "subst" OPT ( LIST1 var ) | DELETE "subst" | DELETE "congruence" -| DELETE "congruence" int +| DELETE "congruence" natural | DELETE "congruence" "with" LIST1 constr -| REPLACE "congruence" int "with" LIST1 constr -| WITH "congruence" OPT int OPT ( "with" LIST1 constr ) +| REPLACE "congruence" natural "with" LIST1 constr +| WITH "congruence" OPT natural OPT ( "with" LIST1 constr ) | DELETE "show" "ltac" "profile" -| REPLACE "show" "ltac" "profile" "cutoff" int -| WITH "show" "ltac" "profile" OPT [ "cutoff" int | string ] +| REPLACE "show" "ltac" "profile" "cutoff" integer +| WITH "show" "ltac" "profile" OPT [ "cutoff" integer | string ] | DELETE "show" "ltac" "profile" string (* perversely, the mlg uses "tactic3" instead of "tactic_expr3" *) | DELETE "transparent_abstract" tactic3 @@ -1098,11 +1201,11 @@ command: [ | REPLACE "Next" "Obligation" "of" ident withtac | WITH "Next" "Obligation" OPT ( "of" ident ) withtac | DELETE "Next" "Obligation" withtac -| REPLACE "Obligation" int "of" ident ":" lglob withtac -| WITH "Obligation" int OPT ( "of" ident ) OPT ( ":" lglob withtac ) -| DELETE "Obligation" int "of" ident withtac -| DELETE "Obligation" int ":" lglob withtac -| DELETE "Obligation" int withtac +| REPLACE "Obligation" natural "of" ident ":" lglob withtac +| WITH "Obligation" natural OPT ( "of" ident ) OPT ( ":" lglob withtac ) +| DELETE "Obligation" natural "of" ident withtac +| DELETE "Obligation" natural ":" lglob withtac +| DELETE "Obligation" natural withtac | REPLACE "Obligations" "of" ident | WITH "Obligations" OPT ( "of" ident ) | DELETE "Obligations" @@ -1122,17 +1225,17 @@ command: [ | DELETE "Show" ident | "Show" OPT [ ident | natural ] | DELETE "Show" "Ltac" "Profile" -| REPLACE "Show" "Ltac" "Profile" "CutOff" int -| WITH "Show" "Ltac" "Profile" OPT [ "CutOff" int | string ] +| REPLACE "Show" "Ltac" "Profile" "CutOff" integer +| WITH "Show" "Ltac" "Profile" OPT [ "CutOff" integer | string ] | DELETE "Show" "Ltac" "Profile" string | DELETE "Show" "Proof" (* combined with Show Proof Diffs in vernac_toplevel *) | REPLACE "Solve" "All" "Obligations" "with" tactic | WITH "Solve" "All" "Obligations" OPT ( "with" tactic ) | DELETE "Solve" "All" "Obligations" -| REPLACE "Solve" "Obligation" int "of" ident "with" tactic -| WITH "Solve" "Obligation" int OPT ( "of" ident ) "with" tactic +| REPLACE "Solve" "Obligation" natural "of" ident "with" tactic +| WITH "Solve" "Obligation" natural OPT ( "of" ident ) "with" tactic | DELETE "Solve" "Obligations" -| DELETE "Solve" "Obligation" int "with" tactic +| DELETE "Solve" "Obligation" natural "with" tactic | REPLACE "Solve" "Obligations" "of" ident "with" tactic | WITH "Solve" "Obligations" OPT ( OPT ( "of" ident ) "with" tactic ) | DELETE "Solve" "Obligations" "with" tactic @@ -1163,6 +1266,7 @@ command: [ | REPLACE "String" "Notation" reference reference reference ":" ident | WITH "String" "Notation" reference reference reference ":" scope_name +| DELETE "Ltac2" ltac2_entry (* was split up *) ] option_setting: [ @@ -1180,14 +1284,10 @@ syntax: [ | WITH "Undelimit" "Scope" scope_name | REPLACE "Bind" "Scope" IDENT; "with" LIST1 class_rawexpr | WITH "Bind" "Scope" scope_name; "with" LIST1 class_rawexpr -| REPLACE "Infix" ne_lstring ":=" constr [ "(" LIST1 syntax_modifier SEP "," ")" | ] OPT [ ":" IDENT ] -| WITH "Infix" ne_lstring ":=" constr OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] OPT [ ":" scope_name ] -| REPLACE "Notation" lstring ":=" constr [ "(" LIST1 syntax_modifier SEP "," ")" | ] OPT [ ":" IDENT ] -| WITH "Notation" lstring ":=" constr OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] OPT [ ":" scope_name ] -| REPLACE "Reserved" "Infix" ne_lstring [ "(" LIST1 syntax_modifier SEP "," ")" | ] -| WITH "Reserved" "Infix" ne_lstring OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] -| REPLACE "Reserved" "Notation" ne_lstring [ "(" LIST1 syntax_modifier SEP "," ")" | ] -| WITH "Reserved" "Notation" ne_lstring OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] +| REPLACE "Infix" ne_lstring ":=" constr syntax_modifiers OPT [ ":" IDENT ] +| WITH "Infix" ne_lstring ":=" constr syntax_modifiers OPT [ ":" scope_name ] +| REPLACE "Notation" lstring ":=" constr syntax_modifiers OPT [ ":" IDENT ] +| WITH "Notation" lstring ":=" constr syntax_modifiers OPT [ ":" scope_name ] ] syntax_modifier: [ @@ -1458,8 +1558,33 @@ by_tactic: [ ] rewriter: [ -| REPLACE [ "?" | LEFTQMARK ] constr_with_bindings_arg -| WITH "?" constr_with_bindings_arg +| DELETE "!" constr_with_bindings_arg +| DELETE [ "?" | LEFTQMARK ] constr_with_bindings_arg +| DELETE natural "!" constr_with_bindings_arg +| DELETE natural [ "?" | LEFTQMARK ] constr_with_bindings_arg +| DELETE natural constr_with_bindings_arg +| DELETE constr_with_bindings_arg +| OPT natural OPT [ "?" | "!" ] constr_with_bindings_arg +] + +ltac2_rewriter: [ +| DELETE "!" ltac2_constr_with_bindings (* Ltac2 plugin *) +| DELETE [ "?" | LEFTQMARK ] ltac2_constr_with_bindings +| DELETE lnatural "!" ltac2_constr_with_bindings (* Ltac2 plugin *) +| DELETE lnatural [ "?" | LEFTQMARK ] ltac2_constr_with_bindings +| DELETE lnatural ltac2_constr_with_bindings (* Ltac2 plugin *) +| DELETE ltac2_constr_with_bindings (* Ltac2 plugin *) +| OPT natural OPT [ "?" | "!" ] ltac2_constr_with_bindings +] + +tac2expr0: [ +| DELETE "(" ")" +] + +tac2type_body: [ +| REPLACE ":=" tac2typ_knd (* Ltac2 plugin *) +| WITH [ ":=" | "::=" ] tac2typ_knd TAG Ltac2 +| DELETE "::=" tac2typ_knd (* Ltac2 plugin *) ] intropattern_or_list_or: [ @@ -1525,6 +1650,12 @@ in_clause: [ | DELETE LIST0 hypident_occ SEP "," ] +ltac2_in_clause: [ +| REPLACE LIST0 ltac2_hypident_occ SEP "," "|-" ltac2_concl_occ (* Ltac2 plugin *) +| WITH LIST0 ltac2_hypident_occ SEP "," OPT ( "|-" ltac2_concl_occ ) TAG Ltac2 +| DELETE LIST0 ltac2_hypident_occ SEP "," (* Ltac2 plugin *) +] + concl_occ: [ | OPTINREF ] @@ -1597,8 +1728,12 @@ by_notation: [ ] decl_notation: [ -| REPLACE ne_lstring ":=" constr only_parsing OPT [ ":" IDENT ] -| WITH ne_lstring ":=" constr only_parsing OPT [ ":" scope_name ] +| REPLACE ne_lstring ":=" constr syntax_modifiers OPT [ ":" IDENT ] +| WITH ne_lstring ":=" constr syntax_modifiers OPT [ ":" scope_name ] +] + +syntax_modifiers: [ +| OPTINREF ] @@ -1636,6 +1771,15 @@ tactic_mode: [ | DELETE command ] +sexpr: [ +| REPLACE syn_node (* Ltac2 plugin *) +| WITH name TAG Ltac2 +| REPLACE syn_node "(" LIST1 sexpr SEP "," ")" (* Ltac2 plugin *) +| WITH name "(" LIST1 sexpr SEP "," ")" TAG Ltac2 +] + +syn_node: [ | DELETENT ] + RENAME: [ | toplevel_selector toplevel_selector_temp ] @@ -1689,7 +1833,7 @@ query_command: [ ] (* re-add as a placeholder *) sentence: [ | OPT attributes command "." -| OPT attributes OPT ( num ":" ) query_command "." +| OPT attributes OPT ( natural ":" ) query_command "." | OPT attributes OPT ( toplevel_selector ":" ) tactic_expr5 [ "." | "..." ] | control_command ] @@ -1754,9 +1898,24 @@ tactic_value: [ | [ value_tactic | syn_value ] ] + +(* defined in Ltac2/Notations.v *) + +ltac2_match_key: [ +| "lazy_match!" +| "match!" +| "multi_match!" +] + +ltac2_constructs: [ +| ltac2_match_key tac2expr6 "with" ltac2_match_list "end" +| ltac2_match_key OPT "reverse" "goal" "with" gmatch_list "end" +] + simple_tactic: [ | ltac_builtins | ltac_constructs +| ltac2_constructs | ltac_defined_tactics | tactic_notation_tactics ] @@ -1767,6 +1926,24 @@ tacdef_body: [ | DELETE global ltac_def_kind tactic_expr5 ] +tac2def_typ: [ +| REPLACE "Type" rec_flag LIST1 tac2typ_def SEP "with" (* Ltac2 plugin *) +| WITH "Type" rec_flag tac2typ_def LIST0 ( "with" tac2typ_def ) TAG Ltac2 +] + +tac2def_val: [ +| REPLACE mut_flag rec_flag LIST1 tac2def_body SEP "with" (* Ltac2 plugin *) +| WITH mut_flag rec_flag tac2def_body LIST0 ( "with" tac2def_body ) TAG Ltac1 +] + +tac2alg_constructors: [ +| REPLACE "|" LIST1 tac2alg_constructor SEP "|" (* Ltac2 plugin *) +| WITH OPT "|" LIST1 tac2alg_constructor SEP "|" TAG Ltac2 +| DELETE LIST0 tac2alg_constructor SEP "|" (* Ltac2 plugin *) +| (* empty *) +| OPTINREF +] + SPLICE: [ | def_token | extended_def_token @@ -1792,15 +1969,239 @@ logical_kind: [ | [ "Field" | "Method" ] ] +(* ltac2 *) + +DELETE: [ +| test_ltac1_env +] + +mut_flag: [ +| OPTINREF +] + +rec_flag: [ +| OPTINREF +] + +ltac2_orient: [ | DELETENT ] + +ltac2_orient: [ +| orient +] + SPLICE: [ +| ltac2_orient +] + +tac2typ_prm: [ +| OPTINREF +] + +tac2type_body: [ +| OPTINREF +] + +atomic_tac2pat: [ +| OPTINREF +] + +tac2expr0: [ +(* +| DELETE "(" ")" (* covered by "()" prodn *) +| REPLACE "{" [ | LIST1 tac2rec_fieldexpr OPT ";" ] "}" +| WITH "{" OPT ( LIST1 tac2rec_fieldexpr OPT ";" ) "}" +*) +] + +(* todo: should +| tac2pat1 "," LIST0 tac2pat1 SEP "," +use LIST1? *) + +SPLICE: [ +| tac2expr4 +] + +tac2expr3: [ +| REPLACE tac2expr2 "," LIST1 tac2expr2 SEP "," (* Ltac2 plugin *) +| WITH LIST1 tac2expr2 SEP "," TAG Ltac2 +| DELETE tac2expr2 (* Ltac2 plugin *) +] + +tac2rec_fieldexprs: [ +| DELETE tac2rec_fieldexpr ";" tac2rec_fieldexprs +| DELETE tac2rec_fieldexpr ";" +| DELETE tac2rec_fieldexpr +| LIST1 tac2rec_fieldexpr OPT ";" +| OPTINREF +] + +tac2rec_fields: [ +| DELETE tac2rec_field ";" tac2rec_fields +| DELETE tac2rec_field ";" +| DELETE tac2rec_field +| LIST1 tac2rec_field SEP ";" OPT ";" TAG Ltac2 +| OPTINREF +] + +(* todo: weird productions, ints only after an initial "-"??: + occs_nums: [ + | LIST1 [ natural | ident ] + | "-" [ natural | ident ] LIST0 int_or_var +*) +ltac2_occs_nums: [ +| DELETE LIST1 nat_or_anti (* Ltac2 plugin *) +| REPLACE "-" nat_or_anti LIST0 nat_or_anti (* Ltac2 plugin *) +| WITH OPT "-" LIST1 nat_or_anti TAG Ltac2 +] + +syn_level: [ +| OPTINREF +] + +ltac2_delta_flag: [ +| OPTINREF +] + +ltac2_occs: [ +| OPTINREF +] + +ltac2_concl_occ: [ +| OPTINREF +] + +ltac2_with_bindings: [ +| OPTINREF +] + +ltac2_as_or_and_ipat: [ +| OPTINREF +] + +ltac2_eqn_ipat: [ +| OPTINREF +] + +ltac2_as_name: [ +| OPTINREF +] + +ltac2_as_ipat: [ +| OPTINREF +] + +ltac2_by_tactic: [ +| OPTINREF +] + +ltac2_entry: [ +| REPLACE tac2def_typ (* Ltac2 plugin *) +| WITH "Ltac2" tac2def_typ +| REPLACE tac2def_syn (* Ltac2 plugin *) +| WITH "Ltac2" tac2def_syn +| REPLACE tac2def_mut (* Ltac2 plugin *) +| WITH "Ltac2" tac2def_mut +| REPLACE tac2def_val (* Ltac2 plugin *) +| WITH "Ltac2" tac2def_val +| REPLACE tac2def_ext (* Ltac2 plugin *) +| WITH "Ltac2" tac2def_ext +| "Ltac2" "Notation" [ string | lident ] ":=" tac2expr6 TAG Ltac2 (* variant *) +| MOVEALLBUT command +(* todo: MOVEALLBUT should ignore tag on "but" prodns *) +] + +ltac2_match_list: [ +| EDIT ADD_OPT "|" LIST1 ltac2_match_rule SEP "|" (* Ltac2 plugin *) +] + +ltac2_or_and_intropattern: [ +| DELETE "(" ltac2_simple_intropattern ")" (* Ltac2 plugin *) +| REPLACE "(" ltac2_simple_intropattern "," LIST1 ltac2_simple_intropattern SEP "," ")" (* Ltac2 plugin *) +| WITH "(" LIST1 ltac2_simple_intropattern SEP "," ")" TAG Ltac2 +| REPLACE "(" ltac2_simple_intropattern "&" LIST1 ltac2_simple_intropattern SEP "&" ")" (* Ltac2 plugin *) +| WITH "(" LIST1 ltac2_simple_intropattern SEP "&" ")" TAG Ltac2 +] + +SPLICE: [ +| tac2def_val +| tac2def_typ +| tac2def_ext +| tac2def_syn +| tac2def_mut +| mut_flag +| rec_flag +| locident +| syn_level +| tac2rec_fieldexprs +| tac2type_body +| tac2alg_constructors +| tac2rec_fields +| ltac2_binder +| branch +| anti +] + +tac2expr5: [ +| REPLACE "let" OPT "rec" LIST1 ltac2_let_clause SEP "with" "in" tac2expr6 (* Ltac2 plugin *) +| WITH "let" OPT "rec" ltac2_let_clause LIST0 ( "with" ltac2_let_clause ) "in" tac2expr6 TAG Ltac2 +| MOVETO simple_tactic "match" tac2expr5 "with" OPT ltac2_branches "end" (* Ltac2 plugin *) +| DELETE simple_tactic +] + +RENAME: [ +| Prim.string string +| Prim.integer integer +| Prim.qualid qualid +| Prim.natural natural +] + +gmatch_list: [ +| EDIT ADD_OPT "|" LIST1 gmatch_rule SEP "|" (* Ltac2 plugin *) +] + +ltac2_quotations: [ + +] + +ltac2_tactic_atom: [ +| MOVETO ltac2_quotations "constr" ":" "(" lconstr ")" (* Ltac2 plugin *) +| MOVETO ltac2_quotations "open_constr" ":" "(" lconstr ")" (* Ltac2 plugin *) +| MOVETO ltac2_quotations "ident" ":" "(" lident ")" (* Ltac2 plugin *) +| MOVETO ltac2_quotations "pattern" ":" "(" cpattern ")" (* Ltac2 plugin *) +| MOVETO ltac2_quotations "reference" ":" "(" globref ")" (* Ltac2 plugin *) +| MOVETO ltac2_quotations "ltac1" ":" "(" ltac1_expr_in_env ")" (* Ltac2 plugin *) +| MOVETO ltac2_quotations "ltac1val" ":" "(" ltac1_expr_in_env ")" (* Ltac2 plugin *) +] + +(* non-Ltac2 "clause" is really clause_dft_concl + there is an ltac2 "clause" *) +ltac2_clause: [ ] + +clause: [ +| MOVEALLBUT ltac2_clause +] + +clause: [ +| clause_dft_concl +] + +q_clause: [ +| REPLACE clause +| WITH ltac2_clause TAG Ltac2 +] + +ltac2_induction_clause: [ +| REPLACE ltac2_destruction_arg OPT ltac2_as_or_and_ipat OPT ltac2_eqn_ipat OPT clause (* Ltac2 plugin *) +| WITH ltac2_destruction_arg OPT ltac2_as_or_and_ipat OPT ltac2_eqn_ipat OPT ltac2_clause TAG Ltac2 +] + +SPLICE: [ +| clause | noedit_mode -| bigint | match_list | match_context_list | IDENT | LEFTQMARK -| natural -| NUMERAL +| NUMBER | STRING | hyp | var @@ -1808,6 +2209,7 @@ SPLICE: [ | pattern_ident | constr_eval (* splices as multiple prods *) | tactic_then_last (* todo: dependency on c.edit_mlg edit?? really useful? *) +| ltac2_tactic_then_last | Prim.name | ltac_selector | Constr.ident @@ -1957,12 +2359,10 @@ SPLICE: [ | search_queries | locatable | scope_delimiter -| bignat | one_import_filter_name | search_where | message_token | input_fun -| tactic_then_last | ltac_use_default | toplevel_selector_temp | comment @@ -1970,14 +2370,24 @@ SPLICE: [ | match_context_rule | match_rule | by_notation +| lnatural +| nat_or_anti +| globref +| let_binder +| refglobals (* Ltac2 *) +| syntax_modifiers +| array_elems +| ltac2_expr +| G_LTAC2_input_fun +| ltac2_simple_intropattern_closed +| ltac2_with_bindings ] (* end SPLICE *) RENAME: [ -| clause clause_dft_concl - | tactic3 ltac_expr3 (* todo: can't figure out how this gets mapped by coqpp *) | tactic1 ltac_expr1 (* todo: can't figure out how this gets mapped by coqpp *) | tactic0 ltac_expr0 (* todo: can't figure out how this gets mapped by coqpp *) +| ltac1_expr ltac_expr | tactic_expr5 ltac_expr | tactic_expr4 ltac_expr4 | tactic_expr3 ltac_expr3 @@ -1998,6 +2408,7 @@ RENAME: [ | ssexpr35 ssexpr (* strange in mlg, ssexpr50 is after this *) | tactic_then_gen for_each_goal +| ltac2_tactic_then_gen ltac2_for_each_goal | selector_body selector | match_hyps match_hyp @@ -2029,6 +2440,20 @@ RENAME: [ | numnotoption numeral_modifier | tactic_arg_compat tactic_arg | lconstr_pattern cpattern +| Pltac.tactic ltac_expr +| sexpr ltac2_scope +| tac2type5 ltac2_type +| tac2type2 ltac2_type2 +| tac2type1 ltac2_type1 +| tac2type0 ltac2_type0 +| typ_param ltac2_typevar +| tac2expr6 ltac2_expr +| tac2expr5 ltac2_expr5 +| tac2expr3 ltac2_expr3 +| tac2expr2 ltac2_expr2 +| tac2expr1 ltac2_expr1 +| tac2expr0 ltac2_expr0 +| gmatch_list goal_match_list ] simple_tactic: [ @@ -2050,6 +2475,7 @@ SPLICE: [ | command_entry | ltac_builtins | ltac_constructs +| ltac2_constructs | ltac_defined_tactics | tactic_notation_tactics ] @@ -2064,12 +2490,47 @@ NOTINRSTS: [ | simple_tactic | REACHABLE | NOTINRSTS +| l1_tactic +| l2_tactic +| l3_tactic +| binder_tactic +| value_tactic +| ltac2_entry +(* ltac2 syntactic classes *) +| q_intropatterns +| q_intropattern +| q_ident +| q_destruction_arg +| q_with_bindings +| q_bindings +| q_strategy_flag +| q_reference +| q_clause +| q_occurrences +| q_induction_clause +| q_conversion +| q_rewriting +| q_dispatch +| q_hintdb +| q_move_location +| q_pose +| q_assert +| q_constr_matching +| q_goal_matching + +(* todo: figure these out +(*Warning: editedGrammar: Undefined symbol 'ltac1_expr' *) +| dangling_pattern_extension_rule +| vernac_aux +| subprf +| tactic_mode +| tac2expr_in_env (* no refs *) +| tac2mode (* no refs *) +| ltac_use_default (* from tac2mode *) +| tacticals +*) ] REACHABLE: [ | NOTINRSTS ] - -strategy_level: [ -| DELETE strategy_level0 -] diff --git a/doc/tools/docgram/doc_grammar.ml b/doc/tools/docgram/doc_grammar.ml index 33c4bd3e01..0ac652c0db 100644 --- a/doc/tools/docgram/doc_grammar.ml +++ b/doc/tools/docgram/doc_grammar.ml @@ -82,6 +82,138 @@ type gram = { order: string list; } + +(*** Print routines ***) + +let sprintf = Printf.sprintf + +let map_and_concat f ?(delim="") l = + String.concat delim (List.map f l) + +let rec db_output_prodn = function + | Sterm s -> sprintf "(Sterm %s) " s + | Snterm s -> sprintf "(Snterm %s) " s + | Slist1 sym -> sprintf "(Slist1 %s) " (db_output_prodn sym) + | Slist1sep (sym, sep) -> sprintf "(Slist1sep %s %s) " (db_output_prodn sep) (db_output_prodn sym) + | Slist0 sym -> sprintf "(Slist0 %s) " (db_output_prodn sym) + | Slist0sep (sym, sep) -> sprintf "(Slist0sep %s %s) " (db_output_prodn sep) (db_output_prodn sym) + | Sopt sym -> sprintf "(Sopt %s) " (db_output_prodn sym) + | Sparen prod -> sprintf "(Sparen %s) " (db_out_list prod) + | Sprod prods -> sprintf "(Sprod %s) " (db_out_prods prods) + | Sedit s -> sprintf "(Sedit %s) " s + | Sedit2 (s, s2) -> sprintf "(Sedit2 %s %s) " s s2 +and db_out_list prod = sprintf "(%s)" (map_and_concat db_output_prodn prod) +and db_out_prods prods = sprintf "( %s )" (map_and_concat ~delim:" | " db_out_list prods) + +(* identify special chars that don't get a trailing space in output *) +let omit_space s = List.mem s ["?"; "."; "#"] + +let rec output_prod plist need_semi = function + | Sterm s -> if plist then sprintf "%s" s else sprintf "\"%s\"" s + | Snterm s -> + if plist then sprintf "`%s`" s else + sprintf "%s%s" s (if s = "IDENT" && need_semi then ";" else "") + | Slist1 sym -> sprintf "LIST1 %s" (prod_to_str ~plist [sym]) + | Slist1sep (sym, sep) -> sprintf "LIST1 %s SEP %s" (prod_to_str ~plist [sym]) (prod_to_str ~plist [sep]) + | Slist0 sym -> sprintf "LIST0 %s" (prod_to_str ~plist [sym]) + | Slist0sep (sym, sep) -> sprintf "LIST0 %s SEP %s" (prod_to_str ~plist [sym]) (prod_to_str ~plist [sep]) + | Sopt sym -> sprintf "OPT %s" (prod_to_str ~plist [sym]) + | Sparen sym_list -> sprintf "( %s )" (prod_to_str sym_list) + | Sprod sym_list_list -> + sprintf "[ %s ]" (String.concat " " (List.mapi (fun i r -> + let prod = (prod_to_str r) in + let sep = if i = 0 then "" else + if prod <> "" then "| " else "|" in + sprintf "%s%s" sep prod) + sym_list_list)) + | Sedit s -> sprintf "%s" s + (* todo: make TAG info output conditional on the set of prods? *) + | Sedit2 ("TAG", plugin) -> + if plist then + sprintf " (%s plugin)" plugin + else + sprintf " (* %s plugin *)" plugin + | Sedit2 ("FILE", file) -> + let file_suffix_regex = Str.regexp ".*/\\([a-zA-Z0-9_\\.]+\\)" in + let suffix = if Str.string_match file_suffix_regex file 0 then Str.matched_group 1 file else file in + if plist then + sprintf " (%s)" suffix + else + sprintf " (* %s *)" suffix + | Sedit2 (s, s2) -> sprintf "%s \"%s\"" s s2 + +and prod_to_str_r plist prod = + match prod with + | Sterm s :: Snterm "ident" :: tl when omit_space s && plist -> + (sprintf "%s`ident`" s) :: (prod_to_str_r plist tl) + | p :: tl -> + let need_semi = + match prod with + | Snterm "IDENT" :: Sterm _ :: _ + | Snterm "IDENT" :: Sprod _ :: _ -> true + | _ -> false in + (output_prod plist need_semi p) :: (prod_to_str_r plist tl) + | [] -> [] + +and prod_to_str ?(plist=false) prod = + String.concat " " (prod_to_str_r plist prod) + +(* Determine if 2 productions are equal ignoring Sedit and Sedit2 *) +let ematch prod edit = + let rec ematchr prod edit = + (*Printf.printf "%s and\n %s\n\n" (prod_to_str prod) (prod_to_str edit);*) + match (prod, edit) with + | (_, Sedit _ :: tl) + | (_, Sedit2 _ :: tl) + -> ematchr prod tl + | (Sedit _ :: tl, _) + | (Sedit2 _ :: tl, _) + -> ematchr tl edit + | (phd :: ptl, hd :: tl) -> + let m = match (phd, hd) with + | (Slist1 psym, Slist1 sym) + | (Slist0 psym, Slist0 sym) + | (Sopt psym, Sopt sym) + -> ematchr [psym] [sym] + | (Slist1sep (psym, psep), Slist1sep (sym, sep)) + | (Slist0sep (psym, psep), Slist0sep (sym, sep)) + -> ematchr [psym] [sym] && ematchr [psep] [sep] + | (Sparen psyml, Sparen syml) + -> ematchr psyml syml + | (Sprod psymll, Sprod symll) -> + if List.compare_lengths psymll symll != 0 then false + else + List.fold_left (&&) true (List.map2 ematchr psymll symll) + | _, _ -> phd = hd + in + m && ematchr ptl tl + | ([], hd :: tl) -> false + | (phd :: ptl, []) -> false + | ([], []) -> true +in + (*Printf.printf "\n";*) + let rv = ematchr prod edit in + (*Printf.printf "%b\n" rv;*) + rv + +let get_first m_prod prods = + let rec find_first_r prods i = + match prods with + | [] -> + raise Not_found + | prod :: tl -> + if ematch prod m_prod then i + else find_first_r tl (i+1) + in + find_first_r prods 0 + +let find_first edit prods nt = + try + get_first edit prods + with Not_found -> + error "Can't find '%s' in edit for '%s'\n" (prod_to_str edit) nt; + raise Not_found + module DocGram = struct (* these guarantee that order and map have a 1-1 relationship on the nt name. They don't guarantee that nts on rhs of a production @@ -90,6 +222,8 @@ module DocGram = struct exception Duplicate exception Invalid + let g_empty () = ref { map = NTMap.empty; order = [] } + (* add an nt at the end (if not already present) then set its prods *) let g_maybe_add g nt prods = if not (NTMap.mem nt !g.map) then @@ -167,81 +301,6 @@ module DocGram = struct end open DocGram -(*** Print routines ***) - -let sprintf = Printf.sprintf - -let map_and_concat f ?(delim="") l = - String.concat delim (List.map f l) - -let rec db_output_prodn = function - | Sterm s -> sprintf "(Sterm %s) " s - | Snterm s -> sprintf "(Snterm %s) " s - | Slist1 sym -> sprintf "(Slist1 %s) " (db_output_prodn sym) - | Slist1sep (sym, sep) -> sprintf "(Slist1sep %s %s) " (db_output_prodn sep) (db_output_prodn sym) - | Slist0 sym -> sprintf "(Slist0 %s) " (db_output_prodn sym) - | Slist0sep (sym, sep) -> sprintf "(Slist0sep %s %s) " (db_output_prodn sep) (db_output_prodn sym) - | Sopt sym -> sprintf "(Sopt %s) " (db_output_prodn sym) - | Sparen prod -> sprintf "(Sparen %s) " (db_out_list prod) - | Sprod prods -> sprintf "(Sprod %s) " (db_out_prods prods) - | Sedit s -> sprintf "(Sedit %s) " s - | Sedit2 (s, s2) -> sprintf "(Sedit2 %s %s) " s s2 -and db_out_list prod = sprintf "(%s)" (map_and_concat db_output_prodn prod) -and db_out_prods prods = sprintf "( %s )" (map_and_concat ~delim:" | " db_out_list prods) - -(* identify special chars that don't get a trailing space in output *) -let omit_space s = List.mem s ["?"; "."; "#"] - -let rec output_prod plist need_semi = function - | Sterm s -> if plist then sprintf "%s" s else sprintf "\"%s\"" s - | Snterm s -> - if plist then sprintf "`%s`" s else - sprintf "%s%s" s (if s = "IDENT" && need_semi then ";" else "") - | Slist1 sym -> sprintf "LIST1 %s" (prod_to_str ~plist [sym]) - | Slist1sep (sym, sep) -> sprintf "LIST1 %s SEP %s" (prod_to_str ~plist [sym]) (prod_to_str ~plist [sep]) - | Slist0 sym -> sprintf "LIST0 %s" (prod_to_str ~plist [sym]) - | Slist0sep (sym, sep) -> sprintf "LIST0 %s SEP %s" (prod_to_str ~plist [sym]) (prod_to_str ~plist [sep]) - | Sopt sym -> sprintf "OPT %s" (prod_to_str ~plist [sym]) - | Sparen sym_list -> sprintf "( %s )" (prod_to_str sym_list) - | Sprod sym_list_list -> - sprintf "[ %s ]" (String.concat " " (List.mapi (fun i r -> - let prod = (prod_to_str r) in - let sep = if i = 0 then "" else - if prod <> "" then "| " else "|" in - sprintf "%s%s" sep prod) - sym_list_list)) - | Sedit s -> sprintf "%s" s - (* todo: make PLUGIN info output conditional on the set of prods? *) - | Sedit2 ("PLUGIN", plugin) -> - if plist then - sprintf " (%s plugin)" plugin - else - sprintf " (* %s plugin *)" plugin - | Sedit2 ("FILE", file) -> - let file_suffix_regex = Str.regexp ".*/\\([a-zA-Z0-9_\\.]+\\)" in - let suffix = if Str.string_match file_suffix_regex file 0 then Str.matched_group 1 file else file in - if plist then - sprintf " (%s)" suffix - else - sprintf " (* %s *)" suffix - | Sedit2 (s, s2) -> sprintf "%s \"%s\"" s s2 - -and prod_to_str_r plist prod = - match prod with - | Sterm s :: Snterm "ident" :: tl when omit_space s && plist -> - (sprintf "%s`ident`" s) :: (prod_to_str_r plist tl) - | p :: tl -> - let need_semi = - match prod with - | Snterm "IDENT" :: Sterm _ :: _ - | Snterm "IDENT" :: Sprod _ :: _ -> true - | _ -> false in - (output_prod plist need_semi p) :: (prod_to_str_r plist tl) - | [] -> [] - -and prod_to_str ?(plist=false) prod = - String.concat " " (prod_to_str_r plist prod) - let rec output_prodn = function | Sterm s -> @@ -275,7 +334,7 @@ let rec output_prodn = function sym_list)) rcurly | Sedit s -> sprintf "%s" s - | Sedit2 ("PLUGIN", s2) -> "" + | Sedit2 ("TAG", s2) -> "" | Sedit2 (s, s2) -> sprintf "%s \"%s\"" s s2 and output_sep sep = @@ -292,6 +351,16 @@ and prod_to_prodn_r prod = and prod_to_prodn prod = String.concat " " (prod_to_prodn_r prod) +let get_tag file prod = + List.fold_left (fun rv sym -> + match sym with + (* todo: temporarily limited to Ltac2 tags in prodn when not in ltac2.rst *) + | Sedit2 ("TAG", s2) + when (s2 = "Ltac2" || s2 = "not Ltac2") && + file <> "doc/sphinx/proof-engine/ltac2.rst" -> " " ^ s2 + | _ -> rv + ) "" prod + let pr_prods nt prods = (* duplicative *) Printf.printf "%s: [\n" nt; List.iter (fun prod -> @@ -397,6 +466,10 @@ and cvt_gram_sym_list l = (Sedit2 ("NOTE", s2)) :: cvt_gram_sym_list tl | GSymbQualid ("USE_NT", _) :: GSymbQualid (s2, l) :: tl -> (Sedit2 ("USE_NT", s2)) :: cvt_gram_sym_list tl + | GSymbQualid ("TAG", _) :: GSymbQualid (s2, l) :: tl -> + (Sedit2 ("TAG", s2)) :: cvt_gram_sym_list tl + | GSymbQualid ("TAG", _) :: GSymbString (s2) :: tl -> + (Sedit2 ("TAG", s2)) :: cvt_gram_sym_list tl | GSymbString s :: tl -> (* todo: not seeing "(bfs)" here for some reason *) keywords := StringSet.add s !keywords; @@ -474,59 +547,36 @@ let autoloaded_mlgs = [ (* in the order they are loaded by Coq *) ] -let ematch prod edit = - let rec ematchr prod edit = - (*Printf.printf "%s and\n %s\n\n" (prod_to_str prod) (prod_to_str edit);*) - match (prod, edit) with - | (_, Sedit _ :: tl) - | (_, Sedit2 _ :: tl) - -> ematchr prod tl - | (Sedit _ :: tl, _) - | (Sedit2 _ :: tl, _) - -> ematchr tl edit - | (phd :: ptl, hd :: tl) -> - let m = match (phd, hd) with - | (Slist1 psym, Slist1 sym) - | (Slist0 psym, Slist0 sym) - | (Sopt psym, Sopt sym) - -> ematchr [psym] [sym] - | (Slist1sep (psym, psep), Slist1sep (sym, sep)) - | (Slist0sep (psym, psep), Slist0sep (sym, sep)) - -> ematchr [psym] [sym] && ematchr [psep] [sep] - | (Sparen psyml, Sparen syml) - -> ematchr psyml syml - | (Sprod psymll, Sprod symll) -> - if List.compare_lengths psymll symll != 0 then false - else - List.fold_left (&&) true (List.map2 ematchr psymll symll) - | _, _ -> phd = hd - in - m && ematchr ptl tl - | ([], hd :: tl) -> false - | (phd :: ptl, []) -> false - | ([], []) -> true -in - (*Printf.printf "\n";*) - let rv = ematchr prod edit in - (*Printf.printf "%b\n" rv;*) - rv - let has_match p prods = List.exists (fun p2 -> ematch p p2) prods let plugin_regex = Str.regexp "^plugins/\\([a-zA-Z0-9_]+\\)/" let level_regex = Str.regexp "[a-zA-Z0-9_]*$" -let read_mlg is_edit ast file level_renames symdef_map = +let get_plugin_name file = + if file = "user-contrib/Ltac2/g_ltac2.mlg" then + "Ltac2" + else if Str.string_match plugin_regex file 0 then + Str.matched_group 1 file + else + "" + +let read_mlg g is_edit ast file level_renames symdef_map = let res = ref [] in let locals = ref StringSet.empty in + let dup_renames = ref StringMap.empty in let add_prods nt prods = if not is_edit then + if NTMap.mem nt !g.map && nt <> "command" && nt <> "simple_tactic" then begin + let new_name = String.uppercase_ascii (Filename.remove_extension (Filename.basename file)) ^ "_" ^ nt in + dup_renames := StringMap.add nt new_name !dup_renames; + Printf.printf "** dup sym %s -> %s in %s\n" nt new_name file + end; add_symdef nt file symdef_map; + let plugin = get_plugin_name file in let prods = if not is_edit && not (List.mem file autoloaded_mlgs) && - Str.string_match plugin_regex file 0 then - let plugin = Str.matched_group 1 file in - List.map (fun p -> p @ [Sedit2 ("PLUGIN", plugin)]) prods + plugin <> "" then + List.map (fun p -> p @ [Sedit2 ("TAG", plugin)]) prods else prods in @@ -600,7 +650,7 @@ let read_mlg is_edit ast file level_renames symdef_map = in List.iter prod_loop ast; - List.rev !res, !locals + List.rev !res, !locals, !dup_renames let dir s = "doc/tools/docgram/" ^ s @@ -608,7 +658,7 @@ let read_mlg_edit file = let fdir = dir file in let level_renames = ref StringMap.empty in (* ignored *) let symdef_map = ref StringMap.empty in (* ignored *) - let prods, _ = read_mlg true (parse_file fdir) fdir level_renames symdef_map in + let prods, _, _ = read_mlg (g_empty ()) true (parse_file fdir) fdir level_renames symdef_map in prods let add_rule g nt prods file = @@ -623,17 +673,99 @@ let add_rule g nt prods file = prods) in g_maybe_add_begin g nt (ent @ nodups) + +let remove_Sedit2 p = + List.filter (fun sym -> match sym with | Sedit2 _ -> false | _ -> true) p + +(* edit a production: rename nonterminals, drop nonterminals, substitute nonterminals *) +let rec edit_prod g top edit_map prod = + let edit_nt edit_map sym0 nt = + try + let binding = StringMap.find nt edit_map in + match binding with + | "DELETE" -> [] + | "SPLICE" -> + begin + try let splice_prods = NTMap.find nt !g.map in + match splice_prods with + | [] -> error "Empty splice for '%s'\n" nt; [] + | [p] -> List.rev (remove_Sedit2 p) + | _ -> [Sprod (List.map remove_Sedit2 splice_prods)] (* todo? check if we create a dup *) + with Not_found -> error "Missing nt '%s' for splice\n" nt; [Snterm nt] + end + | _ -> [Snterm binding] + with Not_found -> [sym0] + in + let maybe_wrap syms = + match syms with + | s :: [] -> List.hd syms + | s -> Sparen (List.rev syms) + in + + let rec edit_symbol sym0 = + match sym0 with + | Sterm s -> [sym0] + | Snterm s -> edit_nt edit_map sym0 s + | Slist1 sym -> [Slist1 (maybe_wrap (edit_symbol sym))] + (* you'll get a run-time failure deleting a SEP symbol *) + | Slist1sep (sym, sep) -> [Slist1sep (maybe_wrap (edit_symbol sym), (List.hd (edit_symbol sep)))] + | Slist0 sym -> [Slist0 (maybe_wrap (edit_symbol sym))] + | Slist0sep (sym, sep) -> [Slist0sep (maybe_wrap (edit_symbol sym), (List.hd (edit_symbol sep)))] + | Sopt sym -> [Sopt (maybe_wrap (edit_symbol sym))] + | Sparen slist -> [Sparen (List.hd (edit_prod g false edit_map slist))] + | Sprod slistlist -> let (_, prods) = edit_rule g edit_map "" slistlist in + [Sprod prods] + | Sedit _ + | Sedit2 _ -> [sym0] (* these constructors not used here *) + in + let is_splice nt = + try + StringMap.find nt edit_map = "SPLICE" + with Not_found -> false + in + let get_splice_prods nt = + try NTMap.find nt !g.map + with Not_found -> (error "Missing nt '%s' for splice\n" nt; []) + in + + (* special case splice creating multiple new productions *) + let splice_prods = match prod with + | Snterm nt :: [] when is_splice nt -> + get_splice_prods nt + | Snterm nt :: Sedit2 ("TAG", _) :: [] when is_splice nt -> + get_splice_prods nt + | _ -> [] + in + if top && splice_prods <> [] then + splice_prods + else + [List.rev (List.concat (List.rev (List.map (fun sym -> edit_symbol sym) prod)))] + +and edit_rule g edit_map nt rule = + let nt = + try let new_name = StringMap.find nt edit_map in + match new_name with + | "SPLICE" -> nt + | "DELETE" -> "" + | _ -> new_name + with Not_found -> nt + in + (nt, (List.concat (List.map (edit_prod g true edit_map) rule))) + let read_mlg_files g args symdef_map = let level_renames = ref StringMap.empty in let last_autoloaded = List.hd (List.rev autoloaded_mlgs) in List.iter (fun file -> - (* does nt renaming, deletion and splicing *) - let rules, locals = read_mlg false (parse_file file) file level_renames symdef_map in + (* todo: ??? does nt renaming, deletion and splicing *) + let rules, locals, dup_renames = read_mlg g false (parse_file file) file level_renames symdef_map in let numprods = List.fold_left (fun num rule -> let nt, prods = rule in - if NTMap.mem nt !g.map && (StringSet.mem nt locals) && - StringSet.cardinal (StringSet.of_list (StringMap.find nt !symdef_map)) > 1 then - warn "%s: local nonterminal '%s' already defined\n" file nt; + (* rename local duplicates *) + let prods = List.map (fun prod -> List.hd (edit_prod g true dup_renames prod)) prods in + let nt = try StringMap.find nt dup_renames with Not_found -> nt in +(* if NTMap.mem nt !g.map && (StringSet.mem nt locals) &&*) +(* StringSet.cardinal (StringSet.of_list (StringMap.find nt !symdef_map)) > 1 then*) +(* warn "%s: local nonterminal '%s' already defined\n" file nt; (* todo: goes away *)*) add_rule g nt prods file; num + List.length prods) 0 rules @@ -701,7 +833,12 @@ let create_edit_map g op edits = | "RENAME" -> if not (StringSet.mem key all_nts_ref || (StringSet.mem key all_nts_def)) then error "Unused/undefined nt `%s` in RENAME\n" key; -(* todo: could not get the following codeto type check + | "MERGE" -> + if not (StringSet.mem key all_nts_ref || (StringSet.mem key all_nts_def)) then + error "Unused/undefined nt `%s` in MERGE\n" key; + if not (StringSet.mem binding all_nts_ref || (StringSet.mem binding all_nts_def)) then + error "Unused/undefined nt `%s` in MERGE\n" key; +(* todo: could not get the following code to type check (match binding with | _ :: Snterm new_nt :: _ -> if not (StringSet.mem new_nt all_nts_ref) then @@ -713,9 +850,6 @@ let create_edit_map g op edits = in aux edits StringMap.empty -let remove_Sedit2 p = - List.filter (fun sym -> match sym with | Sedit2 _ -> false | _ -> true) p - (* don't deal with Sedit, Sedit2 yet (ever?) *) let rec pmatch fullprod fullpat repl = let map_prod prod = List.concat (List.map (fun s -> pmatch [s] fullpat repl) prod) in @@ -768,88 +902,15 @@ let global_repl g pat repl = g_update_prods g nt (List.map (fun prod -> pmatch prod pat repl) (NTMap.find nt !g.map)) ) !g.order -(* edit a production: rename nonterminals, drop nonterminals, substitute nonterminals *) -let rec edit_prod g top edit_map prod = - let edit_nt edit_map sym0 nt = - try - let binding = StringMap.find nt edit_map in - match binding with - | "DELETE" -> [] - | "SPLICE" -> - begin - try let splice_prods = NTMap.find nt !g.map in - match splice_prods with - | [] -> error "Empty splice for '%s'\n" nt; [] - | [p] -> List.rev (remove_Sedit2 p) - | _ -> [Sprod (List.map remove_Sedit2 splice_prods)] - with Not_found -> error "Missing nt '%s' for splice\n" nt; [Snterm nt] - end - | _ -> [Snterm binding] - with Not_found -> [sym0] - in - let maybe_wrap syms = - match syms with - | s :: [] -> List.hd syms - | s -> Sparen (List.rev syms) - in - - let rec edit_symbol sym0 = - match sym0 with - | Sterm s -> [sym0] - | Snterm s -> edit_nt edit_map sym0 s - | Slist1 sym -> [Slist1 (maybe_wrap (edit_symbol sym))] - (* you'll get a run-time failure deleting a SEP symbol *) - | Slist1sep (sym, sep) -> [Slist1sep (maybe_wrap (edit_symbol sym), (List.hd (edit_symbol sep)))] - | Slist0 sym -> [Slist0 (maybe_wrap (edit_symbol sym))] - | Slist0sep (sym, sep) -> [Slist0sep (maybe_wrap (edit_symbol sym), (List.hd (edit_symbol sep)))] - | Sopt sym -> [Sopt (maybe_wrap (edit_symbol sym))] - | Sparen slist -> [Sparen (List.hd (edit_prod g false edit_map slist))] - | Sprod slistlist -> let (_, prods) = edit_rule g edit_map "" slistlist in - [Sprod prods] - | Sedit _ - | Sedit2 _ -> [sym0] (* these constructors not used here *) - in - let is_splice nt = - try - StringMap.find nt edit_map = "SPLICE" - with Not_found -> false - in - let get_splice_prods nt = - try NTMap.find nt !g.map - with Not_found -> (error "Missing nt '%s' for splice\n" nt; []) - in - - (* special case splice creating multiple new productions *) - let splice_prods = match prod with - | Snterm nt :: [] when is_splice nt -> - get_splice_prods nt - | _ -> [] - in - if top && splice_prods <> [] then - splice_prods - else - [List.rev (List.concat (List.rev (List.map (fun sym -> edit_symbol sym) prod)))] - -and edit_rule g edit_map nt rule = - let nt = - try let new_name = StringMap.find nt edit_map in - match new_name with - | "SPLICE" -> nt - | "DELETE" -> "" - | _ -> new_name - with Not_found -> nt - in - (nt, (List.concat (List.map (edit_prod g true edit_map) rule))) - (*** splice: replace a reference to a nonterminal with its definition ***) (* todo: create a better splice routine *) -let apply_splice g splice_map = +let apply_splice g edit_map = List.iter (fun b -> let (nt0, prods0) = b in let rec splice_loop nt prods cnt = let max_cnt = 10 in - let (nt', prods') = edit_rule g splice_map nt prods in + let (nt', prods') = edit_rule g edit_map nt prods in if cnt > max_cnt then error "Splice for '%s' not done after %d iterations\n" nt0 max_cnt; if nt' = nt && prods' = prods then @@ -867,19 +928,8 @@ let apply_splice g splice_map = | "SPLICE" -> g_remove g nt; | _ -> ()) - (StringMap.bindings splice_map) + (StringMap.bindings edit_map) -let find_first edit prods nt = - let rec find_first_r edit prods nt i = - match prods with - | [] -> - error "Can't find '%s' in edit for '%s'\n" (prod_to_str edit) nt; - raise Not_found - | prod :: tl -> - if ematch prod edit then i - else find_first_r edit tl nt (i+1) - in - find_first_r edit prods nt 0 let remove_prod edit prods nt = let res, got_first = List.fold_left (fun args prod -> @@ -1087,6 +1137,29 @@ let expand_lists g = with | Queue.Empty -> () +let apply_merge g edit_map = + List.iter (fun b -> + let (from_nt, to_nt) = b in + let from_prods = NTMap.find from_nt !g.map in + List.iter (fun prod -> + try + ignore( get_first prod (NTMap.find to_nt !g.map)); + with Not_found -> g_add_prod_after g None to_nt prod) + from_prods) + (NTMap.bindings edit_map) + +let apply_rename_delete g edit_map = + List.iter (fun b -> let (nt, _) = b in + let prods = try NTMap.find nt !g.map with Not_found -> [] in + let (nt', prods') = edit_rule g edit_map nt prods in + if nt' = "" then + g_remove g nt + else if nt <> nt' then + g_rename_merge g nt nt' prods' + else + g_update_prods g nt prods') + (NTMap.bindings !g.map) + let edit_all_prods g op eprods = let do_it op eprods num = let rec aux eprods res = @@ -1101,25 +1174,20 @@ let edit_all_prods g op eprods = op (prod_to_str eprod) num; aux tl res in - let map = create_edit_map g op (aux eprods []) in - if op = "SPLICE" then - apply_splice g map - else (* RENAME/DELETE *) - List.iter (fun b -> let (nt, _) = b in - let prods = try NTMap.find nt !g.map with Not_found -> [] in - let (nt', prods') = edit_rule g map nt prods in - if nt' = "" then - g_remove g nt - else if nt <> nt' then - g_rename_merge g nt nt' prods' - else - g_update_prods g nt prods') - (NTMap.bindings !g.map); + let edit_map = create_edit_map g op (aux eprods []) in + match op with + | "SPLICE" -> apply_splice g edit_map + | "MERGE" -> apply_merge g edit_map; apply_rename_delete g edit_map + | "RENAME" + | "DELETE" -> apply_rename_delete g edit_map + | _ -> () + in match op with | "RENAME" -> do_it op eprods 2; true | "DELETE" -> do_it op eprods 1; true | "SPLICE" -> do_it op eprods 1; true + | "MERGE" -> do_it op eprods 2; true | "EXPAND" -> if List.length eprods > 1 || List.length (List.hd eprods) <> 0 then error "'EXPAND:' expects a single empty production\n"; @@ -1559,7 +1627,7 @@ let rec dump prod = [@@@ocaml.warning "+32"] let reorder_grammar eg reordered_rules file = - let og = ref { map = NTMap.empty; order = [] } in + let og = g_empty () in List.iter (fun rule -> let nt, prods = rule in try @@ -1761,11 +1829,12 @@ let process_rst g file args seen tac_prods cmd_prods = let prods = NTMap.find nt !g.map in List.iteri (fun i prod -> let rhs = String.trim (prod_to_prodn prod) in + let tag = get_tag file prod in let sep = if i = 0 then " ::=" else "|" in if has_empty_prod prod then error "%s line %d: Empty (sub-)production for %s, edit to remove: '%s %s'\n" file !linenum nt sep rhs; - fprintf new_rst "%s %s%s %s\n" indent (if i = 0 then nt else "") sep rhs) + fprintf new_rst "%s %s%s %s%s\n" indent (if i = 0 then nt else "") sep rhs tag) prods; if nt <> end_ then copy_prods tl in @@ -1832,8 +1901,10 @@ let process_rst g file args seen tac_prods cmd_prods = "doc/sphinx/language/gallina-specification-language.rst"; "doc/sphinx/language/using/libraries/funind.rst"; "doc/sphinx/proof-engine/ltac.rst"; + "doc/sphinx/proof-engine/ltac2.rst"; "doc/sphinx/proof-engine/vernacular-commands.rst"; - "doc/sphinx/user-extensions/syntax-extensions.rst" + "doc/sphinx/user-extensions/syntax-extensions.rst"; + "doc/sphinx/proof-engine/vernacular-commands.rst" ] in @@ -1941,12 +2012,16 @@ let report_omitted_prods g seen label split = (if first = "" then nt else first), nt, n + 1, total + 1) ("", "", 0, 0) !g.order in maybe_warn first last n; +(* List.iter (fun nt -> + if not (NTMap.mem nt seen || (List.mem nt included)) then + warn "%s %s not included in .rst files\n" "Nonterminal" nt) + !g.order;*) if total <> 0 then Printf.eprintf "TOTAL %ss not included = %d\n" label total let process_grammar args = let symdef_map = ref StringMap.empty in - let g = ref { map = NTMap.empty; order = [] } in + let g = g_empty () in let level_renames = read_mlg_files g args symdef_map in if args.verbose then begin diff --git a/doc/tools/docgram/dune b/doc/tools/docgram/dune index a533a6d367..ba07e6df0d 100644 --- a/doc/tools/docgram/dune +++ b/doc/tools/docgram/dune @@ -12,7 +12,7 @@ (glob_files %{project_root}/parsing/*.mlg) (glob_files %{project_root}/toplevel/*.mlg) (glob_files %{project_root}/vernac/*.mlg) - ; All plugins except SSReflect and Ltac2 for now (mimicking what is done in Makefile.doc) + ; All plugins except SSReflect for now (mimicking what is done in Makefile.doc) (glob_files %{project_root}/plugins/btauto/*.mlg) (glob_files %{project_root}/plugins/cc/*.mlg) (glob_files %{project_root}/plugins/derive/*.mlg) @@ -26,6 +26,7 @@ (glob_files %{project_root}/plugins/rtauto/*.mlg) (glob_files %{project_root}/plugins/setoid_ring/*.mlg) (glob_files %{project_root}/plugins/syntax/*.mlg) + (glob_files %{project_root}/user-contrib/Ltac2/*.mlg) ; Sphinx files (glob_files %{project_root}/doc/sphinx/language/*.rst) (glob_files %{project_root}/doc/sphinx/proof-engine/*.rst) diff --git a/doc/tools/docgram/fullGrammar b/doc/tools/docgram/fullGrammar index c5edb538b7..2ee8e4347e 100644 --- a/doc/tools/docgram/fullGrammar +++ b/doc/tools/docgram/fullGrammar @@ -59,7 +59,6 @@ universe: [ lconstr: [ | operconstr200 -| l_constr ] constr: [ @@ -118,8 +117,12 @@ operconstr0: [ | "{|" record_declaration bar_cbrace | "{" binder_constr "}" | "`{" operconstr200 "}" +| test_array_opening "[" "|" array_elems "|" lconstr type_cstr test_array_closing "|" "]" univ_instance | "`(" operconstr200 ")" -| "ltac" ":" "(" Pltac.tactic_expr ")" +] + +array_elems: [ +| LIST0 lconstr SEP ";" ] record_declaration: [ @@ -159,7 +162,7 @@ appl_arg: [ atomic_constr: [ | global univ_instance | sort -| NUMERAL +| NUMBER | string | "_" | "?" "[" ident "]" @@ -280,7 +283,7 @@ pattern0: [ | "_" | "(" pattern200 ")" | "(" pattern200 "|" LIST1 pattern200 SEP "|" ")" -| NUMERAL +| NUMBER | string ] @@ -305,7 +308,6 @@ open_binders: [ binders: [ | LIST0 binder -| Pcoq.Constr.binders ] binder: [ @@ -435,16 +437,15 @@ integer: [ natural: [ | bignat -| _natural ] bigint: [ -| NUMERAL -| test_minus_nat "-" NUMERAL +| bignat +| test_minus_nat "-" bignat ] bignat: [ -| NUMERAL +| NUMBER ] bar_cbrace: [ @@ -456,7 +457,6 @@ strategy_level: [ | "opaque" | integer | "transparent" -| strategy_level0 ] vernac_toplevel: [ @@ -598,7 +598,7 @@ command: [ | "Hint" "Cut" "[" hints_path "]" opthints | "Typeclasses" "Transparent" LIST0 reference | "Typeclasses" "Opaque" LIST0 reference -| "Typeclasses" "eauto" ":=" debug eauto_search_strategy OPT int +| "Typeclasses" "eauto" ":=" debug eauto_search_strategy OPT integer | "Proof" "with" Pltac.tactic OPT [ "using" G_vernac.section_subset_expr ] | "Proof" "using" G_vernac.section_subset_expr OPT [ "with" Pltac.tactic ] | "Tactic" "Notation" OPT ltac_tactic_level LIST1 ltac_production_item ":=" tactic @@ -606,14 +606,14 @@ command: [ | "Locate" "Ltac" reference | "Ltac" LIST1 ltac_tacdef_body SEP "with" | "Print" "Ltac" "Signatures" -| "Obligation" integer "of" ident ":" lglob withtac -| "Obligation" integer "of" ident withtac -| "Obligation" integer ":" lglob withtac -| "Obligation" integer withtac +| "Obligation" natural "of" ident ":" lglob withtac +| "Obligation" natural "of" ident withtac +| "Obligation" natural ":" lglob withtac +| "Obligation" natural withtac | "Next" "Obligation" "of" ident withtac | "Next" "Obligation" withtac -| "Solve" "Obligation" integer "of" ident "with" tactic -| "Solve" "Obligation" integer "with" tactic +| "Solve" "Obligation" natural "of" ident "with" tactic +| "Solve" "Obligation" natural "with" tactic | "Solve" "Obligations" "of" ident "with" tactic | "Solve" "Obligations" "with" tactic | "Solve" "Obligations" @@ -635,26 +635,37 @@ command: [ | "Add" "Relation" constr constr "reflexivity" "proved" "by" constr "transitivity" "proved" "by" constr "as" ident | "Add" "Relation" constr constr "reflexivity" "proved" "by" constr "symmetry" "proved" "by" constr "transitivity" "proved" "by" constr "as" ident | "Add" "Relation" constr constr "transitivity" "proved" "by" constr "as" ident -| "Add" "Parametric" "Relation" binders ":" constr constr "reflexivity" "proved" "by" constr "symmetry" "proved" "by" constr "as" ident -| "Add" "Parametric" "Relation" binders ":" constr constr "reflexivity" "proved" "by" constr "as" ident -| "Add" "Parametric" "Relation" binders ":" constr constr "as" ident -| "Add" "Parametric" "Relation" binders ":" constr constr "symmetry" "proved" "by" constr "as" ident -| "Add" "Parametric" "Relation" binders ":" constr constr "symmetry" "proved" "by" constr "transitivity" "proved" "by" constr "as" ident -| "Add" "Parametric" "Relation" binders ":" constr constr "reflexivity" "proved" "by" constr "transitivity" "proved" "by" constr "as" ident -| "Add" "Parametric" "Relation" binders ":" constr constr "reflexivity" "proved" "by" constr "symmetry" "proved" "by" constr "transitivity" "proved" "by" constr "as" ident -| "Add" "Parametric" "Relation" binders ":" constr constr "transitivity" "proved" "by" constr "as" ident +| "Add" "Parametric" "Relation" G_REWRITE_binders ":" constr constr "reflexivity" "proved" "by" constr "symmetry" "proved" "by" constr "as" ident +| "Add" "Parametric" "Relation" G_REWRITE_binders ":" constr constr "reflexivity" "proved" "by" constr "as" ident +| "Add" "Parametric" "Relation" G_REWRITE_binders ":" constr constr "as" ident +| "Add" "Parametric" "Relation" G_REWRITE_binders ":" constr constr "symmetry" "proved" "by" constr "as" ident +| "Add" "Parametric" "Relation" G_REWRITE_binders ":" constr constr "symmetry" "proved" "by" constr "transitivity" "proved" "by" constr "as" ident +| "Add" "Parametric" "Relation" G_REWRITE_binders ":" constr constr "reflexivity" "proved" "by" constr "transitivity" "proved" "by" constr "as" ident +| "Add" "Parametric" "Relation" G_REWRITE_binders ":" constr constr "reflexivity" "proved" "by" constr "symmetry" "proved" "by" constr "transitivity" "proved" "by" constr "as" ident +| "Add" "Parametric" "Relation" G_REWRITE_binders ":" constr constr "transitivity" "proved" "by" constr "as" ident | "Add" "Setoid" constr constr constr "as" ident -| "Add" "Parametric" "Setoid" binders ":" constr constr constr "as" ident +| "Add" "Parametric" "Setoid" G_REWRITE_binders ":" constr constr constr "as" ident | "Add" "Morphism" constr ":" ident | "Declare" "Morphism" constr ":" ident | "Add" "Morphism" constr "with" "signature" lconstr "as" ident -| "Add" "Parametric" "Morphism" binders ":" constr "with" "signature" lconstr "as" ident +| "Add" "Parametric" "Morphism" G_REWRITE_binders ":" constr "with" "signature" lconstr "as" ident | "Print" "Rewrite" "HintDb" preident | "Reset" "Ltac" "Profile" | "Show" "Ltac" "Profile" -| "Show" "Ltac" "Profile" "CutOff" int +| "Show" "Ltac" "Profile" "CutOff" integer | "Show" "Ltac" "Profile" string | "Show" "Lia" "Profile" (* micromega plugin *) +| "Add" "Zify" "InjTyp" constr (* micromega plugin *) +| "Add" "Zify" "BinOp" constr (* micromega plugin *) +| "Add" "Zify" "UnOp" constr (* micromega plugin *) +| "Add" "Zify" "CstOp" constr (* micromega plugin *) +| "Add" "Zify" "BinRel" constr (* micromega plugin *) +| "Add" "Zify" "PropOp" constr (* micromega plugin *) +| "Add" "Zify" "PropBinOp" constr (* micromega plugin *) +| "Add" "Zify" "PropUOp" constr (* micromega plugin *) +| "Add" "Zify" "BinOpSpec" constr (* micromega plugin *) +| "Add" "Zify" "UnOpSpec" constr (* micromega plugin *) +| "Add" "Zify" "Saturate" constr (* micromega plugin *) | "Add" "InjTyp" constr (* micromega plugin *) | "Add" "BinOp" constr (* micromega plugin *) | "Add" "UnOp" constr (* micromega plugin *) @@ -663,7 +674,6 @@ command: [ | "Add" "PropOp" constr (* micromega plugin *) | "Add" "PropBinOp" constr (* micromega plugin *) | "Add" "PropUOp" constr (* micromega plugin *) -| "Add" "Spec" constr (* micromega plugin *) | "Add" "BinOpSpec" constr (* micromega plugin *) | "Add" "UnOpSpec" constr (* micromega plugin *) | "Add" "Saturate" constr (* micromega plugin *) @@ -672,13 +682,19 @@ command: [ | "Show" "Zify" "UnOp" (* micromega plugin *) | "Show" "Zify" "CstOp" (* micromega plugin *) | "Show" "Zify" "BinRel" (* micromega plugin *) +| "Show" "Zify" "UnOpSpec" (* micromega plugin *) +| "Show" "Zify" "BinOpSpec" (* micromega plugin *) | "Show" "Zify" "Spec" (* micromega plugin *) | "Add" "Ring" ident ":" constr OPT ring_mods (* setoid_ring plugin *) | "Print" "Rings" (* setoid_ring plugin *) | "Add" "Field" ident ":" constr OPT field_mods (* setoid_ring plugin *) | "Print" "Fields" (* setoid_ring plugin *) +| "Number" "Notation" reference reference reference ":" ident numnotoption | "Numeral" "Notation" reference reference reference ":" ident numnotoption | "String" "Notation" reference reference reference ":" ident +| "Ltac2" ltac2_entry (* Ltac2 plugin *) +| "Ltac2" "Eval" ltac2_expr (* Ltac2 plugin *) +| "Print" "Ltac2" reference (* Ltac2 plugin *) ] reference_or_constr: [ @@ -700,7 +716,6 @@ hint: [ | "Mode" global mode | "Unfold" LIST1 global | "Constructors" LIST1 global -| "Extern" natural OPT Constr.constr_pattern "=>" Pltac.tactic ] constr_body: [ @@ -791,7 +806,7 @@ gallina: [ | "Combined" "Scheme" identref "from" LIST1 identref SEP "," | "Register" global "as" qualid | "Register" "Inline" global -| "Primitive" identref OPT [ ":" lconstr ] ":=" register_token +| "Primitive" ident_decl OPT [ ":" lconstr ] ":=" register_token | "Universe" LIST1 identref | "Universes" LIST1 identref | "Constraint" LIST1 univ_constraint SEP "," @@ -872,7 +887,7 @@ reduce: [ ] decl_notation: [ -| ne_lstring ":=" constr only_parsing OPT [ ":" IDENT ] +| ne_lstring ":=" constr syntax_modifiers OPT [ ":" IDENT ] ] decl_sep: [ @@ -1353,12 +1368,12 @@ syntax: [ | "Delimit" "Scope" IDENT; "with" IDENT | "Undelimit" "Scope" IDENT | "Bind" "Scope" IDENT; "with" LIST1 class_rawexpr -| "Infix" ne_lstring ":=" constr [ "(" LIST1 syntax_modifier SEP "," ")" | ] OPT [ ":" IDENT ] +| "Infix" ne_lstring ":=" constr syntax_modifiers OPT [ ":" IDENT ] | "Notation" identref LIST0 ident ":=" constr only_parsing -| "Notation" lstring ":=" constr [ "(" LIST1 syntax_modifier SEP "," ")" | ] OPT [ ":" IDENT ] +| "Notation" lstring ":=" constr syntax_modifiers OPT [ ":" IDENT ] | "Format" "Notation" STRING STRING STRING -| "Reserved" "Infix" ne_lstring [ "(" LIST1 syntax_modifier SEP "," ")" | ] -| "Reserved" "Notation" ne_lstring [ "(" LIST1 syntax_modifier SEP "," ")" | ] +| "Reserved" "Infix" ne_lstring syntax_modifiers +| "Reserved" "Notation" ne_lstring syntax_modifiers ] only_parsing: [ @@ -1387,6 +1402,11 @@ syntax_modifier: [ | IDENT syntax_extension_type ] +syntax_modifiers: [ +| "(" LIST1 syntax_modifier SEP "," ")" +| +] + syntax_extension_type: [ | "ident" | "global" @@ -1416,9 +1436,9 @@ constr_as_binder_kind: [ simple_tactic: [ | "btauto" | "congruence" -| "congruence" integer +| "congruence" natural | "congruence" "with" LIST1 constr -| "congruence" integer "with" LIST1 constr +| "congruence" natural "with" LIST1 constr | "f_equal" | "firstorder" OPT tactic firstorder_using | "firstorder" OPT tactic "with" LIST1 preident @@ -1516,8 +1536,6 @@ simple_tactic: [ | "simple" "injection" destruction_arg | "dependent" "rewrite" orient constr | "dependent" "rewrite" orient constr "in" hyp -| "cutrewrite" orient constr -| "cutrewrite" orient constr "in" hyp | "decompose" "sum" constr | "decompose" "record" constr | "absurd" constr @@ -1698,7 +1716,7 @@ simple_tactic: [ | "stop" "ltac" "profiling" | "reset" "ltac" "profile" | "show" "ltac" "profile" -| "show" "ltac" "profile" "cutoff" int +| "show" "ltac" "profile" "cutoff" integer | "show" "ltac" "profile" string | "restart_timer" OPT string | "finish_timing" OPT string @@ -1791,6 +1809,10 @@ orient: [ | ] +EXTRAARGS_natural: [ +| _natural +] + occurrences: [ | LIST1 integer | var @@ -1800,8 +1822,12 @@ glob: [ | constr ] +EXTRAARGS_lconstr: [ +| l_constr +] + lglob: [ -| lconstr +| EXTRAARGS_lconstr ] casted_constr: [ @@ -1829,18 +1855,18 @@ by_arg_tac: [ in_clause: [ | in_clause' -| "*" occs -| "*" "|-" concl_occ -| LIST0 hypident_occ SEP "," "|-" concl_occ -| LIST0 hypident_occ SEP "," ] test_lpar_id_colon: [ | local_test_lpar_id_colon ] +EXTRAARGS_strategy_level: [ +| strategy_level0 +] + strategy_level_or_var: [ -| strategy_level +| EXTRAARGS_strategy_level | identref ] @@ -1985,7 +2011,6 @@ failkw: [ binder_tactic: [ | "fun" LIST1 input_fun "=>" tactic_expr5 | "let" [ "rec" | ] LIST1 let_clause SEP "with" "in" tactic_expr5 -| "info" tactic_expr5 ] tactic_arg_compat: [ @@ -2075,7 +2100,7 @@ match_list: [ message_token: [ | identref | STRING -| integer +| natural ] ltac_def_kind: [ @@ -2124,6 +2149,14 @@ tactic_mode: [ | "par" ":" OPT ltac_info tactic ltac_use_default ] +G_LTAC_hint: [ +| "Extern" natural OPT Constr.constr_pattern "=>" Pltac.tactic +] + +G_LTAC_operconstr0: [ +| "ltac" ":" "(" Pltac.tactic_expr ")" +] + ltac_selector: [ | toplevel_selector ] @@ -2194,6 +2227,10 @@ rewstrategy: [ | "fold" constr ] +G_REWRITE_binders: [ +| Pcoq.Constr.binders +] + int_or_var: [ | integer | identref @@ -2372,19 +2409,26 @@ hypident_occ: [ | hypident occs ] +G_TACTIC_in_clause: [ +| "*" occs +| "*" "|-" concl_occ +| LIST0 hypident_occ SEP "," "|-" concl_occ +| LIST0 hypident_occ SEP "," +] + clause_dft_concl: [ -| "in" in_clause +| "in" G_TACTIC_in_clause | occs | ] clause_dft_all: [ -| "in" in_clause +| "in" G_TACTIC_in_clause | ] opt_clause: [ -| "in" in_clause +| "in" G_TACTIC_in_clause | "at" occs_nums | ] @@ -2521,3 +2565,642 @@ numnotoption: [ | "(" "abstract" "after" bignat ")" ] +tac2pat1: [ +| Prim.qualid LIST1 tac2pat0 (* Ltac2 plugin *) +| Prim.qualid (* Ltac2 plugin *) +| "[" "]" (* Ltac2 plugin *) +| tac2pat0 "::" tac2pat0 (* Ltac2 plugin *) +| tac2pat0 (* Ltac2 plugin *) +] + +tac2pat0: [ +| "_" (* Ltac2 plugin *) +| "()" (* Ltac2 plugin *) +| Prim.qualid (* Ltac2 plugin *) +| "(" atomic_tac2pat ")" (* Ltac2 plugin *) +] + +atomic_tac2pat: [ +| (* Ltac2 plugin *) +| tac2pat1 ":" tac2type5 (* Ltac2 plugin *) +| tac2pat1 "," LIST0 tac2pat1 SEP "," (* Ltac2 plugin *) +| tac2pat1 (* Ltac2 plugin *) +] + +tac2expr6: [ +| tac2expr5 ";" tac2expr6 (* Ltac2 plugin *) +| tac2expr5 (* Ltac2 plugin *) +] + +tac2expr5: [ +| "fun" LIST1 G_LTAC2_input_fun "=>" tac2expr6 (* Ltac2 plugin *) +| "let" rec_flag LIST1 G_LTAC2_let_clause SEP "with" "in" tac2expr6 (* Ltac2 plugin *) +| "match" tac2expr5 "with" G_LTAC2_branches "end" (* Ltac2 plugin *) +| tac2expr4 (* Ltac2 plugin *) +] + +tac2expr4: [ +| tac2expr3 (* Ltac2 plugin *) +] + +tac2expr3: [ +| tac2expr2 "," LIST1 tac2expr2 SEP "," (* Ltac2 plugin *) +| tac2expr2 (* Ltac2 plugin *) +] + +tac2expr2: [ +| tac2expr1 "::" tac2expr2 (* Ltac2 plugin *) +| tac2expr1 (* Ltac2 plugin *) +] + +tac2expr1: [ +| tac2expr0 LIST1 tac2expr0 (* Ltac2 plugin *) +| tac2expr0 ".(" Prim.qualid ")" (* Ltac2 plugin *) +| tac2expr0 ".(" Prim.qualid ")" ":=" tac2expr5 (* Ltac2 plugin *) +| tac2expr0 (* Ltac2 plugin *) +] + +tac2expr0: [ +| "(" tac2expr6 ")" (* Ltac2 plugin *) +| "(" tac2expr6 ":" tac2type5 ")" (* Ltac2 plugin *) +| "()" (* Ltac2 plugin *) +| "(" ")" (* Ltac2 plugin *) +| "[" LIST0 tac2expr5 SEP ";" "]" (* Ltac2 plugin *) +| "{" tac2rec_fieldexprs "}" (* Ltac2 plugin *) +| G_LTAC2_tactic_atom (* Ltac2 plugin *) +] + +G_LTAC2_branches: [ +| (* Ltac2 plugin *) +| "|" LIST1 branch SEP "|" (* Ltac2 plugin *) +| LIST1 branch SEP "|" (* Ltac2 plugin *) +] + +branch: [ +| tac2pat1 "=>" tac2expr6 (* Ltac2 plugin *) +] + +rec_flag: [ +| "rec" (* Ltac2 plugin *) +| (* Ltac2 plugin *) +] + +mut_flag: [ +| "mutable" (* Ltac2 plugin *) +| (* Ltac2 plugin *) +] + +typ_param: [ +| "'" Prim.ident (* Ltac2 plugin *) +] + +G_LTAC2_tactic_atom: [ +| Prim.integer (* Ltac2 plugin *) +| Prim.string (* Ltac2 plugin *) +| Prim.qualid (* Ltac2 plugin *) +| "@" Prim.ident (* Ltac2 plugin *) +| "&" lident (* Ltac2 plugin *) +| "'" Constr.constr (* Ltac2 plugin *) +| "constr" ":" "(" Constr.lconstr ")" (* Ltac2 plugin *) +| "open_constr" ":" "(" Constr.lconstr ")" (* Ltac2 plugin *) +| "ident" ":" "(" lident ")" (* Ltac2 plugin *) +| "pattern" ":" "(" Constr.lconstr_pattern ")" (* Ltac2 plugin *) +| "reference" ":" "(" globref ")" (* Ltac2 plugin *) +| "ltac1" ":" "(" ltac1_expr_in_env ")" (* Ltac2 plugin *) +| "ltac1val" ":" "(" ltac1_expr_in_env ")" (* Ltac2 plugin *) +] + +ltac1_expr_in_env: [ +| test_ltac1_env LIST0 locident "|-" ltac1_expr (* Ltac2 plugin *) +| ltac1_expr (* Ltac2 plugin *) +] + +tac2expr_in_env: [ +| test_ltac1_env LIST0 locident "|-" tac2expr6 (* Ltac2 plugin *) +| tac2expr6 (* Ltac2 plugin *) +] + +G_LTAC2_let_clause: [ +| let_binder ":=" tac2expr6 (* Ltac2 plugin *) +] + +let_binder: [ +| LIST1 G_LTAC2_input_fun (* Ltac2 plugin *) +] + +tac2type5: [ +| tac2type2 "->" tac2type5 (* Ltac2 plugin *) +| tac2type2 (* Ltac2 plugin *) +] + +tac2type2: [ +| tac2type1 "*" LIST1 tac2type1 SEP "*" (* Ltac2 plugin *) +| tac2type1 (* Ltac2 plugin *) +] + +tac2type1: [ +| tac2type0 Prim.qualid (* Ltac2 plugin *) +| tac2type0 (* Ltac2 plugin *) +] + +tac2type0: [ +| "(" LIST1 tac2type5 SEP "," ")" OPT Prim.qualid (* Ltac2 plugin *) +| typ_param (* Ltac2 plugin *) +| "_" (* Ltac2 plugin *) +| Prim.qualid (* Ltac2 plugin *) +] + +locident: [ +| Prim.ident (* Ltac2 plugin *) +] + +G_LTAC2_binder: [ +| "_" (* Ltac2 plugin *) +| Prim.ident (* Ltac2 plugin *) +] + +G_LTAC2_input_fun: [ +| tac2pat0 (* Ltac2 plugin *) +] + +tac2def_body: [ +| G_LTAC2_binder LIST0 G_LTAC2_input_fun ":=" tac2expr6 (* Ltac2 plugin *) +] + +tac2def_val: [ +| mut_flag rec_flag LIST1 tac2def_body SEP "with" (* Ltac2 plugin *) +] + +tac2def_mut: [ +| "Set" Prim.qualid OPT [ "as" locident ] ":=" tac2expr6 (* Ltac2 plugin *) +] + +tac2typ_knd: [ +| tac2type5 (* Ltac2 plugin *) +| "[" ".." "]" (* Ltac2 plugin *) +| "[" tac2alg_constructors "]" (* Ltac2 plugin *) +| "{" tac2rec_fields "}" (* Ltac2 plugin *) +] + +tac2alg_constructors: [ +| "|" LIST1 tac2alg_constructor SEP "|" (* Ltac2 plugin *) +| LIST0 tac2alg_constructor SEP "|" (* Ltac2 plugin *) +] + +tac2alg_constructor: [ +| Prim.ident (* Ltac2 plugin *) +| Prim.ident "(" LIST0 tac2type5 SEP "," ")" (* Ltac2 plugin *) +] + +tac2rec_fields: [ +| tac2rec_field ";" tac2rec_fields (* Ltac2 plugin *) +| tac2rec_field ";" (* Ltac2 plugin *) +| tac2rec_field (* Ltac2 plugin *) +| (* Ltac2 plugin *) +] + +tac2rec_field: [ +| mut_flag Prim.ident ":" tac2type5 (* Ltac2 plugin *) +] + +tac2rec_fieldexprs: [ +| tac2rec_fieldexpr ";" tac2rec_fieldexprs (* Ltac2 plugin *) +| tac2rec_fieldexpr ";" (* Ltac2 plugin *) +| tac2rec_fieldexpr (* Ltac2 plugin *) +| (* Ltac2 plugin *) +] + +tac2rec_fieldexpr: [ +| Prim.qualid ":=" tac2expr1 (* Ltac2 plugin *) +] + +tac2typ_prm: [ +| (* Ltac2 plugin *) +| typ_param (* Ltac2 plugin *) +| "(" LIST1 typ_param SEP "," ")" (* Ltac2 plugin *) +] + +tac2typ_def: [ +| tac2typ_prm Prim.qualid tac2type_body (* Ltac2 plugin *) +] + +tac2type_body: [ +| (* Ltac2 plugin *) +| ":=" tac2typ_knd (* Ltac2 plugin *) +| "::=" tac2typ_knd (* Ltac2 plugin *) +] + +tac2def_typ: [ +| "Type" rec_flag LIST1 tac2typ_def SEP "with" (* Ltac2 plugin *) +] + +tac2def_ext: [ +| "@" "external" locident ":" tac2type5 ":=" Prim.string Prim.string (* Ltac2 plugin *) +] + +syn_node: [ +| "_" (* Ltac2 plugin *) +| Prim.ident (* Ltac2 plugin *) +] + +sexpr: [ +| Prim.string (* Ltac2 plugin *) +| Prim.integer (* Ltac2 plugin *) +| syn_node (* Ltac2 plugin *) +| syn_node "(" LIST1 sexpr SEP "," ")" (* Ltac2 plugin *) +] + +syn_level: [ +| (* Ltac2 plugin *) +| ":" Prim.natural (* Ltac2 plugin *) +] + +tac2def_syn: [ +| "Notation" LIST1 sexpr syn_level ":=" tac2expr6 (* Ltac2 plugin *) +] + +lident: [ +| Prim.ident (* Ltac2 plugin *) +] + +globref: [ +| "&" Prim.ident (* Ltac2 plugin *) +| Prim.qualid (* Ltac2 plugin *) +] + +anti: [ +| "$" Prim.ident (* Ltac2 plugin *) +] + +ident_or_anti: [ +| lident (* Ltac2 plugin *) +| "$" Prim.ident (* Ltac2 plugin *) +] + +lnatural: [ +| Prim.natural (* Ltac2 plugin *) +] + +q_ident: [ +| ident_or_anti (* Ltac2 plugin *) +] + +qhyp: [ +| anti (* Ltac2 plugin *) +| lnatural (* Ltac2 plugin *) +| lident (* Ltac2 plugin *) +] + +G_LTAC2_simple_binding: [ +| "(" qhyp ":=" Constr.lconstr ")" (* Ltac2 plugin *) +] + +G_LTAC2_bindings: [ +| test_lpar_idnum_coloneq LIST1 G_LTAC2_simple_binding (* Ltac2 plugin *) +| LIST1 Constr.constr (* Ltac2 plugin *) +] + +q_bindings: [ +| G_LTAC2_bindings (* Ltac2 plugin *) +] + +q_with_bindings: [ +| G_LTAC2_with_bindings (* Ltac2 plugin *) +] + +G_LTAC2_intropatterns: [ +| LIST0 nonsimple_intropattern (* Ltac2 plugin *) +] + +G_LTAC2_or_and_intropattern: [ +| "[" LIST1 G_LTAC2_intropatterns SEP "|" "]" (* Ltac2 plugin *) +| "()" (* Ltac2 plugin *) +| "(" G_LTAC2_simple_intropattern ")" (* Ltac2 plugin *) +| "(" G_LTAC2_simple_intropattern "," LIST1 G_LTAC2_simple_intropattern SEP "," ")" (* Ltac2 plugin *) +| "(" G_LTAC2_simple_intropattern "&" LIST1 G_LTAC2_simple_intropattern SEP "&" ")" (* Ltac2 plugin *) +] + +G_LTAC2_equality_intropattern: [ +| "->" (* Ltac2 plugin *) +| "<-" (* Ltac2 plugin *) +| "[=" G_LTAC2_intropatterns "]" (* Ltac2 plugin *) +] + +G_LTAC2_naming_intropattern: [ +| LEFTQMARK lident (* Ltac2 plugin *) +| "?$" lident (* Ltac2 plugin *) +| "?" (* Ltac2 plugin *) +| ident_or_anti (* Ltac2 plugin *) +] + +nonsimple_intropattern: [ +| G_LTAC2_simple_intropattern (* Ltac2 plugin *) +| "*" (* Ltac2 plugin *) +| "**" (* Ltac2 plugin *) +] + +G_LTAC2_simple_intropattern: [ +| G_LTAC2_simple_intropattern_closed (* Ltac2 plugin *) +] + +G_LTAC2_simple_intropattern_closed: [ +| G_LTAC2_or_and_intropattern (* Ltac2 plugin *) +| G_LTAC2_equality_intropattern (* Ltac2 plugin *) +| "_" (* Ltac2 plugin *) +| G_LTAC2_naming_intropattern (* Ltac2 plugin *) +] + +q_intropatterns: [ +| G_LTAC2_intropatterns (* Ltac2 plugin *) +] + +q_intropattern: [ +| G_LTAC2_simple_intropattern (* Ltac2 plugin *) +] + +nat_or_anti: [ +| lnatural (* Ltac2 plugin *) +| "$" Prim.ident (* Ltac2 plugin *) +] + +G_LTAC2_eqn_ipat: [ +| "eqn" ":" G_LTAC2_naming_intropattern (* Ltac2 plugin *) +| (* Ltac2 plugin *) +] + +G_LTAC2_with_bindings: [ +| "with" G_LTAC2_bindings (* Ltac2 plugin *) +| (* Ltac2 plugin *) +] + +G_LTAC2_constr_with_bindings: [ +| Constr.constr G_LTAC2_with_bindings (* Ltac2 plugin *) +] + +G_LTAC2_destruction_arg: [ +| lnatural (* Ltac2 plugin *) +| lident (* Ltac2 plugin *) +| G_LTAC2_constr_with_bindings (* Ltac2 plugin *) +] + +q_destruction_arg: [ +| G_LTAC2_destruction_arg (* Ltac2 plugin *) +] + +G_LTAC2_as_or_and_ipat: [ +| "as" G_LTAC2_or_and_intropattern (* Ltac2 plugin *) +| (* Ltac2 plugin *) +] + +G_LTAC2_occs_nums: [ +| LIST1 nat_or_anti (* Ltac2 plugin *) +| "-" nat_or_anti LIST0 nat_or_anti (* Ltac2 plugin *) +] + +G_LTAC2_occs: [ +| "at" G_LTAC2_occs_nums (* Ltac2 plugin *) +| (* Ltac2 plugin *) +] + +G_LTAC2_hypident: [ +| ident_or_anti (* Ltac2 plugin *) +| "(" "type" "of" ident_or_anti ")" (* Ltac2 plugin *) +| "(" "value" "of" ident_or_anti ")" (* Ltac2 plugin *) +] + +G_LTAC2_hypident_occ: [ +| G_LTAC2_hypident G_LTAC2_occs (* Ltac2 plugin *) +] + +G_LTAC2_in_clause: [ +| "*" G_LTAC2_occs (* Ltac2 plugin *) +| "*" "|-" G_LTAC2_concl_occ (* Ltac2 plugin *) +| LIST0 G_LTAC2_hypident_occ SEP "," "|-" G_LTAC2_concl_occ (* Ltac2 plugin *) +| LIST0 G_LTAC2_hypident_occ SEP "," (* Ltac2 plugin *) +] + +clause: [ +| "in" G_LTAC2_in_clause (* Ltac2 plugin *) +| "at" G_LTAC2_occs_nums (* Ltac2 plugin *) +] + +q_clause: [ +| clause (* Ltac2 plugin *) +] + +G_LTAC2_concl_occ: [ +| "*" G_LTAC2_occs (* Ltac2 plugin *) +| (* Ltac2 plugin *) +] + +G_LTAC2_induction_clause: [ +| G_LTAC2_destruction_arg G_LTAC2_as_or_and_ipat G_LTAC2_eqn_ipat OPT clause (* Ltac2 plugin *) +] + +q_induction_clause: [ +| G_LTAC2_induction_clause (* Ltac2 plugin *) +] + +G_LTAC2_conversion: [ +| Constr.constr (* Ltac2 plugin *) +| Constr.constr "with" Constr.constr (* Ltac2 plugin *) +] + +q_conversion: [ +| G_LTAC2_conversion (* Ltac2 plugin *) +] + +ltac2_orient: [ +| "->" (* Ltac2 plugin *) +| "<-" (* Ltac2 plugin *) +| (* Ltac2 plugin *) +] + +G_LTAC2_rewriter: [ +| "!" G_LTAC2_constr_with_bindings (* Ltac2 plugin *) +| [ "?" | LEFTQMARK ] G_LTAC2_constr_with_bindings (* Ltac2 plugin *) +| lnatural "!" G_LTAC2_constr_with_bindings (* Ltac2 plugin *) +| lnatural [ "?" | LEFTQMARK ] G_LTAC2_constr_with_bindings (* Ltac2 plugin *) +| lnatural G_LTAC2_constr_with_bindings (* Ltac2 plugin *) +| G_LTAC2_constr_with_bindings (* Ltac2 plugin *) +] + +G_LTAC2_oriented_rewriter: [ +| ltac2_orient G_LTAC2_rewriter (* Ltac2 plugin *) +] + +q_rewriting: [ +| G_LTAC2_oriented_rewriter (* Ltac2 plugin *) +] + +G_LTAC2_tactic_then_last: [ +| "|" LIST0 ( OPT tac2expr6 ) SEP "|" (* Ltac2 plugin *) +| (* Ltac2 plugin *) +] + +G_LTAC2_tactic_then_gen: [ +| tac2expr6 "|" G_LTAC2_tactic_then_gen (* Ltac2 plugin *) +| tac2expr6 ".." G_LTAC2_tactic_then_last (* Ltac2 plugin *) +| ".." G_LTAC2_tactic_then_last (* Ltac2 plugin *) +| tac2expr6 (* Ltac2 plugin *) +| "|" G_LTAC2_tactic_then_gen (* Ltac2 plugin *) +| (* Ltac2 plugin *) +] + +q_dispatch: [ +| G_LTAC2_tactic_then_gen (* Ltac2 plugin *) +] + +q_occurrences: [ +| G_LTAC2_occs (* Ltac2 plugin *) +] + +red_flag: [ +| "beta" (* Ltac2 plugin *) +| "iota" (* Ltac2 plugin *) +| "match" (* Ltac2 plugin *) +| "fix" (* Ltac2 plugin *) +| "cofix" (* Ltac2 plugin *) +| "zeta" (* Ltac2 plugin *) +| "delta" G_LTAC2_delta_flag (* Ltac2 plugin *) +] + +refglobal: [ +| "&" Prim.ident (* Ltac2 plugin *) +| Prim.qualid (* Ltac2 plugin *) +| "$" Prim.ident (* Ltac2 plugin *) +] + +q_reference: [ +| refglobal (* Ltac2 plugin *) +] + +refglobals: [ +| LIST1 refglobal (* Ltac2 plugin *) +] + +G_LTAC2_delta_flag: [ +| "-" "[" refglobals "]" (* Ltac2 plugin *) +| "[" refglobals "]" (* Ltac2 plugin *) +| (* Ltac2 plugin *) +] + +G_LTAC2_strategy_flag: [ +| LIST1 red_flag (* Ltac2 plugin *) +| G_LTAC2_delta_flag (* Ltac2 plugin *) +] + +q_strategy_flag: [ +| G_LTAC2_strategy_flag (* Ltac2 plugin *) +] + +hintdb: [ +| "*" (* Ltac2 plugin *) +| LIST1 ident_or_anti (* Ltac2 plugin *) +] + +q_hintdb: [ +| hintdb (* Ltac2 plugin *) +] + +G_LTAC2_match_pattern: [ +| "context" OPT Prim.ident "[" Constr.lconstr_pattern "]" (* Ltac2 plugin *) +| Constr.lconstr_pattern (* Ltac2 plugin *) +] + +G_LTAC2_match_rule: [ +| G_LTAC2_match_pattern "=>" tac2expr6 (* Ltac2 plugin *) +] + +G_LTAC2_match_list: [ +| LIST1 G_LTAC2_match_rule SEP "|" (* Ltac2 plugin *) +| "|" LIST1 G_LTAC2_match_rule SEP "|" (* Ltac2 plugin *) +] + +q_constr_matching: [ +| G_LTAC2_match_list (* Ltac2 plugin *) +] + +gmatch_hyp_pattern: [ +| Prim.name ":" G_LTAC2_match_pattern (* Ltac2 plugin *) +] + +gmatch_pattern: [ +| "[" LIST0 gmatch_hyp_pattern SEP "," "|-" G_LTAC2_match_pattern "]" (* Ltac2 plugin *) +] + +gmatch_rule: [ +| gmatch_pattern "=>" tac2expr6 (* Ltac2 plugin *) +] + +gmatch_list: [ +| LIST1 gmatch_rule SEP "|" (* Ltac2 plugin *) +| "|" LIST1 gmatch_rule SEP "|" (* Ltac2 plugin *) +] + +q_goal_matching: [ +| gmatch_list (* Ltac2 plugin *) +] + +move_location: [ +| "at" "top" (* Ltac2 plugin *) +| "at" "bottom" (* Ltac2 plugin *) +| "after" ident_or_anti (* Ltac2 plugin *) +| "before" ident_or_anti (* Ltac2 plugin *) +] + +q_move_location: [ +| move_location (* Ltac2 plugin *) +] + +G_LTAC2_as_name: [ +| (* Ltac2 plugin *) +| "as" ident_or_anti (* Ltac2 plugin *) +] + +pose: [ +| test_lpar_id_coloneq "(" ident_or_anti ":=" Constr.lconstr ")" (* Ltac2 plugin *) +| Constr.constr G_LTAC2_as_name (* Ltac2 plugin *) +] + +q_pose: [ +| pose (* Ltac2 plugin *) +] + +G_LTAC2_as_ipat: [ +| "as" G_LTAC2_simple_intropattern (* Ltac2 plugin *) +| (* Ltac2 plugin *) +] + +G_LTAC2_by_tactic: [ +| "by" tac2expr6 (* Ltac2 plugin *) +| (* Ltac2 plugin *) +] + +assertion: [ +| test_lpar_id_coloneq "(" ident_or_anti ":=" Constr.lconstr ")" (* Ltac2 plugin *) +| test_lpar_id_colon "(" ident_or_anti ":" Constr.lconstr ")" G_LTAC2_by_tactic (* Ltac2 plugin *) +| Constr.constr G_LTAC2_as_ipat G_LTAC2_by_tactic (* Ltac2 plugin *) +] + +q_assert: [ +| assertion (* Ltac2 plugin *) +] + +ltac2_entry: [ +| tac2def_val (* Ltac2 plugin *) +| tac2def_typ (* Ltac2 plugin *) +| tac2def_ext (* Ltac2 plugin *) +| tac2def_syn (* Ltac2 plugin *) +| tac2def_mut (* Ltac2 plugin *) +] + +ltac2_expr: [ +| tac2expr6 (* Ltac2 plugin *) +] + +tac2mode: [ +| ltac2_expr ltac_use_default (* Ltac2 plugin *) +| G_vernac.query_command (* Ltac2 plugin *) +] + diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index f4bf51b6ba..aae96fc966 100644 --- a/doc/tools/docgram/orderedGrammar +++ b/doc/tools/docgram/orderedGrammar @@ -45,6 +45,7 @@ term0: [ | term_match | term_record | term_generalizing +| "[|" LIST0 term SEP ";" "|" term OPT ( ":" type ) "|]" OPT univ_annot | term_ltac | "(" term ")" ] @@ -92,7 +93,7 @@ term_explicit: [ ] primitive_notations: [ -| numeral +| number | string ] @@ -128,20 +129,28 @@ type: [ | term ] -numeral: [ -| OPT "-" decnum OPT ( "." LIST1 [ digit | "_" ] ) OPT ( [ "e" | "E" ] OPT [ "+" | "-" ] decnum ) -| OPT "-" hexnum OPT ( "." LIST1 [ hexdigit | "_" ] ) OPT ( [ "p" | "P" ] OPT [ "+" | "-" ] decnum ) +number: [ +| OPT "-" decnat OPT ( "." LIST1 [ digit | "_" ] ) OPT ( [ "e" | "E" ] OPT [ "+" | "-" ] decnat ) +| OPT "-" hexnat OPT ( "." LIST1 [ hexdigit | "_" ] ) OPT ( [ "p" | "P" ] OPT [ "+" | "-" ] decnat ) ] -int: [ -| OPT "-" num +integer: [ +| OPT "-" natural ] -num: [ -| [ decnum | hexnum ] +natural: [ +| bignat ] -decnum: [ +bigint: [ +| OPT "-" bignat +] + +bignat: [ +| [ decnat | hexnat ] +] + +decnat: [ | digit LIST0 [ digit | "_" ] ] @@ -149,7 +158,7 @@ digit: [ | "0" ".." "9" ] -hexnum: [ +hexnat: [ | [ "0x" | "0X" ] hexdigit LIST0 [ hexdigit | "_" ] ] @@ -192,6 +201,32 @@ NOTINRSTS: [ | simple_tactic | REACHABLE | NOTINRSTS +| l1_tactic +| l3_tactic +| l2_tactic +| binder_tactic +| value_tactic +| ltac2_entry +| q_intropatterns +| q_intropattern +| q_ident +| q_destruction_arg +| q_with_bindings +| q_bindings +| q_strategy_flag +| q_reference +| q_clause +| q_occurrences +| q_induction_clause +| q_conversion +| q_rewriting +| q_dispatch +| q_hintdb +| q_move_location +| q_pose +| q_assert +| q_constr_matching +| q_goal_matching ] document: [ @@ -203,7 +238,7 @@ nonterminal: [ sentence: [ | OPT attributes command "." -| OPT attributes OPT ( num ":" ) query_command "." +| OPT attributes OPT ( natural ":" ) query_command "." | OPT attributes OPT ( toplevel_selector ":" ) ltac_expr [ "." | "..." ] | control_command ] @@ -250,7 +285,7 @@ universe: [ ] universe_expr: [ -| universe_name OPT ( "+" num ) +| universe_name OPT ( "+" natural ) ] universe_name: [ @@ -402,7 +437,7 @@ pattern0: [ | "{|" LIST0 ( qualid ":=" pattern ) "|}" | "_" | "(" LIST1 pattern SEP "|" ")" -| numeral +| number | string ] @@ -462,11 +497,11 @@ delta_flag: [ ] strategy_flag: [ -| LIST1 red_flags +| LIST1 red_flag | delta_flag ] -red_flags: [ +red_flag: [ | "beta" | "iota" | "match" @@ -482,12 +517,12 @@ ref_or_pattern_occ: [ ] occs_nums: [ -| LIST1 [ num | ident ] -| "-" [ num | ident ] LIST0 int_or_var +| LIST1 [ natural | ident ] +| "-" [ natural | ident ] LIST0 int_or_var ] int_or_var: [ -| int +| integer | ident ] @@ -508,7 +543,7 @@ record_definition: [ ] record_field: [ -| LIST0 ( "#[" LIST0 attribute SEP "," "]" ) name OPT field_body OPT [ "|" num ] OPT decl_notations +| LIST0 ( "#[" LIST0 attribute SEP "," "]" ) name OPT field_body OPT [ "|" natural ] OPT decl_notations ] field_body: [ @@ -562,7 +597,7 @@ sort_family: [ ] hint_info: [ -| "|" OPT num OPT one_term +| "|" OPT natural OPT one_term ] module_binder: [ @@ -575,7 +610,7 @@ module_type_inl: [ ] functor_app_annot: [ -| "[" "inline" "at" "level" num "]" +| "[" "inline" "at" "level" natural "]" | "[" "no" "inline" "]" ] @@ -659,7 +694,7 @@ scope_key: [ strategy_level: [ | "opaque" -| int +| integer | "expand" | "transparent" ] @@ -687,7 +722,7 @@ command: [ | "Locate" reference | "Locate" "Term" reference | "Locate" "Module" qualid -| "Info" num ltac_expr +| "Info" natural ltac_expr | "Locate" "Ltac" qualid | "Locate" "Library" qualid | "Locate" "File" string @@ -735,7 +770,7 @@ command: [ | "Print" "Module" "Type" qualid | "Print" "Module" qualid | "Print" "Namespace" dirpath -| "Inspect" num +| "Inspect" natural | "Add" "ML" "Path" string | OPT "Export" "Set" setting_name | "Print" "Table" setting_name @@ -746,26 +781,46 @@ command: [ | "Restore" "State" [ ident | string ] | "Reset" "Initial" | "Reset" ident -| "Back" OPT num +| "Back" OPT natural | "Debug" [ "On" | "Off" ] | "Declare" "Reduction" ident ":=" red_expr | "Declare" "Custom" "Entry" ident | "Derive" ident "SuchThat" one_term "As" ident (* derive plugin *) +| "Extraction" qualid (* extraction plugin *) +| "Recursive" "Extraction" LIST1 qualid (* extraction plugin *) +| "Extraction" string LIST1 qualid (* extraction plugin *) +| "Extraction" "TestCompile" LIST1 qualid (* extraction plugin *) +| "Separate" "Extraction" LIST1 qualid (* extraction plugin *) +| "Extraction" "Library" ident (* extraction plugin *) +| "Recursive" "Extraction" "Library" ident (* extraction plugin *) +| "Extraction" "Language" language (* extraction plugin *) +| "Extraction" "Inline" LIST1 qualid (* extraction plugin *) +| "Extraction" "NoInline" LIST1 qualid (* extraction plugin *) +| "Print" "Extraction" "Inline" (* extraction plugin *) +| "Reset" "Extraction" "Inline" (* extraction plugin *) +| "Extraction" "Implicit" qualid "[" LIST0 int_or_id "]" (* extraction plugin *) +| "Extraction" "Blacklist" LIST1 ident (* extraction plugin *) +| "Print" "Extraction" "Blacklist" (* extraction plugin *) +| "Reset" "Extraction" "Blacklist" (* extraction plugin *) +| "Extract" "Constant" qualid LIST0 string "=>" [ ident | string ] (* extraction plugin *) +| "Extract" "Inlined" "Constant" qualid "=>" [ ident | string ] (* extraction plugin *) +| "Extract" "Inductive" qualid "=>" [ ident | string ] "[" LIST0 [ ident | string ] "]" OPT string (* extraction plugin *) +| "Show" "Extraction" (* extraction plugin *) | "Proof" | "Proof" "Mode" string | "Proof" term | "Abort" OPT [ "All" | ident ] -| "Existential" num OPT ( ":" term ) ":=" term +| "Existential" natural OPT ( ":" term ) ":=" term | "Admitted" | "Qed" | "Save" ident | "Defined" OPT ident | "Restart" -| "Undo" OPT ( OPT "To" num ) -| "Focus" OPT num +| "Undo" OPT ( OPT "To" natural ) +| "Focus" OPT natural | "Unfocus" | "Unfocused" -| "Show" OPT [ ident | num ] +| "Show" OPT [ ident | natural ] | "Show" "Existentials" | "Show" "Universes" | "Show" "Conjectures" @@ -777,12 +832,12 @@ command: [ | "Create" "HintDb" ident OPT "discriminated" | "Remove" "Hints" LIST1 qualid OPT ( ":" LIST1 ident ) | "Hint" hint OPT ( ":" LIST1 ident ) -| "Comments" LIST0 [ one_term | string | num ] +| "Comments" LIST0 [ one_term | string | natural ] | "Declare" "Instance" ident_decl LIST0 binder ":" term OPT hint_info | "Declare" "Scope" scope_name -| "Obligation" int OPT ( "of" ident ) OPT ( ":" term OPT ( "with" ltac_expr ) ) +| "Obligation" natural OPT ( "of" ident ) OPT ( ":" term OPT ( "with" ltac_expr ) ) | "Next" "Obligation" OPT ( "of" ident ) OPT ( "with" ltac_expr ) -| "Solve" "Obligation" int OPT ( "of" ident ) "with" ltac_expr +| "Solve" "Obligation" natural OPT ( "of" ident ) "with" ltac_expr | "Solve" "Obligations" OPT ( OPT ( "of" ident ) "with" ltac_expr ) | "Solve" "All" "Obligations" OPT ( "with" ltac_expr ) | "Admit" "Obligations" OPT ( "of" ident ) @@ -805,8 +860,19 @@ command: [ | "Optimize" "Proof" | "Optimize" "Heap" | "Reset" "Ltac" "Profile" -| "Show" "Ltac" "Profile" OPT [ "CutOff" int | string ] +| "Show" "Ltac" "Profile" OPT [ "CutOff" integer | string ] | "Show" "Lia" "Profile" (* micromega plugin *) +| "Add" "Zify" "InjTyp" one_term (* micromega plugin *) +| "Add" "Zify" "BinOp" one_term (* micromega plugin *) +| "Add" "Zify" "UnOp" one_term (* micromega plugin *) +| "Add" "Zify" "CstOp" one_term (* micromega plugin *) +| "Add" "Zify" "BinRel" one_term (* micromega plugin *) +| "Add" "Zify" "PropOp" one_term (* micromega plugin *) +| "Add" "Zify" "PropBinOp" one_term (* micromega plugin *) +| "Add" "Zify" "PropUOp" one_term (* micromega plugin *) +| "Add" "Zify" "BinOpSpec" one_term (* micromega plugin *) +| "Add" "Zify" "UnOpSpec" one_term (* micromega plugin *) +| "Add" "Zify" "Saturate" one_term (* micromega plugin *) | "Add" "InjTyp" one_term (* micromega plugin *) | "Add" "BinOp" one_term (* micromega plugin *) | "Add" "UnOp" one_term (* micromega plugin *) @@ -815,7 +881,6 @@ command: [ | "Add" "PropOp" one_term (* micromega plugin *) | "Add" "PropBinOp" one_term (* micromega plugin *) | "Add" "PropUOp" one_term (* micromega plugin *) -| "Add" "Spec" one_term (* micromega plugin *) | "Add" "BinOpSpec" one_term (* micromega plugin *) | "Add" "UnOpSpec" one_term (* micromega plugin *) | "Add" "Saturate" one_term (* micromega plugin *) @@ -824,15 +889,21 @@ command: [ | "Show" "Zify" "UnOp" (* micromega plugin *) | "Show" "Zify" "CstOp" (* micromega plugin *) | "Show" "Zify" "BinRel" (* micromega plugin *) +| "Show" "Zify" "UnOpSpec" (* micromega plugin *) +| "Show" "Zify" "BinOpSpec" (* micromega plugin *) | "Show" "Zify" "Spec" (* micromega plugin *) | "Add" "Ring" ident ":" one_term OPT ( "(" LIST1 ring_mod SEP "," ")" ) (* setoid_ring plugin *) +| "Print" "Rings" (* setoid_ring plugin *) +| "Add" "Field" ident ":" one_term OPT ( "(" LIST1 field_mod SEP "," ")" ) (* setoid_ring plugin *) +| "Print" "Fields" (* setoid_ring plugin *) +| "Number" "Notation" qualid qualid qualid ":" ident OPT numeral_modifier | "Hint" "Cut" "[" hints_path "]" OPT ( ":" LIST1 ident ) | "Typeclasses" "Transparent" LIST0 qualid | "Typeclasses" "Opaque" LIST0 qualid -| "Typeclasses" "eauto" ":=" OPT "debug" OPT ( "(" eauto_search_strategy_name ")" ) OPT int +| "Typeclasses" "eauto" ":=" OPT "debug" OPT ( "(" eauto_search_strategy_name ")" ) OPT integer | "Proof" "with" ltac_expr OPT [ "using" section_subset_expr ] | "Proof" "using" section_subset_expr OPT [ "with" ltac_expr ] -| "Tactic" "Notation" OPT ( "(" "at" "level" num ")" ) LIST1 ltac_production_item ":=" ltac_expr +| "Tactic" "Notation" OPT ( "(" "at" "level" natural ")" ) LIST1 ltac_production_item ":=" ltac_expr | "Print" "Rewrite" "HintDb" ident | "Print" "Ltac" qualid | "Ltac" tacdef_body LIST0 ( "with" tacdef_body ) @@ -841,26 +912,6 @@ command: [ | "Print" "Firstorder" "Solver" | "Function" fix_definition LIST0 ( "with" fix_definition ) | "Functional" "Scheme" fun_scheme_arg LIST0 ( "with" fun_scheme_arg ) -| "Extraction" qualid (* extraction plugin *) -| "Recursive" "Extraction" LIST1 qualid (* extraction plugin *) -| "Extraction" string LIST1 qualid (* extraction plugin *) -| "Extraction" "TestCompile" LIST1 qualid (* extraction plugin *) -| "Separate" "Extraction" LIST1 qualid (* extraction plugin *) -| "Extraction" "Library" ident (* extraction plugin *) -| "Recursive" "Extraction" "Library" ident (* extraction plugin *) -| "Extraction" "Language" language (* extraction plugin *) -| "Extraction" "Inline" LIST1 qualid (* extraction plugin *) -| "Extraction" "NoInline" LIST1 qualid (* extraction plugin *) -| "Print" "Extraction" "Inline" (* extraction plugin *) -| "Reset" "Extraction" "Inline" (* extraction plugin *) -| "Extraction" "Implicit" qualid "[" LIST0 int_or_id "]" (* extraction plugin *) -| "Extraction" "Blacklist" LIST1 ident (* extraction plugin *) -| "Print" "Extraction" "Blacklist" (* extraction plugin *) -| "Reset" "Extraction" "Blacklist" (* extraction plugin *) -| "Extract" "Constant" qualid LIST0 string "=>" [ ident | string ] (* extraction plugin *) -| "Extract" "Inlined" "Constant" qualid "=>" [ ident | string ] (* extraction plugin *) -| "Extract" "Inductive" qualid "=>" [ ident | string ] "[" LIST0 [ ident | string ] "]" OPT string (* extraction plugin *) -| "Show" "Extraction" (* extraction plugin *) | "Functional" "Case" fun_scheme_arg (* funind plugin *) | "Generate" "graph" "for" qualid (* funind plugin *) | "Hint" "Rewrite" OPT [ "->" | "<-" ] LIST1 one_term OPT ( "using" ltac_expr ) OPT ( ":" LIST0 ident ) @@ -870,14 +921,11 @@ command: [ | "Derive" "Dependent" "Inversion_clear" ident "with" one_term "Sort" sort_family | "Declare" "Left" "Step" one_term | "Declare" "Right" "Step" one_term -| "Print" "Rings" (* setoid_ring plugin *) -| "Add" "Field" ident ":" one_term OPT ( "(" LIST1 field_mod SEP "," ")" ) (* setoid_ring plugin *) -| "Print" "Fields" (* setoid_ring plugin *) | "Numeral" "Notation" qualid qualid qualid ":" scope_name OPT numeral_modifier | "String" "Notation" qualid qualid qualid ":" scope_name | "SubClass" ident_decl def_body | thm_token ident_decl LIST0 binder ":" type LIST0 [ "with" ident_decl LIST0 binder ":" type ] -| assumption_token OPT ( "Inline" OPT ( "(" num ")" ) ) [ LIST1 ( "(" assumpt ")" ) | assumpt ] +| assumption_token OPT ( "Inline" OPT ( "(" natural ")" ) ) [ LIST1 ( "(" assumpt ")" ) | assumpt ] | [ "Definition" | "Example" ] ident_decl def_body | "Let" ident_decl def_body | "Inductive" inductive_definition LIST0 ( "with" inductive_definition ) @@ -889,7 +937,7 @@ command: [ | "Combined" "Scheme" ident "from" LIST1 ident SEP "," | "Register" qualid "as" qualid | "Register" "Inline" qualid -| "Primitive" ident OPT [ ":" term ] ":=" "#" ident +| "Primitive" ident_decl OPT [ ":" term ] ":=" "#" ident | "Universe" LIST1 ident | "Universes" LIST1 ident | "Constraint" LIST1 univ_constraint SEP "," @@ -920,24 +968,24 @@ command: [ | "Context" LIST1 binder | "Instance" OPT ( ident_decl LIST0 binder ) ":" term OPT hint_info OPT [ ":=" "{" LIST0 field_def "}" | ":=" term ] | "Existing" "Instance" qualid OPT hint_info -| "Existing" "Instances" LIST1 qualid OPT [ "|" num ] +| "Existing" "Instances" LIST1 qualid OPT [ "|" natural ] | "Existing" "Class" qualid | "Arguments" reference LIST0 arg_specs LIST0 [ "," LIST0 implicits_alt ] OPT [ ":" LIST1 args_modifier SEP "," ] | "Implicit" [ "Type" | "Types" ] reserv_list | "Generalizable" [ [ "Variable" | "Variables" ] LIST1 ident | "All" "Variables" | "No" "Variables" ] -| "Set" setting_name OPT [ int | string ] +| "Set" setting_name OPT [ integer | string ] | "Unset" setting_name | "Open" "Scope" scope | "Close" "Scope" scope | "Delimit" "Scope" scope_name "with" scope_key | "Undelimit" "Scope" scope_name | "Bind" "Scope" scope_name "with" LIST1 class -| "Infix" string ":=" one_term OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] OPT [ ":" scope_name ] +| "Infix" string ":=" one_term OPT ( "(" LIST1 syntax_modifier SEP "," ")" ) OPT [ ":" scope_name ] | "Notation" ident LIST0 ident ":=" one_term OPT ( "(" "only" "parsing" ")" ) -| "Notation" string ":=" one_term OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] OPT [ ":" scope_name ] +| "Notation" string ":=" one_term OPT ( "(" LIST1 syntax_modifier SEP "," ")" ) OPT [ ":" scope_name ] | "Format" "Notation" string string string -| "Reserved" "Infix" string OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] -| "Reserved" "Notation" string OPT [ "(" LIST1 syntax_modifier SEP "," ")" ] +| "Reserved" "Infix" string OPT ( "(" LIST1 syntax_modifier SEP "," ")" ) +| "Reserved" "Notation" string OPT ( "(" LIST1 syntax_modifier SEP "," ")" ) | "Eval" red_expr "in" term | "Compute" term | "Check" term @@ -946,14 +994,22 @@ command: [ | "SearchPattern" one_term OPT ( [ "inside" | "outside" ] LIST1 qualid ) | "SearchRewrite" one_term OPT ( [ "inside" | "outside" ] LIST1 qualid ) | "Search" LIST1 ( search_query ) OPT ( [ "inside" | "outside" ] LIST1 qualid ) +| "Ltac2" OPT "mutable" OPT "rec" tac2def_body LIST0 ( "with" tac2def_body ) +| "Ltac2" "Type" OPT "rec" tac2typ_def LIST0 ( "with" tac2typ_def ) +| "Ltac2" "@" "external" ident ":" ltac2_type ":=" string string +| "Ltac2" "Notation" LIST1 ltac2_scope OPT ( ":" natural ) ":=" ltac2_expr +| "Ltac2" "Set" qualid OPT [ "as" ident ] ":=" ltac2_expr +| "Ltac2" "Notation" [ string | lident ] ":=" ltac2_expr (* Ltac2 plugin *) +| "Ltac2" "Eval" ltac2_expr (* Ltac2 plugin *) +| "Print" "Ltac2" qualid (* Ltac2 plugin *) | "Time" sentence | "Redirect" string sentence -| "Timeout" num sentence +| "Timeout" natural sentence | "Fail" sentence | "Drop" | "Quit" -| "BackTo" num -| "Show" "Goal" num "at" num +| "BackTo" natural +| "Show" "Goal" natural "at" natural ] section_subset_expr: [ @@ -1020,8 +1076,8 @@ univ_name_list: [ hint: [ | "Resolve" LIST1 [ qualid | one_term ] OPT hint_info -| "Resolve" "->" LIST1 qualid OPT num -| "Resolve" "<-" LIST1 qualid OPT num +| "Resolve" "->" LIST1 qualid OPT natural +| "Resolve" "<-" LIST1 qualid OPT natural | "Immediate" LIST1 [ qualid | one_term ] | "Variables" "Transparent" | "Variables" "Opaque" @@ -1032,7 +1088,7 @@ hint: [ | "Mode" qualid LIST1 [ "+" | "!" | "-" ] | "Unfold" LIST1 qualid | "Constructors" LIST1 qualid -| "Extern" num OPT one_term "=>" ltac_expr +| "Extern" natural OPT one_term "=>" ltac_expr ] tacdef_body: [ @@ -1044,9 +1100,171 @@ ltac_production_item: [ | ident OPT ( "(" ident OPT ( "," string ) ")" ) ] +tac2expr_in_env: [ +| LIST0 ident "|-" ltac2_expr (* Ltac2 plugin *) +| ltac2_expr (* Ltac2 plugin *) +] + +ltac2_type: [ +| ltac2_type2 "->" ltac2_type (* Ltac2 plugin *) +| ltac2_type2 (* Ltac2 plugin *) +] + +ltac2_type2: [ +| ltac2_type1 "*" LIST1 ltac2_type1 SEP "*" (* Ltac2 plugin *) +| ltac2_type1 (* Ltac2 plugin *) +] + +ltac2_type1: [ +| ltac2_type0 qualid (* Ltac2 plugin *) +| ltac2_type0 (* Ltac2 plugin *) +] + +ltac2_type0: [ +| "(" LIST1 ltac2_type SEP "," ")" OPT qualid (* Ltac2 plugin *) +| ltac2_typevar (* Ltac2 plugin *) +| "_" (* Ltac2 plugin *) +| qualid (* Ltac2 plugin *) +] + +ltac2_typevar: [ +| "'" ident (* Ltac2 plugin *) +] + +lident: [ +| ident (* Ltac2 plugin *) +] + +destruction_arg: [ +| natural +| constr_with_bindings +| constr_with_bindings_arg +] + +constr_with_bindings_arg: [ +| ">" constr_with_bindings +| constr_with_bindings +] + +clause_dft_concl: [ +| "in" in_clause +| OPT ( "at" occs_nums ) +] + +in_clause: [ +| "*" OPT ( "at" occs_nums ) +| "*" "|-" OPT concl_occ +| LIST0 hypident_occ SEP "," OPT ( "|-" OPT concl_occ ) +] + +hypident_occ: [ +| hypident OPT ( "at" occs_nums ) +] + +hypident: [ +| ident +| "(" "type" "of" ident ")" +| "(" "value" "of" ident ")" +] + +concl_occ: [ +| "*" OPT ( "at" occs_nums ) +] + +q_intropatterns: [ +| ltac2_intropatterns (* Ltac2 plugin *) +] + +ltac2_intropatterns: [ +| LIST0 nonsimple_intropattern (* Ltac2 plugin *) +] + +nonsimple_intropattern: [ +| "*" (* Ltac2 plugin *) +| "**" (* Ltac2 plugin *) +| ltac2_simple_intropattern (* Ltac2 plugin *) +] + +q_intropattern: [ +| ltac2_simple_intropattern (* Ltac2 plugin *) +] + +ltac2_simple_intropattern: [ +| ltac2_naming_intropattern (* Ltac2 plugin *) +| "_" (* Ltac2 plugin *) +| ltac2_or_and_intropattern (* Ltac2 plugin *) +| ltac2_equality_intropattern (* Ltac2 plugin *) +] + +ltac2_or_and_intropattern: [ +| "[" LIST1 ltac2_intropatterns SEP "|" "]" (* Ltac2 plugin *) +| "()" (* Ltac2 plugin *) +| "(" LIST1 ltac2_simple_intropattern SEP "," ")" (* Ltac2 plugin *) +| "(" LIST1 ltac2_simple_intropattern SEP "&" ")" (* Ltac2 plugin *) +] + +ltac2_equality_intropattern: [ +| "->" (* Ltac2 plugin *) +| "<-" (* Ltac2 plugin *) +| "[=" ltac2_intropatterns "]" (* Ltac2 plugin *) +] + +ltac2_naming_intropattern: [ +| "?" lident (* Ltac2 plugin *) +| "?$" lident (* Ltac2 plugin *) +| "?" (* Ltac2 plugin *) +| ident_or_anti (* Ltac2 plugin *) +] + +q_ident: [ +| ident_or_anti (* Ltac2 plugin *) +] + +ident_or_anti: [ +| lident (* Ltac2 plugin *) +| "$" ident (* Ltac2 plugin *) +] + +q_destruction_arg: [ +| ltac2_destruction_arg (* Ltac2 plugin *) +] + +ltac2_destruction_arg: [ +| natural (* Ltac2 plugin *) +| lident (* Ltac2 plugin *) +| ltac2_constr_with_bindings (* Ltac2 plugin *) +] + +ltac2_constr_with_bindings: [ +| term OPT ( "with" ltac2_bindings ) (* Ltac2 plugin *) +] + +q_bindings: [ +| ltac2_bindings (* Ltac2 plugin *) +] + +q_with_bindings: [ +| OPT ( "with" ltac2_bindings ) (* Ltac2 plugin *) +] + +ltac2_bindings: [ +| LIST1 ltac2_simple_binding (* Ltac2 plugin *) +| LIST1 term (* Ltac2 plugin *) +] + +ltac2_simple_binding: [ +| "(" qhyp ":=" term ")" (* Ltac2 plugin *) +] + +qhyp: [ +| "$" ident (* Ltac2 plugin *) +| natural (* Ltac2 plugin *) +| lident (* Ltac2 plugin *) +] + int_or_id: [ -| ident (* extraction plugin *) -| int (* extraction plugin *) +| ident +| integer (* extraction plugin *) ] language: [ @@ -1082,8 +1300,8 @@ field_mod: [ ] numeral_modifier: [ -| "(" "warning" "after" numeral ")" -| "(" "abstract" "after" numeral ")" +| "(" "warning" "after" bignat ")" +| "(" "abstract" "after" bignat ")" ] hints_path: [ @@ -1109,8 +1327,8 @@ class: [ ] syntax_modifier: [ -| "at" "level" num -| "in" "custom" ident OPT ( "at" "level" num ) +| "at" "level" natural +| "in" "custom" ident OPT ( "at" "level" natural ) | LIST1 ident SEP "," "at" level | ident "at" level OPT binder_interp | ident explicit_subentry @@ -1127,12 +1345,12 @@ explicit_subentry: [ | "ident" | "global" | "bigint" -| "strict" "pattern" OPT ( "at" "level" num ) +| "strict" "pattern" OPT ( "at" "level" natural ) | "binder" | "closed" "binder" | "constr" OPT ( "at" level ) OPT binder_interp | "custom" ident OPT ( "at" level ) OPT binder_interp -| "pattern" OPT ( "at" "level" num ) +| "pattern" OPT ( "at" "level" natural ) ] binder_interp: [ @@ -1142,7 +1360,7 @@ binder_interp: [ ] level: [ -| "level" num +| "level" natural | "next" "level" ] @@ -1151,7 +1369,7 @@ decl_notations: [ ] decl_notation: [ -| string ":=" one_term OPT ( "(" "only" "parsing" ")" ) OPT [ ":" scope_name ] +| string ":=" one_term OPT ( "(" LIST1 syntax_modifier SEP "," ")" ) OPT [ ":" scope_name ] ] simple_tactic: [ @@ -1179,14 +1397,14 @@ simple_tactic: [ | "esplit" OPT ( "with" bindings ) | "exists" OPT ( LIST1 bindings SEP "," ) | "eexists" OPT ( LIST1 bindings SEP "," ) -| "intros" "until" [ ident | num ] +| "intros" "until" [ ident | natural ] | "intro" OPT ident OPT where | "move" ident OPT where | "rename" LIST1 ( ident "into" ident ) SEP "," | "revert" LIST1 ident -| "simple" "induction" [ ident | num ] -| "simple" "destruct" [ ident | num ] -| "double" "induction" [ ident | num ] [ ident | num ] +| "simple" "induction" [ ident | natural ] +| "simple" "destruct" [ ident | natural ] +| "double" "induction" [ ident | natural ] [ ident | natural ] | "admit" | "clear" LIST0 ident | "clear" "-" LIST1 ident @@ -1208,8 +1426,9 @@ simple_tactic: [ | "tryif" ltac_expr "then" ltac_expr "else" ltac_expr2 | "first" "[" LIST0 ltac_expr SEP "|" "]" | "solve" "[" LIST0 ltac_expr SEP "|" "]" -| "idtac" LIST0 [ ident | string | int ] -| [ "fail" | "gfail" ] OPT int_or_var LIST0 [ ident | string | int ] +| "idtac" LIST0 [ ident | string | natural ] +| [ "fail" | "gfail" ] OPT int_or_var LIST0 [ ident | string | natural ] +| "fun" LIST1 name "=>" ltac_expr | "eval" red_expr "in" term | "context" ident "[" term "]" | "type" "of" term @@ -1219,13 +1438,14 @@ simple_tactic: [ | "uconstr" ":" "(" term ")" | "fun" LIST1 name "=>" ltac_expr | "let" OPT "rec" let_clause LIST0 ( "with" let_clause ) "in" ltac_expr -| "info" ltac_expr | ltac_expr3 ";" [ ltac_expr3 | binder_tactic ] | ltac_expr3 ";" "[" for_each_goal "]" | ltac_expr1 "+" [ ltac_expr2 | binder_tactic ] | ltac_expr1 "||" [ ltac_expr2 | binder_tactic ] | "[>" for_each_goal "]" | toplevel_selector ":" ltac_expr +| ltac2_match_key ltac2_expr "with" ltac2_match_list "end" +| ltac2_match_key OPT "reverse" "goal" "with" goal_match_list "end" | "simplify_eq" OPT destruction_arg | "esimplify_eq" OPT destruction_arg | "discriminate" OPT destruction_arg @@ -1234,7 +1454,6 @@ simple_tactic: [ | "einjection" OPT destruction_arg OPT ( "as" LIST0 simple_intropattern ) | "simple" "injection" OPT destruction_arg | "dependent" "rewrite" OPT [ "->" | "<-" ] one_term OPT ( "in" ident ) -| "cutrewrite" OPT [ "->" | "<-" ] one_term OPT ( "in" ident ) | "decompose" "sum" one_term | "decompose" "record" one_term | "absurd" one_term @@ -1252,7 +1471,7 @@ simple_tactic: [ | "evar" "(" ident ":" term ")" | "evar" one_term | "instantiate" "(" ident ":=" term ")" -| "instantiate" "(" int ":=" term ")" OPT hloc +| "instantiate" "(" integer ":=" term ")" OPT hloc | "instantiate" | "stepl" one_term OPT ( "by" ltac_expr ) | "stepr" one_term OPT ( "by" ltac_expr ) @@ -1291,7 +1510,7 @@ simple_tactic: [ | "start" "ltac" "profiling" | "stop" "ltac" "profiling" | "reset" "ltac" "profile" -| "show" "ltac" "profile" OPT [ "cutoff" int | string ] +| "show" "ltac" "profile" OPT [ "cutoff" integer | string ] | "restart_timer" OPT string | "finish_timing" OPT ( "(" string ")" ) OPT string | "eassumption" @@ -1329,10 +1548,10 @@ simple_tactic: [ | "setoid_reflexivity" | "setoid_transitivity" one_term | "setoid_etransitivity" -| "decide" "equality" -| "compare" one_term one_term | "intros" LIST0 intropattern | "eintros" LIST0 intropattern +| "decide" "equality" +| "compare" one_term one_term | "apply" LIST1 constr_with_bindings_arg SEP "," OPT in_hyp_as | "eapply" LIST1 constr_with_bindings_arg SEP "," OPT in_hyp_as | "simple" "apply" LIST1 constr_with_bindings_arg SEP "," OPT in_hyp_as @@ -1341,7 +1560,7 @@ simple_tactic: [ | "eelim" constr_with_bindings_arg OPT ( "using" constr_with_bindings ) | "case" induction_clause_list | "ecase" induction_clause_list -| "fix" ident num OPT ( "with" LIST1 fixdecl ) +| "fix" ident natural OPT ( "with" LIST1 fixdecl ) | "cofix" ident OPT ( "with" LIST1 cofixdecl ) | "pose" bindings_with_parameters | "pose" one_term OPT as_name @@ -1375,11 +1594,11 @@ simple_tactic: [ | "edestruct" induction_clause_list | "rewrite" LIST1 oriented_rewriter SEP "," OPT clause_dft_concl OPT ( "by" ltac_expr3 ) | "erewrite" LIST1 oriented_rewriter SEP "," OPT clause_dft_concl OPT ( "by" ltac_expr3 ) -| "dependent" [ "simple" "inversion" | "inversion" | "inversion_clear" ] [ ident | num ] OPT as_or_and_ipat OPT [ "with" one_term ] -| "simple" "inversion" [ ident | num ] OPT as_or_and_ipat OPT ( "in" LIST1 ident ) -| "inversion" [ ident | num ] OPT as_or_and_ipat OPT ( "in" LIST1 ident ) -| "inversion_clear" [ ident | num ] OPT as_or_and_ipat OPT ( "in" LIST1 ident ) -| "inversion" [ ident | num ] "using" one_term OPT ( "in" LIST1 ident ) +| "dependent" [ "simple" "inversion" | "inversion" | "inversion_clear" ] [ ident | natural ] OPT as_or_and_ipat OPT [ "with" one_term ] +| "simple" "inversion" [ ident | natural ] OPT as_or_and_ipat OPT ( "in" LIST1 ident ) +| "inversion" [ ident | natural ] OPT as_or_and_ipat OPT ( "in" LIST1 ident ) +| "inversion_clear" [ ident | natural ] OPT as_or_and_ipat OPT ( "in" LIST1 ident ) +| "inversion" [ ident | natural ] "using" one_term OPT ( "in" LIST1 ident ) | "red" OPT clause_dft_concl | "hnf" OPT clause_dft_concl | "simpl" OPT delta_flag OPT ref_or_pattern_occ OPT clause_dft_concl @@ -1396,11 +1615,11 @@ simple_tactic: [ | "change_no_check" conversion OPT clause_dft_concl | "btauto" | "rtauto" -| "congruence" OPT int OPT ( "with" LIST1 one_term ) +| "congruence" OPT natural OPT ( "with" LIST1 one_term ) | "f_equal" | "firstorder" OPT ltac_expr firstorder_rhs | "gintuition" OPT ltac_expr -| "functional" "inversion" [ ident | num ] OPT qualid (* funind plugin *) +| "functional" "inversion" [ ident | natural ] OPT qualid (* funind plugin *) | "functional" "induction" term OPT fun_ind_using OPT with_names (* funind plugin *) | "soft" "functional" "induction" LIST1 one_term OPT fun_ind_using OPT with_names (* funind plugin *) | "psatz_Z" OPT int_or_var ltac_expr @@ -1453,6 +1672,7 @@ simple_tactic: [ | "psatz" term OPT int_or_var | "ring" OPT ( "[" LIST1 term "]" ) | "ring_simplify" OPT ( "[" LIST1 term "]" ) LIST1 term OPT ( "in" ident ) +| "match" ltac2_expr5 "with" OPT ltac2_branches "end" | qualid LIST1 tactic_arg ] @@ -1465,26 +1685,6 @@ hloc: [ | "in" "(" "value" "of" ident ")" ] -in_clause: [ -| LIST0 hypident_occ SEP "," OPT ( "|-" OPT concl_occ ) -| "*" "|-" OPT concl_occ -| "*" OPT ( "at" occs_nums ) -] - -concl_occ: [ -| "*" OPT ( "at" occs_nums ) -] - -hypident_occ: [ -| hypident OPT ( "at" occs_nums ) -] - -hypident: [ -| ident -| "(" "type" "of" ident ")" -| "(" "value" "of" ident ")" -] - as_ipat: [ | "as" simple_intropattern ] @@ -1507,12 +1707,7 @@ as_name: [ ] rewriter: [ -| "!" constr_with_bindings_arg -| "?" constr_with_bindings_arg -| num "!" constr_with_bindings_arg -| num [ "?" | "?" ] constr_with_bindings_arg -| num constr_with_bindings_arg -| constr_with_bindings_arg +| OPT natural OPT [ "?" | "!" ] constr_with_bindings_arg ] oriented_rewriter: [ @@ -1554,9 +1749,9 @@ naming_intropattern: [ ] intropattern: [ -| simple_intropattern | "*" | "**" +| simple_intropattern ] simple_intropattern: [ @@ -1572,7 +1767,7 @@ simple_intropattern_closed: [ simple_binding: [ | "(" ident ":=" term ")" -| "(" num ":=" term ")" +| "(" natural ":=" term ")" ] bindings: [ @@ -1597,9 +1792,367 @@ bindings_with_parameters: [ | "(" ident LIST0 simple_binder ":=" term ")" ] -clause_dft_concl: [ -| "in" in_clause -| OPT ( "at" occs_nums ) +q_clause: [ +| ltac2_clause (* Ltac2 plugin *) +] + +ltac2_clause: [ +| "in" ltac2_in_clause (* Ltac2 plugin *) +| "at" ltac2_occs_nums (* Ltac2 plugin *) +] + +ltac2_in_clause: [ +| "*" OPT ltac2_occs (* Ltac2 plugin *) +| "*" "|-" OPT ltac2_concl_occ (* Ltac2 plugin *) +| LIST0 ltac2_hypident_occ SEP "," OPT ( "|-" OPT ltac2_concl_occ ) (* Ltac2 plugin *) +] + +q_occurrences: [ +| OPT ltac2_occs (* Ltac2 plugin *) +] + +ltac2_occs: [ +| "at" ltac2_occs_nums (* Ltac2 plugin *) +] + +ltac2_occs_nums: [ +| OPT "-" LIST1 [ natural (* Ltac2 plugin *) | "$" ident ] (* Ltac2 plugin *) +] + +ltac2_concl_occ: [ +| "*" OPT ltac2_occs (* Ltac2 plugin *) +] + +ltac2_hypident_occ: [ +| ltac2_hypident OPT ltac2_occs (* Ltac2 plugin *) +] + +ltac2_hypident: [ +| ident_or_anti (* Ltac2 plugin *) +| "(" "type" "of" ident_or_anti ")" (* Ltac2 plugin *) +| "(" "value" "of" ident_or_anti ")" (* Ltac2 plugin *) +] + +q_induction_clause: [ +| ltac2_induction_clause (* Ltac2 plugin *) +] + +ltac2_induction_clause: [ +| ltac2_destruction_arg OPT ltac2_as_or_and_ipat OPT ltac2_eqn_ipat OPT ltac2_clause (* Ltac2 plugin *) +] + +ltac2_as_or_and_ipat: [ +| "as" ltac2_or_and_intropattern (* Ltac2 plugin *) +] + +ltac2_eqn_ipat: [ +| "eqn" ":" ltac2_naming_intropattern (* Ltac2 plugin *) +] + +q_conversion: [ +| ltac2_conversion (* Ltac2 plugin *) +] + +ltac2_conversion: [ +| term (* Ltac2 plugin *) +| term "with" term (* Ltac2 plugin *) +] + +q_rewriting: [ +| ltac2_oriented_rewriter (* Ltac2 plugin *) +] + +ltac2_oriented_rewriter: [ +| [ "->" | "<-" ] ltac2_rewriter (* Ltac2 plugin *) +] + +ltac2_rewriter: [ +| OPT natural OPT [ "?" | "!" ] ltac2_constr_with_bindings +] + +q_dispatch: [ +| ltac2_for_each_goal (* Ltac2 plugin *) +] + +ltac2_for_each_goal: [ +| ltac2_goal_tactics (* Ltac2 plugin *) +| OPT ( ltac2_goal_tactics "|" ) OPT ltac2_expr ".." OPT ( "|" ltac2_goal_tactics ) (* Ltac2 plugin *) +] + +ltac2_goal_tactics: [ +| LIST0 ( OPT ltac2_expr ) SEP "|" (* Ltac2 plugin *) +] + +q_strategy_flag: [ +| ltac2_strategy_flag (* Ltac2 plugin *) +] + +ltac2_strategy_flag: [ +| LIST1 ltac2_red_flag (* Ltac2 plugin *) +| OPT ltac2_delta_flag (* Ltac2 plugin *) +] + +ltac2_red_flag: [ +| "beta" (* Ltac2 plugin *) +| "iota" (* Ltac2 plugin *) +| "match" (* Ltac2 plugin *) +| "fix" (* Ltac2 plugin *) +| "cofix" (* Ltac2 plugin *) +| "zeta" (* Ltac2 plugin *) +| "delta" OPT ltac2_delta_flag (* Ltac2 plugin *) +] + +ltac2_delta_flag: [ +| OPT "-" "[" LIST1 refglobal "]" +] + +q_reference: [ +| refglobal (* Ltac2 plugin *) +] + +refglobal: [ +| "&" ident (* Ltac2 plugin *) +| qualid (* Ltac2 plugin *) +| "$" ident (* Ltac2 plugin *) +] + +q_hintdb: [ +| hintdb (* Ltac2 plugin *) +] + +hintdb: [ +| "*" (* Ltac2 plugin *) +| LIST1 ident_or_anti (* Ltac2 plugin *) +] + +q_constr_matching: [ +| ltac2_match_list (* Ltac2 plugin *) +] + +ltac2_match_key: [ +| "lazy_match!" +| "match!" +| "multi_match!" +] + +ltac2_match_list: [ +| OPT "|" LIST1 ltac2_match_rule SEP "|" +] + +ltac2_match_rule: [ +| ltac2_match_pattern "=>" ltac2_expr (* Ltac2 plugin *) +] + +ltac2_match_pattern: [ +| cpattern (* Ltac2 plugin *) +| "context" OPT ident "[" cpattern "]" (* Ltac2 plugin *) +] + +q_goal_matching: [ +| goal_match_list (* Ltac2 plugin *) +] + +goal_match_list: [ +| OPT "|" LIST1 gmatch_rule SEP "|" +] + +gmatch_rule: [ +| gmatch_pattern "=>" ltac2_expr (* Ltac2 plugin *) +] + +gmatch_pattern: [ +| "[" LIST0 gmatch_hyp_pattern SEP "," "|-" ltac2_match_pattern "]" (* Ltac2 plugin *) +] + +gmatch_hyp_pattern: [ +| name ":" ltac2_match_pattern (* Ltac2 plugin *) +] + +q_move_location: [ +| move_location (* Ltac2 plugin *) +] + +move_location: [ +| "at" "top" (* Ltac2 plugin *) +| "at" "bottom" (* Ltac2 plugin *) +| "after" ident_or_anti (* Ltac2 plugin *) +| "before" ident_or_anti (* Ltac2 plugin *) +] + +q_pose: [ +| pose (* Ltac2 plugin *) +] + +pose: [ +| "(" ident_or_anti ":=" term ")" (* Ltac2 plugin *) +| term OPT ltac2_as_name (* Ltac2 plugin *) +] + +ltac2_as_name: [ +| "as" ident_or_anti (* Ltac2 plugin *) +] + +q_assert: [ +| assertion (* Ltac2 plugin *) +] + +assertion: [ +| "(" ident_or_anti ":=" term ")" (* Ltac2 plugin *) +| "(" ident_or_anti ":" term ")" OPT ltac2_by_tactic (* Ltac2 plugin *) +| term OPT ltac2_as_ipat OPT ltac2_by_tactic (* Ltac2 plugin *) +] + +ltac2_as_ipat: [ +| "as" ltac2_simple_intropattern (* Ltac2 plugin *) +] + +ltac2_by_tactic: [ +| "by" ltac2_expr (* Ltac2 plugin *) +] + +ltac2_entry: [ +] + +tac2def_body: [ +| [ "_" | ident ] LIST0 tac2pat0 ":=" ltac2_expr (* Ltac2 plugin *) +] + +tac2typ_def: [ +| OPT tac2typ_prm qualid OPT ( [ ":=" | "::=" ] tac2typ_knd ) (* Ltac2 plugin *) +] + +tac2typ_prm: [ +| ltac2_typevar (* Ltac2 plugin *) +| "(" LIST1 ltac2_typevar SEP "," ")" (* Ltac2 plugin *) +] + +tac2typ_knd: [ +| ltac2_type (* Ltac2 plugin *) +| "[" OPT ( OPT "|" LIST1 tac2alg_constructor SEP "|" ) "]" (* Ltac2 plugin *) +| "[" ".." "]" (* Ltac2 plugin *) +| "{" OPT ( LIST1 tac2rec_field SEP ";" OPT ";" ) "}" (* Ltac2 plugin *) +] + +tac2alg_constructor: [ +| ident (* Ltac2 plugin *) +| ident "(" LIST0 ltac2_type SEP "," ")" (* Ltac2 plugin *) +] + +tac2rec_field: [ +| OPT "mutable" ident ":" ltac2_type (* Ltac2 plugin *) +] + +ltac2_scope: [ +| string (* Ltac2 plugin *) +| integer (* Ltac2 plugin *) +| name (* Ltac2 plugin *) +| name "(" LIST1 ltac2_scope SEP "," ")" (* Ltac2 plugin *) +] + +ltac2_expr: [ +| ltac2_expr5 ";" ltac2_expr (* Ltac2 plugin *) +| ltac2_expr5 (* Ltac2 plugin *) +] + +ltac2_expr5: [ +| "fun" LIST1 tac2pat0 "=>" ltac2_expr (* Ltac2 plugin *) +| "let" OPT "rec" ltac2_let_clause LIST0 ( "with" ltac2_let_clause ) "in" ltac2_expr (* Ltac2 plugin *) +| ltac2_expr3 (* Ltac2 plugin *) +] + +ltac2_let_clause: [ +| LIST1 tac2pat0 ":=" ltac2_expr (* Ltac2 plugin *) +] + +ltac2_expr3: [ +| LIST1 ltac2_expr2 SEP "," (* Ltac2 plugin *) +] + +ltac2_expr2: [ +| ltac2_expr1 "::" ltac2_expr2 (* Ltac2 plugin *) +| ltac2_expr1 (* Ltac2 plugin *) +] + +ltac2_expr1: [ +| ltac2_expr0 LIST1 ltac2_expr0 (* Ltac2 plugin *) +| ltac2_expr0 ".(" qualid ")" (* Ltac2 plugin *) +| ltac2_expr0 ".(" qualid ")" ":=" ltac2_expr5 (* Ltac2 plugin *) +| ltac2_expr0 (* Ltac2 plugin *) +] + +tac2rec_fieldexpr: [ +| qualid ":=" ltac2_expr1 (* Ltac2 plugin *) +] + +ltac2_expr0: [ +| "(" ltac2_expr ")" (* Ltac2 plugin *) +| "(" ltac2_expr ":" ltac2_type ")" (* Ltac2 plugin *) +| "()" (* Ltac2 plugin *) +| "[" LIST0 ltac2_expr5 SEP ";" "]" (* Ltac2 plugin *) +| "{" OPT ( LIST1 tac2rec_fieldexpr OPT ";" ) "}" (* Ltac2 plugin *) +| ltac2_tactic_atom (* Ltac2 plugin *) +] + +ltac2_tactic_atom: [ +| integer (* Ltac2 plugin *) +| string (* Ltac2 plugin *) +| qualid (* Ltac2 plugin *) +| "@" ident (* Ltac2 plugin *) +| "&" lident (* Ltac2 plugin *) +| "'" term (* Ltac2 plugin *) +| ltac2_quotations +] + +ltac2_quotations: [ +| "ident" ":" "(" lident ")" +| "constr" ":" "(" term ")" +| "open_constr" ":" "(" term ")" +| "pattern" ":" "(" cpattern ")" +| "reference" ":" "(" [ "&" ident | qualid ] ")" +| "ltac1" ":" "(" ltac1_expr_in_env ")" +| "ltac1val" ":" "(" ltac1_expr_in_env ")" +] + +ltac1_expr_in_env: [ +| ltac_expr (* Ltac2 plugin *) +| LIST0 ident "|-" ltac_expr (* Ltac2 plugin *) +] + +ltac2_branches: [ +| OPT "|" LIST1 ( tac2pat1 "=>" ltac2_expr ) SEP "|" +] + +tac2pat1: [ +| qualid LIST1 tac2pat0 (* Ltac2 plugin *) +| qualid (* Ltac2 plugin *) +| "[" "]" (* Ltac2 plugin *) +| tac2pat0 "::" tac2pat0 (* Ltac2 plugin *) +| tac2pat0 (* Ltac2 plugin *) +] + +tac2pat0: [ +| "_" (* Ltac2 plugin *) +| "()" (* Ltac2 plugin *) +| qualid (* Ltac2 plugin *) +| "(" OPT atomic_tac2pat ")" (* Ltac2 plugin *) +] + +atomic_tac2pat: [ +| tac2pat1 ":" ltac2_type (* Ltac2 plugin *) +| tac2pat1 "," LIST0 tac2pat1 SEP "," (* Ltac2 plugin *) +| tac2pat1 (* Ltac2 plugin *) +] + +tac2mode: [ +| ltac2_expr [ "." | "..." ] (* Ltac2 plugin *) +| "Eval" red_expr "in" term +| "Compute" term +| "Check" term +| "About" reference OPT univ_name_list +| "SearchHead" one_term OPT ( [ "inside" | "outside" ] LIST1 qualid ) +| "SearchPattern" one_term OPT ( [ "inside" | "outside" ] LIST1 qualid ) +| "SearchRewrite" one_term OPT ( [ "inside" | "outside" ] LIST1 qualid ) +| "Search" LIST1 ( search_query ) OPT ( [ "inside" | "outside" ] LIST1 qualid ) ] clause_dft_all: [ @@ -1636,17 +2189,6 @@ constr_with_bindings: [ | one_term OPT ( "with" bindings ) ] -destruction_arg: [ -| num -| constr_with_bindings -| constr_with_bindings_arg -] - -constr_with_bindings_arg: [ -| ">" constr_with_bindings -| constr_with_bindings -] - conversion: [ | one_term | one_term "with" one_term @@ -1668,7 +2210,7 @@ with_names: [ ] occurrences: [ -| LIST1 int +| LIST1 integer | ident ] @@ -1763,7 +2305,7 @@ ltac_expr0: [ ] tactic_atom: [ -| int +| integer | qualid | "()" ] @@ -1795,8 +2337,8 @@ selector: [ ] range_selector: [ -| num "-" num -| num +| natural "-" natural +| natural ] match_key: [ diff --git a/engine/eConstr.ml b/engine/eConstr.ml index 334c23c963..36297fe243 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -743,6 +743,9 @@ let match_named_context_val : match unsafe_eq with | Refl -> match_named_context_val +let identity_subst_val : named_context_val -> t list = + match unsafe_eq with Refl -> fun ctx -> ctx.env_named_var + let fresh_global ?loc ?rigid ?names env sigma reference = let (evd,t) = Evd.fresh_global ?loc ?rigid ?names env sigma reference in evd, t diff --git a/engine/eConstr.mli b/engine/eConstr.mli index d0f675319d..a018f4064f 100644 --- a/engine/eConstr.mli +++ b/engine/eConstr.mli @@ -326,6 +326,8 @@ val map_rel_context_in_env : val match_named_context_val : named_context_val -> (named_declaration * lazy_val * named_context_val) option +val identity_subst_val : named_context_val -> t list + (* XXX Missing Sigma proxy *) val fresh_global : ?loc:Loc.t -> ?rigid:Evd.rigid -> ?names:Univ.Instance.t -> Environ.env -> diff --git a/engine/evarutil.ml b/engine/evarutil.ml index b4b2032dd2..771571fd3f 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -183,8 +183,6 @@ let meta_ctr, meta_counter_summary_tag = let new_meta () = incr meta_ctr; !meta_ctr -let mk_new_meta () = EConstr.mkMeta(new_meta()) - (* The list of non-instantiated existential declarations (order is important) *) let non_instantiated sigma = @@ -386,14 +384,12 @@ let push_rel_decl_to_named_context let push_rel_context_to_named_context ?hypnaming env sigma typ = (* compute the instances relative to the named context and rel_context *) - let open Context.Named.Declaration in let open EConstr in - let ids = List.map get_id (named_context env) in - let inst_vars = List.map mkVar ids in + let inst_vars = EConstr.identity_subst_val (named_context_val env) in if List.is_empty (Environ.rel_context env) then (named_context_val env, typ, inst_vars, empty_csubst) else - let avoid = List.fold_right Id.Set.add ids Id.Set.empty in + let avoid = Environ.ids_of_named_context_val (named_context_val env) in let inst_rels = List.rev (rel_list 0 (nb_rel env)) in (* move the rel context to a named context and extend the named instance *) (* with vars of the rel context *) @@ -409,8 +405,9 @@ let push_rel_context_to_named_context ?hypnaming env sigma typ = let default_source = Loc.tag @@ Evar_kinds.InternalHole -let new_pure_evar ?(src=default_source) ?(filter = Filter.identity) ?(abstract_arguments = Abstraction.identity) - ?candidates ?(naming = IntroAnonymous) ?typeclass_candidate ?(principal=false) sign evd typ = +let new_pure_evar ?(src=default_source) ?(filter = Filter.identity) ?identity + ?(abstract_arguments = Abstraction.identity) ?candidates + ?(naming = IntroAnonymous) ?typeclass_candidate ?(principal=false) sign evd typ = let name = match naming with | IntroAnonymous -> None | IntroIdentifier id -> Some id @@ -419,6 +416,10 @@ let new_pure_evar ?(src=default_source) ?(filter = Filter.identity) ?(abstract_a let id = Namegen.next_ident_away_from id has_name in Some id in + let identity = match identity with + | None -> Identity.none () + | Some inst -> Identity.make inst + in let evi = { evar_hyps = sign; evar_concl = typ; @@ -426,7 +427,9 @@ let new_pure_evar ?(src=default_source) ?(filter = Filter.identity) ?(abstract_a evar_filter = filter; evar_abstract_arguments = abstract_arguments; evar_source = src; - evar_candidates = candidates } + evar_candidates = candidates; + evar_identity = identity; + } in let typeclass_candidate = if principal then Some false else typeclass_candidate in let (evd, newevk) = Evd.new_evar evd ?name ?typeclass_candidate evi in @@ -447,7 +450,8 @@ let new_evar ?src ?filter ?abstract_arguments ?candidates ?naming ?typeclass_can match filter with | None -> instance | Some filter -> Filter.filter_list filter instance in - let (evd, evk) = new_pure_evar sign evd typ' ?src ?filter ?abstract_arguments ?candidates ?naming + let identity = if Int.equal (Environ.nb_rel env) 0 then Some instance else None in + let (evd, evk) = new_pure_evar sign evd typ' ?src ?filter ?identity ?abstract_arguments ?candidates ?naming ?typeclass_candidate ?principal in (evd, EConstr.mkEvar (evk, instance)) @@ -512,14 +516,7 @@ let restrict_evar evd evk filter ?src candidates = let candidates = Option.map (filter_effective_candidates evd evar_info filter) candidates in match candidates with | Some [] -> raise (ClearDependencyError (*FIXME*)(Id.of_string "blah", (NoCandidatesLeft evk), None)) - | _ -> - let evd, evk' = Evd.restrict evk filter ?candidates ?src evd in - (* Mark new evar as future goal, removing previous one, - circumventing Proofview.advance but making Proof.run_tactic catch these. *) - let future_goals = Evd.save_future_goals evd in - let future_goals = Evd.filter_future_goals (fun evk' -> not (Evar.equal evk evk')) future_goals in - let evd = Evd.restore_future_goals evd future_goals in - (Evd.declare_future_goal evk' evd, evk') + | _ -> Evd.restrict evk filter ?candidates ?src evd let rec check_and_clear_in_constr env evdref err ids global c = (* returns a new constr where all the evars have been 'cleaned' @@ -701,10 +698,22 @@ let rec advance sigma evk = match evi.evar_body with | Evar_empty -> Some evk | Evar_defined v -> - match is_restricted_evar sigma evk with + match is_aliased_evar sigma evk with | Some evk -> advance sigma evk | None -> None +let reachable_from_evars sigma evars = + let aliased = Evd.get_aliased_evars sigma in + let rec search evk visited = + if Evar.Set.mem evk visited then visited + else + let visited = Evar.Set.add evk visited in + match Evar.Map.find evk aliased with + | evk' -> search evk' visited + | exception Not_found -> visited + in + Evar.Set.fold (fun evk visited -> search evk visited) evars Evar.Set.empty + (** The following functions return the set of undefined evars contained in the object, the defined evars being traversed. This is roughly a combination of the previous functions and diff --git a/engine/evarutil.mli b/engine/evarutil.mli index 41b58d38b0..6e1f67021f 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -21,7 +21,6 @@ open EConstr (** [new_meta] is a generator of unique meta variables *) val new_meta : unit -> metavariable -val mk_new_meta : unit -> constr (** {6 Creating a fresh evar given their type and context} *) @@ -40,8 +39,18 @@ val new_evar : ?principal:bool -> ?hypnaming:naming_mode -> env -> evar_map -> types -> evar_map * EConstr.t +(** Low-level interface to create an evar. + @param src User-facing source for the evar + @param filter See {!Evd.Filter}, must be the same length as [named_context_val] + @param identity See {!Evd.Identity}, must be the name projection of [named_context_val] + @param naming A naming scheme for the evar + @param principal Whether the evar is the principal goal + @param named_context_val The context of the evar + @param types The type of conclusion of the evar +*) val new_pure_evar : ?src:Evar_kinds.t Loc.located -> ?filter:Filter.t -> + ?identity:EConstr.t list -> ?abstract_arguments:Abstraction.t -> ?candidates:constr list -> ?naming:intro_pattern_naming_expr -> ?typeclass_candidate:bool -> @@ -103,6 +112,10 @@ val gather_dependent_evars : evar_map -> Evar.t list -> (Evar.Set.t option) Evar solved. *) val advance : evar_map -> Evar.t -> Evar.t option +(** [reachable_from_evars sigma seeds] computes the descendents of + evars in [seeds] by restriction or evar-evar unifications in [sigma]. *) +val reachable_from_evars : evar_map -> Evar.Set.t -> Evar.Set.t + (** The following functions return the set of undefined evars contained in the object, the defined evars being traversed. This is roughly a combination of the previous functions and @@ -225,8 +238,8 @@ exception ClearDependencyError of Id.t * clear_dependency_error * GlobRef.t opti (** Restrict an undefined evar according to a (sub)filter and candidates. The evar will be defined if there is only one candidate left, -@raise ClearDependencyError NoCandidatesLeft if the filter turns the candidates - into an empty list. *) + @raise ClearDependencyError NoCandidatesLeft if the filter turns the candidates + into an empty list. *) val restrict_evar : evar_map -> Evar.t -> Filter.t -> ?src:Evar_kinds.t Loc.located -> constr list option -> evar_map * Evar.t diff --git a/engine/evd.ml b/engine/evd.ml index c570f75c6b..4ae1d034d7 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -139,6 +139,29 @@ module Abstraction = struct let abstract_last l = Abstract :: l end +module Identity : +sig + type t + val make : econstr list -> t + val none : unit -> t + val repr : named_context_val -> Filter.t -> t -> econstr list + val is_identity : econstr list -> t -> bool +end = +struct + type t = econstr list option ref + let make s = ref (Some s) + let none () = ref None + let repr sign filter s = match !s with + | None -> + let ans = Filter.filter_list filter sign.env_named_var in + let () = s := Some ans in + ans + | Some s -> s + let is_identity l s = match !s with + | None -> false + | Some s -> s == l +end + (* The kinds of existential variables are now defined in [Evar_kinds] *) (* The type of mappings for existential variables *) @@ -158,7 +181,9 @@ type evar_info = { evar_filter : Filter.t; evar_abstract_arguments : Abstraction.t; evar_source : Evar_kinds.t Loc.located; - evar_candidates : constr list option; (* if not None, list of allowed instances *)} + evar_candidates : constr list option; (* if not None, list of allowed instances *) + evar_identity : Identity.t; +} let make_evar hyps ccl = { evar_concl = ccl; @@ -167,7 +192,9 @@ let make_evar hyps ccl = { evar_filter = Filter.identity; evar_abstract_arguments = Abstraction.identity; evar_source = Loc.tag @@ Evar_kinds.InternalHole; - evar_candidates = None; } + evar_candidates = None; + evar_identity = Identity.none (); +} let instance_mismatch () = anomaly (Pp.str "Signature and its instance do not match.") @@ -216,6 +243,9 @@ let evar_filtered_env env evi = match Filter.repr (evar_filter evi) with in make_env filter (evar_context evi) +let evar_identity_subst evi = + Identity.repr evi.evar_hyps evi.evar_filter evi.evar_identity + let map_evar_body f = function | Evar_empty -> Evar_empty | Evar_defined d -> Evar_defined (f d) @@ -256,7 +286,9 @@ let evar_instance_array test_id info args = instrec filter (evar_context info) args let make_evar_instance_array info args = - evar_instance_array (NamedDecl.get_id %> isVarId) info args + if Identity.is_identity args info.evar_identity then [] + else + evar_instance_array (NamedDecl.get_id %> isVarId) info args let instantiate_evar_array info c args = let inst = make_evar_instance_array info args in @@ -419,11 +451,9 @@ let key id (_, idtoev) = end -type goal_kind = ToShelve | ToGiveUp - type evar_flags = { obligation_evars : Evar.Set.t; - restricted_evars : Evar.t Evar.Map.t; + aliased_evars : Evar.t Evar.Map.t; typeclass_evars : Evar.Set.t } type side_effect_role = @@ -434,6 +464,124 @@ type side_effects = { seff_roles : side_effect_role Cmap.t; } +module FutureGoals : sig + + type t = private { + comb : Evar.t list; + principal : Evar.t option; (** if [Some e], [e] must be + contained in + [comb]. The evar + [e] will inherit + properties (now: the + name) of the evar which + will be instantiated with + a term containing [e]. *) + } + + val map_filter : (Evar.t -> Evar.t option) -> t -> t + (** Applies a function on the future goals *) + + val filter : (Evar.t -> bool) -> t -> t + (** Applies a filter on the future goals *) + + type stack + + val empty_stack : stack + + val push : stack -> stack + val pop : stack -> t * stack + + val add : principal:bool -> Evar.t -> stack -> stack + val remove : Evar.t -> stack -> stack + + val fold : ('a -> Evar.t -> 'a) -> 'a -> stack -> 'a + + val pr_stack : stack -> Pp.t + +end = struct + + type t = { + comb : Evar.t list; + principal : Evar.t option; (** if [Some e], [e] must be + contained in + [comb]. The evar + [e] will inherit + properties (now: the + name) of the evar which + will be instantiated with + a term containing [e]. *) + } + + type stack = t list + + let set f = function + | [] -> anomaly Pp.(str"future_goals stack should not be empty") + | hd :: tl -> + f hd :: tl + + let add ~principal evk stack = + let add fgl = + let comb = evk :: fgl.comb in + let principal = + if principal then + match fgl.principal with + | Some _ -> CErrors.user_err Pp.(str "Only one main subgoal per instantiation.") + | None -> Some evk + else fgl.principal + in + { comb; principal } + in + set add stack + + let remove e stack = + let remove fgl = + let filter e' = not (Evar.equal e e') in + let principal = Option.filter filter fgl.principal in + let comb = List.filter filter fgl.comb in + { principal; comb } + in + List.map remove stack + + let empty = { + principal = None; + comb = []; + } + + let empty_stack = [empty] + + let push stack = empty :: stack + + let pop stack = + match stack with + | [] -> anomaly Pp.(str"future_goals stack should not be empty") + | hd :: tl -> + hd, tl + + let fold f acc stack = + let future_goals = List.hd stack in + List.fold_left f acc future_goals.comb + + let filter f fgl = + let comb = List.filter f fgl.comb in + let principal = Option.filter f fgl.principal in + { comb; principal } + + let map_filter f fgl = + let comb = List.map_filter f fgl.comb in + let principal = Option.bind fgl.principal f in + { comb; principal } + + let pr_stack stack = + let open Pp in + let pr_future_goals fgl = + prlist_with_sep spc Evar.print fgl.comb ++ + pr_opt (fun ev -> str"(principal: " ++ Evar.print ev ++ str")") fgl.principal + in + if List.is_empty stack then str"(empty stack)" + else prlist_with_sep (fun () -> str"||") pr_future_goals stack + +end + type evar_map = { (* Existential variables *) defn_evars : evar_info EvMap.t; @@ -449,17 +597,10 @@ type evar_map = { evar_flags : evar_flags; (** Interactive proofs *) effects : side_effects; - future_goals : Evar.t list; (** list of newly created evars, to be - eventually turned into goals if not solved.*) - principal_future_goal : Evar.t option; (** if [Some e], [e] must be - contained - [future_goals]. The evar - [e] will inherit - properties (now: the - name) of the evar which - will be instantiated with - a term containing [e]. *) - future_goals_status : goal_kind EvMap.t; + future_goals : FutureGoals.stack; (** list of newly created evars, to be + eventually turned into goals if not solved.*) + given_up : Evar.Set.t; + shelf : Evar.t list list; extras : Store.t; } @@ -490,7 +631,7 @@ let add_with_name ?name ?(typeclass_candidate = true) d e i = match i.evar_body associated to an evar, so we prevent registering its typeclass status. *) let add d e i = add_with_name ~typeclass_candidate:false d e i -(*** Evar flags: typeclasses, restricted or obligation flag *) +(*** Evar flags: typeclasses, aliased or obligation flag *) let get_typeclass_evars evd = evd.evar_flags.typeclass_evars @@ -518,29 +659,28 @@ let is_obligation_evar evd evk = let inherit_evar_flags evar_flags evk evk' = let evk_typeclass = Evar.Set.mem evk evar_flags.typeclass_evars in let evk_obligation = Evar.Set.mem evk evar_flags.obligation_evars in - if not (evk_obligation || evk_typeclass) then evar_flags - else - let typeclass_evars = - if evk_typeclass then - let typeclass_evars = Evar.Set.remove evk evar_flags.typeclass_evars in - Evar.Set.add evk' typeclass_evars - else evar_flags.typeclass_evars - in - let obligation_evars = - if evk_obligation then - let obligation_evars = Evar.Set.remove evk evar_flags.obligation_evars in - Evar.Set.add evk' obligation_evars - else evar_flags.obligation_evars - in - { evar_flags with obligation_evars; typeclass_evars } + let aliased_evars = Evar.Map.add evk evk' evar_flags.aliased_evars in + let typeclass_evars = + if evk_typeclass then + let typeclass_evars = Evar.Set.remove evk evar_flags.typeclass_evars in + Evar.Set.add evk' typeclass_evars + else evar_flags.typeclass_evars + in + let obligation_evars = + if evk_obligation then + let obligation_evars = Evar.Set.remove evk evar_flags.obligation_evars in + Evar.Set.add evk' obligation_evars + else evar_flags.obligation_evars + in + { obligation_evars; aliased_evars; typeclass_evars } (** Removal: in all other cases of definition *) let remove_evar_flags evk evar_flags = { typeclass_evars = Evar.Set.remove evk evar_flags.typeclass_evars; obligation_evars = Evar.Set.remove evk evar_flags.obligation_evars; - (* Restriction information is kept. *) - restricted_evars = evar_flags.restricted_evars } + (* Aliasing information is kept. *) + aliased_evars = evar_flags.aliased_evars } (** New evars *) @@ -558,14 +698,9 @@ let new_evar evd ?name ?typeclass_candidate evi = let remove d e = let undf_evars = EvMap.remove e d.undf_evars in let defn_evars = EvMap.remove e d.defn_evars in - let principal_future_goal = match d.principal_future_goal with - | None -> None - | Some e' -> if Evar.equal e e' then None else d.principal_future_goal - in - let future_goals = List.filter (fun e' -> not (Evar.equal e e')) d.future_goals in - let future_goals_status = EvMap.remove e d.future_goals_status in + let future_goals = FutureGoals.remove e d.future_goals in let evar_flags = remove_evar_flags e d.evar_flags in - { d with undf_evars; defn_evars; principal_future_goal; future_goals; future_goals_status; + { d with undf_evars; defn_evars; future_goals; evar_flags } let find d e = @@ -673,7 +808,7 @@ let create_evar_defs sigma = { sigma with let empty_evar_flags = { obligation_evars = Evar.Set.empty; - restricted_evars = Evar.Map.empty; + aliased_evars = Evar.Map.empty; typeclass_evars = Evar.Set.empty } let empty_side_effects = { @@ -691,9 +826,9 @@ let empty = { metas = Metamap.empty; effects = empty_side_effects; evar_names = EvNames.empty; (* id<->key for undefined evars *) - future_goals = []; - principal_future_goal = None; - future_goals_status = EvMap.empty; + future_goals = FutureGoals.empty_stack; + given_up = Evar.Set.empty; + shelf = [[]]; extras = Store.empty; } @@ -703,6 +838,10 @@ let from_ctx ctx = { empty with universes = ctx } let has_undefined evd = not (EvMap.is_empty evd.undf_evars) +let has_given_up evd = not (Evar.Set.is_empty evd.given_up) + +let has_shelved evd = not (List.for_all List.is_empty evd.shelf) + let evars_reset_evd ?(with_conv_pbs=false) ?(with_univs=true) evd d = let conv_pbs = if with_conv_pbs then evd.conv_pbs else d.conv_pbs in let last_mods = if with_conv_pbs then evd.last_mods else d.last_mods in @@ -732,70 +871,12 @@ let evar_source evk d = (find d evk).evar_source let evar_ident evk evd = EvNames.ident evk evd.evar_names let evar_key id evd = EvNames.key id evd.evar_names -let define_aux def undef evk body = - let oldinfo = - try EvMap.find evk undef - with Not_found -> - if EvMap.mem evk def then - anomaly ~label:"Evd.define" (Pp.str "cannot define an evar twice.") - else - anomaly ~label:"Evd.define" (Pp.str "cannot define undeclared evar.") - in - let () = assert (oldinfo.evar_body == Evar_empty) in - let newinfo = { oldinfo with evar_body = Evar_defined body } in - EvMap.add evk newinfo def, EvMap.remove evk undef - -(* define the existential of section path sp as the constr body *) -let define_gen evk body evd evar_flags = - let (defn_evars, undf_evars) = define_aux evd.defn_evars evd.undf_evars evk body in - let last_mods = match evd.conv_pbs with - | [] -> evd.last_mods - | _ -> Evar.Set.add evk evd.last_mods - in - let evar_names = EvNames.remove_name_defined evk evd.evar_names in - { evd with defn_evars; undf_evars; last_mods; evar_names; evar_flags } +let get_aliased_evars evd = evd.evar_flags.aliased_evars -(** By default, the obligation and evar tag of the evar is removed *) -let define evk body evd = - let evar_flags = remove_evar_flags evk evd.evar_flags in - define_gen evk body evd evar_flags - -(** In case of an evar-evar solution, the flags are inherited *) -let define_with_evar evk body evd = - let evk' = fst (destEvar body) in - let evar_flags = inherit_evar_flags evd.evar_flags evk evk' in - define_gen evk body evd evar_flags - -let is_restricted_evar evd evk = - try Some (Evar.Map.find evk evd.evar_flags.restricted_evars) +let is_aliased_evar evd evk = + try Some (Evar.Map.find evk evd.evar_flags.aliased_evars) with Not_found -> None -let declare_restricted_evar evar_flags evk evk' = - { evar_flags with restricted_evars = Evar.Map.add evk evk' evar_flags.restricted_evars } - -(* In case of restriction, we declare the restriction and inherit the obligation - and typeclass flags. *) - -let restrict evk filter ?candidates ?src evd = - let evk' = new_untyped_evar () in - let evar_info = EvMap.find evk evd.undf_evars in - let evar_info' = - { evar_info with evar_filter = filter; - evar_candidates = candidates; - evar_source = (match src with None -> evar_info.evar_source | Some src -> src) } in - let last_mods = match evd.conv_pbs with - | [] -> evd.last_mods - | _ -> Evar.Set.add evk evd.last_mods in - let evar_names = EvNames.reassign_name_defined evk evk' evd.evar_names in - let ctxt = Filter.filter_list filter (evar_context evar_info) in - let id_inst = List.map (NamedDecl.get_id %> mkVar) ctxt in - let body = mkEvar(evk',id_inst) in - let (defn_evars, undf_evars) = define_aux evd.defn_evars evd.undf_evars evk body in - let evar_flags = declare_restricted_evar evd.evar_flags evk evk' in - let evar_flags = inherit_evar_flags evar_flags evk evk' in - { evd with undf_evars = EvMap.add evk' evar_info' undf_evars; - defn_evars; last_mods; evar_names; evar_flags }, evk' - let downcast evk ccl evd = let evar_info = EvMap.find evk evd.undf_evars in let evar_info' = { evar_info with evar_concl = ccl } in @@ -987,11 +1068,6 @@ let check_constraints evd csts = let fix_undefined_variables evd = { evd with universes = UState.fix_undefined_variables evd.universes } -let refresh_undefined_universes evd = - let uctx', subst = UState.refresh_undefined_univ_variables evd.universes in - let evd' = cmap (subst_univs_level_constr subst) {evd with universes = uctx'} in - evd', subst - let nf_univ_variables evd = let subst, uctx' = UState.normalize_variables evd.universes in let evd' = {evd with universes = uctx'} in @@ -1008,8 +1084,8 @@ let universe_binders evd = UState.universe_binders evd.universes let universes evd = UState.ugraph evd.universes -let update_sigma_env evd env = - { evd with universes = UState.update_sigma_env evd.universes env } +let update_sigma_univs ugraph evd = + { evd with universes = UState.update_sigma_univs evd.universes ugraph } exception UniversesDiffer = UState.UniversesDiffer @@ -1031,72 +1107,129 @@ let drop_side_effects evd = let eval_side_effects evd = evd.effects (* Future goals *) -let declare_future_goal ?tag evk evd = - { evd with future_goals = evk::evd.future_goals; - future_goals_status = Option.fold_right (EvMap.add evk) tag evd.future_goals_status } - -let declare_principal_goal ?tag evk evd = - match evd.principal_future_goal with - | None -> { evd with - future_goals = evk::evd.future_goals; - principal_future_goal=Some evk; - future_goals_status = Option.fold_right (EvMap.add evk) tag evd.future_goals_status; - } - | Some _ -> CErrors.user_err Pp.(str "Only one main subgoal per instantiation.") - -type future_goals = Evar.t list * Evar.t option * goal_kind EvMap.t - -let future_goals evd = evd.future_goals - -let principal_future_goal evd = evd.principal_future_goal - -let save_future_goals evd = - (evd.future_goals, evd.principal_future_goal, evd.future_goals_status) - -let reset_future_goals evd = - { evd with future_goals = [] ; principal_future_goal = None; - future_goals_status = EvMap.empty } - -let restore_future_goals evd (gls,pgl,map) = - { evd with future_goals = gls ; principal_future_goal = pgl; - future_goals_status = map } - -let fold_future_goals f sigma (gls,pgl,map) = - List.fold_left f sigma gls - -let map_filter_future_goals f (gls,pgl,map) = - (* Note: map is now a superset of filtered evs, but its size should - not be too big, so that's probably ok not to update it *) - (List.map_filter f gls,Option.bind pgl f,map) - -let filter_future_goals f (gls,pgl,map) = - (List.filter f gls,Option.bind pgl (fun a -> if f a then Some a else None),map) - -let dispatch_future_goals_gen distinguish_shelf (gls,pgl,map) = - let rec aux (comb,shelf,givenup as acc) = function - | [] -> acc - | evk :: gls -> - let acc = - try match EvMap.find evk map with - | ToGiveUp -> (comb,shelf,evk::givenup) - | ToShelve -> - if distinguish_shelf then (comb,evk::shelf,givenup) - else raise Not_found - with Not_found -> (evk::comb,shelf,givenup) in - aux acc gls in - (* Note: this reverses the order of initial list on purpose *) - let (comb,shelf,givenup) = aux ([],[],[]) gls in - (comb,shelf,givenup,pgl) - -let dispatch_future_goals = - dispatch_future_goals_gen true - -let extract_given_up_future_goals goals = - let (comb,_,givenup,_) = dispatch_future_goals_gen false goals in - (comb,givenup) - -let shelve_on_future_goals shelved (gls,pgl,map) = - (shelved @ gls, pgl, List.fold_right (fun evk -> EvMap.add evk ToShelve) shelved map) +let declare_future_goal evk evd = + let future_goals = FutureGoals.add ~principal:false evk evd.future_goals in + { evd with future_goals } + +let declare_principal_goal evk evd = + let future_goals = FutureGoals.add ~principal:true evk evd.future_goals in + { evd with future_goals } + +let push_future_goals evd = + { evd with future_goals = FutureGoals.push evd.future_goals } + +let pop_future_goals evd = + let hd, future_goals = FutureGoals.pop evd.future_goals in + hd, { evd with future_goals } + +let fold_future_goals f sigma = + FutureGoals.fold f sigma sigma.future_goals + +let remove_future_goal evd evk = + { evd with future_goals = FutureGoals.remove evk evd.future_goals } + +let pr_future_goals_stack evd = + FutureGoals.pr_stack evd.future_goals + +let give_up ev evd = + { evd with given_up = Evar.Set.add ev evd.given_up } + +let push_shelf evd = + { evd with shelf = [] :: evd.shelf } + +let pop_shelf evd = + match evd.shelf with + | [] -> anomaly Pp.(str"shelf stack should not be empty") + | hd :: tl -> + hd, { evd with shelf = tl } + +let filter_shelf f evd = + { evd with shelf = List.map (List.filter f) evd.shelf } + +let shelve evd l = + match evd.shelf with + | [] -> anomaly Pp.(str"shelf stack should not be empty") + | hd :: tl -> + { evd with shelf = (hd@l) :: tl } + +let unshelve evd l = + { evd with shelf = List.map (List.filter (fun ev -> not (CList.mem_f Evar.equal ev l))) evd.shelf } + +let given_up evd = evd.given_up + +let shelf evd = List.flatten evd.shelf + +let pr_shelf evd = + let open Pp in + if List.is_empty evd.shelf then str"(empty stack)" + else prlist_with_sep (fun () -> str"||") (prlist_with_sep spc Evar.print) evd.shelf + +let define_aux def undef evk body = + let oldinfo = + try EvMap.find evk undef + with Not_found -> + if EvMap.mem evk def then + anomaly ~label:"Evd.define" (Pp.str "cannot define an evar twice.") + else + anomaly ~label:"Evd.define" (Pp.str "cannot define undeclared evar.") + in + let () = assert (oldinfo.evar_body == Evar_empty) in + let newinfo = { oldinfo with evar_body = Evar_defined body } in + EvMap.add evk newinfo def, EvMap.remove evk undef + +(* define the existential of section path sp as the constr body *) +let define_gen evk body evd evar_flags = + let (defn_evars, undf_evars) = define_aux evd.defn_evars evd.undf_evars evk body in + let last_mods = match evd.conv_pbs with + | [] -> evd.last_mods + | _ -> Evar.Set.add evk evd.last_mods + in + let evar_names = EvNames.remove_name_defined evk evd.evar_names in + { evd with defn_evars; undf_evars; last_mods; evar_names; evar_flags } + +(** By default, the obligation and evar tag of the evar is removed *) +let define evk body evd = + let evar_flags = remove_evar_flags evk evd.evar_flags in + define_gen evk body evd evar_flags + +(** In case of an evar-evar solution, the flags are inherited *) +let define_with_evar evk body evd = + let evk' = fst (destEvar body) in + let evar_flags = inherit_evar_flags evd.evar_flags evk evk' in + let evd = unshelve evd [evk] in + let future_goals = FutureGoals.remove evk evd.future_goals in + let evd = { evd with future_goals } in + define_gen evk body evd evar_flags + +(* In case of restriction, we declare the aliasing and inherit the obligation + and typeclass flags. *) + +let restrict evk filter ?candidates ?src evd = + let evk' = new_untyped_evar () in + let evar_info = EvMap.find evk evd.undf_evars in + let id_inst = Filter.filter_list filter evar_info.evar_hyps.env_named_var in + let evar_info' = + { evar_info with evar_filter = filter; + evar_candidates = candidates; + evar_source = (match src with None -> evar_info.evar_source | Some src -> src); + evar_identity = Identity.make id_inst; + } in + let last_mods = match evd.conv_pbs with + | [] -> evd.last_mods + | _ -> Evar.Set.add evk evd.last_mods in + let evar_names = EvNames.reassign_name_defined evk evk' evd.evar_names in + let body = mkEvar(evk',id_inst) in + let (defn_evars, undf_evars) = define_aux evd.defn_evars evd.undf_evars evk body in + let evar_flags = inherit_evar_flags evd.evar_flags evk evk' in + let evd = { evd with undf_evars = EvMap.add evk' evar_info' undf_evars; + defn_evars; last_mods; evar_names; evar_flags } + in + (* Mark new evar as future goal, removing previous one, + circumventing Proofview.advance but making Proof.run_tactic catch these. *) + let evd = unshelve evd [evk] in + let evd = remove_future_goal evd evk in + let evd = declare_future_goal evk' evd in + (evd, evk') (**********************************************************) (* Accessing metas *) @@ -1114,8 +1247,8 @@ let set_metas evd metas = { effects = evd.effects; evar_names = evd.evar_names; future_goals = evd.future_goals; - future_goals_status = evd.future_goals_status; - principal_future_goal = evd.principal_future_goal; + given_up = evd.given_up; + shelf = evd.shelf; extras = evd.extras; } diff --git a/engine/evd.mli b/engine/evd.mli index 679173ca72..fafaad9a04 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -89,6 +89,15 @@ module Abstraction : sig val abstract_last : t -> t end +module Identity : +sig + type t + (** Identity substitutions *) + + val make : econstr list -> t + val none : unit -> t +end + (** {6 Evar infos} *) type evar_body = @@ -114,6 +123,9 @@ type evar_info = { (** Information about the evar. *) evar_candidates : econstr list option; (** List of possible solutions when known that it is a finite list *) + evar_identity : Identity.t; + (** Default evar instance, i.e. a list of Var nodes projected from the + filtered environment. *) } val make_evar : named_context_val -> etypes -> evar_info @@ -127,6 +139,7 @@ val evar_candidates : evar_info -> constr list option val evar_filter : evar_info -> Filter.t val evar_env : env -> evar_info -> env val evar_filtered_env : env -> evar_info -> env +val evar_identity_subst : evar_info -> econstr list val map_evar_body : (econstr -> econstr) -> evar_body -> evar_body val map_evar_info : (econstr -> econstr) -> evar_info -> evar_info @@ -154,6 +167,14 @@ val has_undefined : evar_map -> bool (** [has_undefined sigma] is [true] if and only if there are uninstantiated evars in [sigma]. *) +val has_given_up : evar_map -> bool +(** [has_given_up sigma] is [true] if and only if + there are given up evars in [sigma]. *) + +val has_shelved : evar_map -> bool +(** [has_shelved sigma] is [true] if and only if + there are shelved evars in [sigma]. *) + val new_evar : evar_map -> ?name:Id.t -> ?typeclass_candidate:bool -> evar_info -> evar_map * Evar.t (** Creates a fresh evar mapping to the given information. *) @@ -263,8 +284,11 @@ val restrict : Evar.t-> Filter.t -> ?candidates:econstr list -> possibly limiting the instances to a set of candidates (candidates are filtered according to the filter) *) -val is_restricted_evar : evar_map -> Evar.t -> Evar.t option -(** Tell if an evar comes from restriction of another evar, and if yes, which *) +val get_aliased_evars : evar_map -> Evar.t Evar.Map.t +(** The map of aliased evars *) + +val is_aliased_evar : evar_map -> Evar.t -> Evar.t option +(** Tell if an evar has been aliased to another evar, and if yes, which *) val set_typeclass_evars : evar_map -> Evar.Set.t -> evar_map (** Mark the given set of evars as available for resolution. @@ -330,59 +354,64 @@ val drop_side_effects : evar_map -> evar_map (** {5 Future goals} *) -type goal_kind = ToShelve | ToGiveUp - -val declare_future_goal : ?tag:goal_kind -> Evar.t -> evar_map -> evar_map +val declare_future_goal : Evar.t -> evar_map -> evar_map (** Adds an existential variable to the list of future goals. For internal uses only. *) -val declare_principal_goal : ?tag:goal_kind -> Evar.t -> evar_map -> evar_map +val declare_principal_goal : Evar.t -> evar_map -> evar_map (** Adds an existential variable to the list of future goals and make it principal. Only one existential variable can be made principal, an error is raised otherwise. For internal uses only. *) -val future_goals : evar_map -> Evar.t list -(** Retrieves the list of future goals. Used by the [refine] primitive - of the tactic engine. *) +module FutureGoals : sig -val principal_future_goal : evar_map -> Evar.t option -(** Retrieves the name of the principal existential variable if there - is one. Used by the [refine] primitive of the tactic engine. *) + type t = private { + comb : Evar.t list; + principal : Evar.t option; (** if [Some e], [e] must be + contained in + [future_comb]. The evar + [e] will inherit + properties (now: the + name) of the evar which + will be instantiated with + a term containing [e]. *) + } -type future_goals + val map_filter : (Evar.t -> Evar.t option) -> t -> t + (** Applies a function on the future goals *) -val save_future_goals : evar_map -> future_goals -(** Retrieves the list of future goals including the principal future - goal. Used by the [refine] primitive of the tactic engine. *) + val filter : (Evar.t -> bool) -> t -> t + (** Applies a filter on the future goals *) -val reset_future_goals : evar_map -> evar_map -(** Clears the list of future goals (as well as the principal future - goal). Used by the [refine] primitive of the tactic engine. *) +end + +val push_future_goals : evar_map -> evar_map + +val pop_future_goals : evar_map -> FutureGoals.t * evar_map + +val fold_future_goals : (evar_map -> Evar.t -> evar_map) -> evar_map -> evar_map + +val remove_future_goal : evar_map -> Evar.t -> evar_map -val restore_future_goals : evar_map -> future_goals -> evar_map -(** Sets the future goals (including the principal future goal) to a - previous value. Intended to be used after a local list of future - goals has been consumed. Used by the [refine] primitive of the - tactic engine. *) +val pr_future_goals_stack : evar_map -> Pp.t -val fold_future_goals : (evar_map -> Evar.t -> evar_map) -> evar_map -> future_goals -> evar_map -(** Fold future goals *) +val push_shelf : evar_map -> evar_map -val map_filter_future_goals : (Evar.t -> Evar.t option) -> future_goals -> future_goals -(** Applies a function on the future goals *) +val pop_shelf : evar_map -> Evar.t list * evar_map -val filter_future_goals : (Evar.t -> bool) -> future_goals -> future_goals -(** Applies a filter on the future goals *) +val filter_shelf : (Evar.t -> bool) -> evar_map -> evar_map -val dispatch_future_goals : future_goals -> Evar.t list * Evar.t list * Evar.t list * Evar.t option -(** Returns the future_goals dispatched into regular, shelved, given_up - goals; last argument is the goal tagged as principal if any *) +val give_up : Evar.t -> evar_map -> evar_map -val extract_given_up_future_goals : future_goals -> Evar.t list * Evar.t list -(** An ad hoc variant for Proof.proof; not for general use *) +val shelve : evar_map -> Evar.t list -> evar_map -val shelve_on_future_goals : Evar.t list -> future_goals -> future_goals -(** Push goals on the shelve of future goals *) +val unshelve : evar_map -> Evar.t list -> evar_map + +val given_up : evar_map -> Evar.Set.t + +val shelf : evar_map -> Evar.t list + +val pr_shelf : evar_map -> Pp.t (** {5 Sort variables} @@ -643,12 +672,11 @@ val nf_univ_variables : evar_map -> evar_map * Univ.universe_subst val fix_undefined_variables : evar_map -> evar_map -val refresh_undefined_universes : evar_map -> evar_map * Univ.universe_level_subst - (** Universe minimization *) val minimize_universes : evar_map -> evar_map -val update_sigma_env : evar_map -> env -> evar_map +(** Lift [UState.update_sigma_univs] *) +val update_sigma_univs : UGraph.t -> evar_map -> evar_map (** Polymorphic universes *) diff --git a/engine/namegen.ml b/engine/namegen.ml index fb9f6db0ea..f398f29f41 100644 --- a/engine/namegen.ml +++ b/engine/namegen.ml @@ -273,8 +273,8 @@ let visible_ids sigma (nenv, c) = accu := (gseen, vseen, ids) | Rel p -> let (gseen, vseen, ids) = !accu in - if p > n && not (Int.Set.mem p vseen) then - let vseen = Int.Set.add p vseen in + if p > n && not (Int.Set.mem (p - n) vseen) then + let vseen = Int.Set.add (p - n) vseen in let name = try Some (List.nth nenv (p - n - 1)) with Invalid_argument _ | Failure _ -> @@ -290,7 +290,7 @@ let visible_ids sigma (nenv, c) = accu := (gseen, vseen, ids) | _ -> EConstr.iter_with_binders sigma succ visible_ids n c in - let () = visible_ids 1 c in + let () = visible_ids 1 c in (* n = 1 to count the binder to rename *) let (_, _, ids) = !accu in ids @@ -416,6 +416,8 @@ let next_name_away_for_default_printing sigma env_t na avoid = *) type renaming_flags = + (* The term is the body of a binder and the environment excludes this binder *) + (* so, there is a missing binder in the environment *) | RenamingForCasesPattern of (Name.t list * constr) | RenamingForGoal | RenamingElsewhereFor of (Name.t list * constr) diff --git a/engine/proofview.ml b/engine/proofview.ml index de38104ecd..978088872c 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -60,23 +60,28 @@ type telescope = | TNil of Evd.evar_map | TCons of Environ.env * Evd.evar_map * EConstr.types * (Evd.evar_map -> EConstr.constr -> telescope) +let map_telescope_evd f = function + | TNil sigma -> TNil (f sigma) + | TCons (env,sigma,ty,g) -> TCons(env,(f sigma),ty,g) + let dependent_init = (* Goals don't have a source location. *) let src = Loc.tag @@ Evar_kinds.GoalEvar in (* Main routine *) let rec aux = function - | TNil sigma -> [], { solution = sigma; comb = []; shelf = [] } + | TNil sigma -> [], { solution = sigma; comb = [] } | TCons (env, sigma, typ, t) -> let (sigma, econstr) = Evarutil.new_evar env sigma ~src ~typeclass_candidate:false typ in let (gl, _) = EConstr.destEvar sigma econstr in let ret, { solution = sol; comb = comb } = aux (t sigma econstr) in let entry = (econstr, typ) :: ret in - entry, { solution = sol; comb = with_empty_state gl :: comb; shelf = [] } + entry, { solution = sol; comb = with_empty_state gl :: comb } in fun t -> + let t = map_telescope_evd Evd.push_future_goals t in let entry, v = aux t in (* The created goal are not to be shelved. *) - let solution = Evd.reset_future_goals v.solution in + let _goals, solution = Evd.pop_future_goals v.solution in entry, { v with solution } let init = @@ -230,9 +235,6 @@ let apply ~name ~poly env t sp = match ans with | Nil (e, info) -> Exninfo.iraise (TacticFailure e, info) | Cons ((r, (state, _), status, info), _) -> - let (status, gaveup) = status in - let status = (status, state.shelf, gaveup) in - let state = { state with shelf = [] } in r, state, status, Trace.to_tree info @@ -617,7 +619,8 @@ let shelve = Comb.get >>= fun initial -> Comb.set [] >> InfoL.leaf (Info.Tactic (fun _ _ -> Pp.str"shelve")) >> - Shelf.modify (fun gls -> gls @ CList.map drop_state initial) + let initial = CList.map drop_state initial in + Pv.modify (fun pv -> { pv with solution = Evd.shelve pv.solution initial }) let shelve_goals l = let open Proof in @@ -625,7 +628,7 @@ let shelve_goals l = let comb = CList.filter (fun g -> not (CList.mem (drop_state g) l)) initial in Comb.set comb >> InfoL.leaf (Info.Tactic (fun _ _ -> Pp.str"shelve_goals")) >> - Shelf.modify (fun gls -> gls @ l) + Pv.modify (fun pv -> { pv with solution = Evd.shelve pv.solution l }) (** [depends_on sigma src tgt] checks whether the goal [src] appears as an existential variable in the definition of the goal [tgt] in @@ -692,7 +695,7 @@ let shelve_unifiable_informative = Comb.set n >> InfoL.leaf (Info.Tactic (fun _ _ -> Pp.str"shelve_unifiable")) >> let u = CList.map drop_state u in - Shelf.modify (fun gls -> gls @ u) >> + Pv.modify (fun pv -> { pv with solution = Evd.shelve pv.solution u }) >> tclUNIT u let shelve_unifiable = @@ -712,13 +715,17 @@ let guard_no_unifiable = let l = CList.map (fun id -> Names.Name id) l in tclUNIT (Some l) -(** [unshelve l p] adds all the goals in [l] at the end of the focused - goals of p *) +(** [unshelve l p] moves all the goals in [l] from the shelf and put them at + the end of the focused goals of p, if they are still undefined after [advance] *) let unshelve l p = + let solution = Evd.unshelve p.solution l in let l = List.map with_empty_state l in (* advance the goals in case of clear *) let l = undefined p.solution l in - { p with comb = p.comb@l } + { comb = p.comb@l; solution } + +let filter_shelf f pv = + { pv with solution = Evd.filter_shelf f pv.solution } let mark_in_evm ~goal evd evars = let evd = @@ -746,20 +753,20 @@ let mark_in_evm ~goal evd evars = let with_shelf tac = let open Proof in Pv.get >>= fun pv -> - let { shelf; solution } = pv in - Pv.set { pv with shelf = []; solution = Evd.reset_future_goals solution } >> + let { solution } = pv in + Pv.set { pv with solution = Evd.push_shelf @@ Evd.push_future_goals solution } >> tac >>= fun ans -> Pv.get >>= fun npv -> - let { shelf = gls; solution = sigma } = npv in + let { solution = sigma } = npv in + let gls, sigma = Evd.pop_shelf sigma in (* The pending future goals are necessarily coming from V82.tactic *) (* and thus considered as to shelve, as in Proof.run_tactic *) - let gls' = Evd.future_goals sigma in - let fgoals = Evd.save_future_goals solution in - let sigma = Evd.restore_future_goals sigma fgoals in + let fgl, sigma = Evd.pop_future_goals sigma in (* Ensure we mark and return only unsolved goals *) - let gls' = undefined_evars sigma (CList.rev_append gls' gls) in + let gls' = CList.rev_append fgl.Evd.FutureGoals.comb gls in + let gls' = undefined_evars sigma gls' in let sigma = mark_in_evm ~goal:false sigma gls' in - let npv = { npv with shelf; solution = sigma } in + let npv = { npv with solution = sigma } in Pv.set npv >> tclUNIT (gls', ans) (** [goodmod p m] computes the representative of [p] modulo [m] in the @@ -833,14 +840,18 @@ let mark_as_unsafe = Status.put false (** Gives up on the goal under focus. Reports an unsafe status. Proofs with given up goals cannot be closed. *) + +let give_up evs pv = + let solution = List.fold_left (fun sigma ev -> Evd.give_up (drop_state ev) sigma) pv.solution evs in + { pv with solution } + let give_up = let open Proof in Comb.get >>= fun initial -> Comb.set [] >> mark_as_unsafe >> InfoL.leaf (Info.Tactic (fun _ _ -> Pp.str"give_up")) >> - Giveup.put (CList.map drop_state initial) - + Pv.modify (give_up initial) (** {7 Control primitives} *) @@ -986,6 +997,8 @@ let tclProofInfo = module Unsafe = struct + let (>>=) = tclBIND + let tclEVARS evd = Pv.modify (fun ps -> { ps with solution = evd }) @@ -995,29 +1008,28 @@ module Unsafe = struct { step with comb = step.comb @ gls } end + let tclNEWSHELVED gls = + Pv.modify begin fun step -> + let gls = undefined_evars step.solution gls in + { step with solution = Evd.shelve step.solution gls } + end + + let tclGETSHELF = tclEVARMAP >>= fun sigma -> tclUNIT @@ Evd.shelf sigma + let tclSETENV = Env.set let tclGETGOALS = Comb.get let tclSETGOALS = Comb.set - let tclGETSHELF = Shelf.get - - let tclSETSHELF = Shelf.set - - let tclPUTSHELF to_shelve = - tclBIND tclGETSHELF (fun shelf -> tclSETSHELF (to_shelve@shelf)) - - let tclPUTGIVENUP = Giveup.put - let tclEVARSADVANCE evd = - Pv.modify (fun ps -> { ps with solution = evd; comb = undefined evd ps.comb }) + Pv.modify (fun ps -> { solution = evd; comb = undefined evd ps.comb }) let tclEVARUNIVCONTEXT ctx = Pv.modify (fun ps -> { ps with solution = Evd.set_universe_context ps.solution ctx }) - let reset_future_goals p = - { p with solution = Evd.reset_future_goals p.solution } + let push_future_goals p = + { p with solution = Evd.push_future_goals p.solution } let mark_as_goals evd content = mark_in_evm ~goal:true evd content @@ -1032,6 +1044,9 @@ module Unsafe = struct let mark_as_unresolvables p evs = { p with solution = mark_in_evm ~goal:false p.solution evs } + let update_sigma_univs ugraph pv = + { pv with solution = Evd.update_sigma_univs ugraph pv.solution } + end module UnsafeRepr = Proof.Unsafe @@ -1218,7 +1233,7 @@ module V82 = struct let sgs = CList.flatten goalss in let sgs = undefined evd sgs in InfoL.leaf (Info.Tactic (fun _ _ -> Pp.str"<unknown>")) >> - Pv.set { ps with solution = evd; comb = sgs; } + Pv.set { solution = evd; comb = sgs; } with e when catchable_exception e -> let (e, info) = Exninfo.capture e in tclZERO ~info e @@ -1258,7 +1273,7 @@ module V82 = struct let of_tactic t gls = try let env = Global.env () in - let init = { shelf = []; solution = gls.Evd.sigma ; comb = [with_empty_state gls.Evd.it] } in + let init = { solution = gls.Evd.sigma ; comb = [with_empty_state gls.Evd.it] } in let name, poly = Names.Id.of_string "legacy_pe", false in let (_,final,_,_) = apply ~name ~poly (goal_env env gls.Evd.sigma gls.Evd.it) t init in { Evd.sigma = final.solution ; it = CList.map drop_state final.comb } diff --git a/engine/proofview.mli b/engine/proofview.mli index d0a2b37a69..816b45984b 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -162,7 +162,7 @@ val apply -> 'a tactic -> proofview -> 'a * proofview - * (bool*Evar.t list*Evar.t list) + * bool * Proofview_monad.Info.tree (** {7 Monadic primitives} *) @@ -331,17 +331,16 @@ val unifiable : Evd.evar_map -> Evar.t -> Evar.t list -> bool considered). *) val shelve_unifiable : unit tactic -(** Idem but also returns the list of shelved variables *) -val shelve_unifiable_informative : Evar.t list tactic - (** [guard_no_unifiable] returns the list of unifiable goals if some goals are unifiable (see {!shelve_unifiable}) in the current focus. *) val guard_no_unifiable : Names.Name.t list option tactic -(** [unshelve l p] adds all the goals in [l] at the end of the focused - goals of p *) +(** [unshelve l p] moves all the goals in [l] from the shelf and put them at + the end of the focused goals of p, if they are still undefined after [advance] *) val unshelve : Evar.t list -> proofview -> proofview +val filter_shelf : (Evar.t -> bool) -> proofview -> proofview + (** [depends_on g1 g2 sigma] checks if g1 occurs in the type/ctx of g2 *) val depends_on : Evd.evar_map -> Evar.t -> Evar.t -> bool @@ -454,6 +453,10 @@ module Unsafe : sig goal is already solved, it is not added. *) val tclNEWGOALS : Proofview_monad.goal_with_state list -> unit tactic + (** [tclNEWSHELVED gls] adds the goals [gls] to the shelf. If a + goal is already solved, it is not added. *) + val tclNEWSHELVED : Evar.t list -> unit tactic + (** [tclSETGOALS gls] sets goals [gls] as the goals being under focus. If a goal is already solved, it is not set. *) val tclSETGOALS : Proofview_monad.goal_with_state list -> unit tactic @@ -461,23 +464,14 @@ module Unsafe : sig (** [tclGETGOALS] returns the list of goals under focus. *) val tclGETGOALS : Proofview_monad.goal_with_state list tactic - (** [tclSETSHELF gls] sets goals [gls] as the current shelf. *) - val tclSETSHELF : Evar.t list -> unit tactic - (** [tclGETSHELF] returns the list of goals on the shelf. *) val tclGETSHELF : Evar.t list tactic - (** [tclPUTSHELF] appends goals to the shelf. *) - val tclPUTSHELF : Evar.t list -> unit tactic - - (** [tclPUTGIVENUP] add an given up goal. *) - val tclPUTGIVENUP : Evar.t list -> unit tactic - (** Sets the evar universe context. *) val tclEVARUNIVCONTEXT : UState.t -> unit tactic (** Clears the future goals store in the proof view. *) - val reset_future_goals : proofview -> proofview + val push_future_goals : proofview -> proofview (** Give the evars the status of a goal (changes their source location and makes them unresolvable for type classes. *) @@ -503,6 +497,9 @@ module Unsafe : sig val undefined : Evd.evar_map -> Proofview_monad.goal_with_state list -> Proofview_monad.goal_with_state list + (** [update_sigma_univs] lifts [UState.update_sigma_univs] to the proofview *) + val update_sigma_univs : UGraph.t -> proofview -> proofview + end (** This module gives access to the innards of the monad. Its use is diff --git a/engine/proofview_monad.ml b/engine/proofview_monad.ml index 2f53d5bc73..80263694f5 100644 --- a/engine/proofview_monad.ml +++ b/engine/proofview_monad.ml @@ -166,7 +166,6 @@ let map_goal_with_state f (g, s) = (f g, s) type proofview = { solution : Evd.evar_map; comb : goal_with_state list; - shelf : goal list; } (** {6 Instantiation of the logic monad} *) @@ -180,10 +179,10 @@ module P = struct type e = { trace: bool; name : Names.Id.t; poly : bool } (** Status (safe/unsafe) * shelved goals * given up *) - type w = bool * goal list + type w = bool - let wunit = true , [] - let wprod (b1, g1) (b2, g2) = b1 && b2 , g1@g2 + let wunit = true + let wprod b1 b2 = b1 && b2 type u = Info.state @@ -203,6 +202,11 @@ module type State = sig val modify : (t->t) -> unit Logical.t end +module type Reader = sig + type t + val get : t Logical.t +end + module type Writer = sig type t val put : t -> unit Logical.t @@ -235,21 +239,7 @@ module Env : State with type t := Environ.env = struct end module Status : Writer with type t := bool = struct - let put s = Logical.put (s, []) -end - -module Shelf : State with type t = goal list = struct - (* spiwack: I don't know why I cannot substitute ([:=]) [t] with a type expression. *) - type t = goal list - let get = Logical.map (fun {shelf} -> shelf) Pv.get - let set c = Pv.modify (fun pv -> { pv with shelf = c }) - let modify f = Pv.modify (fun pv -> { pv with shelf = f pv.shelf }) -end - -module Giveup : Writer with type t = goal list = struct - (* spiwack: I don't know why I cannot substitute ([:=]) [t] with a type expression. *) - type t = goal list - let put gs = Logical.put (true, gs) + let put s = Logical.put s end (** Lens and utilities pertaining to the info trace *) diff --git a/engine/proofview_monad.mli b/engine/proofview_monad.mli index a32b27904d..00d322858d 100644 --- a/engine/proofview_monad.mli +++ b/engine/proofview_monad.mli @@ -79,11 +79,10 @@ val with_empty_state : goal -> goal_with_state val map_goal_with_state : (goal -> goal) -> goal_with_state -> goal_with_state (** Type of proof views: current [evar_map] together with the list of - focused goals. *) + focused goals, locally shelved goals and globally shelved goals. *) type proofview = { solution : Evd.evar_map; comb : goal_with_state list; - shelf : goal list; } (** {6 Instantiation of the logic monad} *) @@ -92,7 +91,7 @@ module P : sig type s = proofview * Environ.env (** Status (safe/unsafe) * given up *) - type w = bool * goal list + type w = bool val wunit : w val wprod : w -> w -> w @@ -116,6 +115,10 @@ module type State = sig val set : t -> unit Logical.t val modify : (t->t) -> unit Logical.t end +module type Reader = sig + type t + val get : t Logical.t +end module type Writer = sig type t @@ -137,14 +140,6 @@ module Env : State with type t := Environ.env (** Lens to the tactic status ([true] if safe, [false] if unsafe) *) module Status : Writer with type t := bool -(** Lens to the list of goals which have been shelved during the - execution of the tactic. *) -module Shelf : State with type t = goal list - -(** Lens to the list of goals which were given up during the execution - of the tactic. *) -module Giveup : Writer with type t = goal list - (** Lens and utilities pertaining to the info trace *) module InfoL : sig (** [record_trace t] behaves like [t] and compute its [info] trace. *) diff --git a/engine/termops.ml b/engine/termops.ml index e5231ef9cd..0923ab6f4b 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -301,20 +301,24 @@ let pr_evar_map_gen with_univs pr_evars env sigma = if List.is_empty (Evd.meta_list sigma) then mt () else str "METAS:" ++ brk (0, 1) ++ pr_meta_map env sigma + and shelf = + str "SHELF:" ++ brk (0, 1) ++ Evd.pr_shelf sigma ++ fnl () + and future_goals = + str "FUTURE GOALS STACK:" ++ brk (0, 1) ++ Evd.pr_future_goals_stack sigma ++ fnl () in - evs ++ svs ++ cstrs ++ typeclasses ++ obligations ++ metas + evs ++ svs ++ cstrs ++ typeclasses ++ obligations ++ metas ++ shelf ++ future_goals let pr_evar_list env sigma l = let open Evd in - let pr_restrict ev = - match is_restricted_evar sigma ev with + let pr_alias ev = + match is_aliased_evar sigma ev with | None -> mt () - | Some ev' -> str " (restricted to " ++ Evar.print ev' ++ str ")" + | Some ev' -> str " (aliased to " ++ Evar.print ev' ++ str ")" in let pr (ev, evi) = h 0 (Evar.print ev ++ str "==" ++ pr_evar_info env sigma evi ++ - pr_restrict ev ++ + pr_alias ev ++ (if evi.evar_body == Evar_empty then str " {" ++ pr_existential_key sigma ev ++ str "}" else mt ())) diff --git a/engine/uState.ml b/engine/uState.ml index d4cb59da26..8d1584cd95 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -568,8 +568,8 @@ let emit_side_effects eff u = let u = demote_seff_univs (fst uctx) u in merge_seff u uctx -let update_sigma_env uctx env = - let univs = UGraph.set_cumulative_sprop (elaboration_sprop_cumul()) (Environ.universes env) in +let update_sigma_univs uctx ugraph = + let univs = UGraph.set_cumulative_sprop (elaboration_sprop_cumul()) ugraph in let eunivs = { uctx with initial_universes = univs; @@ -718,35 +718,6 @@ let fix_undefined_variables uctx = { uctx with univ_variables = vars'; univ_algebraic = algs' } -let refresh_undefined_univ_variables uctx = - let subst, ctx' = UnivGen.fresh_universe_context_set_instance uctx.local in - let subst_fn u = subst_univs_level_level subst u in - let alg = LSet.fold (fun u acc -> LSet.add (subst_fn u) acc) - uctx.univ_algebraic LSet.empty - in - let vars = - LMap.fold - (fun u v acc -> - LMap.add (subst_fn u) - (Option.map (subst_univs_level_universe subst) v) acc) - uctx.univ_variables LMap.empty - in - let weak = UPairSet.fold (fun (u,v) acc -> UPairSet.add (subst_fn u, subst_fn v) acc) uctx.weak_constraints UPairSet.empty in - let lbound = uctx.universes_lbound in - let declare g = LSet.fold (fun u g -> UGraph.add_universe u ~lbound ~strict:false g) - (ContextSet.levels ctx') g in - let initial = declare uctx.initial_universes in - let univs = declare UGraph.initial_universes in - let uctx' = {names = uctx.names; - local = ctx'; - seff_univs = uctx.seff_univs; - univ_variables = vars; univ_algebraic = alg; - universes = univs; - universes_lbound = lbound; - initial_universes = initial; - weak_constraints = weak; } in - uctx', subst - let minimize uctx = let open UnivMinim in let lbound = uctx.universes_lbound in diff --git a/engine/uState.mli b/engine/uState.mli index 45a0f9964e..7fec03e3b2 100644 --- a/engine/uState.mli +++ b/engine/uState.mli @@ -154,8 +154,6 @@ val abstract_undefined_variables : t -> t val fix_undefined_variables : t -> t -val refresh_undefined_univ_variables : t -> t * Univ.universe_level_subst - (** Universe minimization *) val minimize : t -> t @@ -187,7 +185,7 @@ val check_mono_univ_decl : t -> universe_decl -> Univ.ContextSet.t (** {5 TODO: Document me} *) -val update_sigma_env : t -> Environ.env -> t +val update_sigma_univs : t -> UGraph.t -> t (** {5 Pretty-printing} *) diff --git a/ide/coqide/coq.ml b/ide/coqide/coq.ml index 57cdccce6d..0e237b74fe 100644 --- a/ide/coqide/coq.ml +++ b/ide/coqide/coq.ml @@ -544,6 +544,7 @@ struct let coercions = BoolOpt ["Printing"; "Coercions"] let raw_matching = BoolOpt ["Printing"; "Matching"] let notations = BoolOpt ["Printing"; "Notations"] + let parentheses = BoolOpt ["Printing"; "Parentheses"] let all_basic = BoolOpt ["Printing"; "All"] let existential = BoolOpt ["Printing"; "Existential"; "Instances"] let universes = BoolOpt ["Printing"; "Universes"] @@ -558,7 +559,7 @@ struct { opts = [raw_matching]; init = true; label = "Display raw _matching expressions" }; { opts = [notations]; init = true; label = "Display _notations" }; - { opts = [notations]; init = true; label = "Display _parentheses" }; + { opts = [parentheses]; init = true; label = "Display _parentheses" }; { opts = [all_basic]; init = false; label = "Display _all basic low-level contents" }; { opts = [existential]; init = false; diff --git a/ide/coqide/idetop.ml b/ide/coqide/idetop.ml index 2adc35ae3e..ad21f663e4 100644 --- a/ide/coqide/idetop.ml +++ b/ide/coqide/idetop.ml @@ -220,12 +220,12 @@ let process_goal_diffs diff_goal_map oldp nsigma ng = let (hyps_pp_list, concl_pp) = Proof_diffs.diff_goal_ide og_s ng nsigma in { Interface.goal_hyp = hyps_pp_list; Interface.goal_ccl = concl_pp; Interface.goal_id = Goal.uid ng } -let export_pre_goals Proof.{ sigma; goals; stack; shelf; given_up } process = +let export_pre_goals Proof.{ sigma; goals; stack } process = let process = List.map (process sigma) in { Interface.fg_goals = process goals ; Interface.bg_goals = List.(map (fun (lg,rg) -> process lg, process rg)) stack - ; Interface.shelved_goals = process shelf - ; Interface.given_up_goals = process given_up + ; Interface.shelved_goals = process @@ Evd.shelf sigma + ; Interface.given_up_goals = process (Evar.Set.elements @@ Evd.given_up sigma) } let goals () = diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 3667757a2f..43fef8685d 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -636,10 +636,10 @@ exception Expl (* If the removal of implicit arguments is not possible, raise [Expl] *) (* [inctx] tells if the term is in a context which will enforce the external type *) (* [n] is the total number of arguments block to which the [args] belong *) -let adjust_implicit_arguments inctx n q args impl = - let rec exprec q = function +let adjust_implicit_arguments inctx n args impl = + let rec exprec = function | a::args, imp::impl when is_status_implicit imp -> - let tail = exprec (q+1) (args,impl) in + let tail = exprec (args,impl) in let visible = !Flags.raw_print || (!print_implicits && !print_implicits_explicit_args) || @@ -652,13 +652,13 @@ let adjust_implicit_arguments inctx n q args impl = (Lazy.force a,Some (make @@ ExplByName (name_of_implicit imp))) :: tail else tail - | a::args, _::impl -> (Lazy.force a,None) :: exprec (q+1) (args,impl) + | a::args, _::impl -> (Lazy.force a,None) :: exprec (args,impl) | args, [] -> List.map (fun a -> (Lazy.force a,None)) args (*In case of polymorphism*) | [], (imp :: _) when is_status_implicit imp && maximal_insertion_of imp -> (* The non-explicit application cannot be parsed back with the same type *) raise Expl | [], _ -> [] - in exprec q (args,impl) + in exprec (args,impl) let extern_projection (cf,f) args impl = let ip = is_projection (List.length args) cf in @@ -750,14 +750,14 @@ let extern_applied_ref inctx impl (cf,f) us args = match extern_projection (cf,f) args impl with (* Try a [t.(f args1) args2] projection-style notation *) | Some (i,(args1,impl1),(args2,impl2)) -> - let args1 = adjust_implicit_arguments inctx n 1 args1 impl1 in - let args2 = adjust_implicit_arguments inctx n (i+1) args2 impl2 in + let args1 = adjust_implicit_arguments inctx n args1 impl1 in + let args2 = adjust_implicit_arguments inctx n args2 impl2 in let ip = Some (List.length args1) in CApp ((ip,f),args1@args2) (* A normal application node with each individual implicit arguments either dropped or made explicit *) | None -> - let args = adjust_implicit_arguments inctx n 1 args impl in + let args = adjust_implicit_arguments inctx n args impl in if args = [] then ref else CApp ((None, f), args) with Expl -> (* A [@f args] node *) @@ -765,10 +765,10 @@ let extern_applied_ref inctx impl (cf,f) us args = let isproj = if !print_projections then isproj else None in CAppExpl ((isproj,f,us), args) -let extern_applied_syntactic_definition n extraimpl (cf,f) syndefargs extraargs = +let extern_applied_syntactic_definition inctx n extraimpl (cf,f) syndefargs extraargs = try let syndefargs = List.map (fun a -> (a,None)) syndefargs in - let extraargs = adjust_implicit_arguments false n (n-List.length extraargs+1) extraargs extraimpl in + let extraargs = adjust_implicit_arguments inctx n extraargs extraimpl in let args = syndefargs @ extraargs in if args = [] then cf else CApp ((None, CAst.make cf), args) with Expl -> @@ -784,12 +784,12 @@ let mkFlattenedCApp (head,args) = | _ -> CApp ((None, head), args) -let extern_applied_notation n impl f args = +let extern_applied_notation inctx n impl f args = if List.is_empty args then f.CAst.v else try - let args = adjust_implicit_arguments false n (n-List.length args+1) args impl in + let args = adjust_implicit_arguments inctx n args impl in mkFlattenedCApp (f,args) with Expl -> raise No_match @@ -940,11 +940,11 @@ let extern_var ?loc id = CRef (qualid_of_ident ?loc id,None) let rec extern inctx ?impargs scopes vars r = match remove_one_coercion inctx (flatten_application r) with | Some (nargs,inctx,r') -> - (try extern_notations scopes vars (Some nargs) r + (try extern_notations inctx scopes vars (Some nargs) r with No_match -> extern inctx scopes vars r') | None -> - try extern_notations scopes vars None r + try extern_notations inctx scopes vars None r with No_match -> let loc = r.CAst.loc in @@ -1000,7 +1000,7 @@ let rec extern inctx ?impargs scopes vars r = mkFlattenedCApp (head,args)) | GLetIn (na,b,t,c) -> - CLetIn (make ?loc na,sub_extern false scopes vars b, + CLetIn (make ?loc na,sub_extern (Option.has_some t) scopes vars b, Option.map (extern_typ scopes vars) t, extern inctx ?impargs scopes (add_vname vars na) c) @@ -1197,7 +1197,7 @@ and extern_local_binder scopes vars = function extern_local_binder scopes (Name.fold_right Id.Set.add na vars) l in (assums,na::ids, CLocalDef(CAst.make na, extern false scopes vars bd, - Option.map (extern false scopes vars) ty) :: l) + Option.map (extern_typ scopes vars) ty) :: l) | GLocalAssum (na,bk,ty) -> let implicit_type = is_reserved_type na ty in @@ -1225,14 +1225,14 @@ and extern_eqn inctx scopes vars {CAst.loc;v=(ids,pll,c)} = let pll = List.map (List.map (extern_cases_pattern_in_scope scopes vars)) pll in make ?loc (pll,extern inctx scopes vars c) -and extern_notations scopes vars nargs t = +and extern_notations inctx scopes vars nargs t = if !Flags.raw_print || !print_no_symbol then raise No_match; try extern_possible_prim_token scopes t with No_match -> let t = flatten_application t in - extern_notation scopes vars t (filter_enough_applied nargs (uninterp_notations t)) + extern_notation inctx scopes vars t (filter_enough_applied nargs (uninterp_notations t)) -and extern_notation (custom,scopes as allscopes) vars t rules = +and extern_notation inctx (custom,scopes as allscopes) vars t rules = match rules with | [] -> raise No_match | (keyrule,pat,n as _rule)::rules -> @@ -1313,7 +1313,7 @@ and extern_notation (custom,scopes as allscopes) vars t rules = let c = insert_entry_coercion coercion (insert_delimiters c key) in let args = fill_arg_scopes args argsscopes allscopes in let args = extern_args (extern true) vars args in - CAst.make ?loc @@ extern_applied_notation nallargs argsimpls c args) + CAst.make ?loc @@ extern_applied_notation inctx nallargs argsimpls c args) | SynDefRule kn -> let l = List.map (fun (c,(subentry,(scopt,scl))) -> @@ -1323,13 +1323,13 @@ and extern_notation (custom,scopes as allscopes) vars t rules = let a = CRef (cf,None) in let args = fill_arg_scopes args argsscopes allscopes in let args = extern_args (extern true) vars args in - let c = CAst.make ?loc @@ extern_applied_syntactic_definition nallargs argsimpls (a,cf) l args in + let c = CAst.make ?loc @@ extern_applied_syntactic_definition inctx nallargs argsimpls (a,cf) l args in if isCRef_no_univ c.CAst.v && entry_has_global custom then c else match availability_of_entry_coercion custom InConstrEntrySomeLevel with | None -> raise No_match | Some coercion -> insert_entry_coercion coercion c with - No_match -> extern_notation allscopes vars t rules + No_match -> extern_notation inctx allscopes vars t rules let extern_glob_constr vars c = extern false (InConstrEntrySomeLevel,(None,[])) vars c diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 6d4ab8b4d6..1d3b1bbb24 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -1724,8 +1724,7 @@ let drop_notations_pattern looked_for genv = the domains of lambdas in the encoding of match in constr. This check is here and not in the parser because it would require duplicating the levels of the [pattern] rule. *) - CErrors.user_err ?loc ~hdr:"drop_notations_pattern" - (Pp.strbrk "Casts are not supported in this pattern.") + CErrors.user_err ?loc (Pp.strbrk "Casts are not supported in this pattern.") and in_pat_sc scopes x = in_pat false (x,snd scopes) and in_not top loc scopes (subst,substlist as fullsubst) args = function | NVar id -> diff --git a/interp/dune b/interp/dune index e9ef7ba99a..6d73d5724c 100644 --- a/interp/dune +++ b/interp/dune @@ -3,4 +3,4 @@ (synopsis "Coq's Syntactic Interpretation for AST [notations, implicits]") (public_name coq.interp) (wrapped false) - (libraries pretyping)) + (libraries zarith pretyping)) diff --git a/interp/impargs.ml b/interp/impargs.ml index db102470b0..7742f985de 100644 --- a/interp/impargs.ml +++ b/interp/impargs.ml @@ -20,7 +20,6 @@ open Lib open Libobject open EConstr open Reductionops -open Namegen open Constrexpr module NamedDecl = Context.Named.Declaration @@ -247,24 +246,15 @@ let is_rigid env sigma t = is_rigid_head sigma t | _ -> true -let find_displayed_name_in sigma all avoid na (env, b) = - let envnames_b = (env, b) in - let flag = RenamingElsewhereFor envnames_b in - if all then compute_and_force_displayed_name_in sigma flag avoid na b - else compute_displayed_name_in sigma flag avoid na b - -let compute_implicits_names_gen all env sigma t = +let compute_implicits_names env sigma t = let open Context.Rel.Declaration in - let rec aux env avoid names t = + let rec aux env names t = let t = whd_all env sigma t in match kind sigma t with | Prod (na,a,b) -> - let na',avoid' = find_displayed_name_in sigma all avoid na.Context.binder_name (names,b) in - aux (push_rel (LocalAssum (na,a)) env) avoid' (na'::names) b + aux (push_rel (LocalAssum (na,a)) env) (na.Context.binder_name::names) b | _ -> List.rev names - in aux env Id.Set.empty [] t - -let compute_implicits_names = compute_implicits_names_gen true + in aux env [] t let compute_implicits_explanation_gen strict strongly_strict revpat contextual env sigma t = let open Context.Rel.Declaration in @@ -291,9 +281,9 @@ let compute_implicits_explanation_flags env sigma f t = (f.strict || f.strongly_strict) f.strongly_strict f.reversible_pattern f.contextual env sigma t -let compute_implicits_flags env sigma f all t = +let compute_implicits_flags env sigma f t = List.combine - (compute_implicits_names_gen all env sigma t) + (compute_implicits_names env sigma t) (compute_implicits_explanation_flags env sigma f t) let compute_auto_implicits env sigma flags enriching t = @@ -361,10 +351,10 @@ let positions_of_implicits (_,impls) = let rec prepare_implicits i f = function | [] -> [] - | (Anonymous, Some _)::_ -> anomaly (Pp.str "Unnamed implicit.") - | (Name id, Some imp)::imps -> + | (na, Some imp)::imps -> let imps' = prepare_implicits (i+1) f imps in - Some (ExplByName id,imp,(set_maximality Silent (Name id) i imps' f.maximal,true)) :: imps' + let expl = match na with Name id -> ExplByName id | Anonymous -> ExplByPos (i,None) in + Some (expl,imp,(set_maximality Silent na i imps' f.maximal,true)) :: imps' | _::imps -> None :: prepare_implicits (i+1) f imps let set_manual_implicits silent flags enriching autoimps l = @@ -393,7 +383,7 @@ let set_manual_implicits silent flags enriching autoimps l = let compute_semi_auto_implicits env sigma f t = if not f.auto then [DefaultImpArgs, []] - else let l = compute_implicits_flags env sigma f false t in + else let l = compute_implicits_flags env sigma f t in [DefaultImpArgs, prepare_implicits 1 f l] (*s Constants. *) @@ -677,10 +667,12 @@ let explicit_kind i = function let compute_implicit_statuses autoimps l = let rec aux i = function - | _ :: autoimps, Explicit :: manualimps -> None :: aux (i+1) (autoimps, manualimps) - | na :: autoimps, MaxImplicit :: manualimps -> + | _ :: autoimps, (_, Explicit) :: manualimps -> None :: aux (i+1) (autoimps, manualimps) + | na :: autoimps, (Anonymous, MaxImplicit) :: manualimps + | _ :: autoimps, (na, MaxImplicit) :: manualimps -> Some (explicit_kind i na, Manual, (true, true)) :: aux (i+1) (autoimps, manualimps) - | na :: autoimps, NonMaxImplicit :: manualimps -> + | na :: autoimps, (Anonymous, NonMaxImplicit) :: manualimps + | _ :: autoimps, (na, NonMaxImplicit) :: manualimps -> let imps' = aux (i+1) (autoimps, manualimps) in let max = set_maximality Error na i imps' false in Some (explicit_kind i na, Manual, (max, true)) :: imps' @@ -703,7 +695,7 @@ let set_implicits local ref l = check_rigidity (is_rigid env sigma t); (* Sort by number of implicits, decreasing *) let is_implicit = function - | Explicit -> false + | _, Explicit -> false | _ -> true in let l = List.map (fun imps -> (imps,List.count is_implicit imps)) l in let l = List.sort (fun (_,n1) (_,n2) -> n2 - n1) l in diff --git a/interp/impargs.mli b/interp/impargs.mli index 97841b37f2..c8bcef19c8 100644 --- a/interp/impargs.mli +++ b/interp/impargs.mli @@ -117,7 +117,7 @@ val maybe_declare_manual_implicits : bool -> GlobRef.t -> ?enriching:bool -> (** [set_implicits local ref l] Manual declaration of implicit arguments. `l` is a list of possible sequences of implicit statuses. *) -val set_implicits : bool -> GlobRef.t -> Glob_term.binding_kind list list -> unit +val set_implicits : bool -> GlobRef.t -> (Name.t * Glob_term.binding_kind) list list -> unit val implicits_of_global : GlobRef.t -> implicits_list list diff --git a/interp/notation.ml b/interp/notation.ml index c4e9496b95..17ae045187 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -388,7 +388,7 @@ module InnerPrimToken = struct type interpreter = | RawNumInterp of (?loc:Loc.t -> rawnum -> glob_constr) - | BigNumInterp of (?loc:Loc.t -> Bigint.bigint -> glob_constr) + | BigNumInterp of (?loc:Loc.t -> Z.t -> glob_constr) | StringInterp of (?loc:Loc.t -> string -> glob_constr) let interp_eq f f' = match f,f' with @@ -410,7 +410,7 @@ module InnerPrimToken = struct type uninterpreter = | RawNumUninterp of (any_glob_constr -> rawnum option) - | BigNumUninterp of (any_glob_constr -> Bigint.bigint option) + | BigNumUninterp of (any_glob_constr -> Z.t option) | StringUninterp of (any_glob_constr -> string option) let uninterp_eq f f' = match f,f' with @@ -612,13 +612,14 @@ let uninterp to_raw o (Glob_term.AnyGlobConstr n) = end +let z_two = Z.of_int 2 + (** Conversion from bigint to int63 *) let rec int63_of_pos_bigint i = - let open Bigint in - if equal i zero then Uint63.of_int 0 + if Z.(equal i zero) then Uint63.of_int 0 else - let (quo,rem) = div2_with_rest i in - if rem then Uint63.add (Uint63.of_int 1) + let quo, remi = Z.div_rem i z_two in + if Z.(equal remi one) then Uint63.add (Uint63.of_int 1) (Uint63.mul (Uint63.of_int 2) (int63_of_pos_bigint quo)) else Uint63.mul (Uint63.of_int 2) (int63_of_pos_bigint quo) @@ -800,24 +801,24 @@ let rawnum_of_coqint c = (** First, [positive] from/to bigint *) let rec pos_of_bigint posty n = - match Bigint.div2_with_rest n with - | (q, false) -> + match Z.div_rem n z_two with + | (q, rem) when rem = Z.zero -> let c = mkConstruct (posty, 2) in (* xO *) mkApp (c, [| pos_of_bigint posty q |]) - | (q, true) when not (Bigint.equal q Bigint.zero) -> + | (q, _) when not (Z.equal q Z.zero) -> let c = mkConstruct (posty, 1) in (* xI *) mkApp (c, [| pos_of_bigint posty q |]) - | (q, true) -> + | (q, _) -> mkConstruct (posty, 3) (* xH *) let rec bigint_of_pos c = match Constr.kind c with - | Construct ((_, 3), _) -> (* xH *) Bigint.one + | Construct ((_, 3), _) -> (* xH *) Z.one | App (c, [| d |]) -> begin match Constr.kind c with | Construct ((_, n), _) -> begin match n with - | 1 -> (* xI *) Bigint.add_1 (Bigint.mult_2 (bigint_of_pos d)) - | 2 -> (* xO *) Bigint.mult_2 (bigint_of_pos d) + | 1 -> (* xI *) Z.add Z.one (Z.mul z_two (bigint_of_pos d)) + | 2 -> (* xO *) Z.mul z_two (bigint_of_pos d) | n -> assert false (* no other constructor of type positive *) end | x -> raise NotAValidPrimToken @@ -827,24 +828,24 @@ let rec bigint_of_pos c = match Constr.kind c with (** Now, [Z] from/to bigint *) let z_of_bigint { z_ty; pos_ty } n = - if Bigint.equal n Bigint.zero then + if Z.(equal n zero) then mkConstruct (z_ty, 1) (* Z0 *) else let (s, n) = - if Bigint.is_pos_or_zero n then (2, n) (* Zpos *) - else (3, Bigint.neg n) (* Zneg *) + if Z.(leq zero n) then (2, n) (* Zpos *) + else (3, Z.neg n) (* Zneg *) in let c = mkConstruct (z_ty, s) in mkApp (c, [| pos_of_bigint pos_ty n |]) let bigint_of_z z = match Constr.kind z with - | Construct ((_, 1), _) -> (* Z0 *) Bigint.zero + | Construct ((_, 1), _) -> (* Z0 *) Z.zero | App (c, [| d |]) -> begin match Constr.kind c with | Construct ((_, n), _) -> begin match n with | 2 -> (* Zpos *) bigint_of_pos d - | 3 -> (* Zneg *) Bigint.neg (bigint_of_pos d) + | 3 -> (* Zneg *) Z.neg (bigint_of_pos d) | n -> assert false (* no other constructor of type Z *) end | _ -> raise NotAValidPrimToken @@ -861,20 +862,19 @@ let error_negative ?loc = CErrors.user_err ?loc ~hdr:"interp_int63" (Pp.str "int63 are only non-negative numbers.") let error_overflow ?loc n = - CErrors.user_err ?loc ~hdr:"interp_int63" Pp.(str "overflow in int63 literal: " ++ str (Bigint.to_string n)) + CErrors.user_err ?loc ~hdr:"interp_int63" Pp.(str "overflow in int63 literal: " ++ str (Z.to_string n)) let interp_int63 ?loc n = - let open Bigint in - if is_pos_or_zero n + if Z.(leq zero n) then - if less_than n (pow two 63) + if Z.(lt n (pow z_two 63)) then int63_of_pos_bigint ?loc n else error_overflow ?loc n else error_negative ?loc let bigint_of_int63 c = match Constr.kind c with - | Int i -> Bigint.of_string (Uint63.to_string i) + | Int i -> Z.of_string (Uint63.to_string i) | _ -> raise NotAValidPrimToken let interp o ?loc n = @@ -1429,7 +1429,7 @@ let declare_entry_coercion (scope,(entry,key)) lev entry' = let toaddright = EntryCoercionMap.fold (fun (entry'',entry''') paths l -> List.fold_right (fun ((lev'',lev'''),path) l -> - if entry' = entry'' && level_ord lev' lev'' && entry <> entry''' + if entry' = entry'' && level_ord lev'' lev' && entry <> entry''' then ((entry,entry'''),((lev,lev'''),path@[(scope,(entry,key))]))::l else l) paths l) !entry_coercion_map [] in entry_coercion_map := diff --git a/interp/notation.mli b/interp/notation.mli index 05ddd25a62..948831b317 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -101,7 +101,7 @@ val register_rawnumeral_interpretation : ?allow_overwrite:bool -> prim_token_uid -> rawnum prim_token_interpretation -> unit val register_bignumeral_interpretation : - ?allow_overwrite:bool -> prim_token_uid -> Bigint.bigint prim_token_interpretation -> unit + ?allow_overwrite:bool -> prim_token_uid -> Z.t prim_token_interpretation -> unit val register_string_interpretation : ?allow_overwrite:bool -> prim_token_uid -> string prim_token_interpretation -> unit @@ -196,8 +196,8 @@ val enable_prim_token_interpretation : prim_token_infos -> unit *) val declare_numeral_interpreter : ?local:bool -> scope_name -> required_module -> - Bigint.bigint prim_token_interpreter -> - glob_constr list * Bigint.bigint prim_token_uninterpreter * bool -> unit + Z.t prim_token_interpreter -> + glob_constr list * Z.t prim_token_uninterpreter * bool -> unit val declare_string_interpreter : ?local:bool -> scope_name -> required_module -> string prim_token_interpreter -> glob_constr list * string prim_token_uninterpreter * bool -> unit @@ -349,4 +349,4 @@ val level_of_notation : notation -> level val with_notation_protection : ('a -> 'b) -> 'a -> 'b (** Conversion from bigint to int63 *) -val int63_of_pos_bigint : Bigint.bigint -> Uint63.t +val int63_of_pos_bigint : Z.t -> Uint63.t diff --git a/interp/numTok.ml b/interp/numTok.ml index bb14649b91..124a6cd249 100644 --- a/interp/numTok.ml +++ b/interp/numTok.ml @@ -80,63 +80,14 @@ struct let to_string (sign,n) = (match sign with SPlus -> "" | SMinus -> "-") ^ UnsignedNat.to_string n let classify (_,n) = UnsignedNat.classify n - let bigint_of_string (sign,n) = - (* nasty code to remove when switching to zarith - since zarith's of_string handles hexadecimal *) - match UnsignedNat.classify n with - | CDec -> Bigint.of_string (to_string (sign,n)) - | CHex -> - let int_of_char c = match c with - | 'a'..'f' -> 10 + int_of_char c - int_of_char 'a' - | _ -> int_of_char c - int_of_char '0' in - let c16 = Bigint.of_int 16 in - let s = UnsignedNat.to_string n in - let n = ref Bigint.zero in - let len = String.length s in - for d = 2 to len - 1 do - n := Bigint.(add (mult !n c16) (of_int (int_of_char s.[d]))) - done; - match sign with SPlus -> !n | SMinus -> Bigint.neg !n + let bigint_of_string (sign,n) = Z.of_string (to_string (sign,n)) let to_bigint n = bigint_of_string n let string_of_nonneg_bigint c n = - (* nasty code to remove when switching to zarith - since zarith's format handles hexadecimal *) match c with - | CDec -> Bigint.to_string n - | CHex -> - let div16 n = - let n, r0 = Bigint.div2_with_rest n in - let n, r1 = Bigint.div2_with_rest n in - let n, r2 = Bigint.div2_with_rest n in - let n, r3 = Bigint.div2_with_rest n in - let r = match r3, r2, r1, r0 with - | false, false, false, false -> "0" - | false, false, false, true -> "1" - | false, false, true, false -> "2" - | false, false, true, true -> "3" - | false, true, false, false -> "4" - | false, true, false, true -> "5" - | false, true, true, false -> "6" - | false, true, true, true -> "7" - | true, false, false, false -> "8" - | true, false, false, true -> "9" - | true, false, true, false -> "a" - | true, false, true, true -> "b" - | true, true, false, false -> "c" - | true, true, false, true -> "d" - | true, true, true, false -> "e" - | true, true, true, true -> "f" in - n, r in - let n = ref n in - let l = ref [] in - while Bigint.is_strictly_pos !n do - let n', r = div16 !n in - n := n'; - l := r :: !l - done; - "0x" ^ String.concat "" (List.rev !l) + | CDec -> Z.format "%d" n + | CHex -> Z.format "0x%x" n let of_bigint c n = - let sign, n = if Bigint.is_strictly_neg n then (SMinus, Bigint.neg n) else (SPlus, n) in + let sign, n = if Int.equal (-1) (Z.sign n) then (SMinus, Z.neg n) else (SPlus, n) in (sign, string_of_nonneg_bigint c n) end @@ -339,13 +290,13 @@ struct let frac = UnsignedNat.to_string frac in let i = SignedNat.to_bigint (s, int ^ frac) in let e = - let e = if exp = "" then Bigint.zero else match exp.[1] with - | '+' -> Bigint.of_string (UnsignedNat.to_string (string_del_head 2 exp)) - | '-' -> Bigint.(neg (of_string (UnsignedNat.to_string (string_del_head 2 exp)))) - | _ -> Bigint.of_string (UnsignedNat.to_string (string_del_head 1 exp)) in + let e = if exp = "" then Z.zero else match exp.[1] with + | '+' -> Z.of_string (UnsignedNat.to_string (string_del_head 2 exp)) + | '-' -> Z.(neg (of_string (UnsignedNat.to_string (string_del_head 2 exp)))) + | _ -> Z.of_string (UnsignedNat.to_string (string_del_head 1 exp)) in let l = String.length frac in let l = match c with CDec -> l | CHex -> 4 * l in - Bigint.(sub e (of_int l)) in + Z.(sub e (of_int l)) in (i, match c with CDec -> EDec e | CHex -> EBin e) let of_bigint_and_exponent i e = diff --git a/interp/numTok.mli b/interp/numTok.mli index 11d5a0f980..bcfe663dd2 100644 --- a/interp/numTok.mli +++ b/interp/numTok.mli @@ -65,8 +65,8 @@ sig val classify : t -> num_class - val of_bigint : num_class -> Bigint.bigint -> t - val to_bigint : t -> Bigint.bigint + val of_bigint : num_class -> Z.t -> t + val to_bigint : t -> Z.t end (** {6 Unsigned decimal numerals } *) @@ -131,8 +131,8 @@ sig val to_string : t -> string (** Returns a string in the syntax of OCaml's float_of_string *) - val of_bigint : num_class -> Bigint.bigint -> t - val to_bigint : t -> Bigint.bigint option + val of_bigint : num_class -> Z.t -> t + val to_bigint : t -> Z.t option (** Convert from and to bigint when the denotation of a bigint *) val of_int_frac_and_exponent : SignedNat.t -> UnsignedNat.t option -> SignedNat.t option -> t @@ -140,8 +140,8 @@ sig (** n, p and q such that the number is n.p*10^q or n.p*2^q pre/postcondition: classify n = classify p, classify q = CDec *) - val of_bigint_and_exponent : Bigint.bigint -> Bigint.bigint exp -> t - val to_bigint_and_exponent : t -> Bigint.bigint * Bigint.bigint exp + val of_bigint_and_exponent : Z.t -> Z.t exp -> t + val to_bigint_and_exponent : t -> Z.t * Z.t exp (** n and p such that the number is n*10^p or n*2^p *) val classify : t -> num_class diff --git a/interp/stdarg.ml b/interp/stdarg.ml index d5f104b7f8..343f85be03 100644 --- a/interp/stdarg.ml +++ b/interp/stdarg.ml @@ -25,6 +25,9 @@ let wit_bool : bool uniform_genarg_type = let wit_int : int uniform_genarg_type = make0 "int" +let wit_nat : int uniform_genarg_type = + make0 "nat" + let wit_string : string uniform_genarg_type = make0 "string" @@ -59,6 +62,7 @@ let wit_clause_dft_concl = (** Aliases for compatibility *) let wit_integer = wit_int +let wit_natural = wit_nat let wit_preident = wit_pre_ident let wit_reference = wit_ref let wit_global = wit_ref diff --git a/interp/stdarg.mli b/interp/stdarg.mli index 89bdd78c70..3ae8b7d73f 100644 --- a/interp/stdarg.mli +++ b/interp/stdarg.mli @@ -23,6 +23,8 @@ val wit_unit : unit uniform_genarg_type val wit_bool : bool uniform_genarg_type +val wit_nat : int uniform_genarg_type + val wit_int : int uniform_genarg_type val wit_string : string uniform_genarg_type @@ -54,6 +56,7 @@ val wit_clause_dft_concl : (lident Locus.clause_expr, lident Locus.clause_expr, (** Aliases for compatibility *) +val wit_natural : int uniform_genarg_type val wit_integer : int uniform_genarg_type val wit_preident : string uniform_genarg_type val wit_reference : (qualid, GlobRef.t located or_var, GlobRef.t) genarg_type diff --git a/kernel/declarations.ml b/kernel/declarations.ml index 7609c1a64d..9c32cd8e0e 100644 --- a/kernel/declarations.ml +++ b/kernel/declarations.ml @@ -107,7 +107,7 @@ type 'opaque constant_body = { const_body : (Constr.t Mod_subst.substituted, 'opaque) constant_def; const_type : types; const_relevance : Sorts.relevance; - const_body_code : Cemitcodes.to_patch_substituted option; + const_body_code : Vmemitcodes.to_patch_substituted option; const_universes : universes; const_inline_code : bool; const_typing_flags : typing_flags; (** The typing options which diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 326bf0d6ad..b9f434f179 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -116,7 +116,7 @@ let subst_const_body sub cb = const_body = body'; const_type = type'; const_body_code = - Option.map (Cemitcodes.subst_to_patch_subst sub) cb.const_body_code; + Option.map (Vmemitcodes.subst_to_patch_subst sub) cb.const_body_code; const_universes = cb.const_universes; const_relevance = cb.const_relevance; const_inline_code = cb.const_inline_code; diff --git a/kernel/dune b/kernel/dune index 5f7502ef6b..ce6fdc03df 100644 --- a/kernel/dune +++ b/kernel/dune @@ -11,7 +11,7 @@ (modules genOpcodeFiles)) (rule - (targets copcodes.ml) + (targets vmopcodes.ml) (action (with-stdout-to %{targets} (run ./genOpcodeFiles.exe copml)))) (rule diff --git a/kernel/environ.ml b/kernel/environ.ml index e75ccbb252..03c9cb4be6 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -87,6 +87,7 @@ let build_lazy_val vk key = vk := VKvalue (CEphemeron.create key) type named_context_val = { env_named_ctx : Constr.named_context; env_named_map : (Constr.named_declaration * lazy_val) Id.Map.t; + env_named_var : Constr.t list; } type rel_context_val = { @@ -109,6 +110,7 @@ type env = { let empty_named_context_val = { env_named_ctx = []; env_named_map = Id.Map.empty; + env_named_var = []; } let empty_rel_context_val = { @@ -183,6 +185,7 @@ let push_named_context_val_val d rval ctxt = { env_named_ctx = Context.Named.add d ctxt.env_named_ctx; env_named_map = Id.Map.add (NamedDecl.get_id d) (d, rval) ctxt.env_named_map; + env_named_var = mkVar (NamedDecl.get_id d) :: ctxt.env_named_var; } let push_named_context_val d ctxt = @@ -193,7 +196,7 @@ let match_named_context_val c = match c.env_named_ctx with | decl :: ctx -> let (_, v) = Id.Map.find (NamedDecl.get_id decl) c.env_named_map in let map = Id.Map.remove (NamedDecl.get_id decl) c.env_named_map in - let cval = { env_named_ctx = ctx; env_named_map = map } in + let cval = { env_named_ctx = ctx; env_named_map = map; env_named_var = List.tl c.env_named_var } in Some (decl, v, cval) let map_named_val f ctxt = @@ -208,7 +211,7 @@ let map_named_val f ctxt = in let map, ctx = List.fold_left_map fold ctxt.env_named_map ctxt.env_named_ctx in if map == ctxt.env_named_map then ctxt - else { env_named_ctx = ctx; env_named_map = map } + else { env_named_ctx = ctx; env_named_map = map; env_named_var = ctxt.env_named_var } let push_named d env = {env with env_named_context = push_named_context_val d env.env_named_context} diff --git a/kernel/environ.mli b/kernel/environ.mli index 5cb56a2a29..974e794c6b 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -69,6 +69,11 @@ type stratification = { type named_context_val = private { env_named_ctx : Constr.named_context; env_named_map : (Constr.named_declaration * lazy_val) Id.Map.t; + (** Identifier-indexed version of [env_named_ctx] *) + env_named_var : Constr.t list; + (** List of identifiers in [env_named_ctx], in the same order, including + let-ins. This is not used in the kernel, but is critical to preserve + sharing of evar instances in the proof engine. *) } type rel_context_val = private { diff --git a/kernel/genOpcodeFiles.ml b/kernel/genOpcodeFiles.ml index 67a672c349..2d74cca44c 100644 --- a/kernel/genOpcodeFiles.ml +++ b/kernel/genOpcodeFiles.ml @@ -11,7 +11,7 @@ (** List of opcodes. It is used to generate the [coq_instruct.h], [coq_jumptbl.h] and - [copcodes.ml] files. + [vmopcodes.ml] files. If adding an instruction, DON'T FORGET TO UPDATE coq_fix_code.c with the arity of the instruction and maybe coq_tcode_of_code. @@ -196,7 +196,7 @@ let pp_coq_instruct_h fmt = let pp_coq_jumptbl_h fmt = pp_with_commas fmt (fun fmt -> Format.fprintf fmt "&&coq_lbl_%s") -let pp_copcodes_ml fmt = +let pp_vmopcodes_ml fmt = pp_header true fmt; Array.iteri (fun n s -> Format.fprintf fmt "let op%s = %d@.@." s n @@ -210,7 +210,7 @@ let main () = match Sys.argv.(1) with | "enum" -> pp_coq_instruct_h Format.std_formatter | "jump" -> pp_coq_jumptbl_h Format.std_formatter - | "copml" -> pp_copcodes_ml Format.std_formatter + | "copml" -> pp_vmopcodes_ml Format.std_formatter | _ -> usage () | exception Invalid_argument _ -> usage () diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib index 41388d9f17..d4d7150222 100644 --- a/kernel/kernel.mllib +++ b/kernel/kernel.mllib @@ -15,9 +15,9 @@ Term CPrimitives Mod_subst Vmvalues -Cbytecodes -Copcodes -Cemitcodes +Vmbytecodes +Vmopcodes +Vmemitcodes Opaqueproof Declarations Entries @@ -30,12 +30,12 @@ Primred CClosure Relevanceops Reduction -Clambda +Vmlambda Nativelambda -Cbytegen +Vmbytegen Nativecode Nativelib -Csymtable +Vmsymtable Vm Vconv Nativeconv diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index 44b010204b..5873d1f502 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -124,8 +124,8 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = { cb with const_body = def; const_universes = univs ; - const_body_code = Option.map Cemitcodes.from_val - (Cbytegen.compile_constant_body ~fail_on_error:false env' cb.const_universes def) } + const_body_code = Option.map Vmemitcodes.from_val + (Vmbytegen.compile_constant_body ~fail_on_error:false env' cb.const_universes def) } in before@(lab,SFBconst(cb'))::after, c', ctx' else diff --git a/kernel/modops.ml b/kernel/modops.ml index 77ef38dfd5..883ad79be5 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -328,7 +328,7 @@ let strengthen_const mp_from l cb resolver = let u = Univ.make_abstract_instance (Declareops.constant_polymorphic_context cb) in { cb with const_body = Def (Mod_subst.from_val (mkConstU (con,u))); - const_body_code = Some (Cemitcodes.from_val (Cbytegen.compile_alias con)) } + const_body_code = Some (Vmemitcodes.from_val (Vmbytegen.compile_alias con)) } let rec strengthen_mod mp_from mp_to mb = if mp_in_delta mb.mod_mp mb.mod_delta then mb diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index b00b96018f..99090f0147 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -395,8 +395,8 @@ let rec get_alias env (kn, u as p) = match tps with | None -> p | Some tps -> - match Cemitcodes.force tps with - | Cemitcodes.BCalias kn' -> get_alias env (kn', u) + match Vmemitcodes.force tps with + | Vmemitcodes.BCalias kn' -> get_alias env (kn', u) | _ -> p let prim env kn p args = diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 0754e9d4cc..7c6b869b4a 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -234,6 +234,8 @@ let sort_cmp_universes env pb s0 s1 (u, check) = let convert_instances ~flex u u' (s, check) = (check.compare_instances ~flex u u' s, check) +exception MustExpand + let get_cumulativity_constraints cv_pb variance u u' = match cv_pb with | CONV -> @@ -251,7 +253,8 @@ let convert_inductives_gen cmp_instances cmp_cumul cv_pb (mind,ind) nargs u1 u2 | Some variances -> let num_param_arity = inductive_cumulativity_arguments (mind,ind) in if not (Int.equal num_param_arity nargs) then - cmp_instances u1 u2 s + (* shortcut, not sure if worth doing, could use perf data *) + if Univ.Instance.equal u1 u2 then s else raise MustExpand else cmp_cumul cv_pb variances u1 u2 s @@ -269,7 +272,7 @@ let convert_constructors_gen cmp_instances cmp_cumul (mind, ind, cns) nargs u1 u | Some _ -> let num_cnstr_args = constructor_cumulativity_arguments (mind,ind,cns) in if not (Int.equal num_cnstr_args nargs) then - cmp_instances u1 u2 s + if Univ.Instance.equal u1 u2 then s else raise MustExpand else (** By invariant, both constructors have a common supertype, so they are convertible _at that type_. *) @@ -336,6 +339,28 @@ let is_irrelevant infos lft c = let env = info_env infos.cnv_inf in try Relevanceops.relevance_of_fterm env (info_relevances infos.cnv_inf) lft c == Sorts.Irrelevant with _ -> false +let identity_of_ctx (ctx:Constr.rel_context) = + Context.Rel.to_extended_vect mkRel 0 ctx + +(* ind -> fun args => ind args *) +let eta_expand_ind env (ind,u as pind) = + let mib = Environ.lookup_mind (fst ind) env in + let mip = mib.mind_packets.(snd ind) in + let ctx = Vars.subst_instance_context u mip.mind_arity_ctxt in + let args = identity_of_ctx ctx in + let c = mkApp (mkIndU pind, args) in + let c = Term.it_mkLambda_or_LetIn c ctx in + inject c + +let eta_expand_constructor env ((ind,ctor),u as pctor) = + let mib = Environ.lookup_mind (fst ind) env in + let mip = mib.mind_packets.(snd ind) in + let ctx = Vars.subst_instance_context u (fst mip.mind_nf_lc.(ctor-1)) in + let args = identity_of_ctx ctx in + let c = mkApp (mkConstructU pctor, args) in + let c = Term.it_mkLambda_or_LetIn c ctx in + inject c + (* Conversion between [lft1]term1 and [lft2]term2 *) let rec ccnv cv_pb l2r infos lft1 lft2 term1 term2 cuniv = try eqappr cv_pb l2r infos (lft1, (term1,[])) (lft2, (term2,[])) cuniv @@ -545,7 +570,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = end (* Inductive types: MutInd MutConstruct Fix Cofix *) - | (FInd (ind1,u1), FInd (ind2,u2)) -> + | (FInd (ind1,u1 as pind1), FInd (ind2,u2 as pind2)) -> if eq_ind ind1 ind2 then if Univ.Instance.length u1 = 0 || Univ.Instance.length u2 = 0 then let cuniv = convert_instances ~flex:false u1 u2 cuniv in @@ -556,11 +581,16 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = if not (Int.equal nargs (CClosure.stack_args_size v2)) then raise NotConvertible else - let cuniv = convert_inductives cv_pb (mind, snd ind1) nargs u1 u2 cuniv in - convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + match convert_inductives cv_pb (mind, snd ind1) nargs u1 u2 cuniv with + | cuniv -> convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + | exception MustExpand -> + let env = info_env infos.cnv_inf in + let hd1 = eta_expand_ind env pind1 in + let hd2 = eta_expand_ind env pind2 in + eqappr cv_pb l2r infos (lft1,(hd1,v1)) (lft2,(hd2,v2)) cuniv else raise NotConvertible - | (FConstruct ((ind1,j1),u1), FConstruct ((ind2,j2),u2)) -> + | (FConstruct ((ind1,j1),u1 as pctor1), FConstruct ((ind2,j2),u2 as pctor2)) -> if Int.equal j1 j2 && eq_ind ind1 ind2 then if Univ.Instance.length u1 = 0 || Univ.Instance.length u2 = 0 then let cuniv = convert_instances ~flex:false u1 u2 cuniv in @@ -571,8 +601,13 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = if not (Int.equal nargs (CClosure.stack_args_size v2)) then raise NotConvertible else - let cuniv = convert_constructors (mind, snd ind1, j1) nargs u1 u2 cuniv in - convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + match convert_constructors (mind, snd ind1, j1) nargs u1 u2 cuniv with + | cuniv -> convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + | exception MustExpand -> + let env = info_env infos.cnv_inf in + let hd1 = eta_expand_constructor env pctor1 in + let hd2 = eta_expand_constructor env pctor2 in + eqappr cv_pb l2r infos (lft1,(hd1,v1)) (lft2,(hd2,v2)) cuniv else raise NotConvertible (* Eta expansion of records *) diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 8b85072d6d..da77a2882e 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -936,12 +936,14 @@ let add_private_constant l decl senv : (Constant.t * private_constants) * safe_e | DefinitionEff ce -> Term_typing.translate_constant senv.env kn (Entries.DefinitionEntry ce) in - let senv, dcb = match cb.const_body with - | Def _ as const_body -> senv, { cb with const_body } - | OpaqueDef c -> - let local = empty_private cb.const_universes in - let senv, o = push_opaque_proof (Future.from_val (c, local)) senv in - senv, { cb with const_body = OpaqueDef o } + let dcb = match cb.const_body with + | Def _ as const_body -> { cb with const_body } + | OpaqueDef _ -> + (* We drop the body, to save the definition of an opaque and thus its + hashconsing. It does not matter since this only happens inside a proof, + and depending of the opaque status of the latter, this proof term will be + either inlined or reexported. *) + { cb with const_body = Undef None } | Undef _ | Primitive _ -> assert false in let senv = add_constant_aux senv (kn, dcb) in diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 48567aa564..24aa4ed771 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -283,8 +283,8 @@ let build_constant_declaration env result = let univs = result.cook_universes in let hyps = List.filter (fun d -> Id.Set.mem (NamedDecl.get_id d) hyps) (Environ.named_context env) in let tps = - let res = Cbytegen.compile_constant_body ~fail_on_error:false env univs def in - Option.map Cemitcodes.from_val res + let res = Vmbytegen.compile_constant_body ~fail_on_error:false env univs def in + Option.map Vmemitcodes.from_val res in { const_hyps = hyps; const_body = def; @@ -343,8 +343,8 @@ let translate_recipe env _kn r = let open Cooking in let result = Cooking.cook_constant r in let univs = result.cook_universes in - let res = Cbytegen.compile_constant_body ~fail_on_error:false env univs result.cook_body in - let tps = Option.map Cemitcodes.from_val res in + let res = Vmbytegen.compile_constant_body ~fail_on_error:false env univs result.cook_body in + let tps = Option.map Vmemitcodes.from_val res in let hyps = Option.get result.cook_context in (* Trust the set of section hypotheses generated by Cooking *) let hyps = List.filter (fun d -> Id.Set.mem (NamedDecl.get_id d) hyps) (Environ.named_context env) in diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index 927db9e9e6..52e93a9e22 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -142,6 +142,12 @@ let enforce_leq_alg u v g = | Inl x -> x | Inr e -> raise e +let enforce_leq_alg u v g = + match Universe.is_sprop u, Universe.is_sprop v with + | true, true -> Constraint.empty, g + | true, false | false, true -> raise (UniverseInconsistency (Le, u, v, None)) + | false, false -> enforce_leq_alg u v g + (* sanity check wrapper *) let enforce_leq_alg u v g = let _,g as cg = enforce_leq_alg u v g in diff --git a/kernel/vconv.ml b/kernel/vconv.ml index f78f0d4d1e..cc2c2c0b4b 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -4,7 +4,7 @@ open Environ open Reduction open Vm open Vmvalues -open Csymtable +open Vmsymtable (* Test la structure des piles *) diff --git a/kernel/vm.ml b/kernel/vm.ml index d8c66bebd2..76954a83d8 100644 --- a/kernel/vm.ml +++ b/kernel/vm.ml @@ -44,7 +44,7 @@ external coq_interprete : tcode -> values -> atom array -> vm_global -> vm_env - "coq_interprete_byte" "coq_interprete_ml" let interprete code v env k = - coq_interprete code v (get_atom_rel ()) (Csymtable.get_global_data ()) env k + coq_interprete code v (get_atom_rel ()) (Vmsymtable.get_global_data ()) env k (* Functions over arguments *) diff --git a/kernel/cbytecodes.ml b/kernel/vmbytecodes.ml index 74405a0105..74405a0105 100644 --- a/kernel/cbytecodes.ml +++ b/kernel/vmbytecodes.ml diff --git a/kernel/cbytecodes.mli b/kernel/vmbytecodes.mli index b703058fb7..b703058fb7 100644 --- a/kernel/cbytecodes.mli +++ b/kernel/vmbytecodes.mli diff --git a/kernel/cbytegen.ml b/kernel/vmbytegen.ml index bacc308e1f..1274e3a867 100644 --- a/kernel/cbytegen.ml +++ b/kernel/vmbytegen.ml @@ -15,9 +15,9 @@ open Util open Names open Vmvalues -open Cbytecodes -open Cemitcodes -open Clambda +open Vmbytecodes +open Vmemitcodes +open Vmlambda open Constr open Declarations open Environ @@ -116,7 +116,7 @@ end module FvMap = Map.Make(Fv_elem) -(*spiwack: both type have been moved from Cbytegen because I needed then +(*spiwack: both type have been moved from Vmbytegen because I needed then for the retroknowledge *) type vm_env = { size : int; (* longueur de la liste [n] *) @@ -512,7 +512,7 @@ let rec get_alias env kn = match tps with | None -> kn | Some tps -> - (match Cemitcodes.force tps with + (match Vmemitcodes.force tps with | BCalias kn' -> get_alias env kn' | _ -> kn) diff --git a/kernel/cbytegen.mli b/kernel/vmbytegen.mli index d5ea2509ef..aef7ac3d6b 100644 --- a/kernel/cbytegen.mli +++ b/kernel/vmbytegen.mli @@ -8,8 +8,8 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Cbytecodes -open Cemitcodes +open Vmbytecodes +open Vmemitcodes open Constr open Declarations open Environ diff --git a/kernel/cemitcodes.ml b/kernel/vmemitcodes.ml index ed475dca7e..2dfc9a2941 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/vmemitcodes.ml @@ -14,8 +14,8 @@ open Names open Vmvalues -open Cbytecodes -open Copcodes +open Vmbytecodes +open Vmopcodes open Mod_subst open CPrimitives @@ -350,7 +350,7 @@ let emit_instr env = function | Ksetfield n -> if n <= 1 then out env (opSETFIELD0+n) else (out env opSETFIELD;out_int env n) - | Ksequence _ -> invalid_arg "Cemitcodes.emit_instr" + | Ksequence _ -> invalid_arg "Vmemitcodes.emit_instr" | Kproj p -> out env opPROJ; out_int env (Projection.Repr.arg p); slot_for_proj_name env p | Kensurestackcapacity size -> out env opENSURESTACKCAPACITY; out_int env size | Kbranch lbl -> out env opBRANCH; out_label env lbl diff --git a/kernel/cemitcodes.mli b/kernel/vmemitcodes.mli index c4262f3380..5c0e103143 100644 --- a/kernel/cemitcodes.mli +++ b/kernel/vmemitcodes.mli @@ -9,7 +9,7 @@ (************************************************************************) open Names open Vmvalues -open Cbytecodes +open Vmbytecodes type reloc_info = | Reloc_annot of annot_switch diff --git a/kernel/clambda.ml b/kernel/vmlambda.ml index 6690a379ce..332a331a7a 100644 --- a/kernel/clambda.ml +++ b/kernel/vmlambda.ml @@ -559,8 +559,8 @@ let rec get_alias env kn = match tps with | None -> kn | Some tps -> - (match Cemitcodes.force tps with - | Cemitcodes.BCalias kn' -> get_alias env kn' + (match Vmemitcodes.force tps with + | Vmemitcodes.BCalias kn' -> get_alias env kn' | _ -> kn) (* Compilation of primitive *) @@ -681,7 +681,7 @@ open Renv let rec lambda_of_constr env c = match Constr.kind c with - | Meta _ -> raise (Invalid_argument "Cbytegen.lambda_of_constr: Meta") + | Meta _ -> raise (Invalid_argument "Vmbytegen.lambda_of_constr: Meta") | Evar (evk, args) -> let args = Array.map_of_list (fun c -> lambda_of_constr env c) args in Levar (evk, args) diff --git a/kernel/clambda.mli b/kernel/vmlambda.mli index bd11c2667f..bd11c2667f 100644 --- a/kernel/clambda.mli +++ b/kernel/vmlambda.mli diff --git a/kernel/csymtable.ml b/kernel/vmsymtable.ml index 185fb9f5a4..85f7369654 100644 --- a/kernel/csymtable.ml +++ b/kernel/vmsymtable.ml @@ -17,11 +17,11 @@ open Util open Names open Vmvalues -open Cemitcodes -open Cbytecodes +open Vmemitcodes +open Vmbytecodes open Declarations open Environ -open Cbytegen +open Vmbytegen module NamedDecl = Context.Named.Declaration module RelDecl = Context.Rel.Declaration @@ -155,7 +155,7 @@ let rec slot_for_getglobal env kn = match cb.const_body_code with | None -> set_global (val_of_constant kn) | Some code -> - match Cemitcodes.force code with + match Vmemitcodes.force code with | BCdefined(code,pl,fv) -> let v = eval_to_patch env (code,pl,fv) in set_global v diff --git a/kernel/csymtable.mli b/kernel/vmsymtable.mli index e480bfcec1..e480bfcec1 100644 --- a/kernel/csymtable.mli +++ b/kernel/vmsymtable.mli diff --git a/library/summary.ml b/library/summary.ml index 9ff707f842..221ac868fa 100644 --- a/library/summary.ml +++ b/library/summary.ml @@ -19,7 +19,8 @@ type 'a summary_declaration = { unfreeze_function : 'a -> unit; init_function : unit -> unit } -module DynMap = Dyn.Map(struct type 'a t = 'a summary_declaration end) +module Decl = struct type 'a t = 'a summary_declaration end +module DynMap = Dyn.Map(Decl) type ml_modules = (string * string option) list @@ -46,7 +47,8 @@ let declare_summary_tag sumname decl = let declare_summary sumname decl = ignore(declare_summary_tag sumname decl) -module Frozen = Dyn.Map(struct type 'a t = 'a end) +module ID = struct type 'a t = 'a end +module Frozen = Dyn.Map(ID) type frozen = { summaries : Frozen.t; @@ -57,9 +59,11 @@ type frozen = { let empty_frozen = { summaries = Frozen.empty; ml_module = None } +module HMap = Dyn.HMap(Decl)(ID) + let freeze_summaries ~marshallable : frozen = - let fold (DynMap.Any (tag, decl)) accu = Frozen.add tag (decl.freeze_function ~marshallable) accu in - { summaries = DynMap.fold fold !sum_map Frozen.empty; + let map = { HMap.map = fun tag decl -> decl.freeze_function ~marshallable } in + { summaries = HMap.map map !sum_map; ml_module = Option.map (fun decl -> decl.freeze_function ~marshallable) !sum_mod; } diff --git a/parsing/cLexer.ml b/parsing/cLexer.ml index 85640cabba..a98cf3b7de 100644 --- a/parsing/cLexer.ml +++ b/parsing/cLexer.ml @@ -710,7 +710,7 @@ let rec next_token ~diff_mode loc s = let n = NumTok.Unsigned.parse s in let ep = Stream.count s in comment_stop bp; - (NUMERAL n, set_loc_pos loc bp ep) + (NUMBER n, set_loc_pos loc bp ep) | Some '\"' -> Stream.junk s; let (loc, len) = @@ -796,8 +796,8 @@ let token_text : type c. c Tok.p -> string = function | PKEYWORD t -> "'" ^ t ^ "'" | PIDENT None -> "identifier" | PIDENT (Some t) -> "'" ^ t ^ "'" - | PNUMERAL None -> "numeral" - | PNUMERAL (Some n) -> "'" ^ NumTok.Unsigned.sprint n ^ "'" + | PNUMBER None -> "numeral" + | PNUMBER (Some n) -> "'" ^ NumTok.Unsigned.sprint n ^ "'" | PSTRING None -> "string" | PSTRING (Some s) -> "STRING \"" ^ s ^ "\"" | PLEFTQMARK -> "LEFTQMARK" @@ -891,5 +891,5 @@ let terminal s = (* Precondition: the input is a numeral (c.f. [NumTok.t]) *) let terminal_numeral s = match NumTok.Unsigned.parse_string s with - | Some n -> PNUMERAL (Some n) + | Some n -> PNUMBER (Some n) | None -> failwith "numeral token expected." diff --git a/parsing/extend.ml b/parsing/extend.ml index fadfb6c5f4..a6fa6edad5 100644 --- a/parsing/extend.ml +++ b/parsing/extend.ml @@ -21,6 +21,13 @@ type production_level = | NumLevel of int | DefaultLevel (** Interpreted differently at the border or inside a rule *) +let production_level_eq lev1 lev2 = + match lev1, lev2 with + | NextLevel, NextLevel -> true + | NumLevel n1, NumLevel n2 -> Int.equal n1 n2 + | DefaultLevel, DefaultLevel -> true + | (NextLevel | NumLevel _| DefaultLevel), _ -> false + (** User-level types used to tell how to parse or interpret of the non-terminal *) type 'a constr_entry_key_gen = @@ -59,19 +66,19 @@ type constr_prod_entry_key = (** {5 AST for user-provided entries} *) type 'a user_symbol = -| Ulist1 of 'a user_symbol -| Ulist1sep of 'a user_symbol * string -| Ulist0 of 'a user_symbol -| Ulist0sep of 'a user_symbol * string -| Uopt of 'a user_symbol -| Uentry of 'a -| Uentryl of 'a * int + | Ulist1 of 'a user_symbol + | Ulist1sep of 'a user_symbol * string + | Ulist0 of 'a user_symbol + | Ulist0sep of 'a user_symbol * string + | Uopt of 'a user_symbol + | Uentry of 'a + | Uentryl of 'a * int type ('a,'b,'c) ty_user_symbol = -| TUlist1 : ('a,'b,'c) ty_user_symbol -> ('a list,'b list,'c list) ty_user_symbol -| TUlist1sep : ('a,'b,'c) ty_user_symbol * string -> ('a list,'b list,'c list) ty_user_symbol -| TUlist0 : ('a,'b,'c) ty_user_symbol -> ('a list,'b list,'c list) ty_user_symbol -| TUlist0sep : ('a,'b,'c) ty_user_symbol * string -> ('a list,'b list,'c list) ty_user_symbol -| TUopt : ('a,'b,'c) ty_user_symbol -> ('a option, 'b option, 'c option) ty_user_symbol -| TUentry : ('a, 'b, 'c) Genarg.ArgT.tag -> ('a,'b,'c) ty_user_symbol -| TUentryl : ('a, 'b, 'c) Genarg.ArgT.tag * int -> ('a,'b,'c) ty_user_symbol + | TUlist1 : ('a,'b,'c) ty_user_symbol -> ('a list,'b list,'c list) ty_user_symbol + | TUlist1sep : ('a,'b,'c) ty_user_symbol * string -> ('a list,'b list,'c list) ty_user_symbol + | TUlist0 : ('a,'b,'c) ty_user_symbol -> ('a list,'b list,'c list) ty_user_symbol + | TUlist0sep : ('a,'b,'c) ty_user_symbol * string -> ('a list,'b list,'c list) ty_user_symbol + | TUopt : ('a,'b,'c) ty_user_symbol -> ('a option, 'b option, 'c option) ty_user_symbol + | TUentry : ('a, 'b, 'c) Genarg.ArgT.tag -> ('a,'b,'c) ty_user_symbol + | TUentryl : ('a, 'b, 'c) Genarg.ArgT.tag * int -> ('a,'b,'c) ty_user_symbol diff --git a/parsing/extend.mli b/parsing/extend.mli new file mode 100644 index 0000000000..057fdb3841 --- /dev/null +++ b/parsing/extend.mli @@ -0,0 +1,79 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +(** Entry keys for constr notations *) + +type side = Left | Right + +type production_position = + | BorderProd of side * Gramlib.Gramext.g_assoc option + | InternalProd + +type production_level = + | NextLevel + | NumLevel of int + | DefaultLevel (** Interpreted differently at the border or inside a rule *) + +val production_level_eq : production_level -> production_level -> bool + +(** User-level types used to tell how to parse or interpret of the non-terminal *) + +type 'a constr_entry_key_gen = + | ETIdent + | ETGlobal + | ETBigint + | ETBinder of bool (* open list of binders if true, closed list of binders otherwise *) + | ETConstr of Constrexpr.notation_entry * Notation_term.constr_as_binder_kind option * 'a + | ETPattern of bool * int option (* true = strict pattern, i.e. not a single variable *) + +(** Entries level (left-hand side of grammar rules) *) + +type constr_entry_key = + (production_level * production_position) constr_entry_key_gen + +(** Entries used in productions, vernac side (e.g. "x bigint" or "x ident") *) + +type simple_constr_prod_entry_key = + production_level constr_entry_key_gen + +(** Entries used in productions (in right-hand-side of grammar rules), to parse non-terminals *) + +type binder_entry_kind = ETBinderOpen | ETBinderClosed of string Tok.p list + +type binder_target = ForBinder | ForTerm + +type constr_prod_entry_key = + | ETProdName (* Parsed as a name (ident or _) *) + | ETProdReference (* Parsed as a global reference *) + | ETProdBigint (* Parsed as an (unbounded) integer *) + | ETProdConstr of Constrexpr.notation_entry * (production_level * production_position) (* Parsed as constr or pattern, or a subentry of those *) + | ETProdPattern of int (* Parsed as pattern as a binder (as subpart of a constr) *) + | ETProdConstrList of Constrexpr.notation_entry * (production_level * production_position) * string Tok.p list (* Parsed as non-empty list of constr, or subentries of those *) + | ETProdBinderList of binder_entry_kind (* Parsed as non-empty list of local binders *) + +(** {5 AST for user-provided entries} *) + +type 'a user_symbol = + | Ulist1 of 'a user_symbol + | Ulist1sep of 'a user_symbol * string + | Ulist0 of 'a user_symbol + | Ulist0sep of 'a user_symbol * string + | Uopt of 'a user_symbol + | Uentry of 'a + | Uentryl of 'a * int + +type ('a,'b,'c) ty_user_symbol = + | TUlist1 : ('a,'b,'c) ty_user_symbol -> ('a list,'b list,'c list) ty_user_symbol + | TUlist1sep : ('a,'b,'c) ty_user_symbol * string -> ('a list,'b list,'c list) ty_user_symbol + | TUlist0 : ('a,'b,'c) ty_user_symbol -> ('a list,'b list,'c list) ty_user_symbol + | TUlist0sep : ('a,'b,'c) ty_user_symbol * string -> ('a list,'b list,'c list) ty_user_symbol + | TUopt : ('a,'b,'c) ty_user_symbol -> ('a option, 'b option, 'c option) ty_user_symbol + | TUentry : ('a, 'b, 'c) Genarg.ArgT.tag -> ('a,'b,'c) ty_user_symbol + | TUentryl : ('a, 'b, 'c) Genarg.ArgT.tag * int -> ('a,'b,'c) ty_user_symbol diff --git a/parsing/g_constr.mlg b/parsing/g_constr.mlg index 61317f3ef2..1ec83c496a 100644 --- a/parsing/g_constr.mlg +++ b/parsing/g_constr.mlg @@ -258,7 +258,7 @@ GRAMMAR EXTEND Gram atomic_constr: [ [ g = global; i = univ_instance -> { CAst.make ~loc @@ CRef (g,i) } | s = sort -> { CAst.make ~loc @@ CSort s } - | n = NUMERAL-> { CAst.make ~loc @@ CPrim (Numeral (NumTok.SPlus,n)) } + | n = NUMBER-> { CAst.make ~loc @@ CPrim (Numeral (NumTok.SPlus,n)) } | s = string -> { CAst.make ~loc @@ CPrim (String s) } | "_" -> { CAst.make ~loc @@ CHole (None, IntroAnonymous, None) } | "?"; "["; id = ident; "]" -> { CAst.make ~loc @@ CHole (None, IntroIdentifier id, None) } @@ -370,7 +370,7 @@ GRAMMAR EXTEND Gram | _ -> p } | "("; p = pattern LEVEL "200"; "|" ; pl = LIST1 pattern LEVEL "200" SEP "|"; ")" -> { CAst.make ~loc @@ CPatOr (p::pl) } - | n = NUMERAL-> { CAst.make ~loc @@ CPatPrim (Numeral (NumTok.SPlus,n)) } + | n = NUMBER-> { CAst.make ~loc @@ CPatPrim (Numeral (NumTok.SPlus,n)) } | s = string -> { CAst.make ~loc @@ CPatPrim (String s) } ] ] ; fixannot: diff --git a/parsing/g_prim.mlg b/parsing/g_prim.mlg index cc59b2175b..270662b824 100644 --- a/parsing/g_prim.mlg +++ b/parsing/g_prim.mlg @@ -23,12 +23,11 @@ let my_int_of_string ?loc s = with Failure _ -> CErrors.user_err ?loc (Pp.str "This number is too large.") -let my_to_nat_string ?loc ispos s = +let my_to_nat_string ?loc s = match NumTok.Unsigned.to_nat s with | Some n -> n | None -> - let pos = if ispos then "a natural" else "an integer" in - CErrors.user_err ?loc Pp.(str "This number is not " ++ str pos ++ str " number.") + CErrors.user_err ?loc Pp.(str "This number is not an integer.") let test_pipe_closedcurly = let open Pcoq.Lookahead in @@ -127,12 +126,12 @@ GRAMMAR EXTEND Gram [ [ i = bignat -> { my_int_of_string ~loc i } ] ] ; bigint: - [ [ i = NUMERAL -> { my_to_nat_string true ~loc i } - | test_minus_nat; "-"; i = NUMERAL -> { "-" ^ my_to_nat_string ~loc false i } ] ] + [ [ i = bignat -> { i } + | test_minus_nat; "-"; i = bignat -> { "-" ^ i } ] ] ; bignat: - [ [ i = NUMERAL -> { my_to_nat_string ~loc true i } ] ] - ; + [ [ i = NUMBER -> { my_to_nat_string ~loc i } ] ] + ; bar_cbrace: [ [ test_pipe_closedcurly; "|"; "}" -> { () } ] ] ; diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 2cc16f85d5..0d74ad928c 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -64,7 +64,7 @@ struct | _ -> None let lk_nat tok n strm = match stream_nth n strm with - | Tok.NUMERAL p when NumTok.Unsigned.is_nat p -> Some (n + 1) + | Tok.NUMBER p when NumTok.Unsigned.is_nat p -> Some (n + 1) | _ -> None let rec lk_list lk_elem n strm = @@ -500,6 +500,7 @@ let with_grammar_rule_protection f x = let () = let open Stdarg in + Grammar.register0 wit_nat (Prim.natural); Grammar.register0 wit_int (Prim.integer); Grammar.register0 wit_string (Prim.string); Grammar.register0 wit_pre_ident (Prim.preident); diff --git a/parsing/tok.ml b/parsing/tok.ml index b1ceab8822..1ab7847805 100644 --- a/parsing/tok.ml +++ b/parsing/tok.ml @@ -17,7 +17,7 @@ type 'c p = | PPATTERNIDENT : string option -> string p | PIDENT : string option -> string p | PFIELD : string option -> string p - | PNUMERAL : NumTok.Unsigned.t option -> NumTok.Unsigned.t p + | PNUMBER : NumTok.Unsigned.t option -> NumTok.Unsigned.t p | PSTRING : string option -> string p | PLEFTQMARK : unit p | PBULLET : string option -> string p @@ -30,8 +30,8 @@ let pattern_strings : type c. c p -> string * string option = | PPATTERNIDENT s -> "PATTERNIDENT", s | PIDENT s -> "IDENT", s | PFIELD s -> "FIELD", s - | PNUMERAL None -> "NUMERAL", None - | PNUMERAL (Some n) -> "NUMERAL", Some (NumTok.Unsigned.sprint n) + | PNUMBER None -> "NUMBER", None + | PNUMBER (Some n) -> "NUMBER", Some (NumTok.Unsigned.sprint n) | PSTRING s -> "STRING", s | PLEFTQMARK -> "LEFTQMARK", None | PBULLET s -> "BULLET", s @@ -43,7 +43,7 @@ type t = | PATTERNIDENT of string | IDENT of string | FIELD of string - | NUMERAL of NumTok.Unsigned.t + | NUMBER of NumTok.Unsigned.t | STRING of string | LEFTQMARK | BULLET of string @@ -58,8 +58,8 @@ let equal_p (type a b) (t1 : a p) (t2 : b p) : (a, b) Util.eq option = | PPATTERNIDENT s1, PPATTERNIDENT s2 when streq s1 s2 -> Some Util.Refl | PIDENT s1, PIDENT s2 when streq s1 s2 -> Some Util.Refl | PFIELD s1, PFIELD s2 when streq s1 s2 -> Some Util.Refl - | PNUMERAL None, PNUMERAL None -> Some Util.Refl - | PNUMERAL (Some n1), PNUMERAL (Some n2) when NumTok.Unsigned.equal n1 n2 -> Some Util.Refl + | PNUMBER None, PNUMBER None -> Some Util.Refl + | PNUMBER (Some n1), PNUMBER (Some n2) when NumTok.Unsigned.equal n1 n2 -> Some Util.Refl | PSTRING s1, PSTRING s2 when streq s1 s2 -> Some Util.Refl | PLEFTQMARK, PLEFTQMARK -> Some Util.Refl | PBULLET s1, PBULLET s2 when streq s1 s2 -> Some Util.Refl @@ -73,7 +73,7 @@ let equal t1 t2 = match t1, t2 with | PATTERNIDENT s1, PATTERNIDENT s2 -> string_equal s1 s2 | IDENT s1, IDENT s2 -> string_equal s1 s2 | FIELD s1, FIELD s2 -> string_equal s1 s2 -| NUMERAL n1, NUMERAL n2 -> NumTok.Unsigned.equal n1 n2 +| NUMBER n1, NUMBER n2 -> NumTok.Unsigned.equal n1 n2 | STRING s1, STRING s2 -> string_equal s1 s2 | LEFTQMARK, LEFTQMARK -> true | BULLET s1, BULLET s2 -> string_equal s1 s2 @@ -100,7 +100,7 @@ let extract_string diff_mode = function else s | PATTERNIDENT s -> s | FIELD s -> if diff_mode then "." ^ s else s - | NUMERAL n -> NumTok.Unsigned.sprint n + | NUMBER n -> NumTok.Unsigned.sprint n | LEFTQMARK -> "?" | BULLET s -> s | QUOTATION(_,s) -> s @@ -124,15 +124,15 @@ let match_pattern (type c) (p : c p) : t -> c = let err () = raise Stream.Failure in let seq = string_equal in match p with - | PKEYWORD s -> (function KEYWORD s' when seq s s' -> s' | NUMERAL n when seq s (NumTok.Unsigned.sprint n) -> s | _ -> err ()) + | PKEYWORD s -> (function KEYWORD s' when seq s s' -> s' | NUMBER n when seq s (NumTok.Unsigned.sprint n) -> s | _ -> err ()) | PIDENT None -> (function IDENT s' -> s' | _ -> err ()) | PIDENT (Some s) -> (function (IDENT s' | KEYWORD s') when seq s s' -> s' | _ -> err ()) | PPATTERNIDENT None -> (function PATTERNIDENT s -> s | _ -> err ()) | PPATTERNIDENT (Some s) -> (function PATTERNIDENT s' when seq s s' -> s' | _ -> err ()) | PFIELD None -> (function FIELD s -> s | _ -> err ()) | PFIELD (Some s) -> (function FIELD s' when seq s s' -> s' | _ -> err ()) - | PNUMERAL None -> (function NUMERAL s -> s | _ -> err ()) - | PNUMERAL (Some n) -> let s = NumTok.Unsigned.sprint n in (function NUMERAL n' when s = NumTok.Unsigned.sprint n' -> n' | _ -> err ()) + | PNUMBER None -> (function NUMBER s -> s | _ -> err ()) + | PNUMBER (Some n) -> let s = NumTok.Unsigned.sprint n in (function NUMBER n' when s = NumTok.Unsigned.sprint n' -> n' | _ -> err ()) | PSTRING None -> (function STRING s -> s | _ -> err ()) | PSTRING (Some s) -> (function STRING s' when seq s s' -> s' | _ -> err ()) | PLEFTQMARK -> (function LEFTQMARK -> () | _ -> err ()) diff --git a/parsing/tok.mli b/parsing/tok.mli index b556194eb3..5bbb7a0013 100644 --- a/parsing/tok.mli +++ b/parsing/tok.mli @@ -15,7 +15,7 @@ type 'c p = | PPATTERNIDENT : string option -> string p | PIDENT : string option -> string p | PFIELD : string option -> string p - | PNUMERAL : NumTok.Unsigned.t option -> NumTok.Unsigned.t p + | PNUMBER : NumTok.Unsigned.t option -> NumTok.Unsigned.t p | PSTRING : string option -> string p | PLEFTQMARK : unit p | PBULLET : string option -> string p @@ -29,7 +29,7 @@ type t = | PATTERNIDENT of string | IDENT of string | FIELD of string - | NUMERAL of NumTok.Unsigned.t + | NUMBER of NumTok.Unsigned.t | STRING of string | LEFTQMARK | BULLET of string diff --git a/plugins/cc/g_congruence.mlg b/plugins/cc/g_congruence.mlg index 3920e3da75..2c91901477 100644 --- a/plugins/cc/g_congruence.mlg +++ b/plugins/cc/g_congruence.mlg @@ -22,9 +22,9 @@ DECLARE PLUGIN "cc_plugin" TACTIC EXTEND cc | [ "congruence" ] -> { congruence_tac 1000 [] } -| [ "congruence" integer(n) ] -> { congruence_tac n [] } +| [ "congruence" natural(n) ] -> { congruence_tac n [] } | [ "congruence" "with" ne_constr_list(l) ] -> { congruence_tac 1000 l } - |[ "congruence" integer(n) "with" ne_constr_list(l) ] -> +| [ "congruence" natural(n) "with" ne_constr_list(l) ] -> { congruence_tac n l } END diff --git a/plugins/extraction/big.ml b/plugins/extraction/big.ml index 19055fd425..7228f709f1 100644 --- a/plugins/extraction/big.ml +++ b/plugins/extraction/big.ml @@ -8,63 +8,61 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(** [Big] : a wrapper around ocaml [Big_int] with nicer names, +(** [Big] : a wrapper around ocaml [ZArith] with nicer names, and a few extraction-specific constructions *) -(** To be linked with [nums.(cma|cmxa)] *) +(** To be linked with [zarith] *) -open Big_int - -type big_int = Big_int.big_int +type big_int = Z.t (** The type of big integers. *) -let zero = zero_big_int +let zero = Z.zero (** The big integer [0]. *) -let one = unit_big_int +let one = Z.one (** The big integer [1]. *) -let two = big_int_of_int 2 +let two = Z.of_int 2 (** The big integer [2]. *) (** {6 Arithmetic operations} *) -let opp = minus_big_int +let opp = Z.neg (** Unary negation. *) -let abs = abs_big_int +let abs = Z.abs (** Absolute value. *) -let add = add_big_int +let add = Z.add (** Addition. *) -let succ = succ_big_int - (** Successor (add 1). *) +let succ = Z.succ +(** Successor (add 1). *) -let add_int = add_int_big_int +let add_int = Z.add (** Addition of a small integer to a big integer. *) -let sub = sub_big_int +let sub = Z.sub (** Subtraction. *) -let pred = pred_big_int +let pred = Z.pred (** Predecessor (subtract 1). *) -let mult = mult_big_int +let mult = Z.mul (** Multiplication of two big integers. *) -let mult_int = mult_int_big_int +let mult_int x y = Z.mul (Z.of_int x) y (** Multiplication of a big integer by a small integer *) -let square = square_big_int +let square x = Z.mul x x (** Return the square of the given big integer *) -let sqrt = sqrt_big_int +let sqrt = Z.sqrt (** [sqrt_big_int a] returns the integer square root of [a], that is, the largest big integer [r] such that [r * r <= a]. Raise [Invalid_argument] if [a] is negative. *) -let quomod = quomod_big_int +let quomod = Z.div_rem (** Euclidean division of two big integers. The first part of the result is the quotient, the second part is the remainder. @@ -72,18 +70,18 @@ let quomod = quomod_big_int [a = q * b + r] and [0 <= r < |b|]. Raise [Division_by_zero] if the divisor is zero. *) -let div = div_big_int +let div = Z.div (** Euclidean quotient of two big integers. This is the first result [q] of [quomod_big_int] (see above). *) -let modulo = mod_big_int +let modulo = Z.(mod) (** Euclidean modulus of two big integers. This is the second result [r] of [quomod_big_int] (see above). *) -let gcd = gcd_big_int +let gcd = Z.gcd (** Greatest common divisor of two big integers. *) -let power = power_big_int_positive_big_int +let power = Z.pow (** Exponentiation functions. Return the big integer representing the first argument [a] raised to the power [b] (the second argument). Depending @@ -92,45 +90,45 @@ let power = power_big_int_positive_big_int (** {6 Comparisons and tests} *) -let sign = sign_big_int +let sign = Z.sign (** Return [0] if the given big integer is zero, [1] if it is positive, and [-1] if it is negative. *) -let compare = compare_big_int +let compare = Z.compare (** [compare_big_int a b] returns [0] if [a] and [b] are equal, [1] if [a] is greater than [b], and [-1] if [a] is smaller than [b]. *) -let eq = eq_big_int -let le = le_big_int -let ge = ge_big_int -let lt = lt_big_int -let gt = gt_big_int +let eq = Z.equal +let le = Z.leq +let ge = Z.geq +let lt = Z.lt +let gt = Z.gt (** Usual boolean comparisons between two big integers. *) -let max = max_big_int +let max = Z.max (** Return the greater of its two arguments. *) -let min = min_big_int +let min = Z.min (** Return the smaller of its two arguments. *) (** {6 Conversions to and from strings} *) -let to_string = string_of_big_int +let to_string = Z.to_string (** Return the string representation of the given big integer, in decimal (base 10). *) -let of_string = big_int_of_string +let of_string = Z.of_string (** Convert a string to a big integer, in decimal. The string consists of an optional [-] or [+] sign, followed by one or several decimal digits. *) (** {6 Conversions to and from other numerical types} *) -let of_int = big_int_of_int +let of_int = Z.of_int (** Convert a small integer to a big integer. *) -let is_int = is_int_big_int +let is_int = Z.fits_int (** Test whether the given big integer is small enough to be representable as a small integer (type [int]) without loss of precision. On a 32-bit platform, @@ -139,7 +137,7 @@ let is_int = is_int_big_int [is_int_big_int a] returns [true] if and only if [a] is between -2{^62} and 2{^62}-1. *) -let to_int = int_of_big_int +let to_int = Z.to_int (** Convert a big integer to a small integer (type [int]). Raises [Failure "int_of_big_int"] if the big integer is not representable as a small integer. *) diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml index 4a41f4c890..d215a7673d 100644 --- a/plugins/extraction/common.ml +++ b/plugins/extraction/common.ml @@ -604,6 +604,13 @@ let pp_global k r = | Haskell -> if modular () then pp_haskell_gen k mp rls else s | Ocaml -> pp_ocaml_gen k mp rls (Some l) +(* Main name printing function for declaring a reference *) + +let pp_global_name k r = + let ls = ref_renaming (k,r) in + assert (List.length ls > 1); + List.hd ls + (* The next function is used only in Ocaml extraction...*) let pp_module mp = diff --git a/plugins/extraction/common.mli b/plugins/extraction/common.mli index 0bd9efd255..a482cfc03d 100644 --- a/plugins/extraction/common.mli +++ b/plugins/extraction/common.mli @@ -55,6 +55,7 @@ val opened_libraries : unit -> ModPath.t list type kind = Term | Type | Cons | Mod val pp_global : kind -> GlobRef.t -> string +val pp_global_name : kind -> GlobRef.t -> string val pp_module : ModPath.t -> string val top_visible_mp : unit -> ModPath.t diff --git a/plugins/extraction/dune b/plugins/extraction/dune index 0c01dcd488..d9d675fe6a 100644 --- a/plugins/extraction/dune +++ b/plugins/extraction/dune @@ -2,6 +2,6 @@ (name extraction_plugin) (public_name coq.plugins.extraction) (synopsis "Coq's extraction plugin") - (libraries num coq.plugins.ltac)) + (libraries coq.plugins.ltac)) (coq.pp (modules g_extraction)) diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index 088405da5d..6425c3111e 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -99,6 +99,8 @@ let str_global k r = let pp_global k r = str (str_global k r) +let pp_global_name k r = str (Common.pp_global k r) + let pp_modname mp = str (Common.pp_module mp) (* grammar from OCaml 4.06 manual, "Prefix and infix symbols" *) @@ -451,7 +453,7 @@ let pp_val e typ = let pp_Dfix (rv,c,t) = let names = Array.map - (fun r -> if is_inline_custom r then mt () else pp_global Term r) rv + (fun r -> if is_inline_custom r then mt () else pp_global_name Term r) rv in let rec pp init i = if i >= Array.length rv then mt () @@ -504,7 +506,7 @@ let pp_logical_ind packet = fnl () let pp_singleton kn packet = - let name = pp_global Type (GlobRef.IndRef (kn,0)) in + let name = pp_global_name Type (GlobRef.IndRef (kn,0)) in let l = rename_tvars keywords packet.ip_vars in hov 2 (str "type " ++ pp_parameters l ++ name ++ str " =" ++ spc () ++ pp_type false l (List.hd packet.ip_types.(0)) ++ fnl () ++ @@ -513,7 +515,7 @@ let pp_singleton kn packet = let pp_record kn fields ip_equiv packet = let ind = GlobRef.IndRef (kn,0) in - let name = pp_global Type ind in + let name = pp_global_name Type ind in let fieldnames = pp_fields ind fields in let l = List.combine fieldnames packet.ip_types.(0) in let pl = rename_tvars keywords packet.ip_vars in @@ -535,7 +537,7 @@ let pp_ind co kn ind = let nextkwd = fnl () ++ str "and " in let names = Array.mapi (fun i p -> if p.ip_logical then mt () else - pp_global Type (GlobRef.IndRef (kn,i))) + pp_global_name Type (GlobRef.IndRef (kn,i))) ind.ind_packets in let cnames = @@ -575,7 +577,7 @@ let pp_decl = function | Dterm (r,_,_) when is_inline_custom r -> mt () | Dind (kn,i) -> pp_mind kn i | Dtype (r, l, t) -> - let name = pp_global Type r in + let name = pp_global_name Type r in let l = rename_tvars keywords l in let ids, def = try @@ -592,7 +594,7 @@ let pp_decl = function if is_custom r then str (" = " ^ find_custom r) else pp_function (empty_env ()) a in - let name = pp_global Term r in + let name = pp_global_name Term r in pp_val name t ++ hov 0 (str "let " ++ name ++ def ++ mt ()) | Dfix (rv,defs,typs) -> pp_Dfix (rv,defs,typs) @@ -603,10 +605,10 @@ let pp_spec = function | Sind (kn,i) -> pp_mind kn i | Sval (r,t) -> let def = pp_type false [] t in - let name = pp_global Term r in + let name = pp_global_name Term r in hov 2 (str "val " ++ name ++ str " :" ++ spc () ++ def) | Stype (r,vl,ot) -> - let name = pp_global Type r in + let name = pp_global_name Type r in let l = rename_tvars keywords vl in let ids, def = try diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 743afe4177..72e6006b7e 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -483,7 +483,10 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos g = (Proofview.V82.of_tactic (intro_avoiding (Id.Set.of_list dyn_infos.rec_hyps))) ; (* Then the equation itself *) - Proofview.V82.of_tactic (intro_using heq_id) + Proofview.V82.of_tactic + (intro_using_then heq_id + (* we get the fresh name with onLastHypId *) + (fun _ -> Proofview.tclUNIT ())) ; onLastHypId (fun heq_id -> tclTHENLIST [ (* Then the new hypothesis *) @@ -1113,16 +1116,18 @@ let prove_princ_for_struct (evd : Evd.evar_map ref) interactive_proof fun_num in let first_tac : tactic = (* every operations until fix creations *) + (* names are already refreshed *) tclTHENLIST [ observe_tac "introducing params" (Proofview.V82.of_tactic - (intros_using (List.rev_map id_of_decl princ_info.params))) + (intros_mustbe_force (List.rev_map id_of_decl princ_info.params))) ; observe_tac "introducing predictes" (Proofview.V82.of_tactic - (intros_using (List.rev_map id_of_decl princ_info.predicates))) + (intros_mustbe_force + (List.rev_map id_of_decl princ_info.predicates))) ; observe_tac "introducing branches" (Proofview.V82.of_tactic - (intros_using (List.rev_map id_of_decl princ_info.branches))) + (intros_mustbe_force (List.rev_map id_of_decl princ_info.branches))) ; observe_tac "building fixes" mk_fixes ] in let intros_after_fixes : tactic = diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 253c95fa67..066ade07d2 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -414,7 +414,8 @@ let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = observe_tclTHENLIST (fun _ _ -> str "treat_case1") [ h_intros (List.rev rev_ids) - ; Proofview.V82.of_tactic (intro_using teq_id) + ; Proofview.V82.of_tactic + (intro_using_then teq_id (fun _ -> Proofview.tclUNIT ())) ; onLastHypId (fun heq -> observe_tclTHENLIST (fun _ _ -> str "treat_case2") @@ -601,7 +602,11 @@ let rec destruct_bounds_aux infos (bound, hyple, rechyps) lbounds g = (Proofview.V82.of_tactic (simplest_case (mkVar id))) [ observe_tclTHENLIST (fun _ _ -> str "") - [ Proofview.V82.of_tactic (intro_using h_id) + [ Proofview.V82.of_tactic + (intro_using_then h_id + (* We don't care about the refreshed name, + accessed only through auto? *) + (fun _ -> Proofview.tclUNIT ())) ; Proofview.V82.of_tactic (simplest_elim (mkApp (delayed_force lt_n_O, [|s_max|]))) @@ -865,7 +870,10 @@ let terminate_app_rec (f, args) expr_info continuation_tac _ g = (simplest_elim (mkApp (mkVar expr_info.ih, Array.of_list args)))) [ observe_tclTHENLIST (fun _ _ -> str "terminate_app_rec2") - [ Proofview.V82.of_tactic (intro_using rec_res_id) + [ Proofview.V82.of_tactic + (intro_using_then rec_res_id + (* refreshed name gotten from onNthHypId *) + (fun _ -> Proofview.tclUNIT ())) ; Proofview.V82.of_tactic intro ; onNthHypId 1 (fun v_bound -> onNthHypId 2 (fun v -> diff --git a/plugins/ltac/extratactics.mlg b/plugins/ltac/extratactics.mlg index 66c72a30a2..4f20e5a800 100644 --- a/plugins/ltac/extratactics.mlg +++ b/plugins/ltac/extratactics.mlg @@ -43,7 +43,7 @@ DECLARE PLUGIN "ltac_plugin" (**********************************************************************) (* replace, discriminate, injection, simplify_eq *) -(* cutrewrite, dependent rewrite *) +(* dependent rewrite *) let with_delayed_uconstr ist c tac = let flags = { @@ -203,12 +203,6 @@ TACTIC EXTEND dependent_rewrite -> { rewriteInHyp b c id } END -TACTIC EXTEND cut_rewrite -| [ "cutrewrite" orient(b) constr(eqn) ] -> { cutRewriteInConcl b eqn } -| [ "cutrewrite" orient(b) constr(eqn) "in" hyp(id) ] - -> { cutRewriteInHyp b eqn id } -END - (**********************************************************************) (* Decompose *) diff --git a/plugins/ltac/g_class.mlg b/plugins/ltac/g_class.mlg index 35c90444b1..8d197e6056 100644 --- a/plugins/ltac/g_class.mlg +++ b/plugins/ltac/g_class.mlg @@ -77,7 +77,7 @@ END (* true = All transparent, false = Opaque if possible *) VERNAC COMMAND EXTEND Typeclasses_Settings CLASSIFIED AS SIDEFF - | [ "Typeclasses" "eauto" ":=" debug(d) eauto_search_strategy(s) int_opt(depth) ] -> { + | [ "Typeclasses" "eauto" ":=" debug(d) eauto_search_strategy(s) integer_opt(depth) ] -> { set_typeclasses_debug d; Option.iter set_typeclasses_strategy s; set_typeclasses_depth depth diff --git a/plugins/ltac/g_ltac.mlg b/plugins/ltac/g_ltac.mlg index 114acaa412..78cde2cde8 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -271,7 +271,7 @@ GRAMMAR EXTEND Gram message_token: [ [ id = identref -> { MsgIdent id } | s = STRING -> { MsgString s } - | n = integer -> { MsgInt n } ] ] + | n = natural -> { MsgInt n } ] ] ; ltac_def_kind: diff --git a/plugins/ltac/g_obligations.mlg b/plugins/ltac/g_obligations.mlg index fa176482bf..a6673699af 100644 --- a/plugins/ltac/g_obligations.mlg +++ b/plugins/ltac/g_obligations.mlg @@ -88,13 +88,13 @@ let classify_obbl _ = Vernacextend.(VtStartProof (Doesn'tGuaranteeOpacity,[])) } VERNAC COMMAND EXTEND Obligations CLASSIFIED BY { classify_obbl } STATE declare_program -| [ "Obligation" integer(num) "of" ident(name) ":" lglob(t) withtac(tac) ] -> +| [ "Obligation" natural(num) "of" ident(name) ":" lglob(t) withtac(tac) ] -> { obligation (num, Some name, Some t) tac } -| [ "Obligation" integer(num) "of" ident(name) withtac(tac) ] -> +| [ "Obligation" natural(num) "of" ident(name) withtac(tac) ] -> { obligation (num, Some name, None) tac } -| [ "Obligation" integer(num) ":" lglob(t) withtac(tac) ] -> +| [ "Obligation" natural(num) ":" lglob(t) withtac(tac) ] -> { obligation (num, None, Some t) tac } -| [ "Obligation" integer(num) withtac(tac) ] -> +| [ "Obligation" natural(num) withtac(tac) ] -> { obligation (num, None, None) tac } | [ "Next" "Obligation" "of" ident(name) withtac(tac) ] -> { next_obligation (Some name) tac } @@ -102,9 +102,9 @@ VERNAC COMMAND EXTEND Obligations CLASSIFIED BY { classify_obbl } STATE declare_ END VERNAC COMMAND EXTEND Solve_Obligation CLASSIFIED AS SIDEFF STATE program -| [ "Solve" "Obligation" integer(num) "of" ident(name) "with" tactic(t) ] -> +| [ "Solve" "Obligation" natural(num) "of" ident(name) "with" tactic(t) ] -> { try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) } -| [ "Solve" "Obligation" integer(num) "with" tactic(t) ] -> +| [ "Solve" "Obligation" natural(num) "with" tactic(t) ] -> { try_solve_obligation num None (Some (Tacinterp.interp t)) } END diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 6233807016..f69fe064a7 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -831,7 +831,7 @@ let pr_goal_selector ~toplevel s = ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) h ) | TacChange (check,op,c,h) -> - let name = if check then "change_no_check" else "change" in + let name = if check then "change" else "change_no_check" in hov 1 ( primitive name ++ brk (1,1) ++ ( diff --git a/plugins/ltac/profile_ltac_tactics.mlg b/plugins/ltac/profile_ltac_tactics.mlg index eb9d9cbdce..e5309ea441 100644 --- a/plugins/ltac/profile_ltac_tactics.mlg +++ b/plugins/ltac/profile_ltac_tactics.mlg @@ -55,7 +55,7 @@ END TACTIC EXTEND show_ltac_profile | [ "show" "ltac" "profile" ] -> { tclSHOW_PROFILE ~cutoff:!Flags.profile_ltac_cutoff } -| [ "show" "ltac" "profile" "cutoff" int(n) ] -> { tclSHOW_PROFILE ~cutoff:(float_of_int n) } +| [ "show" "ltac" "profile" "cutoff" integer(n) ] -> { tclSHOW_PROFILE ~cutoff:(float_of_int n) } | [ "show" "ltac" "profile" string(s) ] -> { tclSHOW_PROFILE_TACTIC s } END @@ -74,7 +74,7 @@ END VERNAC COMMAND EXTEND ShowLtacProfile CLASSIFIED AS QUERY | [ "Show" "Ltac" "Profile" ] -> { print_results ~cutoff:!Flags.profile_ltac_cutoff } -| [ "Show" "Ltac" "Profile" "CutOff" int(n) ] -> { print_results ~cutoff:(float_of_int n) } +| [ "Show" "Ltac" "Profile" "CutOff" integer(n) ] -> { print_results ~cutoff:(float_of_int n) } END VERNAC COMMAND EXTEND ShowLtacProfileTactic CLASSIFIED AS QUERY diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index fb149071c9..a1dbf9a439 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -546,7 +546,7 @@ let rewrite_core_unif_flags = { Unification.check_applied_meta_types = true; Unification.use_pattern_unification = true; Unification.use_meta_bound_pattern_unification = true; - Unification.allowed_evars = Unification.AllowAll; + Unification.allowed_evars = Evarsolve.AllowedEvars.all; Unification.restrict_conv_on_strict_subterms = false; Unification.modulo_betaiota = false; Unification.modulo_eta = true; diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index fdebe14a23..2258201c22 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -161,27 +161,45 @@ let catching_error call_trace fail (e, info) = fail located_exc end -let update_loc ?loc (e, info) = - (e, Option.cata (Loc.add_loc info) info loc) +let update_loc loc use_finer (e, info as e') = + match loc with + | Some loc -> + if use_finer then + (* ensure loc if there is none *) + match Loc.get_loc info with + | None -> (e, Loc.add_loc info loc) + | _ -> (e, info) + else + (* override loc (because loc refers to inside of Ltac functions) *) + (e, Loc.add_loc info loc) + | None -> e' -let catch_error ?loc call_trace f x = +let catch_error_with_trace_loc loc use_finer call_trace f x = try f x with e when CErrors.noncritical e -> let e = Exninfo.capture e in - let e = update_loc ?loc e in + let e = update_loc loc use_finer e in catching_error call_trace Exninfo.iraise e -let catch_error_loc ?loc tac = - Proofview.tclOR tac (fun exn -> - let (e, info) = update_loc ?loc exn in +let catch_error_loc loc use_finer tac = + Proofview.tclORELSE tac (fun exn -> + let (e, info) = update_loc loc use_finer exn in Proofview.tclZERO ~info e) -let wrap_error ?loc tac k = +let wrap_error tac k = + if is_traced () then Proofview.tclORELSE tac k else tac + +let wrap_error_loc loc use_finer tac k = if is_traced () then Proofview.tclORELSE tac k - else catch_error_loc ?loc tac + else catch_error_loc loc use_finer tac -let catch_error_tac ?loc call_trace tac = - wrap_error ?loc +let catch_error_tac call_trace tac = + wrap_error + tac + (catching_error call_trace (fun (e, info) -> Proofview.tclZERO ~info e)) + +let catch_error_tac_loc loc use_finer call_trace tac = + wrap_error_loc loc use_finer tac (catching_error call_trace (fun (e, info) -> Proofview.tclZERO ~info e)) @@ -553,7 +571,7 @@ let interp_gen kind ist pattern_mode flags env sigma c = let loc = loc_of_glob_constr term in let trace = push_trace (loc,LtacConstrInterp (term,vars)) ist in let (evd,c) = - catch_error ?loc trace (understand_ltac flags env sigma vars kind) term + catch_error_with_trace_loc loc true trace (understand_ltac flags env sigma vars kind) term in (* spiwack: to avoid unnecessary modifications of tacinterp, as this function already use effect, I call [run] hoping it doesn't mess @@ -1066,12 +1084,12 @@ let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : Val.t Ftacti | _ -> value_interp ist >>= fun v -> return (name_vfun appl v) -and eval_tactic ist tac : unit Proofview.tactic = match tac with +and eval_tactic_ist ist tac : unit Proofview.tactic = match tac with | TacAtom {loc;v=t} -> let call = LtacAtomCall t in let trace = push_trace(loc,call) ist in Profile_ltac.do_profile "eval_tactic:2" trace - (catch_error_tac ?loc trace (interp_atomic ist t)) + (catch_error_tac_loc loc true trace (interp_atomic ist t)) | TacFun _ | TacLetIn _ | TacMatchGoal _ | TacMatch _ -> interp_tactic ist tac | TacId [] -> Proofview.tclLIFT (db_breakpoint (curr_debug ist) []) | TacId s -> @@ -1145,7 +1163,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with | TacFirst l -> Tacticals.New.tclFIRST (List.map (interp_tactic ist) l) | TacSolve l -> Tacticals.New.tclSOLVE (List.map (interp_tactic ist) l) | TacComplete tac -> Tacticals.New.tclCOMPLETE (interp_tactic ist tac) - | TacArg a -> interp_tactic ist (TacArg a) + | TacArg a -> Ftactic.run (val_interp ist tac) (fun v -> catch_error_loc a.CAst.loc false (tactic_of_value ist v)) | TacSelect (sel, tac) -> Tacticals.New.tclSELECT sel (interp_tactic ist tac) (* For extensions *) | TacAlias {loc; v=(s,l)} -> @@ -1162,7 +1180,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with ; poly ; extra = TacStore.set ist.extra f_trace trace } in val_interp ist alias.Tacenv.alias_body >>= fun v -> - Ftactic.lift (catch_error_loc ?loc (tactic_of_value ist v)) + Ftactic.lift (catch_error_loc loc false (tactic_of_value ist v)) in let tac = Ftactic.with_env interp_vars >>= fun (env, lr) -> @@ -1191,7 +1209,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with let args = Ftactic.List.map_right (fun a -> interp_tacarg ist a) l in let tac args = let name _ _ = Pptactic.pr_extend (fun v -> print_top_val () v) 0 opn args in - Proofview.Trace.name_tactic name (catch_error_tac ?loc trace (tac args ist)) + Proofview.Trace.name_tactic name (catch_error_tac_loc loc false trace (tac args ist)) in Ftactic.run args tac @@ -1225,7 +1243,7 @@ and interp_ltac_reference ?loc' mustbetac ist r : Val.t Ftactic.t = let ist = { lfun = Id.Map.empty; poly; extra } in let appl = GlbAppl[r,[]] in Profile_ltac.do_profile "interp_ltac_reference" trace ~count_call:false - (val_interp ~appl ist (Tacenv.interp_ltac r)) + (catch_error_tac_loc loc false trace (val_interp ~appl ist (Tacenv.interp_ltac r))) and interp_tacarg ist arg : Val.t Ftactic.t = match arg with @@ -1294,7 +1312,7 @@ and interp_app loc ist fv largs : Val.t Ftactic.t = ; extra = TacStore.set ist.extra f_trace [] } in Profile_ltac.do_profile "interp_app" trace ~count_call:false - (catch_error_tac ?loc trace (val_interp ist body)) >>= fun v -> + (catch_error_tac_loc loc false trace (val_interp ist body)) >>= fun v -> Ftactic.return (name_vfun (push_appl appl largs) v) end begin fun (e, info) -> @@ -1341,7 +1359,7 @@ and tactic_of_value ist vle = lfun = lfun; poly; extra = TacStore.set ist.extra f_trace []; } in - let tac = name_if_glob appl (eval_tactic ist t) in + let tac = name_if_glob appl (eval_tactic_ist ist t) in Profile_ltac.do_profile "tactic_of_value" trace (catch_error_tac trace tac) | VFun (appl,_,vmap,vars,_) -> let tactic_nm = @@ -1428,7 +1446,7 @@ and interp_match_success ist { Tactic_matching.subst ; context ; terms ; lhs } = ; poly ; extra = TacStore.set ist.extra f_trace trace } in - let tac = eval_tactic ist t in + let tac = eval_tactic_ist ist t in let dummy = VFun (appl,extract_trace ist, Id.Map.empty, [], TacId []) in catch_error_tac trace (tac <*> Ftactic.return (of_tacvalue dummy)) | _ -> Ftactic.return v @@ -1909,11 +1927,11 @@ let default_ist () = let eval_tactic t = Proofview.tclUNIT () >>= fun () -> (* delay for [default_ist] *) Proofview.tclLIFT db_initialize <*> - interp_tactic (default_ist ()) t + eval_tactic_ist (default_ist ()) t let eval_tactic_ist ist t = Proofview.tclLIFT db_initialize <*> - interp_tactic ist t + eval_tactic_ist ist t (** FFI *) @@ -1959,7 +1977,7 @@ let interp_tac_gen lfun avoid_ids debug t = let extra = TacStore.set extra f_avoid_ids avoid_ids in let ist = { lfun; poly; extra } in let ltacvars = Id.Map.domain lfun in - interp_tactic ist + eval_tactic_ist ist (intern_pure_tactic { (Genintern.empty_glob_sign env) with ltacvars } t) end @@ -2010,6 +2028,9 @@ let () = declare_uniform wit_int let () = + declare_uniform wit_nat + +let () = declare_uniform wit_bool let () = @@ -2076,7 +2097,7 @@ let () = register_interp0 wit_tactic interp let () = - let interp ist tac = interp_tactic ist tac >>= fun () -> Ftactic.return () in + let interp ist tac = eval_tactic_ist ist tac >>= fun () -> Ftactic.return () in register_interp0 wit_ltac interp let () = @@ -2103,12 +2124,11 @@ let _ = let eval lfun poly env sigma ty tac = let extra = TacStore.set TacStore.empty f_debug (get_debug ()) in let ist = { lfun; poly; extra; } in - let tac = interp_tactic ist tac in + let tac = eval_tactic_ist ist tac in (* EJGA: We should also pass the proof name if desired, for now poly seems like enough to get reasonable behavior in practice *) - let name, poly = Id.of_string "ltac_gen", poly in - let name, poly = Id.of_string "ltac_gen", poly in + let name = Id.of_string "ltac_gen" in let (c, sigma) = Proof.refine_by_tactic ~name ~poly env sigma ty tac in (EConstr.of_constr c, sigma) in diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index 9eeba614c7..148c1772bf 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -1020,10 +1020,11 @@ let lia (can_enum : bool) (prfdepth : int) sys = p) sys end; + let bnd1 = bound_monomials sys in let sys = subst sys in - let bnd = bound_monomials sys in + let bnd2 = bound_monomials sys in (* To deal with non-linear monomials *) - let sys = bnd @ saturate_by_linear_equalities sys @ sys in + let sys = bnd1 @ bnd2 @ saturate_by_linear_equalities sys @ sys in let sys' = List.map (fun ((p, o), prf) -> (cstr_of_poly (p, o), prf)) sys in xlia (List.map fst sys) can_enum reduction_equations sys' diff --git a/plugins/micromega/sos.ml b/plugins/micromega/sos.ml index 2b04bb80e2..03d2a2d233 100644 --- a/plugins/micromega/sos.ml +++ b/plugins/micromega/sos.ml @@ -80,7 +80,7 @@ let is_zero (d, v) = match v with Empty -> true | _ -> false (* Vectors. Conventionally indexed 1..n. *) (* ------------------------------------------------------------------------- *) -let vector_0 n = ((n, undefined) : vector) +let vector_0 n : vector = (n, undefined) let dim (v : vector) = fst v let vector_const c n = @@ -99,7 +99,7 @@ let vector_of_list l = (* Matrices; again rows and columns indexed from 1. *) (* ------------------------------------------------------------------------- *) -let matrix_0 (m, n) = (((m, n), undefined) : matrix) +let matrix_0 (m, n) : matrix = ((m, n), undefined) let dimensions (m : matrix) = fst m let matrix_cmul c (m : matrix) = @@ -107,7 +107,7 @@ let matrix_cmul c (m : matrix) = if c =/ Q.zero then matrix_0 (i, j) else ((i, j), mapf (fun x -> c */ x) (snd m)) -let matrix_neg (m : matrix) = ((dimensions m, mapf Q.neg (snd m)) : matrix) +let matrix_neg (m : matrix) : matrix = (dimensions m, mapf Q.neg (snd m)) let matrix_add (m1 : matrix) (m2 : matrix) = let d1 = dimensions m1 and d2 = dimensions m2 in @@ -138,7 +138,7 @@ let diagonal (v : vector) = (* Monomials. *) (* ------------------------------------------------------------------------- *) let monomial_1 = (undefined : monomial) -let monomial_var x = (x |=> 1 : monomial) +let monomial_var x : monomial = x |=> 1 let (monomial_mul : monomial -> monomial -> monomial) = combine ( + ) (fun x -> false) @@ -152,16 +152,16 @@ let monomial_variables m = dom m (* ------------------------------------------------------------------------- *) let poly_0 = (undefined : poly) let poly_isconst (p : poly) = foldl (fun a m c -> m = monomial_1 && a) true p -let poly_var x = (monomial_var x |=> Q.one : poly) +let poly_var x : poly = monomial_var x |=> Q.one let poly_const c = if c =/ Q.zero then poly_0 else monomial_1 |=> c let poly_cmul c (p : poly) = if c =/ Q.zero then poly_0 else mapf (fun x -> c */ x) p -let poly_neg (p : poly) = (mapf Q.neg p : poly) +let poly_neg (p : poly) : poly = mapf Q.neg p -let poly_add (p1 : poly) (p2 : poly) = - (combine ( +/ ) (fun x -> x =/ Q.zero) p1 p2 : poly) +let poly_add (p1 : poly) (p2 : poly) : poly = + combine ( +/ ) (fun x -> x =/ Q.zero) p1 p2 let poly_sub p1 p2 = poly_add p1 (poly_neg p2) @@ -1191,14 +1191,13 @@ let sumofsquares_general_symmetry tool pol = let diagents = end_itlist equation_add (List.map (fun i -> apply allassig (i, i)) (1 -- n)) in - let mk_matrix v = - ( ( (n, n) - , foldl - (fun m (i, j) ass -> - let c = tryapplyd ass v Q.zero in - if c =/ Q.zero then m else ((j, i) |-> c) (((i, j) |-> c) m)) - undefined allassig ) - : matrix ) + let mk_matrix v : matrix = + ( (n, n) + , foldl + (fun m (i, j) ass -> + let c = tryapplyd ass v Q.zero in + if c =/ Q.zero then m else ((j, i) |-> c) (((i, j) |-> c) m)) + undefined allassig ) in let mats = List.map mk_matrix qvars and obj = diff --git a/plugins/micromega/zify.ml b/plugins/micromega/zify.ml index 4e1f9a66ac..fa29e6080e 100644 --- a/plugins/micromega/zify.ml +++ b/plugins/micromega/zify.ml @@ -1324,9 +1324,14 @@ let do_let tac (h : Constr.named_declaration) = let env = Tacmach.New.pf_env gl in let evd = Tacmach.New.project gl in try - ignore (get_injection env evd (EConstr.of_constr ty)); - tac id.Context.binder_name (EConstr.of_constr t) - (EConstr.of_constr ty) + let x = id.Context.binder_name in + ignore + (let eq = Lazy.force eq in + find_option + (match_operator env evd eq + [|EConstr.of_constr ty; EConstr.mkVar x; EConstr.of_constr t|]) + (HConstr.find_all eq !table_cache)); + tac x (EConstr.of_constr t) (EConstr.of_constr ty) with Not_found -> Tacticals.New.tclIDTAC) let iter_let_aux tac = diff --git a/plugins/nsatz/dune b/plugins/nsatz/dune index b921c9c408..3b67ab3429 100644 --- a/plugins/nsatz/dune +++ b/plugins/nsatz/dune @@ -2,6 +2,6 @@ (name nsatz_plugin) (public_name coq.plugins.nsatz) (synopsis "Coq's nsatz solver plugin") - (libraries num coq.plugins.ltac)) + (libraries coq.plugins.ltac)) (coq.pp (modules g_nsatz)) diff --git a/plugins/nsatz/ideal.ml b/plugins/nsatz/ideal.ml index 387145a5d0..cbc1773ede 100644 --- a/plugins/nsatz/ideal.ml +++ b/plugins/nsatz/ideal.ml @@ -153,8 +153,8 @@ end module Make (P:Polynom.S) = struct type coef = P.t - let coef0 = P.of_num (Num.Int 0) - let coef1 = P.of_num (Num.Int 1) + let coef0 = P.of_num Q.zero + let coef1 = P.of_num Q.one let string_of_coef c = "["^(P.to_string c)^"]" (*********************************************************************** @@ -305,7 +305,7 @@ let mult_t_pol a m p = let map (b, m') = (P.multP a b, mult_mon m m') in CList.map map p -let coef_of_int x = P.of_num (Num.Int x) +let coef_of_int x = P.of_num (Q.of_int x) (* variable i *) let gen d i = diff --git a/plugins/nsatz/nsatz.ml b/plugins/nsatz/nsatz.ml index 29d08fb4ea..f3021f4ee6 100644 --- a/plugins/nsatz/nsatz.ml +++ b/plugins/nsatz/nsatz.ml @@ -13,30 +13,20 @@ open Util open Constr open Tactics -open Num open Utile (*********************************************************************** Operations on coefficients *) -let num_0 = Int 0 -and num_1 = Int 1 -and num_2 = Int 2 - -let numdom r = - let r' = Ratio.normalize_ratio (ratio_of_num r) in - num_of_big_int(Ratio.numerator_ratio r'), - num_of_big_int(Ratio.denominator_ratio r') - module BigInt = struct - open Big_int + open Big_int_Z type t = big_int let of_int = big_int_of_int let coef0 = of_int 0 - let of_num = Num.big_int_of_num - let to_num = Num.num_of_big_int + let of_num = Q.to_bigint + let to_num = Q.of_bigint let equal = eq_big_int let lt = lt_big_int let le = le_big_int @@ -113,7 +103,7 @@ type vname = string type term = | Zero - | Const of Num.num + | Const of Q.t | Var of vname | Opp of term | Add of term * term @@ -122,7 +112,7 @@ type term = | Pow of term * int let const n = - if eq_num n num_0 then Zero else Const n + if Q.(equal zero) n then Zero else Const n let pow(p,i) = if Int.equal i 1 then p else Pow(p,i) let add = function (Zero,q) -> q @@ -131,8 +121,8 @@ let add = function let mul = function (Zero,_) -> Zero | (_,Zero) -> Zero - | (p,Const n) when eq_num n num_1 -> p - | (Const n,q) when eq_num n num_1 -> q + | (p,Const n) when Q.(equal one) n -> p + | (Const n,q) when Q.(equal one) n -> q | (p,q) -> Mul(p,q) let gen_constant n = lazy (UnivGen.constr_of_monomorphic_global (Coqlib.lib_ref n)) @@ -167,62 +157,64 @@ let mkt_app name l = mkApp (Lazy.force name, Array.of_list l) let tlp () = mkt_app tlist [mkt_app tpexpr [Lazy.force tz]] let tllp () = mkt_app tlist [tlp()] -let rec mkt_pos n = - if n =/ num_1 then Lazy.force pxH - else if mod_num n num_2 =/ num_0 then - mkt_app pxO [mkt_pos (quo_num n num_2)] +let mkt_pos n = + let rec mkt_pos n = + if Z.(equal one) n then Lazy.force pxH + else if Z.is_even n then + mkt_app pxO [mkt_pos Z.(n asr 1)] else - mkt_app pxI [mkt_pos (quo_num n num_2)] + mkt_app pxI [mkt_pos Z.(n asr 1)] + in mkt_pos (Q.to_bigint n) let mkt_n n = - if Num.eq_num n num_0 + if Q.(equal zero) n then Lazy.force nN0 else mkt_app nNpos [mkt_pos n] let mkt_z z = - if z =/ num_0 then Lazy.force z0 - else if z >/ num_0 then + if Q.(equal zero) z then Lazy.force z0 + else if Q.(lt zero) z then mkt_app zpos [mkt_pos z] else - mkt_app zneg [mkt_pos ((Int 0) -/ z)] + mkt_app zneg [mkt_pos (Q.neg z)] let rec mkt_term t = match t with -| Zero -> mkt_term (Const num_0) -| Const r -> let (n,d) = numdom r in - mkt_app ttconst [Lazy.force tz; mkt_z n] -| Var v -> mkt_app ttvar [Lazy.force tz; mkt_pos (num_of_string v)] +| Zero -> mkt_term (Const Q.zero) +| Const r -> let n = r |> Q.num |> Q.of_bigint in + mkt_app ttconst [Lazy.force tz; mkt_z n] +| Var v -> mkt_app ttvar [Lazy.force tz; mkt_pos (Q.of_string v)] | Opp t1 -> mkt_app ttopp [Lazy.force tz; mkt_term t1] | Add (t1,t2) -> mkt_app ttadd [Lazy.force tz; mkt_term t1; mkt_term t2] | Sub (t1,t2) -> mkt_app ttsub [Lazy.force tz; mkt_term t1; mkt_term t2] | Mul (t1,t2) -> mkt_app ttmul [Lazy.force tz; mkt_term t1; mkt_term t2] | Pow (t1,n) -> if Int.equal n 0 then - mkt_app ttconst [Lazy.force tz; mkt_z num_1] + mkt_app ttconst [Lazy.force tz; mkt_z Q.one] else - mkt_app ttpow [Lazy.force tz; mkt_term t1; mkt_n (num_of_int n)] + mkt_app ttpow [Lazy.force tz; mkt_term t1; mkt_n (Q.of_int n)] let rec parse_pos p = match Constr.kind p with | App (a,[|p2|]) -> - if Constr.equal a (Lazy.force pxO) then num_2 */ (parse_pos p2) - else num_1 +/ (num_2 */ (parse_pos p2)) -| _ -> num_1 + if Constr.equal a (Lazy.force pxO) then Q.(mul (of_int 2)) (parse_pos p2) + else Q.(add one) Q.(mul (of_int 2) (parse_pos p2)) +| _ -> Q.one let parse_z z = match Constr.kind z with | App (a,[|p2|]) -> - if Constr.equal a (Lazy.force zpos) then parse_pos p2 else (num_0 -/ (parse_pos p2)) -| _ -> num_0 + if Constr.equal a (Lazy.force zpos) then parse_pos p2 else Q.neg (parse_pos p2) +| _ -> Q.zero let parse_n z = match Constr.kind z with | App (a,[|p2|]) -> parse_pos p2 -| _ -> num_0 +| _ -> Q.zero let rec parse_term p = match Constr.kind p with | App (a,[|_;p2|]) -> - if Constr.equal a (Lazy.force ttvar) then Var (string_of_num (parse_pos p2)) + if Constr.equal a (Lazy.force ttvar) then Var (Q.to_string (parse_pos p2)) else if Constr.equal a (Lazy.force ttconst) then Const (parse_z p2) else if Constr.equal a (Lazy.force ttopp) then Opp (parse_term p2) else Zero @@ -231,7 +223,7 @@ let rec parse_term p = else if Constr.equal a (Lazy.force ttsub) then Sub (parse_term p2, parse_term p3) else if Constr.equal a (Lazy.force ttmul) then Mul (parse_term p2, parse_term p3) else if Constr.equal a (Lazy.force ttpow) then - Pow (parse_term p2, int_of_num (parse_n p3)) + Pow (parse_term p2, Q.to_int (parse_n p3)) else Zero | _ -> Zero @@ -278,7 +270,7 @@ let term_pol_sparse nvars np t= match t with | Zero -> zeroP | Const r -> - if Num.eq_num r num_0 + if Q.(equal zero) r then zeroP else polconst d (Poly.Pint (Coef.of_num r)) | Var v -> @@ -316,7 +308,7 @@ let pol_sparse_to_term n2 p = let p = PIdeal.repr p in let rec aux p = match p with - [] -> const (num_of_string "0") + [] -> const Q.zero | (a,m)::p1 -> let m = Ideal.Monomial.repr m in let n = (Array.length m)-1 in @@ -443,8 +435,9 @@ let expand_pol lb lp = let theoremedeszeros_termes lp = let nvars = List.fold_left set_nvars_term 0 lp in match lp with - | Const (Int sugarparam)::Const (Int nparam)::lp -> - ((match sugarparam with + | Const sugarparam :: Const nparam :: lp -> + let nparam = Q.to_int nparam in + ((match Q.to_int sugarparam with |0 -> sinfo "computation without sugar"; lexico:=false; |1 -> sinfo "computation with sugar"; diff --git a/plugins/nsatz/polynom.ml b/plugins/nsatz/polynom.ml index 726ad54cad..2565d88b13 100644 --- a/plugins/nsatz/polynom.ml +++ b/plugins/nsatz/polynom.ml @@ -30,7 +30,7 @@ module type Coef = sig val pgcd : t -> t -> t val hash : t -> int - val of_num : Num.num -> t + val of_num : Q.t -> t val to_string : t -> string end @@ -39,7 +39,7 @@ module type S = sig type variable = int type t = Pint of coef | Prec of variable * t array - val of_num : Num.num -> t + val of_num : Q.t -> t val x : variable -> t val monome : variable -> int -> t val is_constantP : t -> bool @@ -106,7 +106,7 @@ end module Make (C:Coef) = struct type coef = C.t -let coef_of_int i = C.of_num (Num.Int i) +let coef_of_int i = C.of_num (Q.of_int i) let coef0 = coef_of_int 0 let coef1 = coef_of_int 1 @@ -125,8 +125,8 @@ type t = (* constant polynomials *) let of_num x = Pint (C.of_num x) -let cf0 = of_num (Num.Int 0) -let cf1 = of_num (Num.Int 1) +let cf0 = of_num Q.zero +let cf1 = of_num Q.one (* nth variable *) let x n = Prec (n,[|cf0;cf1|]) diff --git a/plugins/nsatz/polynom.mli b/plugins/nsatz/polynom.mli index 3807a8582b..91f1bcda90 100644 --- a/plugins/nsatz/polynom.mli +++ b/plugins/nsatz/polynom.mli @@ -26,7 +26,7 @@ module type Coef = sig val pgcd : t -> t -> t val hash : t -> int - val of_num : Num.num -> t + val of_num : Q.t -> t val to_string : t -> string end @@ -35,7 +35,7 @@ module type S = sig type variable = int type t = Pint of coef | Prec of variable * t array - val of_num : Num.num -> t + val of_num : Q.t -> t val x : variable -> t val monome : variable -> int -> t val is_constantP : t -> bool diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 3ba6365783..4f7b3fbe74 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -32,7 +32,22 @@ open Tactypes open Context.Named.Declaration module NamedDecl = Context.Named.Declaration -module OmegaSolver = Omega.MakeOmegaSolver (Bigint) + +module ZOmega = struct + type bigint = Z.t + let equal = Z.equal + let less_than = Z.lt + let add = Z.add + let sub = Z.sub + let mult = Z.mul + let euclid = Z.div_rem + let neg = Z.neg + let zero = Z.zero + let one = Z.one + let to_string = Z.to_string +end + +module OmegaSolver = Omega.MakeOmegaSolver (ZOmega) open OmegaSolver (* Added by JCF, 09/03/98 *) @@ -719,7 +734,7 @@ let rec shuffle p (t1,t2) = Oplus(l2,t') else [],Oplus(t1,t2) | Oz t1,Oz t2 -> - [focused_simpl p], Oz(Bigint.add t1 t2) + [focused_simpl p], Oz(Z.add t1 t2) | t1,t2 -> if weight t1 < weight t2 then [clever_rewrite p [[P_APP 1];[P_APP 2]] @@ -741,7 +756,7 @@ let shuffle_mult p_init k1 e1 k2 e2 = [P_APP 2; P_APP 2]] (Lazy.force coq_fast_OMEGA10) in - if Bigint.add (Bigint.mult k1 c1) (Bigint.mult k2 c2) =? zero then + if Z.add (Z.mul k1 c1) (Z.mul k2 c2) =? zero then let tac' = clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] (Lazy.force coq_fast_Zred_factor5) in @@ -798,7 +813,7 @@ let shuffle_mult_right p_init e1 k2 e2 = [P_APP 2; P_APP 2]] (Lazy.force coq_fast_OMEGA15) in - if Bigint.add c1 (Bigint.mult k2 c2) =? zero then + if Z.add c1 (Z.mul k2 c2) =? zero then let tac' = clever_rewrite p [[P_APP 1;P_APP 1];[P_APP 2]] (Lazy.force coq_fast_Zred_factor5) @@ -1004,7 +1019,7 @@ let reduce_factor p = function | Otimes(Oatom v,c) -> let rec compute = function | Oz n -> n - | Oplus(t1,t2) -> Bigint.add (compute t1) (compute t2) + | Oplus(t1,t2) -> Z.add (compute t1) (compute t2) | _ -> CErrors.user_err Pp.(str "condense.1") in [focused_simpl (P_APP 2 :: p)], Otimes(Oatom v,Oz(compute c)) @@ -1055,6 +1070,9 @@ let rec clear_zero p = function let tac,t = clear_zero (P_APP 2 :: p) r in tac,Oplus(f,t) | t -> [],t +open Proofview +open Proofview.Notations + let replay_history tactic_normalisation = let aux = Id.of_string "auxiliary" in let aux1 = Id.of_string "auxiliary_1" in @@ -1085,8 +1103,8 @@ let replay_history tactic_normalisation = mk_integer k; mkVar id1; mkVar id2 |])]; mk_then tac; - (intros_using [aux]); - resolve_id aux; + intro_using_then aux (fun aux -> + resolve_id aux); reflexivity ] | CONTRADICTION (e1,e2) :: l -> @@ -1128,24 +1146,25 @@ let replay_history tactic_normalisation = tclTHENS (cut state_eg) [ tclTHENS - (tclTHENLIST [ - (intros_using [aux]); - (generalize_tac - [mkApp (Lazy.force coq_OMEGA1, - [| eq1; rhs; mkVar aux; mkVar id |])]); - (clear [aux;id]); - (intros_using [id]); - (cut (mk_gt kk dd)) ]) + (intro_using_then aux (fun aux -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_OMEGA1, + [| eq1; rhs; mkVar aux; mkVar id |])]); + (clear [aux;id]); + (intro_mustbe_force id); + (cut (mk_gt kk dd)) ])) [ tclTHENS (cut (mk_gt kk izero)) - [ tclTHENLIST [ - (intros_using [aux1; aux2]); + [ intro_using_then aux1 (fun aux1 -> + intro_using_then aux2 (fun aux2 -> + tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_Zmult_le_approx, [| kk;eq2;dd;mkVar aux1;mkVar aux2; mkVar id |])]); (clear [aux1;aux2;id]); - (intros_using [id]); - (loop l) ]; + (intro_mustbe_force id); + (loop l) ])); tclTHENLIST [ (unfold sp_Zgt); simpl_in_concl; @@ -1156,7 +1175,7 @@ let replay_history tactic_normalisation = | NOT_EXACT_DIVIDE (e1,k) :: l -> let c = floor_div e1.constant k in - let d = Bigint.sub e1.constant (Bigint.mult c k) in + let d = Z.sub e1.constant (Z.mul c k) in let e2 = {id=e1.id; kind=EQUA;constant = c; body = map_eq_linear (fun c -> c / k) e1.body } in let eq2 = val_of(decompile e2) in @@ -1166,21 +1185,24 @@ let replay_history tactic_normalisation = tclTHENS (cut (mk_gt dd izero)) [ tclTHENS (cut (mk_gt kk dd)) - [tclTHENLIST [ - (intros_using [aux2;aux1]); - (generalize_tac - [mkApp (Lazy.force coq_OMEGA4, - [| dd;kk;eq2;mkVar aux1; mkVar aux2 |])]); - (clear [aux1;aux2]); - unfold sp_not; - (intros_using [aux]); - resolve_id aux; - mk_then tac; - assumption ] ; - tclTHENLIST [ - unfold sp_Zgt; - simpl_in_concl; - reflexivity ] ]; + [ intro_using_then aux2 (fun aux2 -> + intro_using_then aux1 (fun aux1 -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_OMEGA4, + [| dd;kk;eq2;mkVar aux1; mkVar aux2 |])]); + (clear [aux1;aux2]); + unfold sp_not; + intro_using_then aux (fun aux -> + tclTHENLIST [ + resolve_id aux; + mk_then tac; + assumption + ])])) ; + tclTHENLIST [ + unfold sp_Zgt; + simpl_in_concl; + reflexivity ] ]; tclTHENLIST [ unfold sp_Zgt; simpl_in_concl; @@ -1196,29 +1218,30 @@ let replay_history tactic_normalisation = let tac = scalar_norm [P_APP 3] e2.body in tclTHENS (cut state_eq) - [tclTHENLIST [ - (intros_using [aux1]); - (generalize_tac - [mkApp (Lazy.force coq_OMEGA18, - [| eq1;eq2;kk;mkVar aux1; mkVar id |])]); - (clear [aux1;id]); - (intros_using [id]); - (loop l) ]; - tclTHEN (mk_then tac) reflexivity ] + [ intro_using_then aux1 (fun aux1 -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_OMEGA18, + [| eq1;eq2;kk;mkVar aux1; mkVar id |])]); + (clear [aux1;id]); + (intro_mustbe_force id); + (loop l) ]); + tclTHEN (mk_then tac) reflexivity ] else let tac = scalar_norm [P_APP 3] e2.body in tclTHENS (cut state_eq) [ tclTHENS (cut (mk_gt kk izero)) - [tclTHENLIST [ - (intros_using [aux2;aux1]); - (generalize_tac + [ intro_using_then aux2 (fun aux2 -> + intro_using_then aux1 (fun aux1 -> + tclTHENLIST [ + (generalize_tac [mkApp (Lazy.force coq_OMEGA3, [| eq1; eq2; kk; mkVar aux2; mkVar aux1;mkVar id|])]); (clear [aux1;aux2;id]); - (intros_using [id]); - (loop l) ]; + (intro_mustbe_force id); + (loop l) ])); tclTHENLIST [ unfold sp_Zgt; simpl_in_concl; @@ -1238,13 +1261,13 @@ let replay_history tactic_normalisation = in tclTHENS (cut (mk_eq eq1 (mk_inv eq2))) - [tclTHENLIST [ - (intros_using [aux]); - (generalize_tac [mkApp (Lazy.force coq_OMEGA8, - [| eq1;eq2;mkVar id1;mkVar id2; mkVar aux|])]); - (clear [id1;id2;aux]); - (intros_using [id]); - (loop l) ]; + [ intro_using_then aux (fun aux -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_OMEGA8, [| eq1;eq2;mkVar id1;mkVar id2; mkVar aux|])]); + (clear [id1;id2;aux]); + (intro_mustbe_force id); + (loop l) ]); tclTHEN (mk_then tac) reflexivity] | STATE {st_new_eq=e;st_def=def;st_orig=orig;st_coef=m;st_var=v} :: l -> @@ -1271,18 +1294,19 @@ let replay_history tactic_normalisation = orig.body m ({c= negone;v= v}::def.body) in tclTHENS (cut theorem) - [tclTHENLIST [ - (intros_using [aux]); - (elim_id aux); - (clear [aux]); - (intros_using [vid; aux]); - (generalize_tac + [ tclTHENLIST [ intro_using_then aux (fun aux -> + (elim_id aux) <*> + (clear [aux])); + intro_using_then vid (fun vid -> + intro_using_then aux (fun aux -> + tclTHENLIST [ + (generalize_tac [mkApp (Lazy.force coq_OMEGA9, [| mkVar vid;eq2;eq1;mm; mkVar id2;mkVar aux |])]); mk_then tac; (clear [aux]); - (intros_using [id]); - (loop l) ]; + (intro_mustbe_force id); + (loop l) ]))]; tclTHEN (exists_tac eq1) reflexivity ] | SPLIT_INEQ(e,(e1,act1),(e2,act2)) :: l -> let id1 = new_identifier () @@ -1294,8 +1318,8 @@ let replay_history tactic_normalisation = let eq = val_of(decompile e) in tclTHENS (simplest_elim (applist (Lazy.force coq_OMEGA19, [eq; mkVar id]))) - [tclTHENLIST [ mk_then tac1; (intros_using [id1]); (loop act1) ]; - tclTHENLIST [ mk_then tac2; (intros_using [id2]); (loop act2) ]] + [tclTHENLIST [ mk_then tac1; (intro_mustbe_force id1); (loop act1) ]; + tclTHENLIST [ mk_then tac2; (intro_mustbe_force id2); (loop act2) ]] | SUM(e3,(k1,e1),(k2,e2)) :: l -> let id = new_identifier () in tag_hypothesis id e3; @@ -1318,7 +1342,7 @@ let replay_history tactic_normalisation = (generalize_tac [mkApp (tac_thm, [| eq1; eq2; kk; mkVar id1; mkVar id2 |])]); mk_then tac; - (intros_using [id]); + (intro_mustbe_force id); (loop l) ] else @@ -1329,25 +1353,26 @@ let replay_history tactic_normalisation = tclTHENS (cut (mk_gt kk1 izero)) [tclTHENS (cut (mk_gt kk2 izero)) - [tclTHENLIST [ - (intros_using [aux2;aux1]); - (generalize_tac - [mkApp (Lazy.force coq_OMEGA7, [| - eq1;eq2;kk1;kk2; - mkVar aux1;mkVar aux2; - mkVar id1;mkVar id2 |])]); - (clear [aux1;aux2]); - mk_then tac; - (intros_using [id]); - (loop l) ]; - tclTHENLIST [ - unfold sp_Zgt; - simpl_in_concl; - reflexivity ] ]; - tclTHENLIST [ - unfold sp_Zgt; - simpl_in_concl; - reflexivity ] ] + [ intro_using_then aux2 (fun aux2 -> + intro_using_then aux1 (fun aux1 -> + tclTHENLIST [ + (generalize_tac + [mkApp (Lazy.force coq_OMEGA7, [| + eq1;eq2;kk1;kk2; + mkVar aux1;mkVar aux2; + mkVar id1;mkVar id2 |])]); + (clear [aux1;aux2]); + mk_then tac; + (intro_mustbe_force id); + (loop l) ])); + tclTHENLIST [ + unfold sp_Zgt; + simpl_in_concl; + reflexivity ] ]; + tclTHENLIST [ + unfold sp_Zgt; + simpl_in_concl; + reflexivity ] ] | CONSTANT_NOT_NUL(e,k) :: l -> tclTHEN ((generalize_tac [mkVar (hyp_of_tag e)])) Equality.discrConcl | CONSTANT_NUL(e) :: l -> @@ -1358,9 +1383,8 @@ let replay_history tactic_normalisation = unfold sp_Zle; simpl_in_concl; unfold sp_not; - (intros_using [aux]); - resolve_id aux; - reflexivity + intro_using_then aux (fun aux -> + resolve_id aux <*> reflexivity) ] | _ -> Proofview.tclUNIT () in @@ -1382,7 +1406,7 @@ let normalize_equation sigma id flag theorem pos t t1 t2 (tactic,defs) = in if not (List.is_empty tac) then let id' = new_identifier () in - ((id',(tclTHENLIST [ shift_left; mk_then tac; (intros_using [id']) ])) + ((id',(tclTHENLIST [ shift_left; mk_then tac; (intro_mustbe_force id') ])) :: tactic, compile id' flag t' :: defs) else @@ -1423,10 +1447,7 @@ let destructure_omega env sigma tac_def (id,c) = let reintroduce id = (* [id] cannot be cleared if dependent: protect it by a try *) - tclTHEN (tclTRY (clear [id])) (intro_using id) - - -open Proofview.Notations + tclTHEN (tclTRY (clear [id])) (intro_using_then id (fun _ -> tclUNIT())) let coq_omega = Proofview.Goal.enter begin fun gl -> @@ -1444,10 +1465,10 @@ let coq_omega = tag_hypothesis id i; (tclTHENLIST [ (simplest_elim (applist (Lazy.force coq_intro_Z, [t]))); - (intros_using [v; id]); + (intros_mustbe_force [v; id]); (elim_id id); (clear [id]); - (intros_using [th;id]); + (intros_mustbe_force [th;id]); tac ]), {kind = INEQ; body = [{v=intern_id v; c=one}]; @@ -1455,7 +1476,7 @@ let coq_omega = else (tclTHENLIST [ (simplest_elim (applist (Lazy.force coq_new_var, [t]))); - (intros_using [v;th]); + (intros_mustbe_force [v;th]); tac ]), sys) (Proofview.tclUNIT (),[]) (dump_tables ()) @@ -1508,7 +1529,7 @@ let nat_inject = tclTHENS (tclTHEN (simplest_elim (applist (Lazy.force coq_le_gt_dec, [t2;t1]))) - (intros_using [id])) + (intro_mustbe_force id)) [ tclTHENLIST [ (clever_rewrite_gen p @@ -1703,7 +1724,7 @@ let onClearedName2 id tac = (tclTRY (clear [id])) (Proofview.Goal.enter begin fun gl -> let id1 = fresh_id Id.Set.empty (add_suffix id "_left") gl in - let id2 = fresh_id Id.Set.empty (add_suffix id "_right") gl in + let id2 = fresh_id (Id.Set.singleton id1) (add_suffix id "_right") gl in tclTHENLIST [ introduction id1; introduction id2; tac id1 id2 ] end) diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 95faede7d0..6ed6b8da91 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -146,17 +146,21 @@ let ic_unsafe c = (*FIXME remove *) let sigma = Evd.from_env env in fst (Constrintern.interp_constr env sigma c) -let decl_constant na univs c = +let decl_constant name univs c = let open Constr in let vars = CVars.universes_of_constr c in let univs = UState.restrict_universe_context ~lbound:(Global.universes_lbound ()) univs vars in let () = DeclareUctx.declare_universe_context ~poly:false univs in let types = (Typeops.infer (Global.env ()) c).uj_type in let univs = Monomorphic_entry Univ.ContextSet.empty in - mkConst(declare_constant ~name:(Id.of_string na) + mkConst(declare_constant ~name ~kind:Decls.(IsProof Lemma) (DefinitionEntry (definition_entry ~opaque:true ~types ~univs c))) +let decl_constant na suff univs c = + let na = Namegen.next_global_ident_away (Nameops.add_suffix na suff) Id.Set.empty in + decl_constant na univs c + (* Calling a global tactic *) let ltac_call tac (args:glob_tactic_arg list) = TacArg(CAst.make @@ TacCall (CAst.make (ArgArg(Loc.tag @@ Lazy.force tac),args))) @@ -581,9 +585,9 @@ let add_theory0 name (sigma, rth) eqth morphth cst_tac (pre,post) power sign div let lemma2 = params.(4) in let lemma1 = - decl_constant (Id.to_string name^"_ring_lemma1") ctx lemma1 in + decl_constant name "_ring_lemma1" ctx lemma1 in let lemma2 = - decl_constant (Id.to_string name^"_ring_lemma2") ctx lemma2 in + decl_constant name "_ring_lemma2" ctx lemma2 in let cst_tac = interp_cst_tac env sigma morphth kind (zero,one,add,mul,opp) cst_tac in let pretac = @@ -898,15 +902,15 @@ let add_field_theory0 name fth eqth morphth cst_tac inj (pre,post) power sign od match inj with | Some thm -> mkApp(params.(8),[|EConstr.to_constr sigma thm|]) | None -> params.(7) in - let lemma1 = decl_constant (Id.to_string name^"_field_lemma1") + let lemma1 = decl_constant name "_field_lemma1" ctx lemma1 in - let lemma2 = decl_constant (Id.to_string name^"_field_lemma2") + let lemma2 = decl_constant name "_field_lemma2" ctx lemma2 in - let lemma3 = decl_constant (Id.to_string name^"_field_lemma3") + let lemma3 = decl_constant name "_field_lemma3" ctx lemma3 in - let lemma4 = decl_constant (Id.to_string name^"_field_lemma4") + let lemma4 = decl_constant name "_field_lemma4" ctx lemma4 in - let cond_lemma = decl_constant (Id.to_string name^"_lemma5") + let cond_lemma = decl_constant name "_lemma5" ctx cond_lemma in let cst_tac = interp_cst_tac env sigma morphth kind (zero,one,add,mul,opp) cst_tac in diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 1b7768852e..d859fe51ab 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -1047,7 +1047,7 @@ let refine_with ?(first_goes_last=false) ?beta ?(with_evars=true) oc = let uct = Evd.evar_universe_context (fst oc) in let n, oc = abs_evars_pirrel env sigma (fst oc, EConstr.to_constr ~abort_on_undefined_evars:false (fst oc) (snd oc)) in Proofview.Unsafe.tclEVARS (Evd.set_universe_context sigma uct) <*> - Proofview.tclOR (applyn ~with_evars ~first_goes_last ~with_shelve:true ?beta n (EConstr.of_constr oc)) + Proofview.tclORELSE (applyn ~with_evars ~first_goes_last ~with_shelve:true ?beta n (EConstr.of_constr oc)) (fun _ -> Proofview.tclZERO dependent_apply_error) end @@ -1352,7 +1352,7 @@ let unsafe_intro env decl b = Refine.refine ~typecheck:false begin fun sigma -> let ctx = Environ.named_context_val env in let nctx = EConstr.push_named_context_val decl ctx in - let inst = List.map (get_id %> EConstr.mkVar) (Environ.named_context env) in + let inst = EConstr.identity_subst_val (Environ.named_context_val env) in let ninst = EConstr.mkRel 1 :: inst in let nb = EConstr.Vars.subst1 (EConstr.mkVar (get_id decl)) b in let sigma, ev = Evarutil.new_pure_evar ~principal:true nctx sigma nb in diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index 1c81fbc10b..582c45cde1 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -478,24 +478,34 @@ let revtoptac n0 = Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let concl = Proofview.Goal.concl gl in + let env = Proofview.Goal.env gl in let n = nb_prod sigma concl - n0 in let dc, cl = EConstr.decompose_prod_n_assum sigma n concl in - let dc' = dc @ [Context.Rel.Declaration.LocalAssum(make_annot (Name rev_id) Sorts.Relevant, EConstr.it_mkProd_or_LetIn cl (List.rev dc))] in - let f = EConstr.it_mkLambda_or_LetIn (mkEtaApp (EConstr.mkRel (n + 1)) (-n) 1) dc' in - Logic.refiner ~check:true EConstr.Unsafe.(to_constr (EConstr.mkApp (f, [|Evarutil.mk_new_meta ()|]))) + let ty = EConstr.it_mkProd_or_LetIn cl (List.rev dc) in + let dc' = dc @ [Context.Rel.Declaration.LocalAssum(make_annot (Name rev_id) Sorts.Relevant, ty)] in + Refine.refine ~typecheck:true begin fun sigma -> + let f = EConstr.it_mkLambda_or_LetIn (mkEtaApp (EConstr.mkRel (n + 1)) (-n) 1) dc' in + let sigma, ev = Evarutil.new_evar env sigma ty in + sigma, (EConstr.mkApp (f, [|ev|])) + end end -let equality_inj l b id c = - Proofview.V82.tactic begin fun gl -> - let msg = ref "" in - try Proofview.V82.of_tactic (Equality.inj None l b None c) gl - with - | CErrors.UserError (_,s) - when msg := Pp.string_of_ppcmds s; - !msg = "Not a projectable equality but a discriminable one." || - !msg = "Nothing to inject." -> - Feedback.msg_warning (Pp.str !msg); - discharge_hyp (id, (id, "")) gl +let nothing_to_inject = + CWarnings.create ~name:"spurious-ssr-injection" ~category:"ssr" + (fun (sigma, env, ty) -> + Pp.(str "SSReflect: cannot obtain new equations out of" ++ fnl() ++ + str" " ++ Printer.pr_econstr_env env sigma ty ++ fnl() ++ + str "Did you write an extra [] in the intro pattern?")) + +let equality_inj l b id c = Proofview.Goal.enter begin fun gl -> + Proofview.tclORELSE (Equality.inj None l b None c) + (function + | (Equality.NothingToInject,_) -> + let open Proofview.Notations in + Ssrcommon.tacTYPEOF (EConstr.mkVar id) >>= fun ty -> + nothing_to_inject (Proofview.Goal.sigma gl, Proofview.Goal.env gl, ty); + Proofview.V82.tactic (discharge_hyp (id, (id, ""))) + | (e,info) -> Proofview.tclZERO ~info e) end let injectidl2rtac id c = diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index da623703a2..38b26d06b9 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -465,7 +465,7 @@ let rwcltac ?under ?map_redex cl rdx dir sr = Tactics.apply_type ~typecheck:true cl'' [rdx; EConstr.it_mkLambda_or_LetIn r3 dc], Tacticals.New.tclTHENLIST (itacs @ rwtacs), sigma0 in let cvtac' = - Proofview.tclOR cvtac begin function + Proofview.tclORELSE cvtac begin function | (PRtype_error e, _) -> let error = Option.cata (fun (env, sigma, te) -> Pp.(fnl () ++ str "Type error was: " ++ Himsg.explain_pretype_error env sigma te)) diff --git a/plugins/ssr/ssrparser.mlg b/plugins/ssr/ssrparser.mlg index 60af804c1b..98439e27a1 100644 --- a/plugins/ssr/ssrparser.mlg +++ b/plugins/ssr/ssrparser.mlg @@ -219,20 +219,20 @@ let test_ssrslashnum b1 b2 _ strm = match Util.stream_nth 0 strm with | Tok.KEYWORD "/" -> (match Util.stream_nth 1 strm with - | Tok.NUMERAL _ when b1 -> + | Tok.NUMBER _ when b1 -> (match Util.stream_nth 2 strm with | Tok.KEYWORD "=" | Tok.KEYWORD "/=" when not b2 -> () | Tok.KEYWORD "/" -> if not b2 then () else begin match Util.stream_nth 3 strm with - | Tok.NUMERAL _ -> () + | Tok.NUMBER _ -> () | _ -> raise Stream.Failure end | _ -> raise Stream.Failure) | Tok.KEYWORD "/" when not b1 -> (match Util.stream_nth 2 strm with | Tok.KEYWORD "=" when not b2 -> () - | Tok.NUMERAL _ when b2 -> + | Tok.NUMBER _ when b2 -> (match Util.stream_nth 3 strm with | Tok.KEYWORD "=" -> () | _ -> raise Stream.Failure) @@ -243,7 +243,7 @@ let test_ssrslashnum b1 b2 _ strm = | Tok.KEYWORD "//" when not b1 -> (match Util.stream_nth 1 strm with | Tok.KEYWORD "=" when not b2 -> () - | Tok.NUMERAL _ when b2 -> + | Tok.NUMBER _ when b2 -> (match Util.stream_nth 2 strm with | Tok.KEYWORD "=" -> () | _ -> raise Stream.Failure) diff --git a/plugins/ssr/ssrvernac.mlg b/plugins/ssr/ssrvernac.mlg index 24772a8514..4a907b2795 100644 --- a/plugins/ssr/ssrvernac.mlg +++ b/plugins/ssr/ssrvernac.mlg @@ -159,7 +159,7 @@ let declare_one_prenex_implicit locality f = | [] -> errorstrm (str "Expected some implicits for " ++ pr_qualid f) | impls -> - Impargs.set_implicits locality fref [impls] + Impargs.set_implicits locality fref [List.map (fun imp -> (Anonymous,imp)) impls] } diff --git a/plugins/syntax/float_syntax.ml b/plugins/syntax/float_syntax.ml index 8e87fc13ca..5d8dcd04fe 100644 --- a/plugins/syntax/float_syntax.ml +++ b/plugins/syntax/float_syntax.ml @@ -48,21 +48,21 @@ let interp_float ?loc n = | None -> "" | Some f -> NumTok.UnsignedNat.to_string f in let e = match e with | None -> "0" | Some e -> NumTok.SignedNat.to_string e in - Bigint.of_string (i ^ f), + Z.of_string (i ^ f), (try int_of_string e with Failure _ -> 0) - String.length f in let m', e' = let m', e' = Float64.frshiftexp f in let m' = Float64.normfr_mantissa m' in let e' = Uint63.to_int_min e' 4096 - Float64.eshift - 53 in - Bigint.of_string (Uint63.to_string m'), + Z.of_string (Uint63.to_string m'), e' in - let c2, c5 = Bigint.(of_int 2, of_int 5) in + let c2, c5 = Z.(of_int 2, of_int 5) in (* check m*5^e <> m'*2^e' *) let check m e m' e' = - not (Bigint.(equal (mult m (pow c5 e)) (mult m' (pow c2 e')))) in + not (Z.(equal (mul m (pow c5 e)) (mul m' (pow c2 e')))) in (* check m*5^e*2^e' <> m' *) let check' m e e' m' = - not (Bigint.(equal (mult (mult m (pow c5 e)) (pow c2 e')) m')) in + not (Z.(equal (mul (mul m (pow c5 e)) (pow c2 e')) m')) in (* we now have to check m*10^e <> m'*2^e' *) if e >= 0 then if e <= e' then check m e m' (e' - e) diff --git a/plugins/syntax/g_numeral.mlg b/plugins/syntax/g_numeral.mlg index e66dbe17b2..c030925ea9 100644 --- a/plugins/syntax/g_numeral.mlg +++ b/plugins/syntax/g_numeral.mlg @@ -24,6 +24,11 @@ let pr_numnot_option = function | Warning n -> str "(warning after " ++ NumTok.UnsignedNat.print n ++ str ")" | Abstract n -> str "(abstract after " ++ NumTok.UnsignedNat.print n ++ str ")" +let warn_deprecated_numeral_notation = + CWarnings.create ~name:"numeral-notation" ~category:"deprecated" + (fun () -> + strbrk "Numeral Notation is deprecated, please use Number Notation instead.") + } VERNAC ARGUMENT EXTEND numnotoption @@ -34,8 +39,13 @@ VERNAC ARGUMENT EXTEND numnotoption END VERNAC COMMAND EXTEND NumeralNotation CLASSIFIED AS SIDEFF - | #[ locality = Attributes.locality; ] [ "Numeral" "Notation" reference(ty) reference(f) reference(g) ":" + | #[ locality = Attributes.locality; ] [ "Number" "Notation" reference(ty) reference(f) reference(g) ":" ident(sc) numnotoption(o) ] -> { vernac_numeral_notation (Locality.make_module_locality locality) ty f g (Id.to_string sc) o } + | #[ locality = Attributes.locality; ] [ "Numeral" "Notation" reference(ty) reference(f) reference(g) ":" + ident(sc) numnotoption(o) ] -> + + { warn_deprecated_numeral_notation (); + vernac_numeral_notation (Locality.make_module_locality locality) ty f g (Id.to_string sc) o } END diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 23a7cc07c5..d66b9537b4 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -11,7 +11,6 @@ open Util open Names open Glob_term -open Bigint (* Poor's man DECLARE PLUGIN *) let __coq_plugin_name = "r_syntax_plugin" @@ -47,10 +46,10 @@ let pos_of_bignat ?loc x = let ref_xH = DAst.make @@ GRef (glob_xH, None) in let ref_xO = DAst.make @@ GRef (glob_xO, None) in let rec pos_of x = - match div2_with_rest x with - | (q,false) -> DAst.make @@ GApp (ref_xO,[pos_of q]) - | (q,true) when not (Bigint.equal q zero) -> DAst.make @@ GApp (ref_xI,[pos_of q]) - | (q,true) -> ref_xH + match Z.(div_rem x (of_int 2)) with + | (q,rem) when rem = Z.zero -> DAst.make @@ GApp (ref_xO,[pos_of q]) + | (q,_) when not Z.(equal q zero) -> DAst.make @@ GApp (ref_xI,[pos_of q]) + | (q,_) -> ref_xH in pos_of x @@ -59,9 +58,9 @@ let pos_of_bignat ?loc x = (**********************************************************************) let rec bignat_of_pos c = match DAst.get c with - | GApp (r, [a]) when is_gr r glob_xO -> mult_2(bignat_of_pos a) - | GApp (r, [a]) when is_gr r glob_xI -> add_1(mult_2(bignat_of_pos a)) - | GRef (a, _) when GlobRef.equal a glob_xH -> Bigint.one + | GApp (r, [a]) when is_gr r glob_xO -> Z.mul Z.(of_int 2) (bignat_of_pos a) + | GApp (r, [a]) when is_gr r glob_xI -> Z.add Z.one Z.(mul (of_int 2) (bignat_of_pos a)) + | GRef (a, _) when GlobRef.equal a glob_xH -> Z.one | _ -> raise Non_closed_number (**********************************************************************) @@ -77,9 +76,9 @@ let glob_POS = GlobRef.ConstructRef path_of_POS let glob_NEG = GlobRef.ConstructRef path_of_NEG let z_of_int ?loc n = - if not (Bigint.equal n zero) then + if not Z.(equal n zero) then let sgn, n = - if is_pos_or_zero n then glob_POS, n else glob_NEG, Bigint.neg n in + if Z.(leq zero n) then glob_POS, n else glob_NEG, Z.neg n in DAst.make @@ GApp(DAst.make @@ GRef (sgn,None), [pos_of_bignat ?loc n]) else DAst.make @@ GRef (glob_ZERO, None) @@ -90,8 +89,8 @@ let z_of_int ?loc n = let bigint_of_z c = match DAst.get c with | GApp (r,[a]) when is_gr r glob_POS -> bignat_of_pos a - | GApp (r,[a]) when is_gr r glob_NEG -> Bigint.neg (bignat_of_pos a) - | GRef (a, _) when GlobRef.equal a glob_ZERO -> Bigint.zero + | GApp (r,[a]) when is_gr r glob_NEG -> Z.neg (bignat_of_pos a) + | GRef (a, _) when GlobRef.equal a glob_ZERO -> Z.zero | _ -> raise Non_closed_number (**********************************************************************) @@ -122,13 +121,13 @@ let r_of_rawnum ?loc n = let rdiv r r' = DAst.make @@ GApp (DAst.make @@ GRef(glob_Rdiv,None), [r; r']) in let pow p e = - let p = z_of_int ?loc (Bigint.of_int p) in + let p = z_of_int ?loc (Z.of_int p) in let e = pos_of_bignat e in DAst.make @@ GApp (DAst.make @@ GRef(glob_pow_pos,None), [p; e]) in let n = izr (z_of_int ?loc n) in - if Bigint.is_strictly_pos e then rmult n (izr (pow p e)) - else if Bigint.is_strictly_neg e then rdiv n (izr (pow p (neg e))) + if Int.equal (Z.sign e) 1 then rmult n (izr (pow p e)) + else if Int.equal (Z.sign e) (-1) then rdiv n (izr (pow p (Z.neg e))) else n (* e = 0 *) (**********************************************************************) @@ -141,24 +140,24 @@ let rawnum_of_r c = (* choose between 123e-2 and 1.23, this is purely heuristic and doesn't play any soundness role *) let choose_exponent = - if Bigint.is_strictly_pos e then + if Int.equal (Z.sign e) 1 then true (* don't print 12 * 10^2 as 1200 to distinguish them *) else - let i = Bigint.to_string i in + let i = Z.to_string i in let li = if i.[0] = '-' then String.length i - 1 else String.length i in - let e = Bigint.neg e in - let le = String.length (Bigint.to_string e) in - Bigint.(less_than (add (of_int li) (of_int le)) e) in + let e = Z.neg e in + let le = String.length (Z.to_string e) in + Z.(lt (add (of_int li) (of_int le)) e) in (* print 123 * 10^-2 as 123e-2 *) let numTok_exponent () = NumTok.Signed.of_bigint_and_exponent i (NumTok.EDec e) in (* print 123 * 10^-2 as 1.23, precondition e < 0 *) let numTok_dot () = let s, i = - if Bigint.is_pos_or_zero i then NumTok.SPlus, Bigint.to_string i - else NumTok.SMinus, Bigint.(to_string (neg i)) in + if Z.sign i >= 0 then NumTok.SPlus, Z.to_string i + else NumTok.SMinus, Z.(to_string (neg i)) in let ni = String.length i in - let e = - (Bigint.to_int e) in + let e = - (Z.to_int e) in assert (e > 0); let i, f = if e < ni then String.sub i 0 (ni - e), String.sub i (ni - e) e @@ -178,12 +177,12 @@ let rawnum_of_r c = begin match DAst.get r with | GApp (p, [t; e]) when is_gr p glob_pow_pos -> let t = bigint_of_z t in - if not (Bigint.(equal t (of_int 10))) then + if not (Z.(equal t (of_int 10))) then raise Non_closed_number else let i = bigint_of_z l in let e = bignat_of_pos e in - let e = if is_gr md glob_Rdiv then neg e else e in + let e = if is_gr md glob_Rdiv then Z.neg e else e in numTok_of_int_exp i e | _ -> raise Non_closed_number end diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index 2c7b689c04..2661000a39 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -397,6 +397,10 @@ and apply_env env t = | _ -> map_with_binders subs_lift apply_env env t +let rec strip_app = function + | APP (args,st) -> APP (args,strip_app st) + | s -> TOP + (* The main recursive functions * * Go under applications and cases/projections (pushed in the stack), @@ -442,7 +446,7 @@ let rec norm_head info env t stack = | Const sp -> Reductionops.reduction_effect_hook info.env info.sigma - (fst sp) (lazy (reify_stack t stack)); + (fst sp) (lazy (reify_stack t (strip_app stack))); norm_head_ref 0 info env stack (ConstKey sp) t | LetIn (_, b, _, c) -> diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 2feae8cc25..61453ff214 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -40,7 +40,7 @@ let default_transparent_state env = TransparentState.full let default_flags_of ?(subterm_ts=TransparentState.empty) ts = { modulo_betaiota = true; open_ts = ts; closed_ts = ts; subterm_ts; - frozen_evars = Evar.Set.empty; with_cs = true; + allowed_evars = AllowedEvars.all; with_cs = true; allow_K_at_toplevel = true } let default_flags env = @@ -118,8 +118,6 @@ type flex_kind_of_term = | MaybeFlexible of EConstr.t (* reducible but not necessarily reduced *) | Flexible of EConstr.existential -let is_frozen flags (evk, _) = Evar.Set.mem evk flags.frozen_evars - let flex_kind_of_term flags env evd c sk = match EConstr.kind evd c with | LetIn _ | Rel _ | Const _ | Var _ | Proj _ -> @@ -128,8 +126,7 @@ let flex_kind_of_term flags env evd c sk = if flags.modulo_betaiota then MaybeFlexible c else Rigid | Evar ev -> - if is_frozen flags ev then Rigid - else Flexible ev + if is_evar_allowed flags (fst ev) then Flexible ev else Rigid | Lambda _ | Prod _ | Sort _ | Ind _ | Construct _ | CoFix _ | Int _ | Float _ | Array _ -> Rigid | Meta _ -> Rigid | Fix _ -> Rigid (* happens when the fixpoint is partially applied *) @@ -192,11 +189,11 @@ let occur_rigidly flags env evd (evk,_) t = | Rigid _ as res -> res | Normal b -> Reducible | Reducible -> Reducible) - | Evar (evk',l as ev) -> + | Evar (evk',l) -> if Evar.equal evk evk' then Rigid true - else if is_frozen flags ev then - Rigid (List.exists (fun x -> rigid_normal_occ (aux x)) l) - else Reducible + else if is_evar_allowed flags evk' then + Reducible + else Rigid (List.exists (fun x -> rigid_normal_occ (aux x)) l) | Cast (p, _, _) -> aux p | Lambda (na, t, b) -> aux b | LetIn (na, _, _, b) -> aux b @@ -458,7 +455,7 @@ let conv_fun f flags on_types = let typefn env evd pbty term1 term2 = let flags = { (default_flags env) with with_cs = flags.with_cs; - frozen_evars = flags.frozen_evars } + allowed_evars = flags.allowed_evars } in f flags env evd pbty term1 term2 in let termfn env evd pbty term1 term2 = @@ -500,7 +497,7 @@ let rec evar_conv_x flags env evd pbty term1 term2 = (whd_nored_state env evd (term2,Stack.empty)) in begin match EConstr.kind evd term1, EConstr.kind evd term2 with - | Evar ev, _ when Evd.is_undefined evd (fst ev) && not (is_frozen flags ev) -> + | Evar ev, _ when Evd.is_undefined evd (fst ev) && is_evar_allowed flags (fst ev) -> (match solve_simple_eqn (conv_fun evar_conv_x) flags env evd (position_problem true pbty,ev,term2) with | UnifFailure (_,(OccurCheck _ | NotClean _)) -> @@ -511,7 +508,7 @@ let rec evar_conv_x flags env evd pbty term1 term2 = Miller patterns *) default () | x -> x) - | _, Evar ev when Evd.is_undefined evd (fst ev) && not (is_frozen flags ev) -> + | _, Evar ev when Evd.is_undefined evd (fst ev) && is_evar_allowed flags (fst ev) -> (match solve_simple_eqn (conv_fun evar_conv_x) flags env evd (position_problem false pbty,ev,term1) with | UnifFailure (_, (OccurCheck _ | NotClean _)) -> @@ -1206,14 +1203,14 @@ type occurrences_selection = let default_occurrence_selection = Unspecified Abstraction.Imitate -let default_occurrence_test ~frozen_evars ts _ origsigma _ env sigma _ c pat = - let flags = { (default_flags_of ~subterm_ts:ts ts) with frozen_evars } in +let default_occurrence_test ~allowed_evars ts _ origsigma _ env sigma _ c pat = + let flags = { (default_flags_of ~subterm_ts:ts ts) with allowed_evars } in match evar_conv_x flags env sigma CONV c pat with | Success sigma -> true, sigma | UnifFailure _ -> false, sigma -let default_occurrences_selection ?(frozen_evars=Evar.Set.empty) ts n = - (default_occurrence_test ~frozen_evars ts, +let default_occurrences_selection ?(allowed_evars=AllowedEvars.all) ts n = + (default_occurrence_test ~allowed_evars ts, List.init n (fun _ -> default_occurrence_selection)) let apply_on_subterm env evd fixedref f test c t = @@ -1352,9 +1349,8 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = (Feedback.msg_debug Pp.(str"env rhs: " ++ Termops.Internal.print_env env_rhs); Feedback.msg_debug Pp.(str"env evars: " ++ Termops.Internal.print_env env_evar)); let args = List.map (nf_evar evd) args in - let vars = List.map NamedDecl.get_id ctxt in - let argsubst = List.map2 (fun id c -> (id, c)) vars args in - let instance = List.map mkVar vars in + let argsubst = List.map2 (fun decl c -> (NamedDecl.get_id decl, c)) ctxt args in + let instance = evar_identity_subst evi in let rhs = nf_evar evd rhs in if not (noccur_evar env_rhs evd evk rhs) then raise (TypingFailed evd); (* Ensure that any progress made by Typing.e_solve_evars will not contradict @@ -1555,7 +1551,7 @@ let second_order_matching_with_args flags env evd with_ho pbty ev l t = if with_ho then let evd,ev = evar_absorb_arguments env evd ev (Array.to_list l) in let argoccs = default_evar_selection flags evd ev in - let test = default_occurrence_test ~frozen_evars:flags.frozen_evars flags.subterm_ts in + let test = default_occurrence_test ~allowed_evars:flags.allowed_evars flags.subterm_ts in let evd, b = try second_order_matching flags env evd ev (test,argoccs) t with PretypeError (_, _, NoOccurrenceFound _) -> evd, false @@ -1583,8 +1579,8 @@ let apply_conversion_problem_heuristic flags env evd with_ho pbty t1 t2 = Termops.Internal.print_constr_env env evd t2 ++ cut ())) in let app_empty = Array.is_empty l1 && Array.is_empty l2 in match EConstr.kind evd term1, EConstr.kind evd term2 with - | Evar (evk1,args1 as ev1), (Rel _|Var _) when app_empty - && not (is_frozen flags ev1) + | Evar (evk1,args1), (Rel _|Var _) when app_empty + && is_evar_allowed flags evk1 && List.for_all (fun a -> EConstr.eq_constr evd a term2 || isEvar evd a) (remove_instance_local_defs evd evk1 args1) -> (* The typical kind of constraint coming from pattern-matching return @@ -1594,8 +1590,8 @@ let apply_conversion_problem_heuristic flags env evd with_ho pbty t1 t2 = | None -> let reason = ProblemBeyondCapabilities in UnifFailure (evd, CannotSolveConstraint ((pbty,env,t1,t2),reason))) - | (Rel _|Var _), Evar (evk2,args2 as ev2) when app_empty - && not (is_frozen flags ev2) + | (Rel _|Var _), Evar (evk2,args2) when app_empty + && is_evar_allowed flags evk2 && List.for_all (fun a -> EConstr.eq_constr evd a term1 || isEvar evd a) (remove_instance_local_defs evd evk2 args2) -> (* The typical kind of constraint coming from pattern-matching return @@ -1621,24 +1617,24 @@ let apply_conversion_problem_heuristic flags env evd with_ho pbty t1 t2 = (evar_define evar_unify flags ~choose:true) evar_unify flags env evd (position_problem true pbty) ev1 ev2) - | Evar ev1,_ when not (is_frozen flags ev1) && Array.length l1 <= Array.length l2 -> + | Evar ev1,_ when is_evar_allowed flags (fst ev1) && Array.length l1 <= Array.length l2 -> (* On "?n t1 .. tn = u u1 .. u(n+p)", try first-order unification *) (* and otherwise second-order matching *) ise_try evd [(fun evd -> first_order_unification flags env evd (ev1,l1) appr2); (fun evd -> second_order_matching_with_args flags env evd with_ho pbty ev1 l1 t2)] - | _,Evar ev2 when not (is_frozen flags ev2) && Array.length l2 <= Array.length l1 -> + | _,Evar ev2 when is_evar_allowed flags (fst ev2) && Array.length l2 <= Array.length l1 -> (* On "u u1 .. u(n+p) = ?n t1 .. tn", try first-order unification *) (* and otherwise second-order matching *) ise_try evd [(fun evd -> first_order_unification flags env evd (ev2,l2) appr1); (fun evd -> second_order_matching_with_args flags env evd with_ho pbty ev2 l2 t1)] - | Evar ev1,_ when not (is_frozen flags ev1) -> + | Evar ev1,_ when is_evar_allowed flags (fst ev1) -> (* Try second-order pattern-matching *) second_order_matching_with_args flags env evd with_ho pbty ev1 l1 t2 - | _,Evar ev2 when not (is_frozen flags ev2) -> + | _,Evar ev2 when is_evar_allowed flags (fst ev2) -> (* Try second-order pattern-matching *) second_order_matching_with_args flags env evd with_ho pbty ev2 l2 t1 | _ -> diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli index 767a173131..a5a8d1f916 100644 --- a/pretyping/evarconv.mli +++ b/pretyping/evarconv.mli @@ -105,11 +105,11 @@ val default_occurrence_selection : occurrence_selection type occurrences_selection = occurrence_match_test * occurrence_selection list -val default_occurrence_test : frozen_evars:Evar.Set.t -> TransparentState.t -> occurrence_match_test +val default_occurrence_test : allowed_evars:Evarsolve.AllowedEvars.t -> TransparentState.t -> occurrence_match_test (** [default_occurrence_selection n] Gives the default test and occurrences for [n] arguments *) -val default_occurrences_selection : ?frozen_evars:Evar.Set.t (* By default, none *) -> +val default_occurrences_selection : ?allowed_evars:Evarsolve.AllowedEvars.t (* By default, all *) -> TransparentState.t -> int -> occurrences_selection val second_order_matching : unify_flags -> env -> evar_map -> diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 79839099f7..4d5715a391 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -25,14 +25,43 @@ open Reductionops open Evarutil open Pretype_errors +module AllowedEvars = struct + + type t = + | AllowAll + | AllowFun of (Evar.t -> bool) * Evar.Set.t + + let mem allowed evk = + match allowed with + | AllowAll -> true + | AllowFun (f,except) -> f evk && not (Evar.Set.mem evk except) + + let remove evk = function + | AllowAll -> AllowFun ((fun _ -> true), Evar.Set.singleton evk) + | AllowFun (f,except) -> AllowFun (f, Evar.Set.add evk except) + + let all = AllowAll + + let except evars = + AllowFun ((fun _ -> true), evars) + + let from_pred f = + AllowFun (f, Evar.Set.empty) + +end + type unify_flags = { modulo_betaiota: bool; open_ts : TransparentState.t; closed_ts : TransparentState.t; subterm_ts : TransparentState.t; - frozen_evars : Evar.Set.t; + allowed_evars : AllowedEvars.t; allow_K_at_toplevel : bool; - with_cs : bool } + with_cs : bool +} + +let is_evar_allowed flags evk = + AllowedEvars.mem flags.allowed_evars evk type unification_kind = | TypeUnification @@ -216,9 +245,6 @@ type 'a update = | UpdateWith of 'a | NoUpdate -open Context.Named.Declaration -let inst_of_vars sign = List.map (get_id %> mkVar) sign - let restrict_evar_key evd evk filter candidates = match filter, candidates with | None, NoUpdate -> evd, evk @@ -701,8 +727,7 @@ let define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_si let (evd, evk) = new_pure_evar sign evd ty_t_in_sign ~filter ~src in let t_in_env = whd_evar evd t_in_env in let evd = define_fun env evd None (evk, inst_in_env) t_in_env in - let ctxt = named_context_of_val sign in - let inst_in_sign = inst_of_vars (Filter.filter_list filter ctxt) in + let inst_in_sign = evar_identity_subst (Evd.find evd evk) in let evar_in_sign = mkEvar (evk, inst_in_sign) in (evd,whd_evar evd evar_in_sign) @@ -735,9 +760,8 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = let sign1 = evar_hyps evi1 in let filter1 = evar_filter evi1 in let src = subterm_source evk1 evi1.evar_source in - let ids1 = List.map get_id (named_context_of_val sign1) in let avoid = Environ.ids_of_named_context_val sign1 in - let inst_in_sign = List.map mkVar (Filter.filter_list filter1 ids1) in + let inst_in_sign = evar_identity_subst evi1 in let open Context.Rel.Declaration in let (sign2,filter2,inst2_in_env,inst2_in_sign,_,evd,_) = List.fold_right (fun d (sign,filter,inst_in_env,inst_in_sign,env,evd,avoid) -> @@ -1312,24 +1336,24 @@ let preferred_orientation evd evk1 evk2 = let solve_evar_evar_aux force f unify flags env evd pbty (evk1,args1 as ev1) (evk2,args2 as ev2) = let aliases = make_alias_map env evd in - let frozen_ev1 = Evar.Set.mem evk1 flags.frozen_evars in - let frozen_ev2 = Evar.Set.mem evk2 flags.frozen_evars in + let allowed_ev1 = is_evar_allowed flags evk1 in + let allowed_ev2 = is_evar_allowed flags evk2 in if preferred_orientation evd evk1 evk2 then - try if not frozen_ev1 then + try if allowed_ev1 then solve_evar_evar_l2r force f unify flags env evd aliases (opp_problem pbty) ev2 ev1 else raise (CannotProject (evd,ev2)) with CannotProject (evd,ev2) -> - try if not frozen_ev2 then + try if allowed_ev2 then solve_evar_evar_l2r force f unify flags env evd aliases pbty ev1 ev2 else raise (CannotProject (evd,ev1)) with CannotProject (evd,ev1) -> add_conv_oriented_pb ~tail:true (pbty,env,mkEvar ev1,mkEvar ev2) evd else - try if not frozen_ev2 then + try if allowed_ev2 then solve_evar_evar_l2r force f unify flags env evd aliases pbty ev1 ev2 else raise (CannotProject (evd,ev1)) with CannotProject (evd,ev1) -> - try if not frozen_ev1 then + try if allowed_ev1 then solve_evar_evar_l2r force f unify flags env evd aliases (opp_problem pbty) ev2 ev1 else raise (CannotProject (evd,ev2)) with CannotProject (evd,ev2) -> @@ -1395,15 +1419,15 @@ let solve_refl ?(can_drop=false) unify flags env evd pbty evk argsv1 argsv2 = let candidates = filter_candidates evd evk untypedfilter NoUpdate in let filter = closure_of_filter evd evk untypedfilter in let evd',ev1 = restrict_applied_evar evd (evk,argsv1) filter candidates in - let frozen = Evar.Set.mem evk flags.frozen_evars in - if Evar.equal (fst ev1) evk && (frozen || can_drop) then + let allowed = is_evar_allowed flags evk in + if Evar.equal (fst ev1) evk && (not allowed || can_drop) then (* No refinement needed *) evd' else (* either progress, or not allowed to drop, e.g. to preserve possibly *) (* informative equations such as ?e[x:=?y]=?e[x:=?y'] where we don't know *) (* if e can depend on x until ?y is not resolved, or, conversely, we *) (* don't know if ?y has to be unified with ?y, until e is resolved *) - if frozen then + if not allowed then (* We cannot prune a frozen evar *) add_conv_oriented_pb (pbty,env,mkEvar (evk, argsv1),mkEvar (evk,argsv2)) evd else @@ -1460,7 +1484,8 @@ let occur_evar_upto_types sigma n c = let instantiate_evar unify flags env evd evk body = (* Check instance freezing the evar to be defined, as checking could involve the same evar definition problem again otherwise *) - let flags = { flags with frozen_evars = Evar.Set.add evk flags.frozen_evars } in + let allowed_evars = AllowedEvars.remove evk flags.allowed_evars in + let flags = { flags with allowed_evars } in let evd' = check_evar_instance unify flags env evd evk body in Evd.define evk body evd' diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli index 3fb80432ad..8ff2d7fc63 100644 --- a/pretyping/evarsolve.mli +++ b/pretyping/evarsolve.mli @@ -16,6 +16,28 @@ type alias val of_alias : alias -> EConstr.t +module AllowedEvars : sig + + type t + (** Represents the set of evars that can be defined by the pretyper *) + + val all : t + (** All evars can be defined *) + + val mem : t -> Evar.t -> bool + (** [mem allowed evk] is true iff evk can be defined *) + + val from_pred : (Evar.t -> bool) -> t + (** [from_pred p] means evars satisfying p can be defined *) + + val except : Evar.Set.t -> t + (** [except evars] means all evars can be defined except the ones in [evars] *) + + val remove : Evar.t -> t -> t + (** [remove evk allowed] removes [evk] from the set of evars allowed by [allowed] *) + +end + type unify_flags = { modulo_betaiota : bool; (* Enable beta-iota reductions during unification *) @@ -26,8 +48,8 @@ type unify_flags = { subterm_ts : TransparentState.t; (* Enable delta reduction according to subterm_ts for selection of subterms during higher-order unifications. *) - frozen_evars : Evar.Set.t; - (* Frozen evars are treated like rigid variables during unification: they can not be instantiated. *) + allowed_evars : AllowedEvars.t; + (* Disallowed evars are treated like rigid variables during unification: they can not be instantiated. *) allow_K_at_toplevel : bool; (* During higher-order unifications, allow to produce K-redexes: i.e. to produce an abstraction for an unused argument *) @@ -41,6 +63,8 @@ type unification_result = val is_success : unification_result -> bool +val is_evar_allowed : unify_flags -> Evar.t -> bool + (** Replace the vars and rels that are aliases to other vars and rels by their representative that is most ancient in the context *) val expand_vars_in_term : env -> evar_map -> constr -> constr diff --git a/pretyping/globEnv.ml b/pretyping/globEnv.ml index 81a62a7048..34fae613bf 100644 --- a/pretyping/globEnv.ml +++ b/pretyping/globEnv.ml @@ -33,8 +33,6 @@ type t = { (** For locating indices *) renamed_env : env; (** For name management *) - renamed_vars : EConstr.t list Lazy.t; - (** Identity instance of named_context of renamed_env, to maximize sharing *) extra : ext_named_context Lazy.t; (** Delay the computation of the evar extended environment *) lvar : ltac_var_map; @@ -45,11 +43,9 @@ let make ~hypnaming env sigma lvar = let avoid = Environ.ids_of_named_context_val (Environ.named_context_val env) in Context.Rel.fold_outside (fun d acc -> push_rel_decl_to_named_context ~hypnaming sigma d acc) (rel_context env) ~init:(empty_csubst, avoid, named_context_val env) in - let open Context.Named.Declaration in { static_env = env; renamed_env = env; - renamed_vars = lazy (List.map (get_id %> mkVar) (named_context env)); extra = lazy (get_extra env sigma); lvar = lvar; } @@ -76,7 +72,6 @@ let push_rel ~hypnaming sigma d env = let env = { static_env = push_rel d env.static_env; renamed_env = push_rel d' env.renamed_env; - renamed_vars = env.renamed_vars; extra = lazy (push_rel_decl_to_named_context ~hypnaming:hypnaming sigma d' (Lazy.force env.extra)); lvar = env.lvar; } in @@ -89,7 +84,6 @@ let push_rel_context ~hypnaming ?(force_names=false) sigma ctx env = let env = { static_env = push_rel_context ctx env.static_env; renamed_env = push_rel_context ctx' env.renamed_env; - renamed_vars = env.renamed_vars; extra = lazy (List.fold_right (fun d acc -> push_rel_decl_to_named_context ~hypnaming:hypnaming sigma d acc) ctx' (Lazy.force env.extra)); lvar = env.lvar; } in @@ -102,7 +96,7 @@ let push_rec_types ~hypnaming sigma (lna,typarray) env = Array.map get_annot ctx, env let new_evar env sigma ?src ?naming typ = - let lazy inst_vars = env.renamed_vars in + let inst_vars = EConstr.identity_subst_val (named_context_val env.renamed_env) in let rec rel_list n accu = if n <= 0 then accu else rel_list (n - 1) (mkRel n :: accu) diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index fdc770dba6..aeb18ec322 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -499,13 +499,6 @@ let beta_applist sigma (c,l) = (* Iota reduction tools *) -type 'a miota_args = { - mP : constr; (* the result type *) - mconstr : constr; (* the constructor *) - mci : case_info; (* special info to re-build pattern *) - mcargs : 'a list; (* the constructor's arguments *) - mlf : 'a array } (* the branch code vector *) - let reducible_mind_case sigma c = match EConstr.kind sigma c with | Construct _ | CoFix _ -> true | _ -> false @@ -514,10 +507,7 @@ let contract_cofix sigma (bodynum,(names,types,bodies as typedbodies)) = let nbodies = Array.length bodies in let make_Fi j = let ind = nbodies-j-1 in - if Int.equal bodynum ind then mkCoFix (ind,typedbodies) - else - let bd = mkCoFix (ind,typedbodies) in - bd + mkCoFix (ind,typedbodies) in let closure = List.init nbodies make_Fi in substl closure bodies.(bodynum) @@ -530,18 +520,6 @@ let reduce_and_refold_cofix recfun env sigma cofix sk = (fun _ (t,sk') -> recfun (t,sk')) [] sigma raw_answer sk -let reduce_mind_case sigma mia = - match EConstr.kind sigma mia.mconstr with - | Construct ((ind_sp,i),u) -> -(* let ncargs = (fst mia.mci).(i-1) in*) - let real_cargs = List.skipn mia.mci.ci_npar mia.mcargs in - applist (mia.mlf.(i-1),real_cargs) - | CoFix cofix -> - let cofix_def = contract_cofix sigma cofix in - (* XXX Is NoInvert OK here? *) - mkCase (mia.mci, mia.mP, NoInvert, applist(cofix_def,mia.mcargs), mia.mlf) - | _ -> assert false - (* contracts fix==FIX[nl;i](A1...Ak;[F1...Fk]{B1....Bk}) to produce Bi[Fj --> FIX[nl;j](A1...Ak;[F1...Fk]{B1...Bk})] *) @@ -549,10 +527,7 @@ let contract_fix sigma ((recindices,bodynum),(names,types,bodies as typedbodies) let nbodies = Array.length recindices in let make_Fi j = let ind = nbodies-j-1 in - if Int.equal bodynum ind then mkFix ((recindices,ind),typedbodies) - else - let bd = mkFix ((recindices,ind),typedbodies) in - bd + mkFix ((recindices,ind),typedbodies) in let closure = List.init nbodies make_Fi in substl closure bodies.(bodynum) @@ -757,7 +732,7 @@ let rec whd_state_gen flags env sigma = | None -> fold ()) | Const (c,u as const) -> reduction_effect_hook env sigma c - (lazy (EConstr.to_constr sigma (Stack.zip sigma (x,stack)))); + (lazy (EConstr.to_constr sigma (Stack.zip sigma (x,fst (Stack.strip_app stack))))); if CClosure.RedFlags.red_set flags (CClosure.RedFlags.fCONST c) then let u' = EInstance.kind sigma u in match constant_value_in env (c, u') with diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 0f288cdd46..d404a7e414 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -217,22 +217,14 @@ val splay_prod_n : env -> evar_map -> int -> constr -> rel_context * constr val splay_lam_n : env -> evar_map -> int -> constr -> rel_context * constr (** Raises [Invalid_argument] *) - -type 'a miota_args = { - mP : constr; (** the result type *) - mconstr : constr; (** the constructor *) - mci : case_info; (** special info to re-build pattern *) - mcargs : 'a list; (** the constructor's arguments *) - mlf : 'a array } (** the branch code vector *) - val reducible_mind_case : evar_map -> constr -> bool -val reduce_mind_case : evar_map -> constr miota_args -> constr val find_conclusion : env -> evar_map -> constr -> (constr, constr, ESorts.t, EInstance.t) kind_of_term val is_arity : env -> evar_map -> constr -> bool val is_sort : env -> evar_map -> types -> bool val contract_fix : evar_map -> fixpoint -> constr +val contract_cofix : evar_map -> cofixpoint -> constr (** {6 Querying the kernel conversion oracle: opaque/transparent constants } *) val is_transparent : Environ.env -> Constant.t tableKey -> bool diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index e4b5dc1edf..9d15e98373 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -458,6 +458,25 @@ let contract_cofix_use_function env sigma f substl_checking_arity env (List.rev subbodies) sigma (nf_beta env sigma bodies.(bodynum)) +type 'a miota_args = { + mP : constr; (** the result type *) + mconstr : constr; (** the constructor *) + mci : case_info; (** special info to re-build pattern *) + mcargs : 'a list; (** the constructor's arguments *) + mlf : 'a array } (** the branch code vector *) + +let reduce_mind_case sigma mia = + match EConstr.kind sigma mia.mconstr with + | Construct ((ind_sp,i),u) -> +(* let ncargs = (fst mia.mci).(i-1) in*) + let real_cargs = List.skipn mia.mci.ci_npar mia.mcargs in + applist (mia.mlf.(i-1),real_cargs) + | CoFix cofix -> + let cofix_def = contract_cofix sigma cofix in + (* XXX Is NoInvert OK here? *) + mkCase (mia.mci, mia.mP, NoInvert, applist(cofix_def,mia.mcargs), mia.mlf) + | _ -> assert false + let reduce_mind_case_use_function func env sigma mia = match EConstr.kind sigma mia.mconstr with | Construct ((ind_sp,i),u) -> diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index d1b65775bd..adb9c5299f 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -68,6 +68,7 @@ type typeclass = { } type typeclasses = typeclass GlobRef.Map.t +(* Invariant: for any pair (gr, tc) in the map, gr and tc.cl_impl are equal *) type instance = { is_class: GlobRef.t; @@ -268,7 +269,7 @@ let instances env sigma r = let cl = class_info env sigma r in instances_of cl let is_class gr = - GlobRef.Map.exists (fun _ v -> GlobRef.equal v.cl_impl gr) !classes + GlobRef.Map.mem gr !classes open Evar_kinds type evar_filter = Evar.t -> Evar_kinds.t Lazy.t -> bool diff --git a/pretyping/unification.ml b/pretyping/unification.ml index a26c981cb9..207a03d80f 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -252,10 +252,6 @@ let unify_r2l x = x let sort_eqns = unify_r2l *) -type allowed_evars = -| AllowAll -| AllowFun of (Evar.t -> bool) - type core_unify_flags = { modulo_conv_on_closed_terms : TransparentState.t option; (* What this flag controls was activated with all constants transparent, *) @@ -289,7 +285,7 @@ type core_unify_flags = { (* This allowed for instance to unify "forall x:?A, ?B x" with "A' -> B'" *) (* when ?B is a Meta. *) - allowed_evars : allowed_evars; + allowed_evars : AllowedEvars.t; (* Evars that are allowed to be instantiated *) (* Useful e.g. for autorewrite *) @@ -341,7 +337,7 @@ let default_core_unify_flags () = check_applied_meta_types = true; use_pattern_unification = true; use_meta_bound_pattern_unification = true; - allowed_evars = AllowAll; + allowed_evars = AllowedEvars.all; restrict_conv_on_strict_subterms = false; modulo_betaiota = true; modulo_eta = true; @@ -421,7 +417,7 @@ let default_no_delta_unify_flags ts = let allow_new_evars sigma = let undefined = Evd.undefined_map sigma in - AllowFun (fun evk -> not (Evar.Map.mem evk undefined)) + AllowedEvars.from_pred (fun evk -> not (Evar.Map.mem evk undefined)) (* Default flags for looking for subterms in elimination tactics *) (* Not used in practice at the current date, to the exception of *) @@ -604,9 +600,8 @@ let do_reduce ts (env, nb) sigma c = Stack.zip sigma (whd_betaiota_deltazeta_for_iota_state ts env sigma (c, Stack.empty)) -let is_evar_allowed flags evk = match flags.allowed_evars with -| AllowAll -> true -| AllowFun f -> f evk +let is_evar_allowed flags evk = + AllowedEvars.mem flags.allowed_evars evk let isAllowedEvar sigma flags c = match EConstr.kind sigma c with | Evar (evk,_) -> is_evar_allowed flags evk diff --git a/pretyping/unification.mli b/pretyping/unification.mli index f9a969a253..5462e09359 100644 --- a/pretyping/unification.mli +++ b/pretyping/unification.mli @@ -13,10 +13,6 @@ open EConstr open Environ open Evd -type allowed_evars = -| AllowAll -| AllowFun of (Evar.t -> bool) - type core_unify_flags = { modulo_conv_on_closed_terms : TransparentState.t option; use_metas_eagerly_in_conv_on_closed_terms : bool; @@ -26,7 +22,7 @@ type core_unify_flags = { check_applied_meta_types : bool; use_pattern_unification : bool; use_meta_bound_pattern_unification : bool; - allowed_evars : allowed_evars; + allowed_evars : Evarsolve.AllowedEvars.t; restrict_conv_on_strict_subterms : bool; modulo_betaiota : bool; modulo_eta : bool; diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index e5fa9bada1..900ba0edb9 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -415,7 +415,7 @@ let cbv_vm env sigma c t = (* This evar-normalizes terms beforehand *) let c = EConstr.to_constr ~abort_on_undefined_evars:false sigma c in let t = EConstr.to_constr ~abort_on_undefined_evars:false sigma t in - let v = Csymtable.val_of_constr env c in + let v = Vmsymtable.val_of_constr env c in EConstr.of_constr (nf_val env sigma v t) let vm_infer_conv ?(pb=Reduction.CUMUL) env sigma t1 t2 = diff --git a/printing/printer.ml b/printing/printer.ml index c5cb6ffad8..a1a2d9ae51 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -780,17 +780,19 @@ let pr_open_subgoals_diff ?(quiet=false) ?(diffs=false) ?oproof proof = straightforward, but seriously, [Proof.proof] should return [evar_info]-s instead. *) let p = proof in - let Proof.{goals; stack; shelf; given_up; sigma} = Proof.data p in + let Proof.{goals; stack; sigma} = Proof.data p in + let shelf = Evd.shelf sigma in + let given_up = Evd.given_up sigma in let stack = List.map (fun (l,r) -> List.length l + List.length r) stack in let seeds = Proof.V82.top_evars p in begin match goals with | [] -> let { Evd.it = bgoals ; sigma = bsigma } = Proof.V82.background_subgoals p in begin match bgoals,shelf,given_up with - | [] , [] , [] -> pr_subgoals None sigma ~seeds ~shelf ~stack ~unfocused:[] ~goals + | [] , [] , g when Evar.Set.is_empty g -> pr_subgoals None sigma ~seeds ~shelf ~stack ~unfocused:[] ~goals | [] , [] , _ -> Feedback.msg_info (str "No more subgoals, but there are some goals you gave up:"); fnl () - ++ pr_subgoals ~pr_first:false None bsigma ~seeds ~shelf:[] ~stack:[] ~unfocused:[] ~goals:given_up + ++ pr_subgoals ~pr_first:false None bsigma ~seeds ~shelf:[] ~stack:[] ~unfocused:[] ~goals:(Evar.Set.elements given_up) ++ fnl () ++ str "You need to go back and solve them." | [] , _ , _ -> Feedback.msg_info (str "All the remaining goals are on the shelf."); diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 9bd7ccda5d..31bc698830 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -47,16 +47,6 @@ let clenv_meta_type clenv mv = Typing.meta_type clenv.env clenv.evd mv let clenv_value clenv = meta_instance clenv.env clenv.evd clenv.templval let clenv_type clenv = meta_instance clenv.env clenv.evd clenv.templtyp -let refresh_undefined_univs clenv = - match EConstr.kind clenv.evd clenv.templval.rebus with - | Var _ -> clenv, Univ.empty_level_subst - | App (f, args) when isVar clenv.evd f -> clenv, Univ.empty_level_subst - | _ -> - let evd', subst = Evd.refresh_undefined_universes clenv.evd in - let map_freelisted f = { f with rebus = subst_univs_level_constr subst f.rebus } in - { clenv with evd = evd'; templval = map_freelisted clenv.templval; - templtyp = map_freelisted clenv.templtyp }, subst - let clenv_hnf_constr ce t = hnf_constr (cl_env ce) (cl_sigma ce) t let clenv_get_type_of ce c = Retyping.get_type_of (cl_env ce) (cl_sigma ce) c @@ -628,9 +618,6 @@ let clenv_cast_meta clenv = in crec -let clenv_value_cast_meta clenv = - clenv_cast_meta clenv (clenv_value clenv) - let clenv_pose_dependent_evars ?(with_evars=false) clenv = let dep_mvs = clenv_dependent clenv in let env, sigma = clenv.env, clenv.evd in @@ -683,7 +670,7 @@ let fail_quick_core_unif_flags = { check_applied_meta_types = false; use_pattern_unification = false; use_meta_bound_pattern_unification = true; (* ? *) - allowed_evars = AllowAll; + allowed_evars = Evarsolve.AllowedEvars.all; restrict_conv_on_strict_subterms = false; (* ? *) modulo_betaiota = false; modulo_eta = true; @@ -726,12 +713,6 @@ let make_clenv_binding_gen hyps_only n env sigma (c,t) = function | NoBindings -> mk_clenv_from_env env sigma n (c,t) -let make_clenv_binding_env_apply env sigma n = - make_clenv_binding_gen true n env sigma - -let make_clenv_binding_env env sigma = - make_clenv_binding_gen false None env sigma - let make_clenv_binding_apply env sigma n = make_clenv_binding_gen true n env sigma let make_clenv_binding env sigma = make_clenv_binding_gen false None env sigma diff --git a/proofs/clenv.mli b/proofs/clenv.mli index fd1e2fe593..a72c8c5e1f 100644 --- a/proofs/clenv.mli +++ b/proofs/clenv.mli @@ -45,9 +45,6 @@ val mk_clenv_from_n : Proofview.Goal.t -> int option -> EConstr.constr * EConstr.types -> clausenv val mk_clenv_from_env : env -> evar_map -> int option -> EConstr.constr * EConstr.types -> clausenv -(** Refresh the universes in a clenv *) -val refresh_undefined_univs : clausenv -> clausenv * Univ.universe_level_subst - (** {6 linking of clenvs } *) val clenv_fchain : @@ -78,17 +75,10 @@ val clenv_unify_meta_types : ?flags:unify_flags -> clausenv -> clausenv (** the arity of the lemma is fixed the optional int tells how many prods of the lemma have to be used use all of them if None *) -val make_clenv_binding_env_apply : - env -> evar_map -> int option -> EConstr.constr * EConstr.constr -> constr bindings -> - clausenv - val make_clenv_binding_apply : env -> evar_map -> int option -> EConstr.constr * EConstr.constr -> constr bindings -> clausenv -val make_clenv_binding_env : - env -> evar_map -> EConstr.constr * EConstr.constr -> constr bindings -> clausenv - val make_clenv_binding : env -> evar_map -> EConstr.constr * EConstr.constr -> constr bindings -> clausenv @@ -102,7 +92,6 @@ val unify : ?flags:unify_flags -> constr -> unit Proofview.tactic val res_pf : ?with_evars:bool -> ?with_classes:bool -> ?flags:unify_flags -> clausenv -> unit Proofview.tactic val clenv_pose_dependent_evars : ?with_evars:bool -> clausenv -> clausenv -val clenv_value_cast_meta : clausenv -> constr (** {6 Pretty-print (debug only) } *) val pr_clenv : clausenv -> Pp.t diff --git a/proofs/goal.ml b/proofs/goal.ml index beeaa60433..e8f2ab5674 100644 --- a/proofs/goal.ml +++ b/proofs/goal.ml @@ -8,7 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Util open Pp module NamedDecl = Context.Named.Declaration @@ -57,13 +56,12 @@ module V82 = struct be shelved. It must not appear as a future_goal, so the future goals are restored to their initial value after the evar is created. *) - let prev_future_goals = Evd.save_future_goals evars in - let (evars, evk) = - Evarutil.new_pure_evar ~src:(Loc.tag Evar_kinds.GoalEvar) ~typeclass_candidate:false hyps evars concl + let evars = Evd.push_future_goals evars in + let inst = EConstr.identity_subst_val hyps in + let (evars,evk) = + Evarutil.new_pure_evar ~src:(Loc.tag Evar_kinds.GoalEvar) ~typeclass_candidate:false ~identity:inst hyps evars concl in - let evars = Evd.restore_future_goals evars prev_future_goals in - let ctxt = Environ.named_context_of_val hyps in - let inst = List.map (NamedDecl.get_id %> EConstr.mkVar) ctxt in + let _, evars = Evd.pop_future_goals evars in let ev = EConstr.mkEvar (evk,inst) in (evk, ev, evars) diff --git a/proofs/goal.mli b/proofs/goal.mli index a3aa1e248f..e8439120c0 100644 --- a/proofs/goal.mli +++ b/proofs/goal.mli @@ -65,4 +65,4 @@ module V82 : sig end -module Set : sig include Set.S with type elt = goal end +module Set = Evar.Set diff --git a/proofs/proof.ml b/proofs/proof.ml index a183fa7797..d864aed25a 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -24,8 +24,6 @@ the focus kind is actually stored inside the condition). To unfocus, one needs to know the focus kind, and the condition (for instance "no condition" or the proof under focused must be complete) must be met. - - Shelf: A list of goals which have been put aside during the proof. They can be - retrieved with the [Unshelve] command, or solved by side effects - Given up goals: as long as there is a given up goal, the proof is not completed. Given up goals cannot be retrieved, the user must go back where the tactic [give_up] was run and solve the goal there. @@ -113,10 +111,6 @@ type t = (** History of the focusings, provides information on how to unfocus the proof and the extra information stored while focusing. The list is empty when the proof is fully unfocused. *) - ; shelf : Goal.goal list - (** List of goals that have been shelved. *) - ; given_up : Goal.goal list - (** List of goals that have been given up *) ; name : Names.Id.t (** the name of the theorem whose proof is being constructed *) ; poly : bool @@ -137,9 +131,7 @@ let proof p = let stack = map_minus_one (fun (_,_,c) -> Proofview.focus_context c) p.focus_stack in - let shelf = p.shelf in - let given_up = p.given_up in - (goals,stack,shelf,given_up,sigma) + (goals,stack,sigma) let rec unroll_focus pv = function | (_,_,ctx)::stk -> unroll_focus (Proofview.unfocus ctx pv) stk @@ -155,8 +147,12 @@ let is_done p = (* spiwack: for compatibility with <= 8.2 proof engine *) let has_unresolved_evar p = Proofview.V82.has_unresolved_evar p.proofview -let has_shelved_goals p = not (CList.is_empty (p.shelf)) -let has_given_up_goals p = not (CList.is_empty (p.given_up)) +let has_shelved_goals p = + let (_goals,sigma) = Proofview.proofview p.proofview in + Evd.has_shelved sigma +let has_given_up_goals p = + let (_goals,sigma) = Proofview.proofview p.proofview in + Evd.has_given_up sigma let is_complete p = is_done p && not (has_unresolved_evar p) && @@ -217,13 +213,10 @@ let focus_id cond inf id pr = (* goal is already under focus *) _focus cond (Obj.repr inf) i i pr | None -> - if CList.mem_f Evar.equal ev pr.shelf then + if CList.mem_f Evar.equal ev (Evd.shelf evar_map) then (* goal is on the shelf, put it in focus *) let proofview = Proofview.unshelve [ev] pr.proofview in - let shelf = - CList.filter (fun ev' -> Evar.equal ev ev' |> not) pr.shelf - in - let pr = { pr with proofview; shelf } in + let pr = { pr with proofview } in let (focused_goals, _) = Proofview.proofview pr.proofview in let i = (* Now we know that this will succeed *) @@ -291,8 +284,6 @@ let start ~name ~poly sigma goals = { proofview ; entry ; focus_stack = [] - ; shelf = [] - ; given_up = [] ; name ; poly } in @@ -304,8 +295,6 @@ let dependent_start ~name ~poly goals = { proofview ; entry ; focus_stack = [] - ; shelf = [] - ; given_up = [] ; name ; poly } in @@ -356,46 +345,53 @@ let compact p = let entry, proofview = Proofview.compact p.entry p.proofview in { p with proofview; entry } +let update_sigma_univs ugraph p = + let proofview = Proofview.Unsafe.update_sigma_univs ugraph p.proofview in + { p with proofview } + (*** Function manipulation proof extra informations ***) (*** Tactics ***) let run_tactic env tac pr = let open Proofview.Notations in - let sp = pr.proofview in let undef sigma l = List.filter (fun g -> Evd.is_undefined sigma g) l in let tac = + Proofview.tclEVARMAP >>= fun sigma -> + Proofview.Unsafe.tclEVARS (Evd.push_shelf sigma) >>= fun () -> tac >>= fun result -> Proofview.tclEVARMAP >>= fun sigma -> (* Already solved goals are not to be counted as shelved. Nor are they to be marked as unresolvable. *) - let retrieved = Evd.filter_future_goals (Evd.is_undefined sigma) (Evd.save_future_goals sigma) in - let retrieved,retrieved_given_up = Evd.extract_given_up_future_goals retrieved in - (* Check that retrieved given up is empty *) - if not (List.is_empty retrieved_given_up) then - CErrors.anomaly Pp.(str "Evars generated outside of proof engine (e.g. V82, clear, ...) are not supposed to be explicitly given up."); + let retrieved, sigma = Evd.pop_future_goals sigma in + let retrieved = Evd.FutureGoals.filter (Evd.is_undefined sigma) retrieved in + let retrieved = List.rev retrieved.Evd.FutureGoals.comb in let sigma = Proofview.Unsafe.mark_as_goals sigma retrieved in + let to_shelve, sigma = Evd.pop_shelf sigma in Proofview.Unsafe.tclEVARS sigma >>= fun () -> - Proofview.tclUNIT (result,retrieved) + Proofview.Unsafe.tclNEWSHELVED (retrieved@to_shelve) <*> + Proofview.tclUNIT (result,retrieved,to_shelve) in - let { name; poly } = pr in - let ((result,retrieved),proofview,(status,to_shelve,give_up),info_trace) = - Proofview.apply ~name ~poly env tac sp + let { name; poly; proofview } = pr in + let proofview = Proofview.Unsafe.push_future_goals proofview in + let ((result,retrieved,to_shelve),proofview,status,info_trace) = + Proofview.apply ~name ~poly env tac proofview in let sigma = Proofview.return proofview in let to_shelve = undef sigma to_shelve in - let shelf = (undef sigma pr.shelf)@retrieved@to_shelve in let proofview = Proofview.Unsafe.mark_as_unresolvables proofview to_shelve in - let given_up = pr.given_up@give_up in - let proofview = Proofview.Unsafe.reset_future_goals proofview in - { pr with proofview ; shelf ; given_up },(status,info_trace),result + let proofview = Proofview.filter_shelf (Evd.is_undefined sigma) proofview in + { pr with proofview },(status,info_trace),result (*** Commands ***) (* Remove all the goals from the shelf and adds them at the end of the focused goals. *) let unshelve p = - { p with proofview = Proofview.unshelve (p.shelf) (p.proofview) ; shelf = [] } + let sigma = Proofview.return p.proofview in + let shelf = Evd.shelf sigma in + let proofview = Proofview.unshelve shelf p.proofview in + { p with proofview } (*** Compatibility layer with <=v8.2 ***) module V82 = struct @@ -441,23 +437,23 @@ module V82 = struct end in let { name; poly } = pr in let ((), proofview, _, _) = Proofview.apply ~name ~poly env tac pr.proofview in - let shelf = - List.filter begin fun g -> + let proofview = Proofview.filter_shelf + begin fun g -> Evd.is_undefined (Proofview.return proofview) g - end pr.shelf + end proofview in - { pr with proofview ; shelf } + { pr with proofview } end let all_goals p = let add gs set = List.fold_left (fun s g -> Goal.Set.add g s) set gs in - let (goals,stack,shelf,given_up,_) = proof p in + let (goals,stack,sigma) = proof p in let set = add goals Goal.Set.empty in let set = List.fold_left (fun s gs -> let (g1, g2) = gs in add g1 (add g2 set)) set stack in - let set = add shelf set in - let set = add given_up set in + let set = add (Evd.shelf sigma) set in + let set = Goal.Set.union (Evd.given_up sigma) set in let { Evd.it = bgoals ; sigma = bsigma } = V82.background_subgoals p in add bgoals set @@ -470,17 +466,13 @@ type data = (** Entry for the proofview *) ; stack : (Evar.t list * Evar.t list) list (** A representation of the focus stack *) - ; shelf : Evar.t list - (** A representation of the shelf *) - ; given_up : Evar.t list - (** A representation of the given up goals *) ; name : Names.Id.t (** The name of the theorem whose proof is being constructed *) ; poly : bool (** Locality, polymorphism, and "kind" [Coercion, Definition, etc...] *) } -let data { proofview; focus_stack; entry; shelf; given_up; name; poly } = +let data { proofview; focus_stack; entry; name; poly } = let goals, sigma = Proofview.proofview proofview in (* spiwack: beware, the bottom of the stack is used by [Proof] internally, and should not be exposed. *) @@ -491,10 +483,10 @@ let data { proofview; focus_stack; entry; shelf; given_up; name; poly } = in let stack = map_minus_one (fun (_,_,c) -> Proofview.focus_context c) focus_stack in - { sigma; goals; entry; stack; shelf; given_up; name; poly } + { sigma; goals; entry; stack; name; poly } let pr_proof p = - let { goals=fg_goals; stack=bg_goals; shelf; given_up; _ } = data p in + let { goals=fg_goals; stack=bg_goals; sigma } = data p in Pp.( let pr_goal_list = prlist_with_sep spc Goal.pr_goal in let rec aux acc = function @@ -504,8 +496,8 @@ let pr_proof p = 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 "shelved: " ++ pr_goal_list (Evd.shelf sigma) ++ str ";" ++ spc () ++ + str "given up: " ++ pr_goal_list (Evar.Set.elements @@ Evd.given_up sigma) ++ str "]" ) @@ -574,7 +566,7 @@ let refine_by_tactic ~name ~poly env sigma ty tac = let eff = Evd.eval_side_effects sigma in let sigma = Evd.drop_side_effects sigma in (* Save the existing goals *) - let prev_future_goals = Evd.save_future_goals sigma in + let sigma = Evd.push_future_goals sigma in (* Start a proof *) let prf = start ~name ~poly sigma [env, ty] in let (prf, _, ()) = @@ -585,7 +577,7 @@ let refine_by_tactic ~name ~poly env sigma ty tac = Exninfo.iraise (e, info) in (* Plug back the retrieved sigma *) - let { goals; stack; shelf; given_up; sigma; entry } = data prf in + let { goals; stack; sigma; entry } = data prf in assert (stack = []); let ans = match Proofview.initial_goals entry with | [c, _] -> c @@ -598,15 +590,10 @@ let refine_by_tactic ~name ~poly env sigma ty tac = let sigma = Evd.drop_side_effects sigma in let sigma = Evd.emit_side_effects eff sigma in (* Restore former goals *) - let sigma = Evd.restore_future_goals sigma prev_future_goals in + let _goals, sigma = Evd.pop_future_goals sigma in (* Push remaining goals as future_goals which is the only way we have to inform the caller that there are goals to collect while not being encapsulated in the monad *) - (* Goals produced by tactic "shelve" *) - let sigma = List.fold_right (Evd.declare_future_goal ~tag:Evd.ToShelve) shelf sigma in - (* Goals produced by tactic "give_up" *) - let sigma = List.fold_right (Evd.declare_future_goal ~tag:Evd.ToGiveUp) given_up sigma in - (* Other goals *) let sigma = List.fold_right Evd.declare_future_goal goals sigma in (* Get rid of the fresh side-effects by internalizing them in the term itself. Note that this is unsound, because the tactic may have solved diff --git a/proofs/proof.mli b/proofs/proof.mli index 0e5bdaf07d..f487595dac 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -43,10 +43,6 @@ type data = (** Entry for the proofview *) ; stack : (Evar.t list * Evar.t list) list (** A representation of the focus stack *) - ; shelf : Evar.t list - (** A representation of the shelf *) - ; given_up : Evar.t list - (** A representation of the given up goals *) ; name : Names.Id.t (** The name of the theorem whose proof is being constructed *) ; poly : bool; @@ -78,6 +74,9 @@ val partial_proof : t -> EConstr.constr list val compact : t -> t +(** [update_sigma_univs] lifts [UState.update_sigma_univs] to the proof *) +val update_sigma_univs : UGraph.t -> t -> t + (* Returns the proofs (with their type) of the initial goals. Raises [UnfinishedProof] is some goals remain to be considered. Raises [HasShelvedGoals] if some goals are left on the shelf. diff --git a/proofs/refine.ml b/proofs/refine.ml index a10bbcbdd4..ac410a958f 100644 --- a/proofs/refine.ml +++ b/proofs/refine.ml @@ -51,19 +51,18 @@ let generic_refine ~typecheck f gl = let state = Proofview.Goal.state gl in (* Save the [future_goals] state to restore them after the refinement. *) - let prev_future_goals = Evd.save_future_goals sigma in + let sigma = Evd.push_future_goals sigma in (* Create the refinement term *) - Proofview.Unsafe.tclEVARS (Evd.reset_future_goals sigma) >>= fun () -> + Proofview.Unsafe.tclEVARS sigma >>= fun () -> f >>= fun (v, c) -> - Proofview.tclEVARMAP >>= fun sigma -> + Proofview.tclEVARMAP >>= fun sigma' -> Proofview.V82.wrap_exceptions begin fun () -> - let evs = Evd.save_future_goals sigma in (* Redo the effects in sigma in the monad's env *) - let privates_csts = Evd.eval_side_effects sigma in + let privates_csts = Evd.eval_side_effects sigma' in let env = Safe_typing.push_private_constants env privates_csts.Evd.seff_private in (* Check that the introduced evars are well-typed *) let fold accu ev = typecheck_evar ev env accu in - let sigma = if typecheck then Evd.fold_future_goals fold sigma evs else sigma in + let sigma = if typecheck then Evd.fold_future_goals fold sigma' else sigma' in (* Check that the refined term is typesafe *) let sigma = if typecheck then Typing.check env sigma c concl else sigma in (* Check that the goal itself does not appear in the refined term *) @@ -73,17 +72,18 @@ let generic_refine ~typecheck f gl = else Pretype_errors.error_occur_check env sigma self c in (* Restore the [future goals] state. *) - let sigma = Evd.restore_future_goals sigma prev_future_goals in + let future_goals, sigma = Evd.pop_future_goals sigma in (* Select the goals *) - let evs = Evd.map_filter_future_goals (Proofview.Unsafe.advance sigma) evs in - let comb,shelf,given_up,evkmain = Evd.dispatch_future_goals evs in + let future_goals = Evd.FutureGoals.map_filter (Proofview.Unsafe.advance sigma) future_goals in + let shelf = Evd.shelf sigma in + let future_goals = Evd.FutureGoals.filter (fun ev -> not @@ List.mem ev shelf) future_goals in (* Proceed to the refinement *) let sigma = match Proofview.Unsafe.advance sigma self with | None -> (* Nothing to do, the goal has been solved by side-effect *) sigma | Some self -> - match evkmain with + match future_goals.Evd.FutureGoals.principal with | None -> Evd.define self c sigma | Some evk -> let id = Evd.evar_ident self sigma in @@ -93,17 +93,14 @@ let generic_refine ~typecheck f gl = | Some id -> Evd.rename evk id sigma in (* Mark goals *) - let sigma = Proofview.Unsafe.mark_as_goals sigma comb in - let sigma = Proofview.Unsafe.mark_unresolvables sigma shelf in - let comb = CList.map (fun x -> Proofview.goal_with_state x state) comb in + let sigma = Proofview.Unsafe.mark_as_goals sigma future_goals.Evd.FutureGoals.comb in + let comb = CList.rev_map (fun x -> Proofview.goal_with_state x state) future_goals.Evd.FutureGoals.comb in let trace env sigma = Pp.(hov 2 (str"simple refine"++spc()++ Termops.Internal.print_constr_env env sigma c)) in Proofview.Trace.name_tactic trace (Proofview.tclUNIT v) >>= fun v -> Proofview.Unsafe.tclSETENV (Environ.reset_context env) <*> Proofview.Unsafe.tclEVARS sigma <*> Proofview.Unsafe.tclSETGOALS comb <*> - Proofview.Unsafe.tclPUTSHELF shelf <*> - Proofview.Unsafe.tclPUTGIVENUP given_up <*> Proofview.tclUNIT v end diff --git a/stm/proofBlockDelimiter.ml b/stm/proofBlockDelimiter.ml index 3d892fa5ca..f367167d48 100644 --- a/stm/proofBlockDelimiter.ml +++ b/stm/proofBlockDelimiter.ml @@ -51,8 +51,8 @@ let is_focused_goal_simple ~doc id = | `Valid (Some { Vernacstate.lemmas }) -> Option.cata (Vernacstate.LemmaStack.with_top ~f:(fun proof -> let proof = Declare.Proof.get proof in - let Proof.{ goals=focused; stack=r1; shelf=r2; given_up=r3; sigma } = Proof.data proof in - let rest = List.(flatten (map (fun (x,y) -> x @ y) r1)) @ r2 @ r3 in + let Proof.{ goals=focused; stack=r1; sigma } = Proof.data proof in + let rest = List.(flatten (map (fun (x,y) -> x @ y) r1)) @ (Evd.shelf sigma) @ (Evar.Set.elements @@ Evd.given_up sigma) in if List.for_all (fun x -> simple_goal sigma x rest) focused then `Simple focused else `Not)) `Not lemmas diff --git a/stm/stm.ml b/stm/stm.ml index 3b7921f638..4ca0c365bf 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -142,10 +142,6 @@ let may_pierce_opaque = function | VernacExtend (("ExtractionInductive",_), _) -> true | _ -> false -let update_global_env () = - if PG_compat.there_are_pending_proofs () then - PG_compat.update_global_env () - module Vcs_ = Vcs.Make(Stateid.Self) type future_proof = Declare.Proof.closed_proof_output Future.computation @@ -834,15 +830,11 @@ module State : sig (* to send states across worker/master *) val get_cached : Stateid.t -> Vernacstate.t - val same_env : Vernacstate.t -> Vernacstate.t -> bool - - type proof_part type partial_state = [ `Full of Vernacstate.t - | `ProofOnly of Stateid.t * proof_part ] + | `ProofOnly of Stateid.t * Vernacstate.Stm.pstate ] - val proof_part_of_frozen : Vernacstate.t -> proof_part val assign : Stateid.t -> partial_state -> unit (* Handlers for initial state, prior to document creation. *) @@ -865,13 +857,9 @@ end = struct (* {{{ *) let invalidate_cur_state () = cur_id := Stateid.dummy - type proof_part = Vernacstate.Stm.pstate - type partial_state = [ `Full of Vernacstate.t - | `ProofOnly of Stateid.t * proof_part ] - - let proof_part_of_frozen st = Vernacstate.Stm.pstate st + | `ProofOnly of Stateid.t * Vernacstate.Stm.pstate ] let cache_state ~marshallable id = VCS.set_state id (FullState (Vernacstate.freeze_interp_state ~marshallable)) @@ -924,7 +912,6 @@ end = struct (* {{{ *) with VCS.Expired -> anomaly Pp.(str "not a cached state (expired).") let assign id what = - let open Vernacstate in if VCS.get_state id <> EmptyState then () else try match what with | `Full s -> @@ -932,9 +919,11 @@ end = struct (* {{{ *) try let prev = (VCS.visit id).next in if is_cached_and_valid prev - then { s with lemmas = - PG_compat.copy_terminators - ~src:((get_cached prev).lemmas) ~tgt:s.lemmas } + then + let open Vernacstate in + { s with + lemmas = PG_compat.copy_terminators + ~src:((get_cached prev).lemmas) ~tgt:s.lemmas } else s with VCS.Expired -> s in VCS.set_state id (FullState s) @@ -953,8 +942,6 @@ end = struct (* {{{ *) execution_error ?loc id (iprint (e, info)); (e, Stateid.add info ~valid id) - let same_env = Vernacstate.Stm.same_env - (* [define] puts the system in state [id] calling [f ()] *) (* [safe_id] is the last known valid state before execution *) let define ~doc ?safe_id ?(redefine=false) ?(cache=false) ?(feedback_processed=true) @@ -1549,8 +1536,8 @@ end = struct (* {{{ *) match prev, this with | _, None -> None | Some (prev, o, `Cmd { cast = { expr }}), Some n - when is_tac expr && State.same_env o n -> (* A pure tactic *) - Some (id, `ProofOnly (prev, State.proof_part_of_frozen n)) + when is_tac expr && Vernacstate.Stm.same_env o n -> (* A pure tactic *) + Some (id, `ProofOnly (prev, Vernacstate.Stm.pstate n)) | Some _, Some s -> if !Flags.debug then msg_debug (Pp.str "STM: sending back a fat state"); Some (id, `Full s) @@ -1931,7 +1918,8 @@ end = struct (* {{{ *) str" solves the goal and leaves no unresolved existential variables. The following" ++ str" existentials remain unsolved: " ++ prlist (Termops.pr_existential_key sigma) (Evar.Set.elements evars)) end) () - with e when CErrors.noncritical e -> RespError (CErrors.print e) + with e when CErrors.noncritical e -> + RespError (CErrors.print e ++ spc() ++ str "(for subgoal "++int (fst r_ast) ++ str ")") let name_of_task { t_name } = t_name let name_of_request { r_name } = r_name @@ -2344,7 +2332,9 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = (* ugly functions to process nested lemmas, i.e. hard to reproduce * side effects *) let inject_non_pstate (s,l) = - Summary.unfreeze_summaries ~partial:true s; Lib.unfreeze l; update_global_env () + Summary.unfreeze_summaries ~partial:true s; Lib.unfreeze l; + if PG_compat.there_are_pending_proofs () then + PG_compat.update_sigma_univs (Global.universes ()) in let rec pure_cherry_pick_non_pstate safe_id id = diff --git a/tactics/abstract.ml b/tactics/abstract.ml index 6b575d0807..83ae3ea09a 100644 --- a/tactics/abstract.ml +++ b/tactics/abstract.ml @@ -60,33 +60,39 @@ let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = in let name = name_op_to_name ~name_op ~name suffix in Proofview.Goal.enter begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = Proofview.Goal.sigma gl in - let current_sign = Global.named_context_val () - and global_sign = Proofview.Goal.hyps gl in - let sign,secsign = - List.fold_right - (fun d (s1,s2) -> - let id = NamedDecl.get_id d in - if mem_named_context_val id current_sign && - interpretable_as_section_decl env sigma (lookup_named_val id current_sign) d - then (s1,push_named_context_val d s2) - else (Context.Named.add d s1,s2)) - global_sign (Context.Named.empty, Environ.empty_named_context_val) in - let name = Namegen.next_global_ident_away name (pf_ids_set_of_hyps gl) in - let concl = match goal_type with - | None -> Proofview.Goal.concl gl - | Some ty -> ty in - let concl = it_mkNamedProd_or_LetIn concl sign in - let solve_tac = tclCOMPLETE (tclTHEN (tclDO (List.length sign) Tactics.intro) tac) in - let effs, sigma, lem, args, safe = - !declare_abstract ~name ~poly ~sign ~secsign ~kind ~opaque ~solve_tac sigma concl in - let solve = - Proofview.tclEFFECTS effs <*> - tacK lem args - in - let tac = if not safe then Proofview.mark_as_unsafe <*> solve else solve in - Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) tac + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let section_sign = Global.named_context_val () in + let goal_sign = Proofview.Goal.hyps gl in + let sign,secsign = + List.fold_right + (fun d (s1,s2) -> + let id = NamedDecl.get_id d in + if mem_named_context_val id section_sign && + interpretable_as_section_decl env sigma (lookup_named_val id section_sign) d + then (s1,push_named_context_val d s2) + else (Context.Named.add d s1,s2)) + goal_sign (Context.Named.empty, Environ.empty_named_context_val) + in + let name = Namegen.next_global_ident_away name (pf_ids_set_of_hyps gl) in + let concl = match goal_type with + | None -> Proofview.Goal.concl gl + | Some ty -> ty + in + let concl = it_mkNamedProd_or_LetIn concl sign in + let solve_tac = tclCOMPLETE + (Tactics.intros_mustbe_force (List.rev_map NamedDecl.get_id sign) <*> + tac) + in + let effs, sigma, lem, args, safe = + !declare_abstract ~name ~poly ~sign ~secsign ~kind ~opaque ~solve_tac sigma concl + in + let solve = + Proofview.tclEFFECTS effs <*> + tacK lem args + in + let tac = if not safe then Proofview.mark_as_unsafe <*> solve else solve in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) tac end let abstract_subproof ~opaque tac = diff --git a/tactics/auto.ml b/tactics/auto.ml index 3287c1c354..369508c2a3 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -12,11 +12,9 @@ open Pp open Util open Names open Termops -open EConstr open Environ open Genredexpr open Tactics -open Clenv open Locus open Proofview.Notations open Hints @@ -49,7 +47,7 @@ let auto_core_unif_flags_of st1 st2 = { check_applied_meta_types = false; use_pattern_unification = false; use_meta_bound_pattern_unification = true; - allowed_evars = AllowAll; + allowed_evars = Evarsolve.AllowedEvars.all; restrict_conv_on_strict_subterms = false; (* Compat *) modulo_betaiota = false; modulo_eta = true; @@ -69,38 +67,7 @@ let auto_unif_flags = (* Try unification with the precompiled clause, then use registered Apply *) -let connect_hint_clenv h gl = - let { hint_term = c; hint_uctx = ctx; hint_clnv = clenv } = h in - (* [clenv] has been generated by a hint-making function, so the only relevant - data in its evarmap is the set of metas. The [evar_reset_evd] function - below just replaces the metas of sigma by those coming from the clenv. *) - let sigma = Tacmach.New.project gl in - let evd = Evd.evars_reset_evd ~with_conv_pbs:true ~with_univs:false sigma clenv.evd in - (* Still, we need to update the universes *) - let clenv, c = - if h.hint_poly then - (* Refresh the instance of the hint *) - let (subst, ctx) = UnivGen.fresh_universe_context_set_instance ctx in - let emap c = Vars.subst_univs_level_constr subst c in - let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in - (* Only metas are mentioning the old universes. *) - let clenv = { - templval = Evd.map_fl emap clenv.templval; - templtyp = Evd.map_fl emap clenv.templtyp; - evd = Evd.map_metas emap evd; - env = Proofview.Goal.env gl; - } in - clenv, emap c - else - let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in - { clenv with evd = evd ; env = Proofview.Goal.env gl }, c - in clenv, c - -let unify_resolve flags (h : hint) = - Proofview.Goal.enter begin fun gl -> - let clenv, c = connect_hint_clenv h gl in - Clenv.res_pf ~flags clenv - end +let unify_resolve flags h = Hints.hint_res_pf ~flags h let unify_resolve_nodelta h = unify_resolve auto_unif_flags h @@ -110,10 +77,10 @@ let unify_resolve_gen = function let exact h = Proofview.Goal.enter begin fun gl -> - let clenv', c = connect_hint_clenv h gl in - Tacticals.New.tclTHEN - (Proofview.Unsafe.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd)) - (exact_check c) + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let sigma, c = Hints.fresh_hint env sigma h in + Proofview.Unsafe.tclEVARS sigma <*> exact_check c end (* Util *) @@ -299,7 +266,7 @@ let flags_of_state st = let auto_flags_of_state st = auto_unif_flags_of TransparentState.full st -let hintmap_of sigma secvars hdc concl = +let hintmap_of env sigma secvars hdc concl = match hdc with | None -> Hint_db.map_none ~secvars | Some hdc -> @@ -307,7 +274,7 @@ let hintmap_of sigma secvars hdc concl = (fun db -> match Hint_db.map_existential sigma ~secvars hdc concl db with | ModeMatch l -> l | ModeMismatch -> []) - else Hint_db.map_auto sigma ~secvars hdc concl + else Hint_db.map_auto env sigma ~secvars hdc concl let exists_evaluable_reference env = function | EvalConstRef _ -> true @@ -333,23 +300,24 @@ let rec trivial_fail_db dbg mod_delta db_list local_db = Proofview.Goal.enter begin fun gl -> let concl = Tacmach.New.pf_concl gl in let sigma = Tacmach.New.project gl in + let env = Proofview.Goal.env gl in let secvars = compute_secvars gl in Tacticals.New.tclFIRST ((dbg_assumption dbg)::intro_tac:: (List.map Tacticals.New.tclCOMPLETE - (trivial_resolve sigma dbg mod_delta db_list local_db secvars concl))) + (trivial_resolve env sigma dbg mod_delta db_list local_db secvars concl))) end -and my_find_search_nodelta sigma db_list local_db secvars hdc concl = +and my_find_search_nodelta env sigma db_list local_db secvars hdc concl = List.map (fun hint -> (None,hint)) - (List.map_append (hintmap_of sigma secvars hdc concl) (local_db::db_list)) + (List.map_append (hintmap_of env sigma secvars hdc concl) (local_db::db_list)) and my_find_search mod_delta = if mod_delta then my_find_search_delta else my_find_search_nodelta -and my_find_search_delta sigma db_list local_db secvars hdc concl = - let f = hintmap_of sigma secvars hdc concl in +and my_find_search_delta env sigma db_list local_db secvars hdc concl = + let f = hintmap_of env sigma secvars hdc concl in if occur_existential sigma concl then List.map_append (fun db -> @@ -373,7 +341,7 @@ and my_find_search_delta sigma db_list local_db secvars hdc concl = | None -> Hint_db.map_none ~secvars db | Some hdc -> if TransparentState.is_empty st - then Hint_db.map_auto sigma ~secvars hdc concl db + then Hint_db.map_auto env sigma ~secvars hdc concl db else match Hint_db.map_existential sigma ~secvars hdc concl db with | ModeMatch l -> l | ModeMismatch -> [] @@ -402,8 +370,7 @@ and tac_of_hint dbg db_list local_db concl (flags, h) = let info = Exninfo.reify () in Tacticals.New.tclFAIL ~info 0 (str"Unbound reference") end - | Extern tacast -> - let p = FullHint.pattern h in + | Extern (p, tacast) -> conclPattern concl p tacast in let pr_hint env sigma = @@ -415,7 +382,7 @@ and tac_of_hint dbg db_list local_db concl (flags, h) = in tclLOG dbg pr_hint (FullHint.run h tactic) -and trivial_resolve sigma dbg mod_delta db_list local_db secvars cl = +and trivial_resolve env sigma dbg mod_delta db_list local_db secvars cl = try let head = try let hdconstr = decompose_app_bound sigma cl in @@ -424,7 +391,7 @@ and trivial_resolve sigma dbg mod_delta db_list local_db secvars cl = in List.map (tac_of_hint dbg db_list local_db cl) (priority - (my_find_search mod_delta sigma db_list local_db secvars head cl)) + (my_find_search mod_delta env sigma db_list local_db secvars head cl)) with Not_found -> [] (** The use of the "core" database can be de-activated by passing @@ -464,7 +431,7 @@ let h_trivial ?(debug=Off) lems l = gen_trivial ~debug lems l (* The classical Auto tactic *) (**************************************************************************) -let possible_resolve sigma dbg mod_delta db_list local_db secvars cl = +let possible_resolve env sigma dbg mod_delta db_list local_db secvars cl = try let head = try let hdconstr = decompose_app_bound sigma cl in @@ -472,7 +439,7 @@ let possible_resolve sigma dbg mod_delta db_list local_db secvars cl = with Bound -> None in List.map (tac_of_hint dbg db_list local_db cl) - (my_find_search mod_delta sigma db_list local_db secvars head cl) + (my_find_search mod_delta env sigma db_list local_db secvars head cl) with Not_found -> [] let extend_local_db decl db gl = @@ -507,12 +474,13 @@ let search d n mod_delta db_list local_db = ( Proofview.Goal.enter begin fun gl -> let concl = Tacmach.New.pf_concl gl in let sigma = Tacmach.New.project gl in + let env = Proofview.Goal.env gl in let secvars = compute_secvars gl in let d' = incr_dbg d in Tacticals.New.tclFIRST (List.map (fun ntac -> Tacticals.New.tclTHEN ntac (search d' (n-1) local_db)) - (possible_resolve sigma d mod_delta db_list local_db secvars concl)) + (possible_resolve env sigma d mod_delta db_list local_db secvars concl)) end)) end [] in diff --git a/tactics/auto.mli b/tactics/auto.mli index 903da143d2..bc2eee0e4c 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -12,7 +12,6 @@ open Names open EConstr -open Clenv open Pattern open Hints open Tactypes @@ -23,9 +22,6 @@ val default_search_depth : int ref val auto_flags_of_state : TransparentState.t -> Unification.unify_flags -val connect_hint_clenv - : hint -> Proofview.Goal.t -> clausenv * constr - (** Try unification with the precompiled clause, then use registered Apply *) val unify_resolve : Unification.unify_flags -> hint -> unit Proofview.tactic diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml index bb062bfc11..bacb5a7b8f 100644 --- a/tactics/btermdn.ml +++ b/tactics/btermdn.ml @@ -49,17 +49,25 @@ let decomp sigma t = in decrec [] t -let constr_val_discr sigma t = +let evaluable_constant c env = + (* This is a hack to work around a broken Print Module implementation, see + bug #2668. *) + if Environ.mem_constant c env then Environ.evaluable_constant c env + else true + +let constr_val_discr env sigma t = let open GlobRef in let c, l = decomp sigma t in match EConstr.kind sigma c with | Ind (ind_sp,u) -> Label(GRLabel (IndRef ind_sp),l) | Construct (cstr_sp,u) -> Label(GRLabel (ConstructRef cstr_sp),l) | Var id -> Label(GRLabel (VarRef id),l) - | Const _ -> Everything + | Const (c, _) -> + if evaluable_constant c env then Everything + else Label(GRLabel (ConstRef c),l) | _ -> Nothing -let constr_pat_discr t = +let constr_pat_discr env t = if not (Patternops.occur_meta_pattern t) then None else @@ -68,16 +76,23 @@ let constr_pat_discr t = | PRef ((IndRef _) as ref), args | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args) | PRef ((VarRef v) as ref), args -> Some(GRLabel ref,args) + | PRef ((ConstRef c) as ref), args -> + if evaluable_constant c env then None + else Some (GRLabel ref, args) | _ -> None -let constr_val_discr_st sigma ts t = +let constr_val_discr_st env sigma ts t = let c, l = decomp sigma t in let open GlobRef in match EConstr.kind sigma c with - | Const (c,u) -> if TransparentState.is_transparent_constant ts c then Everything else Label(GRLabel (ConstRef c),l) + | Const (c,u) -> + if evaluable_constant c env && TransparentState.is_transparent_constant ts c then Everything + else Label(GRLabel (ConstRef c),l) | Ind (ind_sp,u) -> Label(GRLabel (IndRef ind_sp),l) | Construct (cstr_sp,u) -> Label(GRLabel (ConstructRef cstr_sp),l) - | Var id -> if TransparentState.is_transparent_variable ts id then Everything else Label(GRLabel (VarRef id),l) + | Var id -> + if Environ.evaluable_named id env && TransparentState.is_transparent_variable ts id then Everything + else Label(GRLabel (VarRef id),l) | Prod (n, d, c) -> Label(ProdLabel, [d; c]) | Lambda (n, d, c) -> if List.is_empty l then @@ -88,52 +103,54 @@ let constr_val_discr_st sigma ts t = | Rel _ | Meta _ | Cast _ | LetIn _ | App _ | Case _ | Fix _ | CoFix _ | Proj _ | Int _ | Float _ | Array _ -> Nothing -let constr_pat_discr_st ts t = +let constr_pat_discr_st env ts t = let open GlobRef in match decomp_pat t with | PRef ((IndRef _) as ref), args | PRef ((ConstructRef _ ) as ref), args -> Some (GRLabel ref,args) - | PRef ((VarRef v) as ref), args when not (TransparentState.is_transparent_variable ts v) -> - Some(GRLabel ref,args) + | PRef ((VarRef v) as ref), args -> + if Environ.evaluable_named v env && (TransparentState.is_transparent_variable ts v) then None + else Some(GRLabel ref,args) + | PRef ((ConstRef c) as ref), args -> + if evaluable_constant c env && TransparentState.is_transparent_constant ts c then None + else Some (GRLabel ref, args) | PVar v, args when not (TransparentState.is_transparent_variable ts v) -> Some(GRLabel (VarRef v),args) - | PRef ((ConstRef c) as ref), args when not (TransparentState.is_transparent_constant ts c) -> - Some (GRLabel ref, args) | PProd (_, d, c), [] -> Some (ProdLabel, [d ; c]) | PLambda (_, d, c), [] -> Some (LambdaLabel, [d ; c]) | PSort s, [] -> Some (SortLabel, []) | _ -> None -let bounded_constr_pat_discr_st st (t,depth) = +let bounded_constr_pat_discr_st env st (t,depth) = if Int.equal depth 0 then None else - match constr_pat_discr_st st t with + match constr_pat_discr_st env st t with | None -> None | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l) -let bounded_constr_val_discr_st sigma st (t,depth) = +let bounded_constr_val_discr_st env sigma st (t,depth) = if Int.equal depth 0 then Nothing else - match constr_val_discr_st sigma st t with + match constr_val_discr_st env sigma st t with | Label (c,l) -> Label(c,List.map (fun c -> (c,depth-1)) l) | Nothing -> Nothing | Everything -> Everything -let bounded_constr_pat_discr (t,depth) = +let bounded_constr_pat_discr env (t,depth) = if Int.equal depth 0 then None else - match constr_pat_discr t with + match constr_pat_discr env t with | None -> None | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l) -let bounded_constr_val_discr sigma (t,depth) = +let bounded_constr_val_discr env sigma (t,depth) = if Int.equal depth 0 then Nothing else - match constr_val_discr sigma t with + match constr_val_discr env sigma t with | Label (c,l) -> Label(c,List.map (fun c -> (c,depth-1)) l) | Nothing -> Nothing | Everything -> Everything @@ -151,31 +168,23 @@ struct type t = Dn.t - let empty = Dn.empty + type pattern = Dn.pattern - let add = function - | None -> - (fun dn (c,v) -> - Dn.add dn bounded_constr_pat_discr ((c,!dnet_depth),v)) - | Some st -> - (fun dn (c,v) -> - Dn.add dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v)) + let pattern env st pat = match st with + | None -> Dn.pattern (bounded_constr_pat_discr env) (pat, !dnet_depth) + | Some st -> Dn.pattern (bounded_constr_pat_discr_st env st) (pat, !dnet_depth) - let rmv = function - | None -> - (fun dn (c,v) -> - Dn.rmv dn bounded_constr_pat_discr ((c,!dnet_depth),v)) - | Some st -> - (fun dn (c,v) -> - Dn.rmv dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v)) + let empty = Dn.empty + let add = Dn.add + let rmv = Dn.rmv - let lookup sigma = function + let lookup env sigma = function | None -> (fun dn t -> - Dn.lookup dn (bounded_constr_val_discr sigma) (t,!dnet_depth)) + Dn.lookup dn (bounded_constr_val_discr env sigma) (t,!dnet_depth)) | Some st -> (fun dn t -> - Dn.lookup dn (bounded_constr_val_discr_st sigma st) (t,!dnet_depth)) + Dn.lookup dn (bounded_constr_val_discr_st env sigma st) (t,!dnet_depth)) let app f dn = Dn.app f dn diff --git a/tactics/btermdn.mli b/tactics/btermdn.mli index 4358e5a8d9..ab201a1872 100644 --- a/tactics/btermdn.mli +++ b/tactics/btermdn.mli @@ -28,12 +28,16 @@ module Make : sig type t + type pattern + + val pattern : Environ.env -> TransparentState.t option -> constr_pattern -> pattern + val empty : t - val add : TransparentState.t option -> t -> (constr_pattern * Z.t) -> t - val rmv : TransparentState.t option -> t -> (constr_pattern * Z.t) -> t + val add : t -> pattern -> Z.t -> t + val rmv : t -> pattern -> Z.t -> t - val lookup : Evd.evar_map -> TransparentState.t option -> t -> EConstr.constr -> Z.t list + val lookup : Environ.env -> Evd.evar_map -> TransparentState.t option -> t -> EConstr.constr -> Z.t list val app : (Z.t -> unit) -> t -> unit end diff --git a/tactics/cbn.ml b/tactics/cbn.ml index dfbcc9fbce..8f0966a486 100644 --- a/tactics/cbn.ml +++ b/tactics/cbn.ml @@ -571,7 +571,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = | None -> fold ()) | Const (c,u as const) -> Reductionops.reduction_effect_hook env sigma c - (lazy (EConstr.to_constr sigma (Stack.zip sigma (x,stack)))); + (lazy (EConstr.to_constr sigma (Stack.zip sigma (x,fst (Stack.strip_app stack))))); if CClosure.RedFlags.red_set flags (CClosure.RedFlags.fCONST c) then let u' = EInstance.kind sigma u in match constant_value_in env (c, u') with diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 63cafbf76d..96cbbf0ba8 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -134,7 +134,7 @@ let auto_core_unif_flags st allowed_evars = { modulo_eta = false; } -let auto_unif_flags ?(allowed_evars = AllowAll) st = +let auto_unif_flags ?(allowed_evars = Evarsolve.AllowedEvars.all) st = let fl = auto_core_unif_flags st allowed_evars in { core_unify_flags = fl; merge_unify_flags = fl; @@ -144,61 +144,50 @@ let auto_unif_flags ?(allowed_evars = AllowAll) st = } let e_give_exact flags h = - let { hint_term = c; hint_clnv = clenv } = h in let open Tacmach.New in Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in let sigma = project gl in - let c, sigma = - if h.hint_poly then - let clenv', subst = Clenv.refresh_undefined_univs clenv in - let evd = evars_reset_evd ~with_conv_pbs:true sigma clenv'.evd in - let c = Vars.subst_univs_level_constr subst c in - c, evd - else c, sigma - in + let sigma, c = Hints.fresh_hint env sigma h in let (sigma, t1) = Typing.type_of (pf_env gl) sigma c in Proofview.Unsafe.tclEVARS sigma <*> Clenv.unify ~flags t1 <*> exact_no_check c end -let unify_e_resolve flags = begin fun gls (h, _) -> - let clenv', c = connect_hint_clenv h gls in - Clenv.res_pf ~with_evars:true ~with_classes:false ~flags clenv' - end - -let unify_resolve flags = begin fun gls (h, _) -> - let clenv', _ = connect_hint_clenv h gls in - Clenv.res_pf ~with_evars:false ~with_classes:false ~flags clenv' +let unify_resolve ~with_evars flags h diff = match diff with +| None -> + Hints.hint_res_pf ~with_evars ~with_classes:false ~flags h +| Some (diff, ty) -> + let () = assert (not h.hint_poly) in + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let sigma, c = Hints.fresh_hint env sigma h in + let clenv = mk_clenv_from_env env sigma (Some diff) (c, ty) in + Clenv.res_pf ~with_evars ~with_classes:false ~flags clenv end (** Application of a lemma using [refine] instead of the old [w_unify] *) -let unify_resolve_refine flags gls (h, n) = - let { hint_term = c; hint_type = t; hint_uctx = ctx; hint_clnv = clenv } = h in +let unify_resolve_refine flags h diff = + let len = match diff with None -> None | Some (diff, _) -> Some diff in + Proofview.Goal.enter begin fun gls -> let open Clenv in let env = Proofview.Goal.env gls in let concl = Proofview.Goal.concl gls in Refine.refine ~typecheck:false begin fun sigma -> - let sigma, term, ty = - if h.hint_poly then - let (subst, ctx) = UnivGen.fresh_universe_context_set_instance ctx in - let map c = Vars.subst_univs_level_constr subst c in - let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in - sigma, map c, map t - else - let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in - sigma, c, t - in - let sigma', cl = Clenv.make_evar_clause env sigma ?len:n ty in - let term = applist (term, List.map (fun x -> x.hole_evar) cl.cl_holes) in - let sigma' = - Evarconv.(unify_leq_delay - ~flags:(default_flags_of flags.core_unify_flags.modulo_delta) - env sigma' cl.cl_concl concl) - in (sigma', term) end - -let unify_resolve_refine flags gl clenv = + let sigma, term = Hints.fresh_hint env sigma h in + let ty = Retyping.get_type_of env sigma term in + let sigma, cl = Clenv.make_evar_clause env sigma ?len ty in + let term = applist (term, List.map (fun x -> x.hole_evar) cl.cl_holes) in + let flags = Evarconv.default_flags_of flags.core_unify_flags.modulo_delta in + let sigma = Evarconv.unify_leq_delay ~flags env sigma cl.cl_concl concl in + (sigma, term) + end + end + +let unify_resolve_refine flags h diff = Proofview.tclORELSE - (unify_resolve_refine flags gl clenv) + (unify_resolve_refine flags h diff) (fun (exn,info) -> match exn with | Evarconv.UnableToUnify _ -> @@ -211,35 +200,21 @@ let unify_resolve_refine flags gl clenv = (** Dealing with goals of the form A -> B and hints of the form C -> A -> B. *) -let clenv_of_prods nprods h gl = - let { hint_term = c; hint_clnv = clenv; hint_poly = poly } = h in - if poly || Int.equal nprods 0 then Some (None, clenv) - else - let sigma = Tacmach.New.project gl in - let ty = Retyping.get_type_of (Proofview.Goal.env gl) sigma c in - let diff = nb_prod sigma ty - nprods in - if (>=) diff 0 then - (* Was Some clenv... *) - Some (Some diff, - mk_clenv_from_n gl (Some diff) (c,ty)) - else None - let with_prods nprods h f = if get_typeclasses_limit_intros () then Proofview.Goal.enter begin fun gl -> - try match clenv_of_prods nprods h gl with - | None -> - let info = Exninfo.reify () in - Tacticals.New.tclZEROMSG ~info (str"Not enough premisses") - | Some (diff, clenv') -> - let h = { h with hint_clnv = clenv' } in - f gl (h, diff) - with e when CErrors.noncritical e -> - let e, info = Exninfo.capture e in - Proofview.tclZERO ~info e end + let { hint_term = c; hint_poly = poly } = h in + if poly || Int.equal nprods 0 then f None + else + let sigma = Tacmach.New.project gl in + let ty = Retyping.get_type_of (Proofview.Goal.env gl) sigma c in + let diff = nb_prod sigma ty - nprods in + if (>=) diff 0 then f (Some (diff, ty)) + else Tacticals.New.tclZEROMSG (str"Not enough premisses") + end else Proofview.Goal.enter begin fun gl -> - if Int.equal nprods 0 then f gl (h, None) + if Int.equal nprods 0 then f None else Tacticals.New.tclZEROMSG (str"Not enough premisses") end let matches_pattern concl pat = @@ -282,13 +257,13 @@ let shelve_dependencies gls = Feedback.msg_debug (str" shelving dependent subgoals: " ++ pr_gls sigma gls); shelve_goals gls) -let hintmap_of sigma hdc secvars concl = +let hintmap_of env sigma hdc secvars concl = match hdc with | None -> fun db -> ModeMatch (Hint_db.map_none ~secvars db) | Some hdc -> fun db -> if Hint_db.use_dn db then (* Using dnet *) - Hint_db.map_eauto sigma ~secvars hdc concl db + Hint_db.map_eauto env sigma ~secvars hdc concl db else Hint_db.map_existential sigma ~secvars hdc concl db (** Hack to properly solve dependent evars that are typeclasses *) @@ -332,10 +307,10 @@ and e_my_find_search db_list local_db secvars hdc complete only_classes env sigm if cl.cl_strict then let undefined = lazy (Evarutil.undefined_evars_of_term sigma concl) in let allowed evk = not (Evar.Set.mem evk (Lazy.force undefined)) in - AllowFun allowed - else AllowAll - | _ -> AllowAll - with e when CErrors.noncritical e -> AllowAll + Evarsolve.AllowedEvars.from_pred allowed + else Evarsolve.AllowedEvars.all + | _ -> Evarsolve.AllowedEvars.all + with e when CErrors.noncritical e -> Evarsolve.AllowedEvars.all in let tac_of_hint = fun (flags, h) -> @@ -347,25 +322,25 @@ and e_my_find_search db_list local_db secvars hdc complete only_classes env sigm if get_typeclasses_filtered_unification () then let tac = with_prods nprods h - (fun gl clenv -> + (fun diff -> matches_pattern concl p <*> - unify_resolve_refine flags gl clenv) + unify_resolve_refine flags h diff) in Tacticals.New.tclTHEN tac Proofview.shelve_unifiable else let tac = - with_prods nprods h (unify_resolve flags) in + with_prods nprods h (unify_resolve ~with_evars:false flags h) in Proofview.tclBIND (Proofview.with_shelf tac) (fun (gls, ()) -> shelve_dependencies gls) | ERes_pf h -> if get_typeclasses_filtered_unification () then let tac = (with_prods nprods h - (fun gl clenv -> + (fun diff -> matches_pattern concl p <*> - unify_resolve_refine flags gl clenv)) in + unify_resolve_refine flags h diff)) in Tacticals.New.tclTHEN tac Proofview.shelve_unifiable else let tac = - with_prods nprods h (unify_e_resolve flags) in + with_prods nprods h (unify_resolve ~with_evars:true flags h) in Proofview.tclBIND (Proofview.with_shelf tac) (fun (gls, ()) -> shelve_dependencies gls) | Give_exact h -> @@ -373,18 +348,18 @@ and e_my_find_search db_list local_db secvars hdc complete only_classes env sigm let tac = matches_pattern concl p <*> Proofview.Goal.enter - (fun gl -> unify_resolve_refine flags gl (h, None)) in + (fun gl -> unify_resolve_refine flags h None) in Tacticals.New.tclTHEN tac Proofview.shelve_unifiable else e_give_exact flags h | Res_pf_THEN_trivial_fail h -> - let fst = with_prods nprods h (unify_e_resolve flags) in + let fst = with_prods nprods h (unify_resolve ~with_evars:true flags h) in let snd = if complete then Tacticals.New.tclIDTAC else e_trivial_fail_db only_classes db_list local_db secvars in Tacticals.New.tclTHEN fst snd | Unfold_nth c -> Proofview.tclPROGRESS (unfold_in_concl [AllOccurrences,c]) - | Extern tacast -> conclPattern concl p tacast + | Extern (p, tacast) -> conclPattern concl p tacast in let tac = FullHint.run h tac in let tac = if complete then Tacticals.New.tclCOMPLETE tac else tac in @@ -398,7 +373,7 @@ and e_my_find_search db_list local_db secvars hdc complete only_classes env sigm | Extern _ -> (tac, b, true, name, lazy (FullHint.print env sigma h ++ pp)) | _ -> (tac, b, false, name, lazy (FullHint.print env sigma h ++ pp)) in - let hint_of_db = hintmap_of sigma hdc secvars concl in + let hint_of_db = hintmap_of env sigma hdc secvars concl in let hintl = List.map_filter (fun db -> match hint_of_db db with | ModeMatch l -> Some (db, l) | ModeMismatch -> None) @@ -740,8 +715,8 @@ module Search = struct shelve_goals shelved <*> (if List.is_empty goals then tclUNIT () else - let sigma' = make_unresolvables (fun x -> List.mem_f Evar.equal x goals) sigma in - with_shelf (Unsafe.tclEVARS sigma' <*> Unsafe.tclNEWGOALS (CList.map Proofview.with_empty_state goals)) >>= + let make_unresolvables = tclEVARMAP >>= fun sigma -> Unsafe.tclEVARS @@ make_unresolvables (fun x -> List.mem_f Evar.equal x goals) sigma in + with_shelf (make_unresolvables <*> Unsafe.tclNEWGOALS (CList.map Proofview.with_empty_state goals)) >>= fun s -> result s i (Some (Option.default 0 k + j))) end in with_shelf res >>= fun (sh, ()) -> @@ -956,12 +931,14 @@ module Search = struct top_sort evm goals else Evar.Set.elements goals in - let tac = tac <*> Proofview.Unsafe.tclGETGOALS >>= + let goalsl = List.map Proofview_monad.with_empty_state goalsl in + let tac = + Proofview.Unsafe.tclNEWGOALS goalsl <*> + tac <*> Proofview.Unsafe.tclGETGOALS >>= fun stuck -> Proofview.shelve_goals (List.map Proofview_monad.drop_state stuck) in let evm = Evd.set_typeclass_evars evm Evar.Set.empty in - let fgoals = Evd.save_future_goals evm in + let evm = Evd.push_future_goals evm in let _, pv = Proofview.init evm [] in - let pv = Proofview.unshelve goalsl pv in try (* Instance may try to call this before a proof is set up! Thus, give_me_the_proof will fail. Beware! *) @@ -972,30 +949,29 @@ module Search = struct * with | Proof_global.NoCurrentProof -> *) Id.of_string "instance", false in - let finish pv' shelved = + let finish pv' = let evm' = Proofview.return pv' in + let shelf = Evd.shelf evm' in assert(Evd.fold_undefined (fun ev _ acc -> - let okev = Evd.mem evm ev || List.mem ev shelved in + let okev = Evd.mem evm ev || List.mem ev shelf in if not okev then Feedback.msg_debug (str "leaking evar " ++ int (Evar.repr ev) ++ spc () ++ pr_ev evm' ev); acc && okev) evm' true); - let fgoals = Evd.shelve_on_future_goals shelved fgoals in - let evm' = Evd.restore_future_goals evm' fgoals in + let _, evm' = Evd.pop_future_goals evm' in let nongoals' = Evar.Set.fold (fun ev acc -> match Evarutil.advance evm' ev with | Some ev' -> Evar.Set.add ev acc | None -> acc) (Evar.Set.union goals nongoals) (Evd.get_typeclass_evars evm') in + (* let evm' = { evm' with metas = evm.metas } *) let evm' = evars_reset_evd ~with_conv_pbs:true ~with_univs:false evm' evm in let evm' = Evd.set_typeclass_evars evm' nongoals' in Some evm' in - let (), pv', (unsafe, shelved, gaveup), _ = Proofview.apply ~name ~poly env tac pv in - if not (List.is_empty gaveup) then - CErrors.anomaly (Pp.str "run_on_evars not assumed to apply tactics generating given up goals."); - if Proofview.finished pv' then finish pv' shelved + let (), pv', unsafe, _ = Proofview.apply ~name ~poly env tac pv in + if Proofview.finished pv' then finish pv' else raise Not_found with Logic_monad.TacticFailure _ -> raise Not_found @@ -1235,8 +1211,7 @@ let autoapply c i = (Hints.Hint_db.transparent_state hintdb) in let cty = Tacmach.New.pf_get_type_of gl c in let ce = mk_clenv_from gl (c,cty) in - let h = { hint_term = c; hint_type = cty; hint_uctx = Univ.ContextSet.empty; hint_clnv = ce; hint_poly = false } in - unify_e_resolve flags gl (h, 0) <*> + Clenv.res_pf ~with_evars:true ~with_classes:false ~flags ce <*> Proofview.tclEVARMAP >>= (fun sigma -> let sigma = Typeclasses.make_unresolvables (fun ev -> Typeclasses.all_goals ev (Lazy.from_val (snd (Evd.find sigma ev).evar_source))) sigma in diff --git a/tactics/dn.ml b/tactics/dn.ml index e1c9b7c0b5..07eb49442a 100644 --- a/tactics/dn.ml +++ b/tactics/dn.ml @@ -38,6 +38,8 @@ struct type t = Trie.t + type pattern = (Y.t * int) option list + let empty = Trie.empty (* [path_of dna pat] returns the list of nodes of the pattern [pat] read in @@ -89,11 +91,13 @@ prefix ordering, [dna] is the function returning the main node of a pattern *) in List.flatten (List.map (fun (tm,b) -> ZSet.elements (Trie.get tm)) (lookrec t tm)) - let add tm dna (pat,inf) = - let p = path_of dna pat in Trie.add p (ZSet.singleton inf) tm + let pattern dna pat = path_of dna pat + + let add tm p inf = + Trie.add p (ZSet.singleton inf) tm - let rmv tm dna (pat,inf) = - let p = path_of dna pat in Trie.remove p (ZSet.singleton inf) tm + let rmv tm p inf = + Trie.remove p (ZSet.singleton inf) tm let app f tm = Trie.iter (fun _ p -> ZSet.iter f p) tm diff --git a/tactics/dn.mli b/tactics/dn.mli index 2a60c3eb82..287aa2b257 100644 --- a/tactics/dn.mli +++ b/tactics/dn.mli @@ -18,9 +18,13 @@ sig must decompose any tree into a label characterizing its root node and the list of its subtree *) - val add : t -> 'a decompose_fun -> 'a * Z.t -> t + type pattern - val rmv : t -> 'a decompose_fun -> 'a * Z.t -> t + val pattern : 'a decompose_fun -> 'a -> pattern + + val add : t -> pattern -> Z.t -> t + + val rmv : t -> pattern -> Z.t -> t type 'tree lookup_fun = 'tree -> (Y.t * 'tree list) lookup_res diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 686303a2ab..e920093648 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -19,7 +19,6 @@ open Tacticals open Tacmach open Evd open Tactics -open Clenv open Auto open Genredexpr open Tactypes @@ -66,12 +65,9 @@ open Auto (***************************************************************************) let unify_e_resolve flags h = - Proofview.Goal.enter begin fun gl -> - let clenv', c = connect_hint_clenv h gl in - Clenv.res_pf ~with_evars:true ~with_classes:true ~flags clenv' - end + Hints.hint_res_pf ~with_evars:true ~with_classes:true ~flags h -let hintmap_of sigma secvars concl = +let hintmap_of env sigma secvars concl = (* Warning: for computation sharing, we need to return a closure *) let hdc = try Some (decompose_app_bound sigma concl) with Bound -> None in match hdc with @@ -82,15 +78,15 @@ let hintmap_of sigma secvars concl = match Hint_db.map_existential sigma ~secvars hdc concl db with | ModeMatch l -> l | ModeMismatch -> []) - else (fun db -> Hint_db.map_auto sigma ~secvars hdc concl db) + else (fun db -> Hint_db.map_auto env sigma ~secvars hdc concl db) (* FIXME: should be (Hint_db.map_eauto hdc concl db) *) let e_exact flags h = Proofview.Goal.enter begin fun gl -> - let clenv', c = connect_hint_clenv h gl in - Tacticals.New.tclTHEN - (Proofview.Unsafe.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd)) - (e_give_exact c) + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let sigma, c = Hints.fresh_hint env sigma h in + Proofview.Unsafe.tclEVARS sigma <*> e_give_exact c end let rec e_trivial_fail_db db_list local_db = @@ -110,7 +106,7 @@ let rec e_trivial_fail_db db_list local_db = end and e_my_find_search env sigma db_list local_db secvars concl = - let hint_of_db = hintmap_of sigma secvars concl in + let hint_of_db = hintmap_of env sigma secvars concl in let hintl = List.map_append (fun db -> let flags = auto_flags_of_state (Hint_db.transparent_state db) in @@ -130,7 +126,7 @@ and e_my_find_search env sigma db_list local_db secvars concl = Tacticals.New.tclTHEN (unify_e_resolve st h) (e_trivial_fail_db db_list local_db) | Unfold_nth c -> reduce (Unfold [AllOccurrences,c]) onConcl - | Extern tacast -> conclPattern concl (FullHint.pattern h) tacast + | Extern (pat, tacast) -> conclPattern concl pat tacast in let tac = FullHint.run h tac in (tac, b, lazy (FullHint.print env sigma h)) diff --git a/tactics/elim.ml b/tactics/elim.ml index 415c980c2a..49437a2aef 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -10,33 +10,137 @@ open Util open Names +open Constr open Termops open EConstr open Inductiveops open Hipattern open Tacmach.New open Tacticals.New +open Clenv open Tactics open Proofview.Notations +type branch_args = { + branchnum : int; (* the branch number *) + nassums : int; (* number of assumptions/letin to be introduced *) + branchsign : bool list; (* the signature of the branch. + true=assumption, false=let-in *) + branchnames : Tactypes.intro_patterns} + module NamedDecl = Context.Named.Declaration +type elim_kind = Case of bool | Elim + +(* Find the right elimination suffix corresponding to the sort of the goal *) +(* c should be of type A1->.. An->B with B an inductive definition *) +let general_elim_then_using mk_elim + rec_flag allnames tac predicate (ind, u, args) id = + let open Pp in + Proofview.Goal.enter begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let sort = Retyping.get_sort_family_of env sigma (Proofview.Goal.concl gl) in + let sigma, elim = match mk_elim with + | Case dep -> + let u = EInstance.kind sigma u in + let (sigma, r) = Indrec.build_case_analysis_scheme env sigma (ind, u) dep sort in + (sigma, EConstr.of_constr r) + | Elim -> + let gr = Indrec.lookup_eliminator env ind sort in + Evd.fresh_global env sigma gr + in + let indclause = mk_clenv_from_env env sigma None (mkVar id, mkApp (mkIndU (ind, u), args)) in + (* applying elimination_scheme just a little modified *) + let elimclause = mk_clenv_from_env env sigma None (elim, Retyping.get_type_of env sigma elim) in + let indmv = + match EConstr.kind elimclause.evd (last_arg elimclause.evd elimclause.templval.Evd.rebus) with + | Meta mv -> mv + | _ -> CErrors.anomaly (str"elimination.") + in + let pmv = + let p, _ = decompose_app elimclause.evd elimclause.templtyp.Evd.rebus in + match EConstr.kind elimclause.evd p with + | Meta p -> p + | _ -> + let name_elim = + match EConstr.kind sigma elim with + | Const _ | Var _ -> str " " ++ Printer.pr_econstr_env env sigma elim + | _ -> mt () + in + CErrors.user_err ~hdr:"Tacticals.general_elim_then_using" + (str "The elimination combinator " ++ name_elim ++ str " is unknown.") + in + let elimclause' = clenv_fchain ~with_univs:false indmv elimclause indclause in + let branchsigns = Tacticals.compute_constructor_signatures ~rec_flag (ind, u) in + let brnames = Tacticals.compute_induction_names false branchsigns allnames in + let flags = Unification.elim_flags () in + let elimclause' = + match predicate with + | None -> elimclause' + | Some p -> clenv_unify ~flags Reduction.CONV (mkMeta pmv) p elimclause' + in + let after_tac i = + let ba = { branchsign = branchsigns.(i); + branchnames = brnames.(i); + nassums = List.length branchsigns.(i); + branchnum = i+1; } + in + tac ba + in + let branchtacs = List.init (Array.length branchsigns) after_tac in + Proofview.tclTHEN + (Clenv.res_pf ~flags elimclause') + (Proofview.tclEXTEND [] tclIDTAC branchtacs) + end + +(* computing the case/elim combinators *) + +let make_elim_branch_assumptions ba hyps = + let assums = + try List.rev (List.firstn ba.nassums hyps) + with Failure _ -> CErrors.anomaly (Pp.str "make_elim_branch_assumptions.") in + assums + +let elim_on_ba tac ba = + Proofview.Goal.enter begin fun gl -> + let branches = make_elim_branch_assumptions ba (Proofview.Goal.hyps gl) in + tac branches + end + +let elimination_then tac id = + let open Declarations in + Proofview.Goal.enter begin fun gl -> + let ((ind, u), t) = pf_apply Tacred.reduce_to_atomic_ind gl (pf_get_type_of gl (mkVar id)) in + let _, args = decompose_app_vect (Proofview.Goal.sigma gl) t in + let isrec,mkelim = + match (Global.lookup_mind (fst ind)).mind_record with + | NotRecord -> true, Elim + | FakeRecord | PrimRecord _ -> false, Case true + in + general_elim_then_using mkelim isrec None tac None (ind, u, args) id + end + (* Supposed to be called without as clause *) let introElimAssumsThen tac ba = - assert (ba.Tacticals.branchnames == []); - let introElimAssums = tclDO ba.Tacticals.nassums intro in + assert (ba.branchnames == []); + let introElimAssums = tclDO ba.nassums intro in (tclTHEN introElimAssums (elim_on_ba tac ba)) (* Supposed to be called with a non-recursive scheme *) let introCaseAssumsThen with_evars tac ba = - let n1 = List.length ba.Tacticals.branchsign in - let n2 = List.length ba.Tacticals.branchnames in + let n1 = List.length ba.branchsign in + let n2 = List.length ba.branchnames in let (l1,l2),l3 = - if n1 < n2 then List.chop n1 ba.Tacticals.branchnames, [] - else (ba.Tacticals.branchnames, []), List.make (n1-n2) false in + if n1 < n2 then List.chop n1 ba.branchnames, [] + else (ba.branchnames, []), List.make (n1-n2) false in let introCaseAssums = tclTHEN (intro_patterns with_evars l1) (intros_clearing l3) in - (tclTHEN introCaseAssums (case_on_ba (tac l2) ba)) + (tclTHEN introCaseAssums (elim_on_ba (tac l2) ba)) + +let case_tac dep names tac elim ind c = + let tac = introCaseAssumsThen false (* ApplyOn not supported by inversion *) tac in + general_elim_then_using (Case dep) false names tac (Some elim) ind c (* The following tactic Decompose repeatedly applies the elimination(s) rule(s) of the types satisfying the predicate @@ -56,19 +160,16 @@ Another example : Qed. *) -let elimHypThen tac id = - elimination_then tac (mkVar id) - let rec general_decompose_on_hyp recognizer = ifOnHyp recognizer (general_decompose_aux recognizer) (fun _ -> Proofview.tclUNIT()) and general_decompose_aux recognizer id = - elimHypThen + elimination_then (introElimAssumsThen (fun bas -> tclTHEN (clear [id]) (tclMAP (general_decompose_on_hyp recognizer) - (ids_of_named_context bas.Tacticals.assums)))) + (ids_of_named_context bas)))) id (* We should add a COMPLETE to be sure that the created hypothesis @@ -76,28 +177,23 @@ and general_decompose_aux recognizer id = (* Best strategies but loss of compatibility *) let tmphyp_name = Id.of_string "_TmpHyp" -let up_to_delta = ref false (* true *) let general_decompose recognizer c = Proofview.Goal.enter begin fun gl -> let typc = pf_get_type_of gl c in tclTHENS (cut typc) - [ tclTHEN (intro_using tmphyp_name) - (onLastHypId - (ifOnHyp recognizer (general_decompose_aux recognizer) - (fun id -> clear [id]))); + [ intro_using_then tmphyp_name (fun id -> + ifOnHyp recognizer (general_decompose_aux recognizer) + (fun id -> clear [id]) + id); exact_no_check c ] end let head_in indl t gl = - let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in try - let ity,_ = - if !up_to_delta - then find_mrectype env sigma t - else extract_mrectype sigma t - in List.exists (fun i -> eq_ind (fst i) (fst ity)) indl + let ity,_ = extract_mrectype sigma t in + List.exists (fun i -> eq_ind (fst i) (fst ity)) indl with Not_found -> false let decompose_these c l = @@ -124,9 +220,6 @@ let h_decompose_and = decompose_and (* The tactic Double performs a double induction *) -let simple_elimination c = - elimination_then (fun _ -> tclIDTAC) c - let induction_trailer abs_i abs_j bargs = tclTHEN (tclDO (abs_j - abs_i) intro) @@ -136,7 +229,7 @@ let induction_trailer abs_i abs_j bargs = let idty = pf_get_type_of gl (mkVar id) in let fvty = global_vars (pf_env gl) (project gl) idty in let possible_bring_hyps = - (List.tl (nLastDecls gl (abs_j - abs_i))) @ bargs.Tacticals.assums + (List.tl (nLastDecls gl (abs_j - abs_i))) @ bargs in let (hyps,_) = List.fold_left @@ -149,7 +242,7 @@ let induction_trailer abs_i abs_j bargs = in let ids = List.rev (ids_of_named_context hyps) in (tclTHENLIST - [revert ids; simple_elimination (mkVar id)]) + [revert ids; elimination_then (fun _ -> tclIDTAC) id]) end )) @@ -167,7 +260,7 @@ let double_ind h1 h2 = (onLastHypId (fun id -> elimination_then - (introElimAssumsThen (induction_trailer abs_i abs_j)) (mkVar id)))) + (introElimAssumsThen (induction_trailer abs_i abs_j)) id))) end let h_double_induction = double_ind diff --git a/tactics/elim.mli b/tactics/elim.mli index e89855a050..01053502e4 100644 --- a/tactics/elim.mli +++ b/tactics/elim.mli @@ -10,14 +10,13 @@ open Names open EConstr -open Tacticals open Tactypes (** Eliminations tactics. *) -val introCaseAssumsThen : Tactics.evars_flag -> - (intro_patterns -> branch_assumptions -> unit Proofview.tactic) -> - branch_args -> unit Proofview.tactic +val case_tac : bool -> or_and_intro_pattern option -> + (intro_patterns -> named_context -> unit Proofview.tactic) -> + constr -> inductive * EInstance.t * EConstr.t array -> Id.t -> unit Proofview.tactic val h_decompose : inductive list -> constr -> unit Proofview.tactic val h_decompose_or : constr -> unit Proofview.tactic diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index 57d793b2a5..d4cc193eb3 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -150,12 +150,12 @@ let injHyp id = let diseqCase hyps eqonleft = let diseq = Id.of_string "diseq" in let absurd = Id.of_string "absurd" in - (tclTHEN (intro_using diseq) - (tclTHEN (choose_noteq eqonleft) + (intro_using_then diseq (fun diseq -> + tclTHEN (choose_noteq eqonleft) (tclTHEN (rewrite_and_clear (List.rev hyps)) (tclTHEN (red_in_concl) - (tclTHEN (intro_using absurd) - (tclTHEN (Simple.apply (mkVar diseq)) + (intro_using_then absurd (fun absurd -> + tclTHEN (Simple.apply (mkVar diseq)) (tclTHEN (injHyp absurd) (full_trivial [])))))))) diff --git a/tactics/equality.ml b/tactics/equality.ml index a2325b69cc..8478c1957a 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -105,7 +105,7 @@ let rewrite_core_unif_flags = { check_applied_meta_types = true; use_pattern_unification = true; use_meta_bound_pattern_unification = true; - allowed_evars = AllowAll; + allowed_evars = Evarsolve.AllowedEvars.all; restrict_conv_on_strict_subterms = false; modulo_betaiota = false; modulo_eta = true; @@ -130,7 +130,7 @@ let freeze_initial_evars sigma flags clause = if Evar.Map.mem evk initial then false else Evar.Set.mem evk (Lazy.force newevars) in - let allowed_evars = AllowFun allowed in + let allowed_evars = Evarsolve.AllowedEvars.from_pred allowed in {flags with core_unify_flags = {flags.core_unify_flags with allowed_evars}; merge_unify_flags = {flags.merge_unify_flags with allowed_evars}; @@ -187,7 +187,7 @@ let rewrite_conv_closed_core_unif_flags = { use_meta_bound_pattern_unification = true; - allowed_evars = AllowAll; + allowed_evars = Evarsolve.AllowedEvars.all; restrict_conv_on_strict_subterms = false; modulo_betaiota = false; @@ -221,7 +221,7 @@ let rewrite_keyed_core_unif_flags = { use_meta_bound_pattern_unification = true; - allowed_evars = AllowAll; + allowed_evars = Evarsolve.AllowedEvars.all; restrict_conv_on_strict_subterms = false; modulo_betaiota = true; @@ -1013,19 +1013,16 @@ let discrimination_pf e (t,t1,t2) discriminator lbeq to_kind = Proofview.tclUNIT (applist (eq_elim, [t;t1;mkNamedLambda (make_annot e Sorts.Relevant) t discriminator;i;t2])) +type equality = { + eq_data : (coq_eq_data * (EConstr.t * EConstr.t * EConstr.t)); + (* equality data + A : Type, t1 : A, t2 : A *) + eq_clenv : clausenv; + (* clause [M : R A t1 t2] where [R] is the equality from above *) +} let eq_baseid = Id.of_string "e" -let apply_on_clause (f,t) clause = - let sigma = clause.evd in - let f_clause = mk_clenv_from_env clause.env sigma None (f,t) in - let argmv = - (match EConstr.kind sigma (last_arg f_clause.evd f_clause.templval.Evd.rebus) with - | Meta mv -> mv - | _ -> user_err (str "Ill-formed clause applicator.")) in - clenv_fchain ~with_univs:false argmv f_clause clause - -let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn = +let discr_positions env sigma { eq_data = (lbeq,(t,t1,t2)); eq_clenv = eq_clause } cpath dirn = build_coq_True () >>= fun true_0 -> build_coq_False () >>= fun false_0 -> let false_ty = Retyping.get_type_of env sigma false_0 in @@ -1043,13 +1040,13 @@ let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn = in discriminator >>= fun discriminator -> discrimination_pf e (t,t1,t2) discriminator lbeq false_kind >>= fun pf -> - let pf_ty = mkArrow eqn Sorts.Relevant false_0 in - let absurd_clause = apply_on_clause (pf,pf_ty) eq_clause in - let pf = Clenv.clenv_value_cast_meta absurd_clause in + (* pf : eq t t1 t2 -> False *) + let pf = EConstr.mkApp (pf, [|clenv_value eq_clause|]) in tclTHENS (assert_after Anonymous false_0) [onLastHypId gen_absurdity; (Logic.refiner ~check:true EConstr.Unsafe.(to_constr pf))] -let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause = +let discrEq eq = + let { eq_data = (_, (_, t1, t2)); eq_clenv = eq_clause } = eq in let sigma = eq_clause.evd in Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in @@ -1058,7 +1055,7 @@ let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause = let info = Exninfo.reify () in tclZEROMSG ~info (str"Not a discriminable equality.") | Inl (cpath, (_,dirn), _) -> - discr_positions env sigma u eq_clause cpath dirn + discr_positions env sigma eq cpath dirn end let onEquality with_evars tac (c,lbindc) = @@ -1071,9 +1068,10 @@ let onEquality with_evars tac (c,lbindc) = let eqn = clenv_type eq_clause' in (* FIXME evar leak *) let (eq,u,eq_args) = pf_apply find_this_eq_data_decompose gl eqn in + let eq = { eq_data = (eq, eq_args); eq_clenv = eq_clause' } in tclTHEN (Proofview.Unsafe.tclEVARS eq_clause'.evd) - (tac (eq,eqn,eq_args) eq_clause') + (tac eq) end let onNegatedEquality with_evars tac = @@ -1134,6 +1132,7 @@ let make_tuple env sigma (rterm,rty) lind = assert (not (noccurn sigma lind rty)); let sigdata = find_sigma_data env (get_sort_of env sigma rty) in let sigma, a = type_of ~refresh:true env sigma (mkRel lind) in + let a = simpl env sigma a in let na = Context.Rel.Declaration.get_annot (lookup_rel lind env) in (* We move [lind] to [1] and lift other rels > [lind] by 1 *) let rty = lift (1-lind) (liftn lind (lind+1) rty) in @@ -1384,7 +1383,8 @@ let simplify_args env sigma t = | eq, [t1;c1;t2;c2] -> applist (eq,[t1;simpl env sigma c1;t2;simpl env sigma c2]) | _ -> t -let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = +let inject_at_positions env sigma l2r eq posns tac = + let { eq_data = (eq, (t,t1,t2)); eq_clenv = eq_clause } = eq in let e = next_ident_away eq_baseid (vars_of_env env) in let e_env = push_named (LocalAssum (make_annot e Sorts.Relevant,t)) env in let evdref = ref sigma in @@ -1394,11 +1394,12 @@ let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = let sigma, (injbody,resty) = build_injector e_env !evdref t1' (mkVar e) cpath in let injfun = mkNamedLambda (make_annot e Sorts.Relevant) t injbody in let sigma,congr = Evd.fresh_global env sigma eq.congr in - let pf = applist(congr,[t;resty;injfun;t1;t2]) in + (* pf : eq t t1 t2 -> eq resty (injfun t1) (injfun t2) *) + let pf = mkApp (congr,[|t; resty; injfun; t1; t2|]) in let sigma, pf_typ = Typing.type_of env sigma pf in - let inj_clause = apply_on_clause (pf,pf_typ) eq_clause in - let pf = Clenv.clenv_value_cast_meta inj_clause in - let ty = simplify_args env sigma (clenv_type inj_clause) in + let pf_typ = Vars.subst1 mkProp (pi3 @@ destProd sigma pf_typ) in + let pf = mkApp (pf, [| Clenv.clenv_value eq_clause |]) in + let ty = simplify_args env sigma pf_typ in evdref := sigma; Some (pf, ty) with Failure _ -> None @@ -1416,7 +1417,13 @@ let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = (if l2r then List.rev injectors else injectors))) (tac (List.length injectors))) -let injEqThen keep_proofs tac l2r (eq,_,(t,t1,t2) as u) eq_clause = +exception NothingToInject +let () = CErrors.register_handler (function + | NothingToInject -> Some (Pp.str "Nothing to inject.") + | _ -> None) + +let injEqThen keep_proofs tac l2r eql = + let { eq_data = (eq, (t,t1,t2)); eq_clenv = eq_clause } = eql in let sigma = eq_clause.evd in let env = eq_clause.env in match find_positions env sigma ~keep_proofs ~no_discr:true t1 t2 with @@ -1429,9 +1436,9 @@ let injEqThen keep_proofs tac l2r (eq,_,(t,t1,t2) as u) eq_clause = " You can try to use option Set Keep Proof Equalities." in tclZEROMSG (strbrk("No information can be deduced from this equality and the injectivity of constructors. This may be because the terms are convertible, or due to pattern matching restrictions in the sort Prop." ^ suggestion)) | Inr [([],_,_)] -> - tclZEROMSG (str"Nothing to inject.") + Proofview.tclZERO NothingToInject | Inr posns -> - inject_at_positions env sigma l2r u eq_clause posns + inject_at_positions env sigma l2r eql posns (tac (clenv_value eq_clause)) let get_previous_hyp_position id gl = @@ -1485,17 +1492,18 @@ let simpleInjClause flags with_evars = function let injConcl flags = injClause flags None false None let injHyp flags clear_flag id = injClause flags None false (Some (clear_flag,ElimOnIdent CAst.(make id))) -let decompEqThen keep_proofs ntac (lbeq,_,(t,t1,t2) as u) clause = +let decompEqThen keep_proofs ntac eq = + let { eq_data = (_, (_,t1,t2) as u); eq_clenv = clause } = eq in Proofview.Goal.enter begin fun gl -> let sigma = clause.evd in let env = Proofview.Goal.env gl in match find_positions env sigma ~keep_proofs ~no_discr:false t1 t2 with | Inl (cpath, (_,dirn), _) -> - discr_positions env sigma u clause cpath dirn + discr_positions env sigma eq cpath dirn | Inr [] -> (* Change: do not fail, simplify clear this trivial hyp *) ntac (clenv_value clause) 0 | Inr posns -> - inject_at_positions env sigma true u clause posns + inject_at_positions env sigma true eq posns (ntac (clenv_value clause)) end @@ -1507,10 +1515,11 @@ let dEq ~keep_proofs with_evars = dEqThen ~keep_proofs with_evars (fun clear_flag c x -> (apply_clear_request clear_flag (use_clear_hyp_by_default ()) c)) -let intro_decomp_eq tac data (c, t) = +let intro_decomp_eq tac (eq, _, data) (c, t) = Proofview.Goal.enter begin fun gl -> let cl = pf_apply make_clenv_binding gl (c, t) NoBindings in - decompEqThen !keep_proof_equalities_for_injection (fun _ -> tac) data cl + let eq = { eq_data = (eq, data); eq_clenv = cl } in + decompEqThen !keep_proof_equalities_for_injection (fun _ -> tac) eq end let () = declare_intro_decomp_eq intro_decomp_eq @@ -1642,17 +1651,6 @@ let cutSubstClause l2r eqn cls = | None -> cutSubstInConcl l2r eqn | Some id -> cutSubstInHyp l2r eqn id -let warn_deprecated_cutrewrite = - CWarnings.create ~name:"deprecated-cutrewrite" ~category:"deprecated" - (fun () -> strbrk"\"cutrewrite\" is deprecated. See documentation for proposed replacement.") - -let cutRewriteClause l2r eqn cls = - warn_deprecated_cutrewrite (); - try_rewrite (cutSubstClause l2r eqn cls) - -let cutRewriteInHyp l2r eqn id = cutRewriteClause l2r eqn (Some id) -let cutRewriteInConcl l2r eqn = cutRewriteClause l2r eqn None - let substClause l2r c cls = Proofview.Goal.enter begin fun gl -> let eq = pf_apply get_type_of gl c in diff --git a/tactics/equality.mli b/tactics/equality.mli index e252eeab28..5a4fe47cab 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -91,6 +91,7 @@ val discr_tac : evars_flag -> constr with_bindings Tactics.destruction_arg option -> unit Proofview.tactic (* Below, if flag is [None], it takes the value from the dynamic value of the option *) +exception NothingToInject val inj : inj_flags option -> intro_patterns option -> evars_flag -> clear_flag -> constr with_bindings -> unit Proofview.tactic val injClause : inj_flags option -> intro_patterns option -> evars_flag -> @@ -106,10 +107,6 @@ val dEqThen : keep_proofs:(bool option) -> evars_flag -> (clear_flag -> constr - val make_iterated_tuple : env -> evar_map -> constr -> (constr * types) -> evar_map * (constr * constr * constr) -(* The family cutRewriteIn expect an equality statement *) -val cutRewriteInHyp : bool -> types -> Id.t -> unit Proofview.tactic -val cutRewriteInConcl : bool -> constr -> unit Proofview.tactic - (* The family rewriteIn expect the proof of an equality *) val rewriteInHyp : bool -> constr -> Id.t -> unit Proofview.tactic val rewriteInConcl : bool -> constr -> unit Proofview.tactic diff --git a/tactics/hints.ml b/tactics/hints.ml index 386224824f..355cea8fa8 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -42,21 +42,22 @@ type debug = Debug | Info | Off exception Bound -let head_constr_bound sigma t = - let t = strip_outer_cast sigma t in - let _,ccl = decompose_prod_assum sigma t in - let hd,args = decompose_app sigma ccl in - let open GlobRef in - match EConstr.kind sigma hd with - | Const (c, _) -> ConstRef c - | Ind (i, _) -> IndRef i - | Construct (c, _) -> ConstructRef c - | Var id -> VarRef id - | Proj (p, _) -> ConstRef (Projection.constant p) - | _ -> raise Bound +let rec head_bound sigma t = match EConstr.kind sigma t with +| Prod (_, _, b) -> head_bound sigma b +| LetIn (_, _, _, b) -> head_bound sigma b +| App (c, _) -> head_bound sigma c +| Case (_, _, _, c, _) -> head_bound sigma c +| Ind (ind, _) -> GlobRef.IndRef ind +| Const (c, _) -> GlobRef.ConstRef c +| Construct (c, _) -> GlobRef.ConstructRef c +| Var id -> GlobRef.VarRef id +| Proj (p, _) -> GlobRef.ConstRef (Projection.constant p) +| Cast (c, _, _) -> head_bound sigma c +| Evar _ | Rel _ | Meta _ | Sort _ | Fix _ | Lambda _ +| CoFix _ | Int _ | Float _ | Array _ -> raise Bound let head_constr sigma c = - try head_constr_bound sigma c + try head_bound sigma c with Bound -> user_err (Pp.str "Head identifier must be a constant, section variable, \ (co)inductive type, (co)inductive type constructor, or projection.") @@ -105,7 +106,7 @@ type 'a hint_ast = | Give_exact of 'a | Res_pf_THEN_trivial_fail of 'a (* Hint Immediate *) | Unfold_nth of evaluable_global_reference (* Hint Unfold *) - | Extern of Genarg.glob_generic_argument (* Hint Extern *) + | Extern of Pattern.constr_pattern option * Genarg.glob_generic_argument (* Hint Extern *) type 'a hints_path_atom_gen = @@ -237,10 +238,38 @@ let pri_order t1 t2 = pri_order_int t1 t2 <= 0 type stored_data = int * full_hint (* First component is the index of insertion in the table, to keep most recent first semantics. *) -module Bounded_net = Btermdn.Make(struct - type t = stored_data - let compare = pri_order_int - end) +module Bounded_net : +sig + type t + val empty : t + val add : TransparentState.t option -> t -> Pattern.constr_pattern -> stored_data -> t + val lookup : Environ.env -> Evd.evar_map -> TransparentState.t option -> t -> EConstr.constr -> stored_data list +end = +struct + module Data = struct type t = stored_data let compare = pri_order_int end + module Bnet = Btermdn.Make(Data) + + type diff = Pattern.constr_pattern * stored_data + type data = Bnet of Bnet.t | Diff of diff * data ref + type t = data ref + + let empty = ref (Bnet Bnet.empty) + + let add _st net p v = ref (Diff ((p, v), net)) + + let rec force env st net = match !net with + | Bnet dn -> dn + | Diff ((p, v), rem) -> + let dn = force env st rem in + let p = Bnet.pattern env st p in + let dn = Bnet.add dn p v in + let () = net := (Bnet dn) in + dn + + let lookup env sigma st net p = + let dn = force env st net in + Bnet.lookup env sigma st dn p +end type search_entry = { sentry_nopat : stored_data list; @@ -258,27 +287,28 @@ let empty_se = { let eq_pri_auto_tactic (_, x) (_, y) = KerName.equal x.code.uid y.code.uid -let add_tac pat t st se = +let add_tac pat t se = match pat with | None -> if List.exists (eq_pri_auto_tactic t) se.sentry_nopat then se else { se with sentry_nopat = List.insert pri_order t se.sentry_nopat } - | Some pat -> + | Some (st, pat) -> if List.exists (eq_pri_auto_tactic t) se.sentry_pat then se else { se with sentry_pat = List.insert pri_order t se.sentry_pat; - sentry_bnet = Bounded_net.add st se.sentry_bnet (pat, t); } + sentry_bnet = Bounded_net.add st se.sentry_bnet pat t; } let rebuild_dn st se = let dn' = List.fold_left - (fun dn (id, t) -> Bounded_net.add (Some st) dn (Option.get t.pat, (id, t))) + (fun dn (id, t) -> + Bounded_net.add (Some st) dn (Option.get t.pat) (id, t)) Bounded_net.empty se.sentry_pat in { se with sentry_bnet = dn' } -let lookup_tacs sigma concl st se = - let l' = Bounded_net.lookup sigma st se.sentry_bnet concl in +let lookup_tacs env sigma concl st se = + let l' = Bounded_net.lookup env sigma st se.sentry_bnet concl in let sl' = List.stable_sort pri_order_int l' in List.merge pri_order_int se.sentry_nopat sl' @@ -320,8 +350,7 @@ let instantiate_hint env sigma p = | Res_pf_THEN_trivial_fail c -> Res_pf_THEN_trivial_fail (mk_clenv c) | Give_exact c -> Give_exact (mk_clenv c) - | Unfold_nth e -> Unfold_nth e - | Extern t -> Extern t + | (Unfold_nth _ | Extern _) as h -> h in { p with code = { p.code with obj = code } } @@ -500,14 +529,14 @@ val map_none : secvars:Id.Pred.t -> t -> full_hint list val map_all : secvars:Id.Pred.t -> GlobRef.t -> t -> full_hint list val map_existential : evar_map -> secvars:Id.Pred.t -> (GlobRef.t * constr array) -> constr -> t -> full_hint list with_mode -val map_eauto : evar_map -> secvars:Id.Pred.t -> +val map_eauto : Environ.env -> evar_map -> secvars:Id.Pred.t -> (GlobRef.t * constr array) -> constr -> t -> full_hint list with_mode -val map_auto : evar_map -> secvars:Id.Pred.t -> +val map_auto : Environ.env -> evar_map -> secvars:Id.Pred.t -> (GlobRef.t * constr array) -> constr -> t -> full_hint list val add_one : env -> evar_map -> hint_entry -> t -> t val add_list : env -> evar_map -> hint_entry list -> t -> t -val remove_one : GlobRef.t -> t -> t -val remove_list : GlobRef.t list -> t -> t +val remove_one : Environ.env -> GlobRef.t -> t -> t +val remove_list : Environ.env -> GlobRef.t list -> t -> t val iter : (GlobRef.t option -> hint_mode array list -> full_hint list -> unit) -> t -> unit val use_dn : t -> bool val transparent_state : t -> TransparentState.t @@ -600,10 +629,10 @@ struct merge_entry secvars db se.sentry_nopat se.sentry_pat (* Precondition: concl has no existentials *) - let map_auto sigma ~secvars (k,args) concl db = + let map_auto env sigma ~secvars (k,args) concl db = let se = find k db in let st = if db.use_dn then (Some db.hintdb_state) else None in - let pat = lookup_tacs sigma concl st se in + let pat = lookup_tacs env sigma concl st se in merge_entry secvars db [] pat let map_existential sigma ~secvars (k,args) concl db = @@ -613,11 +642,11 @@ struct else ModeMismatch (* [c] contains an existential *) - let map_eauto sigma ~secvars (k,args) concl db = + let map_eauto env sigma ~secvars (k,args) concl db = let se = find k db in if matches_modes sigma args se.sentry_mode then let st = if db.use_dn then Some db.hintdb_state else None in - let pat = lookup_tacs sigma concl st se in + let pat = lookup_tacs env sigma concl st se in ModeMatch (merge_entry secvars db [] pat) else ModeMismatch @@ -636,8 +665,6 @@ struct is_unfold v.code.obj then None else Some gr | None -> None in - let dnst = if db.use_dn then Some db.hintdb_state else None in - let pat = if not db.use_dn && is_exact v.code.obj then None else v.pat in match k with | None -> let is_present (_, (_, v')) = KerName.equal v.code.uid v'.code.uid in @@ -646,8 +673,14 @@ struct { db with hintdb_nopat = (gr,idv) :: db.hintdb_nopat } else db | Some gr -> + let pat = + if not db.use_dn && is_exact v.code.obj then None + else + let dnst = if db.use_dn then Some db.hintdb_state else None in + Option.map (fun p -> (dnst, p)) v.pat + in let oval = find gr db in - { db with hintdb_map = GlobRef.Map.add gr (add_tac pat idv dnst oval) db.hintdb_map } + { db with hintdb_map = GlobRef.Map.add gr (add_tac pat idv oval) db.hintdb_map } let rebuild_db st' db = let db' = @@ -687,14 +720,14 @@ struct if sl1' == se.sentry_nopat && sl2' == se.sentry_pat then se else rebuild_dn st { se with sentry_nopat = sl1'; sentry_pat = sl2' } - let remove_list grs db = + let remove_list env grs db = let filter (_, h) = match h.name with PathHints [gr] -> not (List.mem_f GlobRef.equal gr grs) | _ -> true in let hintmap = GlobRef.Map.map (remove_he db.hintdb_state filter) db.hintdb_map in let hintnopat = List.filter (fun (ge, sd) -> filter sd) db.hintdb_nopat in { db with hintdb_map = hintmap; hintdb_nopat = hintnopat } - let remove_one gr db = remove_list [gr] db + let remove_one env gr db = remove_list env [gr] db let get_entry se = let h = List.merge pri_order_int se.sentry_nopat se.sentry_pat in @@ -769,12 +802,6 @@ let rec nb_hyp sigma c = match EConstr.kind sigma c with (* adding and removing tactics in the search table *) -let try_head_pattern c = - try head_pattern_bound c - with BoundPattern -> - user_err (Pp.str "Head pattern or sub-pattern must be a global constant, a section variable, \ - an if, case, or let expression, an application, or a projection.") - let with_uid c = { obj = c; uid = fresh_key () } let secvars_of_idset s = @@ -795,38 +822,39 @@ let make_exact_entry env sigma info ~poly ?(name=PathAny) (c, cty, ctx) = match EConstr.kind sigma cty with | Prod _ -> failwith "make_exact_entry" | _ -> - let pat = Patternops.pattern_of_constr env sigma (EConstr.to_constr ~abort_on_undefined_evars:false sigma cty) in let hd = - try head_pattern_bound pat - with BoundPattern -> failwith "make_exact_entry" + try head_bound sigma cty + with Bound -> failwith "make_exact_entry" in let pri = match info.hint_priority with None -> 0 | Some p -> p in let pat = match info.hint_pattern with | Some pat -> snd pat - | None -> pat + | None -> + Patternops.pattern_of_constr env sigma (EConstr.to_constr ~abort_on_undefined_evars:false sigma cty) in (Some hd, { pri; pat = Some pat; name; db = None; secvars; code = with_uid (Give_exact (c, cty, ctx, poly)); }) -let make_apply_entry env sigma (eapply,hnf,verbose) info ~poly ?(name=PathAny) (c, cty, ctx) = +let make_apply_entry env sigma hnf info ~poly ?(name=PathAny) (c, cty, ctx) = let cty = if hnf then hnf_constr env sigma cty else cty in match EConstr.kind sigma cty with | Prod _ -> let sigma' = Evd.merge_context_set univ_flexible sigma ctx in let ce = mk_clenv_from_env env sigma' None (c,cty) in let c' = clenv_type (* ~reduce:false *) ce in - let pat = Patternops.pattern_of_constr env ce.evd (EConstr.to_constr ~abort_on_undefined_evars:false sigma c') in let hd = - try head_pattern_bound pat - with BoundPattern -> failwith "make_apply_entry" in + try head_bound ce.evd c' + with Bound -> failwith "make_apply_entry" in let miss = clenv_missing ce in let nmiss = List.length miss in let secvars = secvars_of_constr env sigma c in let pri = match info.hint_priority with None -> nb_hyp sigma' cty + nmiss | Some p -> p in let pat = match info.hint_pattern with - | Some p -> snd p | None -> pat + | Some p -> snd p + | None -> + Patternops.pattern_of_constr env ce.evd (EConstr.to_constr ~abort_on_undefined_evars:false sigma c') in if Int.equal nmiss 0 then (Some hd, @@ -834,25 +862,11 @@ let make_apply_entry env sigma (eapply,hnf,verbose) info ~poly ?(name=PathAny) ( db = None; secvars; code = with_uid (Res_pf(c,cty,ctx,poly)); }) - else begin - if not eapply then failwith "make_apply_entry"; - if verbose then begin - let variables = str (CString.plural nmiss "variable") in - Feedback.msg_info ( - strbrk "The hint " ++ - pr_leconstr_env env sigma' c ++ - strbrk " will only be used by eauto, because applying " ++ - pr_leconstr_env env sigma' c ++ - strbrk " would leave " ++ variables ++ Pp.spc () ++ - Pp.prlist_with_sep Pp.pr_comma Name.print (List.map (Evd.meta_name ce.evd) miss) ++ - strbrk " as unresolved existential " ++ variables ++ str "." - ) - end; + else (Some hd, { pri; pat = Some pat; name; db = None; secvars; code = with_uid (ERes_pf(c,cty,ctx,poly)); }) - end | _ -> failwith "make_apply_entry" (* flags is (e,h,v) with e=true if eapply and h=true if hnf and v=true if verbose @@ -888,19 +902,25 @@ let fresh_global_or_constr env sigma poly cr = (c, Univ.ContextSet.empty) end -let make_resolves env sigma flags info ~check ~poly ?name cr = +let make_resolves env sigma (eapply, hnf) info ~check ~poly ?name cr = let c, ctx = fresh_global_or_constr env sigma poly cr in let cty = Retyping.get_type_of env sigma c in let try_apply f = - try Some (f (c, cty, ctx)) with Failure _ -> None in + try + let (_, hint) as ans = f (c, cty, ctx) in + match hint.code.obj with + | ERes_pf _ -> if not eapply then None else Some ans + | _ -> Some ans + with Failure _ -> None + in let ents = List.map_filter try_apply [make_exact_entry env sigma info ~poly ?name; - make_apply_entry env sigma flags info ~poly ?name] + make_apply_entry env sigma hnf info ~poly ?name] in if check && List.is_empty ents then user_err ~hdr:"Hint" (pr_leconstr_env env sigma c ++ spc() ++ - (if pi1 flags then str"cannot be used as a hint." + (if eapply then str"cannot be used as a hint." else str "can be used as a hint only for eauto.")); ents @@ -909,7 +929,7 @@ let make_resolve_hyp env sigma decl = let hname = NamedDecl.get_id decl in let c = mkVar hname in try - [make_apply_entry env sigma (true, true, false) empty_hint_info ~poly:false + [make_apply_entry env sigma true empty_hint_info ~poly:false ~name:(PathHints [GlobRef.VarRef hname]) (c, NamedDecl.get_type decl, Univ.ContextSet.empty)] with @@ -929,14 +949,21 @@ let make_unfold eref = code = with_uid (Unfold_nth eref) }) let make_extern pri pat tacast = - let hdconstr = Option.map try_head_pattern pat in + let hdconstr = match pat with + | None -> None + | Some c -> + try Some (head_pattern_bound c) + with BoundPattern -> + user_err (Pp.str "Head pattern or sub-pattern must be a global constant, a section variable, \ + an if, case, or let expression, an application, or a projection.") + in (hdconstr, { pri = pri; pat = pat; name = PathAny; db = None; secvars = Id.Pred.empty; (* Approximation *) - code = with_uid (Extern tacast) }) + code = with_uid (Extern (pat, tacast)) }) let make_mode ref m = let open Term in @@ -1009,8 +1036,9 @@ let add_transparency dbname target b = in searchtable_add (dbname, Hint_db.set_transparent_state db st') let remove_hint dbname grs = + let env = Global.env () in let db = get_db dbname in - let db' = Hint_db.remove_list grs db in + let db' = Hint_db.remove_list env grs db in searchtable_add (dbname, db') type hint_action = @@ -1070,7 +1098,7 @@ let subst_autohint (subst, obj) = match t with | None -> gr' | Some t -> - (try head_constr_bound Evd.empty (EConstr.of_constr t.Univ.univ_abstracted_value) + (try head_bound Evd.empty (EConstr.of_constr t.Univ.univ_abstracted_value) with Bound -> gr') in let subst_mps subst c = EConstr.of_constr (subst_mps subst (EConstr.Unsafe.to_constr c)) in @@ -1100,9 +1128,10 @@ let subst_autohint (subst, obj) = | Unfold_nth ref -> let ref' = subst_evaluable_reference subst ref in if ref==ref' then data.code.obj else Unfold_nth ref' - | Extern tac -> + | Extern (pat, tac) -> + let pat' = Option.Smart.map (subst_pattern env sigma subst) data.pat in let tac' = Genintern.generic_substitute subst tac in - if tac==tac' then data.code.obj else Extern tac' + if pat==pat' && tac==tac' then data.code.obj else Extern (pat', tac') in let name' = subst_path_atom subst data.name in let uid' = subst_kn subst data.code.uid in @@ -1186,9 +1215,28 @@ let add_resolves env sigma clist ~local ~superglobal dbnames = (fun dbname -> let r = List.flatten (List.map (fun (pri, poly, hnf, path, gr) -> - make_resolves env sigma (true,hnf,not !Flags.quiet) + make_resolves env sigma (true, hnf) pri ~check:true ~poly ~name:path gr) clist) in + let check (_, hint) = match hint.code.obj with + | ERes_pf (c, cty, ctx, _) -> + let sigma' = Evd.merge_context_set univ_flexible sigma ctx in + let ce = mk_clenv_from_env env sigma' None (c,cty) in + let miss = clenv_missing ce in + let nmiss = List.length miss in + let variables = str (CString.plural nmiss "variable") in + Feedback.msg_info ( + strbrk "The hint " ++ + pr_leconstr_env env sigma' c ++ + strbrk " will only be used by eauto, because applying " ++ + pr_leconstr_env env sigma' c ++ + strbrk " would leave " ++ variables ++ Pp.spc () ++ + Pp.prlist_with_sep Pp.pr_comma Name.print (List.map (Evd.meta_name ce.evd) miss) ++ + strbrk " as unresolved existential " ++ variables ++ str "." + ) + | _ -> () + in + let () = if not !Flags.quiet then List.iter check r in let hint = make_hint ~local dbname (AddHints { superglobal; hints = r }) in Lib.add_anonymous_leaf (inAutoHint hint)) dbnames @@ -1338,10 +1386,10 @@ let expand_constructor_hints env sigma lems = let constructor_hints env sigma eapply lems = let lems = expand_constructor_hints env sigma lems in List.map_append (fun (poly, lem) -> - make_resolves env sigma (eapply,true,false) empty_hint_info ~check:true ~poly lem) lems + make_resolves env sigma (eapply, true) empty_hint_info ~check:true ~poly lem) lems let make_resolves env sigma info ~check ~poly ?name hint = - make_resolves env sigma (true, false, false) info ~check ~poly ?name hint + make_resolves env sigma (true, false) info ~check ~poly ?name hint let make_local_hint_db env sigma ts eapply lems = let map c = c env sigma in @@ -1382,7 +1430,7 @@ let pr_hint env sigma h = match h.obj with (str"simple apply " ++ pr_hint_elt env sigma c ++ str" ; trivial") | Unfold_nth c -> str"unfold " ++ pr_evaluable_reference c - | Extern tac -> + | Extern (_, tac) -> str "(*external*) " ++ Pputils.pr_glb_generic env sigma tac let pr_id_hint env sigma (id, v) = @@ -1427,7 +1475,7 @@ let pr_hint_term env sigma cl = (fun db -> match Hint_db.map_existential sigma ~secvars:Id.Pred.full hdc cl db with | ModeMatch l -> l | ModeMismatch -> []) - else Hint_db.map_auto sigma ~secvars:Id.Pred.full hdc cl + else Hint_db.map_auto env sigma ~secvars:Id.Pred.full hdc cl with Bound -> Hint_db.map_none ~secvars:Id.Pred.full in let fn db = List.map (fun x -> 0, x) (fn db) in @@ -1593,3 +1641,45 @@ struct let repr (h : t) = h.code.obj end + +let connect_hint_clenv h gl = + let { hint_uctx = ctx; hint_clnv = clenv } = h in + (* [clenv] has been generated by a hint-making function, so the only relevant + data in its evarmap is the set of metas. The [evar_reset_evd] function + below just replaces the metas of sigma by those coming from the clenv. *) + let sigma = Tacmach.New.project gl in + let evd = Evd.evars_reset_evd ~with_conv_pbs:true ~with_univs:false sigma clenv.evd in + (* Still, we need to update the universes *) + if h.hint_poly then + (* Refresh the instance of the hint *) + let (subst, ctx) = UnivGen.fresh_universe_context_set_instance ctx in + let emap c = Vars.subst_univs_level_constr subst c in + let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in + (* Only metas are mentioning the old universes. *) + { + templval = Evd.map_fl emap clenv.templval; + templtyp = Evd.map_fl emap clenv.templtyp; + evd = Evd.map_metas emap evd; + env = Proofview.Goal.env gl; + } + else + let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in + { clenv with evd = evd ; env = Proofview.Goal.env gl } + +let fresh_hint env sigma h = + let { hint_term = c; hint_uctx = ctx } = h in + if h.hint_poly then + (* Refresh the instance of the hint *) + let (subst, ctx) = UnivGen.fresh_universe_context_set_instance ctx in + let c = Vars.subst_univs_level_constr subst c in + let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in + sigma, c + else + let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in + sigma, c + +let hint_res_pf ?with_evars ?with_classes ?flags h = + Proofview.Goal.enter begin fun gl -> + let clenv = connect_hint_clenv h gl in + Clenv.res_pf ?with_evars ?with_classes ?flags clenv + end diff --git a/tactics/hints.mli b/tactics/hints.mli index 8243716624..e061bd7648 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -37,9 +37,9 @@ type 'a hint_ast = | Give_exact of 'a | Res_pf_THEN_trivial_fail of 'a (* Hint Immediate *) | Unfold_nth of evaluable_global_reference (* Hint Unfold *) - | Extern of Genarg.glob_generic_argument (* Hint Extern *) + | Extern of Pattern.constr_pattern option * Genarg.glob_generic_argument (* Hint Extern *) -type hint = { +type hint = private { hint_term : constr; hint_type : types; hint_uctx : Univ.ContextSet.t; @@ -134,18 +134,18 @@ module Hint_db : (** All hints associated to the reference, respecting modes if evars appear in the arguments and using the discrimination net. Returns a [ModeMismatch] if there are declared modes and none matches. *) - val map_eauto : evar_map -> secvars:Id.Pred.t -> (GlobRef.t * constr array) -> constr -> t -> FullHint.t list with_mode + val map_eauto : env -> evar_map -> secvars:Id.Pred.t -> (GlobRef.t * constr array) -> constr -> t -> FullHint.t list with_mode (** All hints associated to the reference. Precondition: no evars should appear in the arguments, so no modes are checked. *) - val map_auto : evar_map -> secvars:Id.Pred.t -> + val map_auto : env -> evar_map -> secvars:Id.Pred.t -> (GlobRef.t * constr array) -> constr -> t -> FullHint.t list val add_one : env -> evar_map -> hint_entry -> t -> t val add_list : env -> evar_map -> hint_entry list -> t -> t - val remove_one : GlobRef.t -> t -> t - val remove_list : GlobRef.t list -> t -> t + val remove_one : Environ.env -> GlobRef.t -> t -> t + val remove_list : Environ.env -> GlobRef.t list -> t -> t val iter : (GlobRef.t option -> hint_mode array list -> FullHint.t list -> unit) -> t -> unit @@ -239,6 +239,11 @@ val wrap_hint_warning_fun : env -> evar_map -> (evar_map -> 'a * evar_map) -> 'a * evar_map (** Variant of the above for non-tactics *) +val fresh_hint : env -> evar_map -> hint -> evar_map * constr + +val hint_res_pf : ?with_evars:bool -> ?with_classes:bool -> + ?flags:Unification.unify_flags -> hint -> unit Proofview.tactic + (** Printing hints *) val pr_searchtable : env -> evar_map -> Pp.t diff --git a/tactics/inv.ml b/tactics/inv.ml index 4b94dd0e72..41899132a6 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -409,7 +409,7 @@ let nLastDecls i tac = let rewrite_equations as_mode othin neqns names ba = Proofview.Goal.enter begin fun gl -> - let (depids,nodepids) = split_dep_and_nodep ba.Tacticals.assums gl in + let (depids,nodepids) = split_dep_and_nodep ba gl in let first_eq = ref Logic.MoveLast in let avoid = if as_mode then Id.Set.of_list (List.map NamedDecl.get_id nodepids) else Id.Set.empty in match othin with @@ -463,7 +463,7 @@ let raw_inversion inv_kind id status names = let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in let c = mkVar id in - let (ind, t) = + let ((ind, u), t) = try pf_apply Tacred.reduce_to_atomic_ind gl (pf_get_type_of gl c) with UserError _ -> let msg = str "The type of " ++ Id.print id ++ str " is not inductive." in @@ -474,13 +474,12 @@ let raw_inversion inv_kind id status names = let (elim_predicate, args) = make_inv_predicate env evdref indf realargs id status concl in let sigma = !evdref in - let (cut_concl,case_tac) = - if status != NoDep && (local_occur_var sigma id concl) then - Reductionops.beta_applist sigma (elim_predicate, realargs@[c]), - case_then_using + let dep = status != NoDep && (local_occur_var sigma id concl) in + let cut_concl = + if dep then + Reductionops.beta_applist sigma (elim_predicate, realargs@[c]) else - Reductionops.beta_applist sigma (elim_predicate, realargs), - case_nodep_then_using + Reductionops.beta_applist sigma (elim_predicate, realargs) in let refined id = let prf = mkApp (mkVar id, args) in @@ -488,13 +487,11 @@ let raw_inversion inv_kind id status names = in let neqns = List.length realargs in let as_mode = names != None in + let (_, args) = decompose_app_vect sigma t in tclTHEN (Proofview.Unsafe.tclEVARS sigma) (tclTHENS (assert_before Anonymous cut_concl) - [case_tac names - (introCaseAssumsThen false (* ApplyOn not supported by inversion *) - (rewrite_equations_tac as_mode inv_kind id neqns)) - (Some elim_predicate) ind (c,t); + [case_tac dep names (rewrite_equations_tac as_mode inv_kind id neqns) elim_predicate (ind, u, args) id; onLastHypId (fun id -> tclTHEN (refined id) reflexivity)]) end diff --git a/tactics/redexpr.ml b/tactics/redexpr.ml index c463c06cd5..a8747e0a7c 100644 --- a/tactics/redexpr.ml +++ b/tactics/redexpr.ml @@ -60,7 +60,7 @@ let set_strategy_one ref l = Global.set_strategy k l; match k,l with ConstKey sp, Conv_oracle.Opaque -> - Csymtable.set_opaque_const sp + Vmsymtable.set_opaque_const sp | ConstKey sp, _ -> let cb = Global.lookup_constant sp in (match cb.const_body with @@ -69,7 +69,7 @@ let set_strategy_one ref l = (str "Cannot make" ++ spc () ++ Nametab.pr_global_env Id.Set.empty (GlobRef.ConstRef sp) ++ spc () ++ str "transparent because it was declared opaque."); - | _ -> Csymtable.set_transparent_const sp) + | _ -> Vmsymtable.set_transparent_const sp) | _ -> () let cache_strategy (_,str) = diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index ec770e2473..c0fad0026f 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -14,10 +14,8 @@ open Util open Names open Constr open EConstr -open Termops open Declarations open Tacmach -open Clenv open Tactypes module RelDecl = Context.Rel.Declaration @@ -335,18 +333,6 @@ let ifOnHyp pred tac1 tac2 id gl = used to keep track of some information about the ``branches'' of the elimination. *) -type branch_args = { - ity : pinductive; (* the type we were eliminating on *) - branchnum : int; (* the branch number *) - nassums : int; (* number of assumptions/letin to be introduced *) - branchsign : bool list; (* the signature of the branch. - true=assumption, false=let-in *) - branchnames : intro_patterns} - -type branch_assumptions = { - ba : branch_args; (* the branch args *) - assums : named_context} (* the list of assumptions introduced *) - let fix_empty_or_and_pattern nv l = (* 1- The syntax does not distinguish between "[ ]" for one clause with no names and "[ ]" for no clause at all *) @@ -401,15 +387,13 @@ let get_and_check_or_and_pattern_gen ?loc check_and names branchsigns = let get_and_check_or_and_pattern ?loc = get_and_check_or_and_pattern_gen ?loc true -let compute_induction_names_gen check_and branchletsigns = function +let compute_induction_names check_and branchletsigns = function | None -> Array.make (Array.length branchletsigns) [] | Some {CAst.loc;v=names} -> let names = fix_empty_or_and_pattern (Array.length branchletsigns) names in get_and_check_or_and_pattern_gen check_and ?loc names branchletsigns -let compute_induction_names = compute_induction_names_gen true - (* Compute the let-in signature of case analysis or standard induction scheme *) let compute_constructor_signatures ~rec_flag ((_,k as ity),u) = let rec analrec c recargs = @@ -711,6 +695,8 @@ module New = struct (* Check that holes in arguments have been resolved *) let check_evars env sigma extsigma origsigma = + let reachable = lazy (Evarutil.reachable_from_evars sigma + (Evar.Map.domain (Evd.undefined_map origsigma))) in let rec is_undefined_up_to_restriction sigma evk = if Evd.mem origsigma evk then None else let evi = Evd.find sigma evk in @@ -726,7 +712,12 @@ module New = struct let rest = Evd.fold_undefined (fun evk evi acc -> match is_undefined_up_to_restriction sigma evk with - | Some (evk',evi) -> (evk',evi)::acc + | Some (evk',evi) -> + (* If [evk'] descends from [evk] which descends itself from + an originally undefined evar in [origsigma], it is a not + a fresh undefined hole from [sigma]. *) + if Evar.Set.mem evk (Lazy.force reachable) then acc + else (evk',evi)::acc | _ -> acc) extsigma [] in @@ -844,60 +835,6 @@ module New = struct tclMAP tac (Locusops.simple_clause_of (fun () -> hyps) cl) end - (* Find the right elimination suffix corresponding to the sort of the goal *) - (* c should be of type A1->.. An->B with B an inductive definition *) - let general_elim_then_using mk_elim - rec_flag allnames tac predicate ind (c, t) = - Proofview.Goal.enter begin fun gl -> - let sigma, elim = mk_elim ind gl in - let ind = on_snd (fun u -> EInstance.kind sigma u) ind in - Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) - (Proofview.Goal.enter begin fun gl -> - let indclause = mk_clenv_from gl (c, t) in - (* applying elimination_scheme just a little modified *) - let elimclause = mk_clenv_from gl (elim,Tacmach.New.pf_get_type_of gl elim) in - let indmv = - match EConstr.kind elimclause.evd (last_arg elimclause.evd elimclause.templval.Evd.rebus) with - | Meta mv -> mv - | _ -> anomaly (str"elimination.") - in - let pmv = - let p, _ = decompose_app elimclause.evd elimclause.templtyp.Evd.rebus in - match EConstr.kind elimclause.evd p with - | Meta p -> p - | _ -> - let name_elim = - match EConstr.kind sigma elim with - | Const _ | Var _ -> str " " ++ Printer.pr_econstr_env (pf_env gl) sigma elim - | _ -> mt () - in - user_err ~hdr:"Tacticals.general_elim_then_using" - (str "The elimination combinator " ++ name_elim ++ str " is unknown.") - in - let elimclause' = clenv_fchain ~with_univs:false indmv elimclause indclause in - let branchsigns = compute_constructor_signatures ~rec_flag ind in - let brnames = compute_induction_names_gen false branchsigns allnames in - let flags = Unification.elim_flags () in - let elimclause' = - match predicate with - | None -> elimclause' - | Some p -> clenv_unify ~flags Reduction.CONV (mkMeta pmv) p elimclause' - in - let after_tac i = - let ba = { branchsign = branchsigns.(i); - branchnames = brnames.(i); - nassums = List.length branchsigns.(i); - branchnum = i+1; - ity = ind; } - in - tac ba - in - let branchtacs = List.init (Array.length branchsigns) after_tac in - Proofview.tclTHEN - (Clenv.res_pf ~flags elimclause') - (Proofview.tclEXTEND [] tclIDTAC branchtacs) - end) end - let elimination_sort_of_goal gl = (* Retyping will expand evars anyway. *) let c = Proofview.Goal.concl gl in @@ -912,68 +849,6 @@ module New = struct | None -> elimination_sort_of_goal gl | Some id -> elimination_sort_of_hyp id gl - (* computing the case/elim combinators *) - - let gl_make_elim ind = begin fun gl -> - let env = Proofview.Goal.env gl in - let gr = Indrec.lookup_eliminator env (fst ind) (elimination_sort_of_goal gl) in - let (sigma, c) = pf_apply Evd.fresh_global gl gr in - (sigma, c) - end - - let gl_make_case_dep (ind, u) = begin fun gl -> - let sigma = project gl in - let u = EInstance.kind (project gl) u in - let (sigma, r) = Indrec.build_case_analysis_scheme (pf_env gl) sigma (ind, u) true - (elimination_sort_of_goal gl) - in - (sigma, EConstr.of_constr r) - end - - let gl_make_case_nodep (ind, u) = begin fun gl -> - let sigma = project gl in - let u = EInstance.kind sigma u in - let (sigma, r) = Indrec.build_case_analysis_scheme (pf_env gl) sigma (ind, u) false - (elimination_sort_of_goal gl) - in - (sigma, EConstr.of_constr r) - end - - let make_elim_branch_assumptions ba hyps = - let assums = - try List.rev (List.firstn ba.nassums hyps) - with Failure _ -> anomaly (Pp.str "make_elim_branch_assumptions.") in - { ba = ba; assums = assums } - - let elim_on_ba tac ba = - Proofview.Goal.enter begin fun gl -> - let branches = make_elim_branch_assumptions ba (Proofview.Goal.hyps gl) in - tac branches - end - - let case_on_ba tac ba = - Proofview.Goal.enter begin fun gl -> - let branches = make_elim_branch_assumptions ba (Proofview.Goal.hyps gl) in - tac branches - end - - let elimination_then tac c = - Proofview.Goal.enter begin fun gl -> - let (ind,t) = pf_reduce_to_quantified_ind gl (pf_get_type_of gl c) in - let isrec,mkelim = - match (Global.lookup_mind (fst (fst ind))).mind_record with - | NotRecord -> true,gl_make_elim - | FakeRecord | PrimRecord _ -> false,gl_make_case_dep - in - general_elim_then_using mkelim isrec None tac None ind (c, t) - end - - let case_then_using = - general_elim_then_using gl_make_case_dep false - - let case_nodep_then_using = - general_elim_then_using gl_make_case_nodep false - let pf_constr_of_global ref = Proofview.tclEVARMAP >>= fun sigma -> Proofview.tclENV >>= fun env -> diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 48a06e6e1d..bfead34b3b 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -9,7 +9,6 @@ (************************************************************************) open Names -open Constr open EConstr open Evd open Locus @@ -94,18 +93,6 @@ val onClauseLR : (Id.t option -> tactic) -> clause -> tactic (** {6 Elimination tacticals. } *) -type branch_args = private { - ity : pinductive; (** the type we were eliminating on *) - branchnum : int; (** the branch number *) - nassums : int; (** number of assumptions/letin to be introduced *) - branchsign : bool list; (** the signature of the branch. - true=assumption, false=let-in *) - branchnames : intro_patterns} - -type branch_assumptions = private { - ba : branch_args; (** the branch args *) - assums : named_context} (** the list of assumptions introduced *) - (** [get_and_check_or_and_pattern loc pats branchsign] returns an appropriate error message if |pats| <> |branchsign|; extends them if no pattern is given for let-ins in the case of a conjunctive pattern *) @@ -122,7 +109,7 @@ val compute_constructor_signatures : rec_flag:bool -> inductive * 'a -> bool lis (** Useful for [as intro_pattern] modifier *) val compute_induction_names : - bool list array -> or_and_intro_pattern option -> intro_patterns array + bool -> bool list array -> or_and_intro_pattern option -> intro_patterns array val elimination_sort_of_goal : Goal.goal sigma -> Sorts.family val elimination_sort_of_hyp : Id.t -> Goal.goal sigma -> Sorts.family @@ -249,20 +236,5 @@ module New : sig val elimination_sort_of_hyp : Id.t -> Proofview.Goal.t -> Sorts.family val elimination_sort_of_clause : Id.t option -> Proofview.Goal.t -> Sorts.family - val elimination_then : - (branch_args -> unit Proofview.tactic) -> - constr -> unit Proofview.tactic - - val case_then_using : - or_and_intro_pattern option -> (branch_args -> unit Proofview.tactic) -> - constr option -> inductive * EInstance.t -> constr * types -> unit Proofview.tactic - - val case_nodep_then_using : - or_and_intro_pattern option -> (branch_args -> unit Proofview.tactic) -> - constr option -> inductive * EInstance.t -> constr * types -> unit Proofview.tactic - - val elim_on_ba : (branch_assumptions -> unit Proofview.tactic) -> branch_args -> unit Proofview.tactic - val case_on_ba : (branch_assumptions -> unit Proofview.tactic) -> branch_args -> unit Proofview.tactic - val pf_constr_of_global : GlobRef.t -> constr Proofview.tactic end diff --git a/tactics/tactics.ml b/tactics/tactics.ml index f553a290f9..a607c09010 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -117,7 +117,7 @@ let unsafe_intro env decl b = Refine.refine ~typecheck:false begin fun sigma -> let ctx = named_context_val env in let nctx = push_named_context_val decl ctx in - let inst = List.map (NamedDecl.get_id %> mkVar) (named_context env) in + let inst = identity_subst_val (named_context_val env) in let ninst = mkRel 1 :: inst in let nb = subst1 (mkVar (NamedDecl.get_id decl)) b in let (sigma, ev) = new_pure_evar nctx sigma nb ~principal:true in @@ -338,7 +338,7 @@ let rename_hyp repl = let nhyps = List.map map hyps in let nconcl = subst concl in let nctx = val_of_named_context nhyps in - let instance = List.map (NamedDecl.get_id %> mkVar) hyps in + let instance = EConstr.identity_subst_val (Environ.named_context_val env) in Refine.refine ~typecheck:false begin fun sigma -> let sigma, ev = Evarutil.new_pure_evar nctx sigma nconcl ~principal:true in sigma, mkEvar (ev, instance) @@ -437,11 +437,6 @@ let clear_hyps2 env sigma ids sign t cl = with Evarutil.ClearDependencyError (id,err,inglobal) -> error_replacing_dependency env sigma id err inglobal -let new_evar_from_context ?principal sign evd typ = - let instance = List.map (NamedDecl.get_id %> EConstr.mkVar) (named_context_of_val sign) in - let (evd, evk) = Evarutil.new_pure_evar sign evd typ in - (evd, mkEvar (evk, instance)) - let internal_cut ?(check=true) replace id t = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in @@ -449,22 +444,22 @@ let internal_cut ?(check=true) replace id t = let concl = Proofview.Goal.concl gl in let sign = named_context_val env in let r = Retyping.relevance_of_type env sigma t in - let sign',t,concl,sigma = + let env',t,concl,sigma = if replace then let nexthyp = get_next_hyp_position env sigma id (named_context_of_val sign) in let sigma,sign',t,concl = clear_hyps2 env sigma (Id.Set.singleton id) sign t concl in let sign' = insert_decl_in_named_context env sigma (LocalAssum (make_annot id r,t)) nexthyp sign' in - sign',t,concl,sigma + Environ.reset_with_named_context sign' env,t,concl,sigma else (if check && mem_named_context_val id sign then user_err (str "Variable " ++ Id.print id ++ str " is already declared."); - push_named_context_val (LocalAssum (make_annot id r,t)) sign,t,concl,sigma) in + push_named (LocalAssum (make_annot id r,t)) env,t,concl,sigma) in let nf_t = nf_betaiota env sigma t in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Refine.refine ~typecheck:false begin fun sigma -> - let (sigma, ev) = new_evar_from_context sign sigma nf_t in - let (sigma, ev') = new_evar_from_context sign' sigma ~principal:true concl in + let (sigma, ev) = Evarutil.new_evar env sigma nf_t in + let (sigma, ev') = Evarutil.new_evar ~principal:true env' sigma concl in let term = mkLetIn (make_annot (Name id) r, ev, t, EConstr.Vars.subst_var id ev') in (sigma, term) end) @@ -729,7 +724,9 @@ type hyp_conversion = | StableHypConv (** Does not introduce new dependencies on variables *) | LocalHypConv (** Same as above plus no dependence on the named environment *) -let e_change_in_hyps ~check ~reorder f args = +let e_change_in_hyps ~check ~reorder f args = match args with +| [] -> Proofview.tclUNIT () +| _ :: _ -> Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in @@ -1049,12 +1046,15 @@ let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = end end -let intro_gen n m f d = intro_then_gen n m f d (fun _ -> Proofview.tclUNIT ()) +let drop_intro_name (_ : Id.t) = Proofview.tclUNIT () + +let intro_gen n m f d = intro_then_gen n m f d drop_intro_name let intro_mustbe_force id = intro_gen (NamingMustBe (CAst.make id)) MoveLast true false -let intro_using id = intro_gen (NamingBasedOn (id, Id.Set.empty)) MoveLast false false +let intro_using_then id = intro_then_gen (NamingBasedOn (id, Id.Set.empty)) MoveLast false false +let intro_using id = intro_using_then id drop_intro_name let intro_then = intro_then_gen (NamingAvoid Id.Set.empty) MoveLast false false -let intro = intro_gen (NamingAvoid Id.Set.empty) MoveLast false false +let intro = intro_then drop_intro_name let introf = intro_gen (NamingAvoid Id.Set.empty) MoveLast true false let intro_avoiding l = intro_gen (NamingAvoid l) MoveLast false false @@ -1070,6 +1070,15 @@ let rec intros_using = function | [] -> Proofview.tclUNIT() | str::l -> Tacticals.New.tclTHEN (intro_using str) (intros_using l) +let rec intros_mustbe_force = function + | [] -> Proofview.tclUNIT() + | str::l -> Tacticals.New.tclTHEN (intro_mustbe_force str) (intros_mustbe_force l) + +let rec intros_using_then_helper tac acc = function + | [] -> tac (List.rev acc) + | str::l -> intro_using_then str (fun str' -> intros_using_then_helper tac (str'::acc) l) +let intros_using_then l tac = intros_using_then_helper tac [] l + let intros = Tacticals.New.tclREPEAT intro let intro_forthcoming_then_gen name_flag move_flag dep_flag n bound tac = @@ -2323,7 +2332,7 @@ let intro_decomp_eq ?loc l thin tac id = let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let sigma, t = Typing.type_of env sigma c in - let _,t = reduce_to_quantified_ind env sigma t in + let _,t = reduce_to_atomic_ind env sigma t in match my_find_eq_data_decompose env sigma t with | Some (eq,u,eq_args) -> !intro_decomp_eq_function @@ -2788,7 +2797,7 @@ let pose_tac na c = let id = make_annot id Sorts.Relevant in let nhyps = EConstr.push_named_context_val (NamedDecl.LocalDef (id, c, t)) hyps in let (sigma, ev) = Evarutil.new_pure_evar nhyps sigma concl in - let inst = List.map (fun d -> mkVar (get_id d)) (named_context env) in + let inst = EConstr.identity_subst_val hyps in let body = mkEvar (ev, mkRel 1 :: inst) in (sigma, mkLetIn (map_annot Name.mk_name id, c, t, body)) end @@ -3241,13 +3250,10 @@ let rec consume_pattern avoid na isdep gl = let open CAst in function | {loc;v=IntroForthcoming true}::names when not isdep -> consume_pattern avoid na isdep gl names | {loc;v=IntroForthcoming _}::names as fullpat -> - let avoid = Id.Set.union avoid (explicit_intro_names names) in (CAst.make ?loc @@ intropattern_of_name gl avoid na, fullpat) | {loc;v=IntroNaming IntroAnonymous}::names -> - let avoid = Id.Set.union avoid (explicit_intro_names names) in (CAst.make ?loc @@ intropattern_of_name gl avoid na, names) | {loc;v=IntroNaming (IntroFresh id')}::names -> - let avoid = Id.Set.union avoid (explicit_intro_names names) in (CAst.make ?loc @@ IntroNaming (IntroIdentifier (new_fresh_id avoid id' gl)), names) | pat::names -> (pat,names) @@ -3305,7 +3311,7 @@ let get_recarg_dest (recargdests,tophyp) = *) let induct_discharge with_evars dests avoid' tac (avoid,ra) names = - let avoid = Id.Set.union avoid avoid' in + let avoid = Id.Set.union avoid' (Id.Set.union avoid (explicit_intro_names names)) in let rec peel_tac ra dests names thin = match ra with | (RecArg,_,deprec,recvarname) :: @@ -3313,7 +3319,7 @@ let induct_discharge with_evars dests avoid' tac (avoid,ra) names = Proofview.Goal.enter begin fun gl -> let (recpat,names) = match names with | [{CAst.loc;v=IntroNaming (IntroIdentifier id)} as pat] -> - let id' = next_ident_away (add_prefix "IH" id) avoid in + let id' = new_fresh_id avoid (add_prefix "IH" id) gl in (pat, [CAst.make @@ IntroNaming (IntroIdentifier id')]) | _ -> consume_pattern avoid (Name recvarname) deprec gl names in let dest = get_recarg_dest dests in @@ -4390,7 +4396,7 @@ let apply_induction_in_context with_evars hyp0 inhyps elim indvars names induct_ let branchletsigns = let f (_,is_not_let,_,_) = is_not_let in Array.map (fun (_,l) -> List.map f l) indsign in - let names = compute_induction_names branchletsigns names in + let names = compute_induction_names true branchletsigns names in Array.iter (check_name_unicity env toclear []) names; let tac = (if isrec then Tacticals.New.tclTHENFIRSTn else Tacticals.New.tclTHENLASTn) @@ -5177,14 +5183,14 @@ end (** Tacticals defined directly in term of Proofview *) module New = struct - open Genredexpr - open Locus - let reduce_after_refine = - reduce - (Lazy {rBeta=true;rMatch=true;rFix=true;rCofix=true; - rZeta=false;rDelta=false;rConst=[]}) - {onhyps = Some []; concl_occs = AllOccurrences } + (* For backward compatibility reasons, we do not contract let-ins, but we unfold them. *) + let redfun env t = + let open CClosure in + let flags = RedFlags.red_add_transparent allnolet TransparentState.empty in + clos_norm_flags flags env t + in + reduct_in_concl ~check:false (redfun,DEFAULTcast) let refine ~typecheck c = Refine.refine ~typecheck c <*> diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 5b397b15d0..54c781af5c 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -65,9 +65,14 @@ val intro_avoiding : Id.Set.t -> unit Proofview.tactic val intro_replacing : Id.t -> unit Proofview.tactic val intro_using : Id.t -> unit Proofview.tactic +[@@ocaml.deprecated "Prefer [intro_using_then] to avoid renaming issues."] +val intro_using_then : Id.t -> (Id.t -> unit Proofview.tactic) -> unit Proofview.tactic val intro_mustbe_force : Id.t -> unit Proofview.tactic +val intros_mustbe_force : Id.t list -> unit Proofview.tactic val intro_then : (Id.t -> unit Proofview.tactic) -> unit Proofview.tactic val intros_using : Id.t list -> unit Proofview.tactic +[@@ocaml.deprecated "Prefer [intros_using_then] to avoid renaming issues."] +val intros_using_then : Id.t list -> (Id.t list -> unit Proofview.tactic) -> unit Proofview.tactic val intros_replacing : Id.t list -> unit Proofview.tactic val intros_possibly_replacing : Id.t list -> unit Proofview.tactic diff --git a/test-suite/Makefile b/test-suite/Makefile index f7447d6cec..758374c5de 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -198,7 +198,6 @@ summary: $(call summary_dir, "Coqdoc tests", coqdoc); \ $(call summary_dir, "tools/ tests", tools); \ $(call summary_dir, "Unit tests", unit-tests); \ - $(call summary_dir, "Machine arithmetic tests", arithmetic); \ $(call summary_dir, "Ltac2 tests", ltac2); \ nb_success=`find . -name '*.log' -exec tail -n2 '{}' \; | grep -e $(log_success) | wc -l`; \ nb_failure=`find . -name '*.log' -exec tail -n2 '{}' \; | grep -e $(log_failure) | wc -l`; \ @@ -223,7 +222,7 @@ report: summary.log # printed for all opened bugs (still active or seems to be closed). # For closed bugs that behave as expected, no message is printed -# All files are assumed to have <# of the bug>.v as a name +# All files are assumed to have bug_<# of the bug>.v as a name # Opened bugs that should not fail $(addsuffix .log,$(wildcard bugs/opened/*.v)): %.v.log: %.v @@ -301,20 +300,20 @@ endif unit-tests/src/utest.cmx: unit-tests/src/utest.ml unit-tests/src/utest.cmi $(SHOW) 'OCAMLOPT $<' - $(HIDE)$(OCAMLOPT) -c -I unit-tests/src -package oUnit $< + $(HIDE)$(OCAMLOPT) -c -I unit-tests/src -package ounit2 $< unit-tests/src/utest.cmo: unit-tests/src/utest.ml unit-tests/src/utest.cmi $(SHOW) 'OCAMLC $<' - $(HIDE)$(OCAMLC) -c -I unit-tests/src -package oUnit $< + $(HIDE)$(OCAMLC) -c -I unit-tests/src -package ounit2 $< unit-tests/src/utest.cmi: unit-tests/src/utest.mli $(SHOW) 'OCAMLC $<' - $(HIDE)$(OCAMLC) -package oUnit -c $< + $(HIDE)$(OCAMLC) -package ounit2 -c $< unit-tests: $(UNIT_LOGFILES) # Build executable, run it to generate log file unit-tests/%.ml.log: unit-tests/%.ml unit-tests/src/$(UNIT_LINK) $(SHOW) 'TEST $<' - $(HIDE)$(OCAMLBEST) -linkall -linkpkg -package coq.toplevel,oUnit \ + $(HIDE)$(OCAMLBEST) -linkall -linkpkg -package coq.toplevel,ounit2 \ -I unit-tests/src $(UNIT_LINK) $< -o $<.test; $(HIDE)./$<.test @@ -501,8 +500,8 @@ $(addsuffix .log,$(wildcard output-coqchk/*.v)): %.v.log: %.v %.out $(PREREQUISI } > "$(shell dirname $<)/$(shell basename $< .v).chk.log"; fi .PHONY: approve-output -approve-output: output output-coqtop - $(HIDE)for f in output/*.out.real; do \ +approve-output: output output-coqtop output-coqchk + $(HIDE)for f in $(wildcard $(addsuffix /*.out.real,$^)); do \ mv "$$f" "$${f%.real}"; \ echo "Updated $${f%.real}!"; \ done diff --git a/test-suite/bugs/bug_5996.v b/test-suite/bugs/bug_5996.v deleted file mode 100644 index c9e3292b48..0000000000 --- a/test-suite/bugs/bug_5996.v +++ /dev/null @@ -1,8 +0,0 @@ -Goal Type. - let c := constr:(prod nat nat) in - let c' := (eval pattern nat in c) in - let c' := lazymatch c' with ?f _ => f end in - let c'' := lazymatch c' with fun x : Set => ?f => constr:(forall x : Type, f) end in - let _ := type of c'' in - exact c''. -Defined. diff --git a/test-suite/bugs/closed/bug_10939.v b/test-suite/bugs/closed/bug_10939.v new file mode 100644 index 0000000000..e4adc35554 --- /dev/null +++ b/test-suite/bugs/closed/bug_10939.v @@ -0,0 +1,5 @@ +Goal False. +Proof. + epose proof ltac:(shelve). (* works *) + epose proof ltac:(admit). (* anomaly *) +Abort. diff --git a/test-suite/bugs/bug_11140.v b/test-suite/bugs/closed/bug_11140.v index ca806ea324..ca806ea324 100644 --- a/test-suite/bugs/bug_11140.v +++ b/test-suite/bugs/closed/bug_11140.v diff --git a/test-suite/bugs/closed/bug_12001.v b/test-suite/bugs/closed/bug_12001.v new file mode 100644 index 0000000000..19533e49f1 --- /dev/null +++ b/test-suite/bugs/closed/bug_12001.v @@ -0,0 +1,24 @@ +(* Argument names don't get mangled *) +Set Mangle Names. +Lemma leibniz_equiv_iff {A : Type} (x y : A) : True. +Proof. tauto. Qed. +Check leibniz_equiv_iff (A := nat) 2 3 : True. +Unset Mangle Names. + +(* Coq doesn't make up names for arguments *) +Definition bar (a a : nat) : nat := 3. +Arguments bar _ _ : assert. +Fail Arguments bar a a0 : assert. + +(* This definition caused an anomaly in a version of this PR +without the change to prepare_implicits *) +Set Implicit Arguments. +Definition foo (_ : nat) (_ : @eq nat ltac:(assumption) 2) : True := I. +Fail Check foo (H := 2). + +Definition baz (a b : nat) := b. +Arguments baz a {b}. +Set Mangle Names. +Definition baz2 (a b : nat) := b. +Arguments baz2 a {b}. +Unset Mangle Names. diff --git a/test-suite/bugs/closed/bug_12483.v b/test-suite/bugs/closed/bug_12483.v index 0d034a65eb..ae46117e59 100644 --- a/test-suite/bugs/closed/bug_12483.v +++ b/test-suite/bugs/closed/bug_12483.v @@ -4,7 +4,7 @@ Goal False. Proof. cut (false = true). { intro H; discriminate H. } -change false with (1 <= 0)%float. +change false with (1 <=? 0)%float. rewrite leb_spec. Fail reflexivity. Abort. diff --git a/test-suite/bugs/closed/bug_12676.v b/test-suite/bugs/closed/bug_12676.v new file mode 100644 index 0000000000..5118ddb472 --- /dev/null +++ b/test-suite/bugs/closed/bug_12676.v @@ -0,0 +1,13 @@ + + +Definition nat_eq_dec(i j:nat) : {i=j}+{i<>j}. +Proof. + pose (diseq := false). + decide equality. +Defined. + +Set Mangle Names. +Definition nat_eq_dec_mangle (i j:nat) : {i=j}+{i<>j}. +Proof. + decide equality. (*Error: Anomaly "variable diseq unbound." ...*) +Defined. diff --git a/test-suite/bugs/closed/bug_12763.v b/test-suite/bugs/closed/bug_12763.v new file mode 100644 index 0000000000..6cbcc0d3b0 --- /dev/null +++ b/test-suite/bugs/closed/bug_12763.v @@ -0,0 +1,6 @@ +Inductive bool_list := S (y : bool) (l : bool_list) | O. +Scheme Equality for bool_list. + +Set Mangle Names. +Scheme Equality for nat. +Scheme Equality for list. diff --git a/test-suite/bugs/closed/bug_12787.v b/test-suite/bugs/closed/bug_12787.v new file mode 100644 index 0000000000..2566e1f261 --- /dev/null +++ b/test-suite/bugs/closed/bug_12787.v @@ -0,0 +1,26 @@ +Inductive sigT3 {A: Type} {P: A -> Type} (Q: forall a: A, P a -> Type) := + existT3: forall a: A, forall b: P a, Q a b -> sigT3 Q +. + +Definition projT3_1 {A: Type} {P: A -> Type} {Q: forall a: A, P a -> Type} (a: sigT3 Q) := + let 'existT3 _ x0 _ _ := a in x0. + +Definition projT3_2 {A: Type} {P: A -> Type} {Q: forall a: A, P a -> Type} (a: sigT3 Q) : P (projT3_1 a) := + let 'existT3 _ x0 x1 _ := a in x1. + + + +Lemma projT3_3_eq' (A B: Type) (Q: B -> Type) (a b: sigT3 (fun (_: A) b => Q b)) (H: a = b) : + unit. +Proof. + destruct a as [x0 x1 x2], b as [y0 y1 y2]. + assert (H' := f_equal projT3_1 H). + cbn in H'. + subst x0. + assert (H' := f_equal (projT3_2 (P := fun _ => B)) H). + cbn in H'. + subst x1. + + injection H as H'. + exact tt. +Qed. diff --git a/test-suite/bugs/closed/bug_12860.v b/test-suite/bugs/closed/bug_12860.v new file mode 100644 index 0000000000..243aeceba2 --- /dev/null +++ b/test-suite/bugs/closed/bug_12860.v @@ -0,0 +1,10 @@ +Require Import Coq.nsatz.NsatzTactic. +Require Import Coq.ZArith.ZArith Coq.QArith.QArith. + +Goal forall x y : Z, (x + y = y + x)%Z. + intros; nsatz. +Qed. + +Goal forall x y : Q, Qeq (x + y) (y + x). + intros; nsatz. +Qed. diff --git a/test-suite/bugs/closed/bug_12889.v b/test-suite/bugs/closed/bug_12889.v new file mode 100644 index 0000000000..f53cb8272d --- /dev/null +++ b/test-suite/bugs/closed/bug_12889.v @@ -0,0 +1,28 @@ +Require Import Relations. +Require Import Setoid. +Require Import Ring_theory. +Require Import Ring_base. + +Section S1. +Variable R : Type. +Variable Rone Rzero : R. +Variable Rplus Rmult Rminus : R -> R -> R. +Variable Rneg : R -> R. + +Lemma my_ring_theory1 : @ring_theory R Rzero Rone Rplus Rmult Rminus Rneg (@eq +R). +Admitted. +Add Ring my_ring : my_ring_theory1. +End S1. + +Section S2. +Variable R : Type. +Variable Rone Rzero : R. +Variable Rplus Rmult Rminus : R -> R -> R. +Variable Rneg : R -> R. + +Lemma my_ring_theory2 : @ring_theory R Rzero Rone Rplus Rmult Rminus Rneg (@eq +R). +Admitted. +Add Ring my_ring : my_ring_theory2. +End S2. diff --git a/test-suite/bugs/closed/bug_12907.v b/test-suite/bugs/closed/bug_12907.v new file mode 100644 index 0000000000..4cd79cc1af --- /dev/null +++ b/test-suite/bugs/closed/bug_12907.v @@ -0,0 +1,7 @@ +From Coq Require Export Lia. +Set Mangle Names. +Lemma test (n : nat) : n <= 10 -> n <= 20. +Proof. lia. Qed. + +Lemma test2 : 0 < 1. +Proof. lia. Qed. diff --git a/test-suite/bugs/closed/bug_12909.v b/test-suite/bugs/closed/bug_12909.v new file mode 100644 index 0000000000..fafb6a418f --- /dev/null +++ b/test-suite/bugs/closed/bug_12909.v @@ -0,0 +1,8 @@ +Module Type T. +Axiom A : Type. +End T. + +Module M. + Axiom A : SProp. +End M. +Fail Module N <: T := M. diff --git a/test-suite/bugs/closed/bug_12928.v b/test-suite/bugs/closed/bug_12928.v new file mode 100644 index 0000000000..2f4d1dd16d --- /dev/null +++ b/test-suite/bugs/closed/bug_12928.v @@ -0,0 +1,7 @@ + +Lemma test: forall (x:bool) (x: nat), nat. +Proof. intros y x; abstract (exact x). Qed. + +Set Mangle Names. +Lemma test': forall x : nat, nat. +Proof. intros x. abstract exact x. Qed. diff --git a/test-suite/bugs/closed/bug_12930.v b/test-suite/bugs/closed/bug_12930.v new file mode 100644 index 0000000000..e2a524301a --- /dev/null +++ b/test-suite/bugs/closed/bug_12930.v @@ -0,0 +1,10 @@ +Section S. + Variable v : Prop. + Variable vv : v. + Collection easy := Type*. + + Lemma ybar : v. + Proof using easy. + exact vv. + Qed. +End S. diff --git a/test-suite/bugs/closed/bug_12944.v b/test-suite/bugs/closed/bug_12944.v new file mode 100644 index 0000000000..d6720d9906 --- /dev/null +++ b/test-suite/bugs/closed/bug_12944.v @@ -0,0 +1,12 @@ + +Inductive vector A : nat -> Type := + |nil : vector A 0 + |cons : forall (h:A) (n:nat), vector A n -> vector A (S n). + +Global Set Mangle Names. + +Lemma vlookup_middle {A n} (v : vector A n) : True. +Proof. + induction v as [|?? IHv]. + all:exact I. +Qed. diff --git a/test-suite/bugs/closed/bug_3146.v b/test-suite/bugs/closed/bug_3146.v new file mode 100644 index 0000000000..c42e28818a --- /dev/null +++ b/test-suite/bugs/closed/bug_3146.v @@ -0,0 +1,5 @@ +Axiom x : True. +Goal nat -> nat. + intro x. + abstract (exact x). +Qed. diff --git a/test-suite/bugs/closed/bug_4095.v b/test-suite/bugs/closed/bug_4095.v index 3d3015c383..d667022e68 100644 --- a/test-suite/bugs/closed/bug_4095.v +++ b/test-suite/bugs/closed/bug_4095.v @@ -71,18 +71,9 @@ Goal forall (T : Type) (O0 : T -> OPred) (O1 : T -> PointedOPred) refine (P _ _) end. Undo. - Fail lazymatch goal with + lazymatch goal with | |- ?R (?f ?a ?b) (?f ?a' ?b') => let P := constr:(fun H H' => Morphisms.proper_prf a a' H b b' H') in set(p:=P) - end. (* Toplevel input, characters 15-182: -Error: Cannot infer an instance of type -"PointedOPred" for the variable p in environment: -T : Type -O0 : T -> OPred -O1 : T -> PointedOPred -tr : T -> T -O2 : PointedOPred -x0 : T -H : forall x0 : T, catOP (O0 x0) (O1 (tr x0)) |-- O1 x0 *) + end. Abort. diff --git a/test-suite/bugs/closed/bug_4413.v b/test-suite/bugs/closed/bug_4413.v new file mode 100644 index 0000000000..cb30aa5d1f --- /dev/null +++ b/test-suite/bugs/closed/bug_4413.v @@ -0,0 +1,8 @@ + +(* Regression wrt v8.4 related to the change of order of resolution of evar-evar unification problems. *) +Goal exists x, x=1 -> True. +eexists. intro H. +pose proof (f_equal (fun k => k) H). +Undo. +pose (@f_equal _ _ S _ _ H). +Abort. diff --git a/test-suite/bugs/bug_4690.v b/test-suite/bugs/closed/bug_4690.v index f50866a990..f50866a990 100644 --- a/test-suite/bugs/bug_4690.v +++ b/test-suite/bugs/closed/bug_4690.v diff --git a/test-suite/bugs/closed/bug_5703.v b/test-suite/bugs/closed/bug_5703.v new file mode 100644 index 0000000000..c6e9eab9a7 --- /dev/null +++ b/test-suite/bugs/closed/bug_5703.v @@ -0,0 +1,9 @@ +Class A := {}. +Instance a:A := {}. +Hint Extern 0 A => abstract (exact a) : typeclass_instances. +Lemma lem : A. +Proof. + let a := constr:(_:A) in + let b := type of a in + exact a. +Defined. diff --git a/test-suite/bugs/closed/bug_7015.v b/test-suite/bugs/closed/bug_7015.v new file mode 100644 index 0000000000..a57fa94960 --- /dev/null +++ b/test-suite/bugs/closed/bug_7015.v @@ -0,0 +1,74 @@ +Set Universe Polymorphism. +Set Polymorphic Inductive Cumulativity. +Set Printing Universes. + +Module Simple. + + (* in the real world foo@{i} might be [@paths@{i} nat] I guess *) + Inductive foo : nat -> Type :=. + + (* on [refl (fun x => f x)] this computes to [refl f] *) + Definition eta_out {A B} (f g : forall x : A, B x) (e : (fun x => f x) = (fun x => g x)) : f = g. + Proof. + change (f = g) in e. destruct e;reflexivity. + Defined. + + Section univs. + Universes i j. + Constraint i < j. (* fail instead of forcing equality *) + + Definition one : (fun n => foo@{i} n) = fun n => foo@{j} n := eq_refl. + + Definition two : foo@{i} = foo@{j} := eta_out _ _ one. + + Definition two' : foo@{i} = foo@{j} := Eval compute in two. + + Definition three := @eq_refl (foo@{i} = foo@{j}) two. + Definition four := Eval compute in three. + + Definition five : foo@{i} = foo@{j} := eq_refl. + End univs. + + (* inference tries and succeeds with syntactic equality which doesn't eta expand *) + Fail Definition infer@{i j k|i < k, j < k, k < eq.u0} + : foo@{i} = foo@{j} :> (nat -> Type@{k}) + := eq_refl. + +End Simple. + +Module WithRed. + (** this test needs to reduce the parameter's type to work *) + + + Inductive foo@{i j} (b:bool) (x:if b return Type@{j} then Type@{i} else nat) : Type@{i} := . + + (* on [refl (fun x => f x)] this computes to [refl f] *) + Definition eta_out {A B} (f g : forall x : A, B x) (e : (fun x => f x) = (fun x => g x)) : f = g. + Proof. + change (f = g) in e. destruct e;reflexivity. + Defined. + + Section univs. + Universes i j k. + Constraint i < j. (* fail instead of forcing equality *) + + Definition one : (fun n => foo@{i k} false n) = fun n => foo@{j k} false n := eq_refl. + + Definition two : foo@{i k} false = foo@{j k} false := eta_out _ _ one. + + Definition two' : foo@{i k} false = foo@{j k} false := Eval compute in two. + + (* Failure of SR doesn't just mean that the type changes, sometimes + we lose being well-typed entirely. *) + Definition three := @eq_refl (foo@{i k} false = foo@{j k} false) two. + Definition four := Eval compute in three. + + Definition five : foo@{i k} false = foo@{j k} false := eq_refl. + End univs. + + (* inference tries and succeeds with syntactic equality which doesn't eta expand *) + Fail Definition infer@{i j k|i < k, j < k, k < eq.u0} + : foo@{i k} false = foo@{j k} false :> (nat -> Type@{k}) + := eq_refl. + +End WithRed. diff --git a/test-suite/bugs/closed/bug_7825.v b/test-suite/bugs/closed/bug_7825.v new file mode 100644 index 0000000000..3f8708059a --- /dev/null +++ b/test-suite/bugs/closed/bug_7825.v @@ -0,0 +1,50 @@ +Record T (x : nat) := { t : x = x }. + +Goal exists x, T x. + refine (ex_intro _ _ _). + Show Existentials. + simple refine {| t := _ |}. + reflexivity. + Unshelve. exact 0. +Qed. + +(** Fine if the new evar is defined as the originally shelved evar: we do nothing. + In the other direction we promote the non-shelved new goal to a shelved one: + shelved status has priority over goal status. *) + +Goal forall a : nat, exists x, T x. + evar (x : nat). subst x. Show Existentials. + intros a. simple refine (ex_intro ?[x0] _ _). shelve. simpl. + (** Here ?x := ?x0 which is shelved, so ?x becomes shelved even if it would + not be by default (refine ?x and _ produce non-shelved evars by default)*) + simple refine (Build_T ?x _). + reflexivity. + Unshelve. exact 0. +Qed. + +Goal { A : _ & { P : _ & @sigT A P } }. + epose _ as A; + epose _ as P; + exists A, P. + (* Regardless of which evars are in the goals vs the hypotheses, + [simple refine (existT _ _ _)] should leave over two goals. This + should be true even when chained with epose. *) + assert_succeeds (simple refine (existT _ _ _); let n := numgoals in guard n = 2); + subst P; + assert_succeeds (simple refine (existT _ _ _); let n := numgoals in guard n = 2); + subst A; + assert_succeeds (simple refine (existT _ _ _); let n := numgoals in guard n = 2). + (* fails *) +Abort. + +Goal { A : _ & { P : _ & @sigT A P } }. + epose _ as A; + epose _ as P; + exists A, P; (* In this example we chain everything *) + assert_succeeds (simple refine (existT _ _ _); let n := numgoals in guard n = 2); + subst P; + assert_succeeds (simple refine (existT _ _ _); let n := numgoals in guard n = 2); + subst A; + assert_succeeds (simple refine (existT _ _ _); let n := numgoals in guard n = 2). + (* fails *) +Abort. diff --git a/test-suite/bugs/bug_9490.v b/test-suite/bugs/closed/bug_9490.v index a5def40c49..a5def40c49 100644 --- a/test-suite/bugs/bug_9490.v +++ b/test-suite/bugs/closed/bug_9490.v diff --git a/test-suite/bugs/bug_9532.v b/test-suite/bugs/closed/bug_9532.v index d198d45f2f..d198d45f2f 100644 --- a/test-suite/bugs/bug_9532.v +++ b/test-suite/bugs/closed/bug_9532.v diff --git a/test-suite/bugs/opened/bug_2904.v b/test-suite/bugs/opened/bug_2904.v new file mode 100644 index 0000000000..da30a509ac --- /dev/null +++ b/test-suite/bugs/opened/bug_2904.v @@ -0,0 +1,18 @@ +Module Type S. +Parameter t : Type. +Module M'. +Parameter t : Type. +Definition u := S.t. +End M'. +End S. + +Module M : S. +Definition t := unit. +Module M'. +Definition t := bool. +Definition u := M.t. +End M'. +End M. + +Require Extraction. +Fail Extraction TestCompile M. diff --git a/test-suite/bugs/opened/bug_5996.v b/test-suite/bugs/opened/bug_5996.v new file mode 100644 index 0000000000..2e81a183cd --- /dev/null +++ b/test-suite/bugs/opened/bug_5996.v @@ -0,0 +1,19 @@ +(* Original example *) +Goal Type. + let c := constr:(prod nat nat) in + let c' := (eval pattern nat in c) in + let c' := lazymatch c' with ?f _ => f end in + let c'' := lazymatch c' with fun x : Set => ?f => constr:(forall x : Type, f) end in + exact c''. +Fail Defined. +Abort. + +(* Workaround *) +Goal Type. + let c := constr:(prod nat nat) in + let c' := (eval pattern nat in c) in + let c' := lazymatch c' with ?f _ => f end in + let c'' := lazymatch c' with fun x : Set => ?f => constr:(forall x : Type, f) end in + let _ := type of c'' in + exact c''. +Defined. diff --git a/test-suite/coqdoc/details.html.out b/test-suite/coqdoc/details.html.out new file mode 100644 index 0000000000..e1f1ad9867 --- /dev/null +++ b/test-suite/coqdoc/details.html.out @@ -0,0 +1,48 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" +"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml"> +<head> +<meta http-equiv="Content-Type" content="text/html; charset=utf-8" /> +<link href="coqdoc.css" rel="stylesheet" type="text/css" /> +<title>Coqdoc.details</title> +</head> + +<body> + +<div id="page"> + +<div id="header"> +</div> + +<div id="main"> + +<h1 class="libtitle">Library Coqdoc.details</h1> + +<div class="code"> +</div> +<details><div class="code"> +<span class="id" title="keyword">Definition</span> <a id="foo" class="idref" href="#foo"><span class="id" title="definition">foo</span></a> : <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a> := 3.<br/> +</div> +</details><div class="code"> + +<br/> +</div> +<details><summary>Foo bar </summary><div class="code"> +<span class="id" title="keyword">Fixpoint</span> <a id="idnat" class="idref" href="#idnat"><span class="id" title="definition">idnat</span></a> (<a id="x:1" class="idref" href="#x:1"><span class="id" title="binder">x</span></a> : <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a>) : <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#nat"><span class="id" title="inductive">nat</span></a> :=<br/> + <span class="id" title="keyword">match</span> <a class="idref" href="Coqdoc.details.html#x:1"><span class="id" title="variable">x</span></a> <span class="id" title="keyword">with</span><br/> + | <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#S"><span class="id" title="constructor">S</span></a> <span class="id" title="var">x</span> ⇒ <a class="idref" href="http://coq.inria.fr/stdlib/Coq.Init.Datatypes.html#S"><span class="id" title="constructor">S</span></a> (<a class="idref" href="Coqdoc.details.html#idnat:2"><span class="id" title="definition">idnat</span></a> <a class="idref" href="Coqdoc.details.html#x:1"><span class="id" title="variable">x</span></a>)<br/> + | 0 ⇒ 0<br/> + <span class="id" title="keyword">end</span>.<br/> +</div> +</details><div class="code"> +</div> +</div> + +<div id="footer"> +<hr/><a href="index.html">Index</a><hr/>This page has been generated by <a href="http://coq.inria.fr/">coqdoc</a> +</div> + +</div> + +</body> +</html>
\ No newline at end of file diff --git a/test-suite/coqdoc/details.tex.out b/test-suite/coqdoc/details.tex.out new file mode 100644 index 0000000000..37778944ba --- /dev/null +++ b/test-suite/coqdoc/details.tex.out @@ -0,0 +1,44 @@ +\documentclass[12pt]{report} +\usepackage[utf8x]{inputenc} + +%Warning: tipa declares many non-standard macros used by utf8x to +%interpret utf8 characters but extra packages might have to be added +%such as "textgreek" for Greek letters not already in tipa +%or "stmaryrd" for mathematical symbols. +%Utf8 codes missing a LaTeX interpretation can be defined by using +%\DeclareUnicodeCharacter{code}{interpretation}. +%Use coqdoc's option -p to add new packages or declarations. +\usepackage{tipa} + +\usepackage[T1]{fontenc} +\usepackage{fullpage} +\usepackage{coqdoc} +\usepackage{amsmath,amssymb} +\usepackage{url} +\begin{document} +\coqlibrary{Coqdoc.details}{Library }{Coqdoc.details} + +\begin{coqdoccode} +\end{coqdoccode} +\begin{coqdoccode} +\coqdocnoindent +\coqdockw{Definition} \coqdef{Coqdoc.details.foo}{foo}{\coqdocdefinition{foo}} : \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}} := 3.\coqdoceol +\end{coqdoccode} +\begin{coqdoccode} +\coqdocemptyline +\end{coqdoccode} +\begin{coqdoccode} +\coqdocnoindent +\coqdockw{Fixpoint} \coqdef{Coqdoc.details.idnat}{idnat}{\coqdocdefinition{idnat}} (\coqdef{Coqdoc.details.x:1}{x}{\coqdocbinder{x}} : \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}}) : \coqexternalref{nat}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocinductive{nat}} :=\coqdoceol +\coqdocindent{1.00em} +\coqdockw{match} \coqref{Coqdoc.details.x:1}{\coqdocvariable{x}} \coqdockw{with}\coqdoceol +\coqdocindent{1.00em} +\ensuremath{|} \coqexternalref{S}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocconstructor{S}} \coqdocvar{x} \ensuremath{\Rightarrow} \coqexternalref{S}{http://coq.inria.fr/stdlib/Coq.Init.Datatypes}{\coqdocconstructor{S}} (\coqref{Coqdoc.details.idnat:2}{\coqdocdefinition{idnat}} \coqref{Coqdoc.details.x:1}{\coqdocvariable{x}})\coqdoceol +\coqdocindent{1.00em} +\ensuremath{|} 0 \ensuremath{\Rightarrow} 0\coqdoceol +\coqdocindent{1.00em} +\coqdockw{end}.\coqdoceol +\end{coqdoccode} +\begin{coqdoccode} +\end{coqdoccode} +\end{document} diff --git a/test-suite/coqdoc/details.v b/test-suite/coqdoc/details.v new file mode 100644 index 0000000000..208e60317d --- /dev/null +++ b/test-suite/coqdoc/details.v @@ -0,0 +1,11 @@ +(* begin details *) +Definition foo : nat := 3. +(* end details *) + +(* begin details : Foo bar *) +Fixpoint idnat (x : nat) : nat := + match x with + | S x => S (idnat x) + | 0 => 0 + end. +(* end details *) diff --git a/test-suite/interactive/PrimNotation.v b/test-suite/interactive/PrimNotation.v index 07986b0df3..55116dc78b 100644 --- a/test-suite/interactive/PrimNotation.v +++ b/test-suite/interactive/PrimNotation.v @@ -21,7 +21,7 @@ Local Set Universe Polymorphism. Delimit Scope punit_scope with punit. Delimit Scope pcunit_scope with pcunit. Delimit Scope int_scope with int. -Numeral Notation Decimal.int Decimal.int_of_int Decimal.int_of_int : int_scope. +Number Notation Decimal.int Decimal.int_of_int Decimal.int_of_int : int_scope. Module A. NonCumulative Inductive punit@{u} : Type@{u} := ptt. Cumulative Inductive pcunit@{u} : Type@{u} := pctt. @@ -31,10 +31,10 @@ Module A. := fun v => match v with 0%int => Some pctt | _ => None end. Definition of_punit : punit -> Decimal.uint := fun _ => Nat.to_uint 0. Definition of_pcunit : pcunit -> Decimal.uint := fun _ => Nat.to_uint 0. - Numeral Notation punit to_punit of_punit : punit_scope. + Number Notation punit to_punit of_punit : punit_scope. Check let v := 0%punit in v : punit. Back 2. - Numeral Notation pcunit to_pcunit of_pcunit : punit_scope. + Number Notation pcunit to_pcunit of_pcunit : punit_scope. Check let v := 0%punit in v : pcunit. End A. Reset A. @@ -44,7 +44,7 @@ Module A. Definition to_punit : Decimal.int -> option punit := fun v => match v with 0%int => Some ptt | _ => None end. Definition of_punit : punit -> Decimal.uint := fun _ => Nat.to_uint 0. - Numeral Notation punit to_punit of_punit : punit_scope. + Number Notation punit to_punit of_punit : punit_scope. Check let v := 0%punit in v : punit. End A. Local Set Universe Polymorphism. @@ -52,7 +52,7 @@ Inductive punit@{u} : Type@{u} := ptt. Definition to_punit : Decimal.int -> option punit := fun v => match v with 0%int => Some ptt | _ => None end. Definition of_punit : punit -> Decimal.uint := fun _ => Nat.to_uint 0. -Numeral Notation punit to_punit of_punit : punit_scope. +Number Notation punit to_punit of_punit : punit_scope. Check let v := 0%punit in v : punit. Back 6. (* check backtracking of registering universe polymorphic constants *) Local Unset Universe Polymorphism. @@ -60,5 +60,5 @@ Inductive punit : Set := ptt. Definition to_punit : Decimal.int -> option punit := fun v => match v with 0%int => Some ptt | _ => None end. Definition of_punit : punit -> Decimal.uint := fun _ => Nat.to_uint 0. -Numeral Notation punit to_punit of_punit : punit_scope. +Number Notation punit to_punit of_punit : punit_scope. Check let v := 0%punit in v : punit. diff --git a/test-suite/micromega/bug_12790.v b/test-suite/micromega/bug_12790.v new file mode 100644 index 0000000000..39d640ebd9 --- /dev/null +++ b/test-suite/micromega/bug_12790.v @@ -0,0 +1,8 @@ +Require Import Lia. + +Goal forall (a b c d x: nat), +S c = a - b -> x <= x + (S c) * d. +Proof. +intros a b c d x H. +lia. +Qed. diff --git a/test-suite/micromega/bug_12791.v b/test-suite/micromega/bug_12791.v new file mode 100644 index 0000000000..8aec1904a4 --- /dev/null +++ b/test-suite/micromega/bug_12791.v @@ -0,0 +1,9 @@ +Require Import Lia. + +Definition t := nat. + +Goal forall (a b: t), let c := a in b = a -> b = c. +Proof. + intros a b c H. + lia. +Qed. diff --git a/test-suite/output-coqchk/bug_12845.out b/test-suite/output-coqchk/bug_12845.out new file mode 100644 index 0000000000..bef45bf2f6 --- /dev/null +++ b/test-suite/output-coqchk/bug_12845.out @@ -0,0 +1,14 @@ + +CONTEXT SUMMARY +=============== + +* Theory: Set is predicative + +* Axioms: <none> + +* Constants/Inductives relying on type-in-type: <none> + +* Constants/Inductives relying on unsafe (co)fixpoints: <none> + +* Inductives whose positivity is assumed: <none> + diff --git a/test-suite/output-coqchk/bug_12845.v b/test-suite/output-coqchk/bug_12845.v new file mode 100644 index 0000000000..d16146855b --- /dev/null +++ b/test-suite/output-coqchk/bug_12845.v @@ -0,0 +1,13 @@ +Module Type A. + Module B. + Axiom t : Set. + End B. +End A. + +Module a : A. + Module B. + Definition t : Set := unit. + End B. +End a. + +Check a.B.t. diff --git a/test-suite/output/Arguments.out b/test-suite/output/Arguments.out index 8cf0797b17..5d1da05809 100644 --- a/test-suite/output/Arguments.out +++ b/test-suite/output/Arguments.out @@ -43,7 +43,7 @@ forall {D1 C1 : Type}, (D1 -> C1) -> forall D2 C2 : Type, (D2 -> C2) -> D1 * D2 -> C1 * C2 pf is not universe polymorphic -Arguments pf {D1}%foo_scope {C1}%type_scope _ [D2 C2] : simpl never +Arguments pf {D1}%foo_scope {C1}%type_scope _ [D2 C2] _ _ : simpl never The reduction tactics never unfold pf pf is transparent Expands to: Constant Arguments.pf diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out index e0aa758812..e46774f68a 100644 --- a/test-suite/output/Arguments_renaming.out +++ b/test-suite/output/Arguments_renaming.out @@ -13,21 +13,25 @@ where ?y : [ |- nat] Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x -Arguments eq {A}%type_scope -Arguments eq_refl {B}%type_scope {y}, [B] _ -eq_refl : forall {A : Type} {x : A}, x = x +Arguments eq {A}%type_scope _ _ +Arguments eq_refl {B}%type_scope {y}, [_] _ + (where some original arguments have been renamed) +eq_refl : forall {B : Type} {y : B}, y = y eq_refl is not universe polymorphic -Arguments eq_refl {B}%type_scope {y}, [B] _ +Arguments eq_refl {B}%type_scope {y}, [_] _ + (where some original arguments have been renamed) Expands to: Constructor Coq.Init.Logic.eq_refl Inductive myEq (B : Type) (x : A) : A -> Prop := myrefl : B -> myEq B x x -Arguments myEq _%type_scope -Arguments myrefl {C}%type_scope x : rename -myrefl : forall {B : Type} (x : A), B -> myEq B x x +Arguments myEq _%type_scope _ _ +Arguments myrefl {C}%type_scope x _ + (where some original arguments have been renamed) +myrefl : forall {C : Type} (x : A), C -> myEq C x x myrefl is not universe polymorphic -Arguments myrefl {C}%type_scope x : rename +Arguments myrefl {C}%type_scope x _ + (where some original arguments have been renamed) Expands to: Constructor Arguments_renaming.Test1.myrefl myplus = fix myplus (T : Type) (t : T) (n m : nat) {struct n} : nat := @@ -37,11 +41,13 @@ fix myplus (T : Type) (t : T) (n m : nat) {struct n} : nat := end : forall T : Type, T -> nat -> nat -> nat -Arguments myplus {Z}%type_scope !t (!n m)%nat_scope : rename -myplus : forall {T : Type}, T -> nat -> nat -> nat +Arguments myplus {Z}%type_scope !t (!n m)%nat_scope + (where some original arguments have been renamed) +myplus : forall {Z : Type}, Z -> nat -> nat -> nat myplus is not universe polymorphic -Arguments myplus {Z}%type_scope !t (!n m)%nat_scope : rename +Arguments myplus {Z}%type_scope !t (!n m)%nat_scope + (where some original arguments have been renamed) The reduction tactics unfold myplus when the 2nd and 3rd arguments evaluate to a constructor myplus is transparent @@ -51,12 +57,14 @@ Expands to: Constant Arguments_renaming.Test1.myplus Inductive myEq (A B : Type) (x : A) : A -> Prop := myrefl : B -> myEq A B x x -Arguments myEq (_ _)%type_scope -Arguments myrefl A%type_scope {C}%type_scope x : rename -myrefl : forall (A : Type) {B : Type} (x : A), B -> myEq A B x x +Arguments myEq (_ _)%type_scope _ _ +Arguments myrefl A%type_scope {C}%type_scope x _ + (where some original arguments have been renamed) +myrefl : forall (A : Type) {C : Type} (x : A), C -> myEq A C x x myrefl is not universe polymorphic -Arguments myrefl A%type_scope {C}%type_scope x : rename +Arguments myrefl A%type_scope {C}%type_scope x _ + (where some original arguments have been renamed) Expands to: Constructor Arguments_renaming.myrefl myrefl : forall (A C : Type) (x : A), C -> myEq A C x x @@ -68,11 +76,13 @@ fix myplus (T : Type) (t : T) (n m : nat) {struct n} : nat := end : forall T : Type, T -> nat -> nat -> nat -Arguments myplus {Z}%type_scope !t (!n m)%nat_scope : rename -myplus : forall {T : Type}, T -> nat -> nat -> nat +Arguments myplus {Z}%type_scope !t (!n m)%nat_scope + (where some original arguments have been renamed) +myplus : forall {Z : Type}, Z -> nat -> nat -> nat myplus is not universe polymorphic -Arguments myplus {Z}%type_scope !t (!n m)%nat_scope : rename +Arguments myplus {Z}%type_scope !t (!n m)%nat_scope + (where some original arguments have been renamed) The reduction tactics unfold myplus when the 2nd and 3rd arguments evaluate to a constructor myplus is transparent @@ -84,11 +94,12 @@ Argument lists should agree on the names they provide. The command has indeed failed with message: Sequences of implicit arguments must be of different lengths. The command has indeed failed with message: -Some argument names are duplicated: F -The command has indeed failed with message: Argument number 3 is a trailing implicit, so it can't be declared non maximal. Please use { } instead of [ ]. The command has indeed failed with message: +Argument z is a trailing implicit, so it can't be declared non maximal. +Please use { } instead of [ ]. +The command has indeed failed with message: Extra arguments: y. The command has indeed failed with message: Flag "rename" expected to rename A into R. diff --git a/test-suite/output/Arguments_renaming.v b/test-suite/output/Arguments_renaming.v index 6ac09cf771..13bda0c070 100644 --- a/test-suite/output/Arguments_renaming.v +++ b/test-suite/output/Arguments_renaming.v @@ -48,7 +48,7 @@ Check @myplus. Fail Arguments eq_refl {F g}, [H] k. Fail Arguments eq_refl {F}, [F] : rename. -Fail Arguments eq_refl {F F}, [F] F : rename. +Fail Arguments eq {A} x [_] : rename. Fail Arguments eq {A} x [z] : rename. Fail Arguments eq {F} x z y. Fail Arguments eq {R} s t. diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out index 6976610b22..da2fc90fc3 100644 --- a/test-suite/output/Cases.out +++ b/test-suite/output/Cases.out @@ -7,7 +7,7 @@ fix F (t : t) : P t := : forall P : t -> Type, (let x := t in forall x0 : x, P x0 -> P (k x0)) -> forall t : t, P t -Arguments t_rect (_ _)%function_scope +Arguments t_rect (_ _)%function_scope _ = fun d : TT => match d with | {| f3 := b |} => b end @@ -26,7 +26,7 @@ match Nat.eq_dec x y with end : forall (x y : nat) (P : nat -> Type), P x -> P y -> P y -Arguments proj (_ _)%nat_scope _%function_scope +Arguments proj (_ _)%nat_scope _%function_scope _ _ foo = fix foo (A : Type) (l : list A) {struct l} : option A := match l with @@ -43,7 +43,7 @@ fun (A : Type) (x : I A) => match x with end : forall A : Type, I A -> A -Arguments uncast _%type_scope +Arguments uncast _%type_scope _ foo' = if A 0 then true else false : bool f = diff --git a/test-suite/output/ErrorLocation_12774_1.out b/test-suite/output/ErrorLocation_12774_1.out new file mode 100644 index 0000000000..e27992ed59 --- /dev/null +++ b/test-suite/output/ErrorLocation_12774_1.out @@ -0,0 +1,3 @@ +File "stdin", line 2, characters 13-14: +Error: The term "0" has type "nat" while it is expected to have type "Type". + diff --git a/test-suite/output/ErrorLocation_12774_1.v b/test-suite/output/ErrorLocation_12774_1.v new file mode 100644 index 0000000000..8516d402d1 --- /dev/null +++ b/test-suite/output/ErrorLocation_12774_1.v @@ -0,0 +1,3 @@ +Goal Type. +simpl; exact 0. +Abort. diff --git a/test-suite/output/ErrorLocation_12774_2.out b/test-suite/output/ErrorLocation_12774_2.out new file mode 100644 index 0000000000..434275eca5 --- /dev/null +++ b/test-suite/output/ErrorLocation_12774_2.out @@ -0,0 +1,3 @@ +File "stdin", line 3, characters 9-10: +Error: The term "0" has type "nat" while it is expected to have type "Type". + diff --git a/test-suite/output/ErrorLocation_12774_2.v b/test-suite/output/ErrorLocation_12774_2.v new file mode 100644 index 0000000000..e50e1caa0f --- /dev/null +++ b/test-suite/output/ErrorLocation_12774_2.v @@ -0,0 +1,4 @@ +Ltac f := simpl. +Goal Type. +f; exact 0. +Abort. diff --git a/test-suite/output/ErrorLocation_12774_3.out b/test-suite/output/ErrorLocation_12774_3.out new file mode 100644 index 0000000000..dbd3dbd1e2 --- /dev/null +++ b/test-suite/output/ErrorLocation_12774_3.out @@ -0,0 +1,3 @@ +File "stdin", line 3, characters 0-1: +Error: No product even after head-reduction. + diff --git a/test-suite/output/ErrorLocation_12774_3.v b/test-suite/output/ErrorLocation_12774_3.v new file mode 100644 index 0000000000..c624402a81 --- /dev/null +++ b/test-suite/output/ErrorLocation_12774_3.v @@ -0,0 +1,4 @@ +Ltac f := auto; intro. +Goal False. +f. +Abort. diff --git a/test-suite/output/ErrorLocation_tac_in_term_1.out b/test-suite/output/ErrorLocation_tac_in_term_1.out new file mode 100644 index 0000000000..55ad5a36da --- /dev/null +++ b/test-suite/output/ErrorLocation_tac_in_term_1.out @@ -0,0 +1,4 @@ +File "stdin", line 2, characters 21-25: +Error: +The term "true" has type "bool" while it is expected to have type "nat". + diff --git a/test-suite/output/ErrorLocation_tac_in_term_1.v b/test-suite/output/ErrorLocation_tac_in_term_1.v new file mode 100644 index 0000000000..ef0b5aa757 --- /dev/null +++ b/test-suite/output/ErrorLocation_tac_in_term_1.v @@ -0,0 +1,3 @@ +Goal True. +apply ltac:(apply (S true)). +Abort. diff --git a/test-suite/output/ErrorLocation_tac_in_term_2.out b/test-suite/output/ErrorLocation_tac_in_term_2.out new file mode 100644 index 0000000000..5bff5ede43 --- /dev/null +++ b/test-suite/output/ErrorLocation_tac_in_term_2.out @@ -0,0 +1,4 @@ +File "stdin", line 4, characters 12-20: +Error: +The term "true" has type "bool" while it is expected to have type "nat". + diff --git a/test-suite/output/ErrorLocation_tac_in_term_2.v b/test-suite/output/ErrorLocation_tac_in_term_2.v new file mode 100644 index 0000000000..e0fc2a9f4f --- /dev/null +++ b/test-suite/output/ErrorLocation_tac_in_term_2.v @@ -0,0 +1,5 @@ +Ltac f x y := apply (x y). + +Goal True. +apply ltac:(f S true). +Abort. diff --git a/test-suite/output/Error_msg_diffs.out b/test-suite/output/Error_msg_diffs.out index 3e337e892d..2645524a70 100644 --- a/test-suite/output/Error_msg_diffs.out +++ b/test-suite/output/Error_msg_diffs.out @@ -1,4 +1,4 @@ -File "stdin", line 32, characters 0-12: +File "stdin", line 32, characters 0-11: [37;41;1mError:[0m In environment T : [33;1mType[0m diff --git a/test-suite/output/Implicit.out b/test-suite/output/Implicit.out index ef7667936c..781e8e13a3 100644 --- a/test-suite/output/Implicit.out +++ b/test-suite/output/Implicit.out @@ -5,7 +5,7 @@ ex_intro (P:=fun _ : nat => True) (x:=0) I d2 = fun x : nat => d1 (y:=x) : forall x x0 : nat, x0 = x -> x0 = x -Arguments d2 [x x0]%nat_scope +Arguments d2 [x x]%nat_scope _ map id (1 :: nil) : list nat map id' (1 :: nil) @@ -17,3 +17,7 @@ fix f (x : nat) : option nat := match x with | S _ => x end : nat -> option nat +fun x : False => let y := False_rect (A:=bool) x in y + : False -> bool +fun x : False => let y : True := False_rect x in y + : False -> True diff --git a/test-suite/output/Implicit.v b/test-suite/output/Implicit.v index a7c4399e38..86420bd8c8 100644 --- a/test-suite/output/Implicit.v +++ b/test-suite/output/Implicit.v @@ -61,3 +61,13 @@ Coercion some_nat := @Some nat. Check fix f x := match x with 0 => None | n => some_nat n end. End MatchBranchesInContext. + +Module LetInContext. + +Set Implicit Arguments. +Set Contextual Implicit. +Axiom False_rect : forall A:Type, False -> A. +Check fun x:False => let y:= False_rect (A:=bool) x in y. (* will not be in context: explicitation *) +Check fun x:False => let y:= False_rect (A:=True) x in y. (* will be in context: no explicitation *) + +End LetInContext. diff --git a/test-suite/output/Inductive.out b/test-suite/output/Inductive.out index e6c2806433..8e10107673 100644 --- a/test-suite/output/Inductive.out +++ b/test-suite/output/Inductive.out @@ -7,7 +7,7 @@ l : list' A Unable to unify "list' (A * A)%type" with "list' A". Inductive foo (A : Type) (x : A) (y : A := x) : Prop := Foo : foo A x -Arguments foo _%type_scope -Arguments Foo _%type_scope +Arguments foo _%type_scope _ +Arguments Foo _%type_scope _ myprod unit bool : Set diff --git a/test-suite/output/InitSyntax.out b/test-suite/output/InitSyntax.out index da255e86cd..02e58775b5 100644 --- a/test-suite/output/InitSyntax.out +++ b/test-suite/output/InitSyntax.out @@ -2,7 +2,7 @@ Inductive sig2 (A : Type) (P Q : A -> Prop) : Type := exist2 : forall x : A, P x -> Q x -> {x : A | P x & Q x} Arguments sig2 [A]%type_scope (_ _)%type_scope -Arguments exist2 [A]%type_scope (_ _)%function_scope +Arguments exist2 [A]%type_scope (_ _)%function_scope _ _ _ exists x : nat, x = x : Prop fun b : bool => if b then b else b diff --git a/test-suite/output/Notations4.out b/test-suite/output/Notations4.out index fa03ec8193..ce51acac95 100644 --- a/test-suite/output/Notations4.out +++ b/test-suite/output/Notations4.out @@ -123,3 +123,5 @@ File "stdin", line 297, characters 0-30: Warning: Notation "_ :=: _" was already used. [notation-overridden,parsing] 0 :=: 0 : Prop +fun x : nat => <{ x; (S x) }> + : nat -> nat diff --git a/test-suite/output/Notations4.v b/test-suite/output/Notations4.v index 90d8da2bec..6dadd8c7fe 100644 --- a/test-suite/output/Notations4.v +++ b/test-suite/output/Notations4.v @@ -131,7 +131,7 @@ Module NumeralNotations. Delimit Scope test17_scope with test17. Local Set Primitive Projections. Record myint63 := of_int { to_int : int }. - Numeral Notation myint63 of_int to_int : test17_scope. + Number Notation myint63 of_int to_int : test17_scope. Check let v := 0%test17 in v : myint63. End Test17. End NumeralNotations. @@ -298,3 +298,18 @@ Notation "x :=: y" := (x = y). Check (0 :=: 0). End Bug12691. + +Module CoercionEntryTransitivity. + +Declare Custom Entry com. +Declare Custom Entry com_top. +Notation "<{ e }>" := e (at level 0, e custom com_top at level 99). +Notation "x ; y" := + (x + y) + (in custom com_top at level 90, x custom com at level 90, right associativity). +Notation "x" := x (in custom com at level 0, x constr at level 0). +Notation "x" := x (in custom com_top at level 90, x custom com at level 90). + +Check fun x => <{ x ; (S x) }>. + +End CoercionEntryTransitivity. diff --git a/test-suite/output/Notations5.out b/test-suite/output/Notations5.out index f59306c454..a6c2553a89 100644 --- a/test-suite/output/Notations5.out +++ b/test-suite/output/Notations5.out @@ -146,8 +146,10 @@ v : forall (B : Type) (b : B), 0 = 0 /\ b = b @v 0 : forall (B : Type) (b : B), 0 = 0 /\ b = b -v 0 (B:=bool) +v 0 : forall b : bool, 0 = 0 /\ b = b + = ?n@{x:=v 0 (B:=bool)} + : nat v : forall (a2 : nat) (B : Type) (b : B), 0 = a2 /\ b = b v 0 @@ -166,8 +168,10 @@ v : forall (B : Type) (b : B), 0 = 0 /\ b = b @v 0 : forall (B : Type) (b : B), 0 = 0 /\ b = b -v 0 (B:=bool) +v 0 : forall b : bool, 0 = 0 /\ b = b + = ?n@{x:=v 0 (B:=bool)} + : nat ## : forall (a1 a2 : ?A) (B : Type) (b : B), a1 = a2 /\ b = b where @@ -192,10 +196,12 @@ where : 0 = 0 /\ true = true ## 0 0 true : 0 = 0 /\ true = true -## 0 0 (B:=bool) +## 0 0 : forall b : bool, 0 = 0 /\ b = b -## 0 0 (B:=bool) +## 0 0 : forall b : bool, 0 = 0 /\ b = b + = ?n@{x:=## 0 0 (B:=bool)} + : nat ## ?A : forall (a1 a2 : ?A) (B : Type) (b : B), a1 = a2 /\ b = b where @@ -230,10 +236,12 @@ where : forall b : ?B, 0 = 0 /\ b = b where ?B : [ |- Type] -## 0 0 (B:=bool) +## 0 0 : forall b : bool, 0 = 0 /\ b = b -## 0 0 (B:=bool) +## 0 0 : forall b : bool, 0 = 0 /\ b = b + = ?n@{x:=## 0 0 (B:=bool)} + : nat ## 0 0 true : 0 = 0 /\ true = true ## 0 0 true @@ -246,10 +254,12 @@ where : forall b : ?B, 0 = 0 /\ b = b where ?B : [ |- Type] -## 0 0 (B:=bool) +## 0 0 : forall b : bool, 0 = 0 /\ b = b -## 0 0 (B:=bool) +## 0 0 : forall b : bool, 0 = 0 /\ b = b + = ?n@{x:=## 0 0 (B:=bool)} + : nat ## 0 0 true : 0 = 0 /\ true = true ## 0 0 true diff --git a/test-suite/output/Notations5.v b/test-suite/output/Notations5.v index 09d5e31c48..010b0da4a9 100644 --- a/test-suite/output/Notations5.v +++ b/test-suite/output/Notations5.v @@ -189,7 +189,9 @@ Module AppliedTermsPrinting. Check @v 0. (* @v 0 *) Check @p nat 0 0 bool. - (* v 0 (B:=bool) *) + (* v 0 *) + Eval simpl in (fun x => _:nat) (@p nat 0 0 bool). + (* ?n@{x:=v 0 (B:=bool)} *) End AtAbbreviationForPartialApplication. @@ -217,7 +219,9 @@ Module AppliedTermsPrinting. Check @v 0. (* @v 0 *) Check @p nat 0 0 bool. - (* v 0 (B:=bool) *) + (* v 0 *) + Eval simpl in (fun x => _:nat) (@p nat 0 0 bool). + (* ?n@{x:=v 0 (B:=bool)} *) End AbbreviationForPartialApplication. @@ -247,9 +251,11 @@ Module AppliedTermsPrinting. Check ## 0 0 true. (* ## 0 0 true *) Check p 0 0 (B:=bool). - (* ## 0 0 (B:=bool) *) + (* ## 0 0 *) Check ## 0 0 (B:=bool). - (* ## 0 0 (B:=bool) *) + (* ## 0 0 *) + Eval simpl in (fun x => _:nat) (@p nat 0 0 bool). + (* ?n@{x:=## 0 0 (B:=bool)} *) End NotationForHeadApplication. @@ -301,9 +307,11 @@ Module AppliedTermsPrinting. Check ## 0 0. (* ## 0 0 *) Check p 0 0 (B:=bool). - (* ## 0 0 (B:=bool) *) + (* ## 0 0 *) Check ## 0 0 (B:=bool). - (* ## 0 0 (B:=bool) *) + (* ## 0 0 *) + Eval simpl in (fun x => _:nat) (## 0 0 (B:=bool)). + (* ?n@{## 0 0 (B:=bool)} *) Check p 0 0 true. (* ## 0 0 true *) Check ## 0 0 true. @@ -327,9 +335,11 @@ Module AppliedTermsPrinting. Check ## 0 0. (* ## 0 0 *) Check p 0 0 (B:=bool). - (* ## 0 0 (B:=bool) *) + (* ## 0 0 *) Check ## 0 0 (B:=bool). - (* ## 0 0 (B:=bool) *) + (* ## 0 0 *) + Eval simpl in (fun x => _:nat) (## 0 0 (B:=bool)). + (* ?n@{## 0 0 (B:=bool)} *) Check p 0 0 true. (* ## 0 0 true *) Check ## 0 0 true. diff --git a/test-suite/output/NumeralNotations.out b/test-suite/output/NumberNotations.out index 34c31ff8a6..8065c8d311 100644 --- a/test-suite/output/NumeralNotations.out +++ b/test-suite/output/NumberNotations.out @@ -75,7 +75,7 @@ The command has indeed failed with message: In environment v := 0 : nat The term "v" has type "nat" while it is expected to have type "wuint". -File "stdin", line 203, characters 2-72: +File "stdin", line 203, characters 2-71: Warning: The 'abstract after' directive has no effect when the parsing function (of_uint) targets an option type. [abstract-large-number-no-op,numbers] @@ -141,7 +141,7 @@ let v := 0%test15 in v : unit let v := foo a.t in v : Foo : Foo The command has indeed failed with message: -Cannot interpret in test16_scope because NumeralNotations.Test16.F.Foo could not be found in the current environment. +Cannot interpret in test16_scope because NumberNotations.Test16.F.Foo could not be found in the current environment. let v := 0%test17 in v : myint63 : myint63 let v := 0%Q in v : Q diff --git a/test-suite/output/NumeralNotations.v b/test-suite/output/NumberNotations.v index ca8a14cce1..e411005da3 100644 --- a/test-suite/output/NumeralNotations.v +++ b/test-suite/output/NumberNotations.v @@ -6,7 +6,7 @@ Declare Scope opaque_scope. Module Test1. Axiom hold : forall {A B C}, A -> B -> C. Definition opaque3 (x : Numeral.int) : Numeral.int := hold x (fix f (x : nat) : nat := match x with O => O | S n => S (f n) end). - Numeral Notation Numeral.int opaque3 opaque3 : opaque_scope. + Number Notation Numeral.int opaque3 opaque3 : opaque_scope. Delimit Scope opaque_scope with opaque. Fail Check 1%opaque. End Test1. @@ -15,7 +15,7 @@ End Test1. Module Test2. Axiom opaque4 : option Numeral.int. Definition opaque6 (x : Numeral.int) : option Numeral.int := opaque4. - Numeral Notation Numeral.int opaque6 opaque6 : opaque_scope. + Number Notation Numeral.int opaque6 opaque6 : opaque_scope. Delimit Scope opaque_scope with opaque. Open Scope opaque_scope. Fail Check 1%opaque. @@ -27,7 +27,7 @@ Module Test3. Inductive silly := SILLY (v : Numeral.uint) (f : forall A, A -> A). Definition to_silly (v : Numeral.uint) := SILLY v (fun _ x => x). Definition of_silly (v : silly) := match v with SILLY v _ => v end. - Numeral Notation silly to_silly of_silly : silly_scope. + Number Notation silly to_silly of_silly : silly_scope. Delimit Scope silly_scope with silly. Fail Check 1%silly. End Test3. @@ -54,11 +54,11 @@ Module Test4. Polymorphic Definition pof_unit (v : unit) : Numeral.uint := Nat.to_num_uint 0. Definition to_unit (v : Numeral.uint) : option unit := match Nat.of_num_uint v with O => Some tt | _ => None end. Definition of_unit (v : unit) : Numeral.uint := Nat.to_num_uint 0. - Numeral Notation punit to_punit of_punit : pto. - Numeral Notation punit pto_punit of_punit : ppo. - Numeral Notation punit to_punit pof_punit : ptp. - Numeral Notation punit pto_punit pof_punit : ppp. - Numeral Notation unit to_unit of_unit : uto. + Number Notation punit to_punit of_punit : pto. + Number Notation punit pto_punit of_punit : ppo. + Number Notation punit to_punit pof_punit : ptp. + Number Notation punit pto_punit pof_punit : ppp. + Number Notation unit to_unit of_unit : uto. Delimit Scope pto with pto. Delimit Scope ppo with ppo. Delimit Scope ptp with ptp. @@ -71,9 +71,9 @@ Module Test4. Check let v := 0%uto in v : unit. Fail Check 1%uto. Fail Check (-1)%uto. - Numeral Notation unit pto_unit of_unit : upo. - Numeral Notation unit to_unit pof_unit : utp. - Numeral Notation unit pto_unit pof_unit : upp. + Number Notation unit pto_unit of_unit : upo. + Number Notation unit to_unit pof_unit : utp. + Number Notation unit pto_unit pof_unit : upp. Delimit Scope upo with upo. Delimit Scope utp with utp. Delimit Scope upp with upp. @@ -83,7 +83,7 @@ Module Test4. Polymorphic Definition pto_punits := pto_punit_all@{Set}. Polymorphic Definition pof_punits := pof_punit@{Set}. - Numeral Notation punit pto_punits pof_punits : ppps (abstract after 1). + Number Notation punit pto_punits pof_punits : ppps (abstract after 1). Delimit Scope ppps with ppps. Universe u. Constraint Set < u. @@ -121,7 +121,7 @@ Module Test6. End Scopes. Module Export Notations. Export Scopes. - Numeral Notation wnat of_uint to_uint : wnat_scope (abstract after 5000). + Number Notation wnat of_uint to_uint : wnat_scope (abstract after 5000). End Notations. Set Printing Coercions. Check let v := 0%wnat in v : wnat. @@ -141,7 +141,7 @@ Module Test7. Record wuint := wrap { unwrap : Numeral.uint }. Declare Scope wuint_scope. Delimit Scope wuint_scope with wuint. - Numeral Notation wuint wrap unwrap : wuint_scope. + Number Notation wuint wrap unwrap : wuint_scope. Check let v := 0%wuint in v : wuint. Check let v := 1%wuint in v : wuint. End Test7. @@ -157,7 +157,7 @@ Module Test8. Context (dummy : unit). Definition wrap' := let __ := dummy in wrap. Definition unwrap' := let __ := dummy in unwrap. - Numeral Notation wuint wrap' unwrap' : wuint8_scope. + Number Notation wuint wrap' unwrap' : wuint8_scope. Check let v := 0%wuint8 in v : wuint. End with_var. Check let v := 0%wuint8 in v : nat. @@ -166,7 +166,7 @@ Module Test8. Notation wrap'' := wrap. Notation unwrap'' := unwrap. - Numeral Notation wuint wrap'' unwrap'' : wuint8'_scope. + Number Notation wuint wrap'' unwrap'' : wuint8'_scope. Check let v := 0%wuint8' in v : wuint. End Test8. @@ -182,9 +182,9 @@ Module Test9. Let unwrap' := unwrap. Local Notation wrap'' := wrap. Local Notation unwrap'' := unwrap. - Numeral Notation wuint wrap' unwrap' : wuint9_scope. + Number Notation wuint wrap' unwrap' : wuint9_scope. Check let v := 0%wuint9 in v : wuint. - Numeral Notation wuint wrap'' unwrap'' : wuint9'_scope. + Number Notation wuint wrap'' unwrap'' : wuint9'_scope. Check let v := 0%wuint9' in v : wuint. End with_let. Check let v := 0%wuint9 in v : nat. @@ -200,12 +200,12 @@ Module Test10. Declare Scope unit2_scope. Delimit Scope unit_scope with unit. Delimit Scope unit2_scope with unit2. - Numeral Notation unit of_uint to_uint : unit_scope (abstract after 1). + Number Notation unit of_uint to_uint : unit_scope (abstract after 1). Local Set Warnings Append "+abstract-large-number-no-op". (* Check that there is actually a warning here *) - Fail Numeral Notation unit of_uint to_uint : unit2_scope (abstract after 1). + Fail Number Notation unit of_uint to_uint : unit2_scope (abstract after 1). (* Check that there is no warning here *) - Numeral Notation unit of_any_uint to_uint : unit2_scope (abstract after 1). + Number Notation unit of_any_uint to_uint : unit2_scope (abstract after 1). End Test10. Module Test12. @@ -215,7 +215,7 @@ Module Test12. Section test12. Context (to_uint : unit -> Numeral.uint) (of_uint : Numeral.uint -> unit). - Numeral Notation unit of_uint to_uint : test12_scope. + Number Notation unit of_uint to_uint : test12_scope. Check let v := 1%test12 in v : unit. End test12. End Test12. @@ -233,17 +233,17 @@ Module Test13. Definition to_uint_good := to_uint tt. Notation to_uint' := (to_uint tt). Notation to_uint'' := (to_uint _). - Numeral Notation unit of_uint to_uint_good : test13_scope. + Number Notation unit of_uint to_uint_good : test13_scope. Check let v := 0%test13 in v : unit. - Fail Numeral Notation unit of_uint to_uint' : test13'_scope. + Fail Number Notation unit of_uint to_uint' : test13'_scope. Fail Check let v := 0%test13' in v : unit. - Fail Numeral Notation unit of_uint to_uint'' : test13''_scope. + Fail Number Notation unit of_uint to_uint'' : test13''_scope. Fail Check let v := 0%test13'' in v : unit. End Test13. Module Test14. (* Test that numeral notations follow [Import], not [Require], and - also test that [Local Numeral Notation]s do not escape modules + also test that [Local Number Notation]s do not escape modules nor sections. *) Declare Scope test14_scope. Declare Scope test14'_scope. @@ -256,8 +256,8 @@ Module Test14. Module Inner. Definition to_uint (x : unit) : Numeral.uint := Nat.to_num_uint O. Definition of_uint (x : Numeral.uint) : unit := tt. - Local Numeral Notation unit of_uint to_uint : test14_scope. - Global Numeral Notation unit of_uint to_uint : test14'_scope. + Local Number Notation unit of_uint to_uint : test14_scope. + Global Number Notation unit of_uint to_uint : test14'_scope. Check let v := 0%test14 in v : unit. Check let v := 0%test14' in v : unit. End Inner. @@ -269,8 +269,8 @@ Module Test14. Section InnerSection. Definition to_uint (x : unit) : Numeral.uint := Nat.to_num_uint O. Definition of_uint (x : Numeral.uint) : unit := tt. - Local Numeral Notation unit of_uint to_uint : test14''_scope. - Fail Global Numeral Notation unit of_uint to_uint : test14'''_scope. + Local Number Notation unit of_uint to_uint : test14''_scope. + Fail Global Number Notation unit of_uint to_uint : test14'''_scope. Check let v := 0%test14'' in v : unit. Fail Check let v := 0%test14''' in v : unit. End InnerSection. @@ -285,7 +285,7 @@ Module Test15. Module Inner. Definition to_uint (x : unit) : Numeral.uint := Nat.to_num_uint O. Definition of_uint (x : Numeral.uint) : unit := tt. - Numeral Notation unit of_uint to_uint : test15_scope. + Number Notation unit of_uint to_uint : test15_scope. Check let v := 0%test15 in v : unit. End Inner. Module Inner2. @@ -308,7 +308,7 @@ Module Test16. Inductive Foo := foo (_ : a.T). Definition to_uint (x : Foo) : Numeral.uint := Nat.to_num_uint O. Definition of_uint (x : Numeral.uint) : Foo := foo a.t. - Global Numeral Notation Foo of_uint to_uint : test16_scope. + Global Number Notation Foo of_uint to_uint : test16_scope. Check let v := 0%test16 in v : Foo. End F. Module a <: A. @@ -328,7 +328,7 @@ Module Test17. Delimit Scope test17_scope with test17. Local Set Primitive Projections. Record myint63 := of_int { to_int : int }. - Numeral Notation myint63 of_int to_int : test17_scope. + Number Notation myint63 of_int to_int : test17_scope. Check let v := 0%test17 in v : myint63. End Test17. @@ -356,7 +356,7 @@ Module Test18. Definition uint_of_Q (x : Q) : option Numeral.uint := option_map Nat.to_num_uint (nat_of_Q x). - Numeral Notation Q Q_of_uint uint_of_Q : Q_scope. + Number Notation Q Q_of_uint uint_of_Q : Q_scope. Check let v := 0%Q in v : Q. Check let v := 1%Q in v : Q. @@ -381,7 +381,7 @@ Module Test19. Definition Z_of_Zlike (x : Zlike) := List.fold_right Z.add 0%Z (summands x). Definition Zlike_of_Z (x : Z) := {| summands := cons x nil |}. - Numeral Notation Zlike Zlike_of_Z Z_of_Zlike : Zlike_scope. + Number Notation Zlike Zlike_of_Z Z_of_Zlike : Zlike_scope. Check let v := (-1)%Zlike in v : Zlike. Check let v := 0%Zlike in v : Zlike. @@ -434,7 +434,7 @@ Module Test20. Declare Scope kt_scope. Delimit Scope kt_scope with kt. - Numeral Notation ty ty_of_uint uint_of_ty : kt_scope. + Number Notation ty ty_of_uint uint_of_ty : kt_scope. Check let v := 0%kt in v : ty. Check let v := 1%kt in v : ty. diff --git a/test-suite/output/Partac.out b/test-suite/output/Partac.out new file mode 100644 index 0000000000..889e698fa2 --- /dev/null +++ b/test-suite/output/Partac.out @@ -0,0 +1,6 @@ +The command has indeed failed with message: +The term "false" has type "bool" while it is expected to have type "nat". +(for subgoal 1) +The command has indeed failed with message: +The term "0" has type "nat" while it is expected to have type "bool". +(for subgoal 2) diff --git a/test-suite/output/Partac.v b/test-suite/output/Partac.v new file mode 100644 index 0000000000..f579ee683b --- /dev/null +++ b/test-suite/output/Partac.v @@ -0,0 +1,6 @@ +Goal nat * bool. +Proof. + split. + Fail par: exact false. + Fail par: exact 0. +Abort. diff --git a/test-suite/output/PatternsInBinders.out b/test-suite/output/PatternsInBinders.out index bdfa8afb6a..b8daa69ad2 100644 --- a/test-suite/output/PatternsInBinders.out +++ b/test-suite/output/PatternsInBinders.out @@ -15,7 +15,7 @@ swap = fun (A B : Type) '(x, y) => (y, x) : forall A B : Type, A * B -> B * A -Arguments swap {A B}%type_scope +Arguments swap {A B}%type_scope _ fun (A B : Type) '(x, y) => swap (x, y) = (y, x) : forall A B : Type, A * B -> Prop forall (A B : Type) '(x, y), swap (x, y) = (y, x) diff --git a/test-suite/output/PrintInfos.out b/test-suite/output/PrintInfos.out index 8fb267e343..fe16dba496 100644 --- a/test-suite/output/PrintInfos.out +++ b/test-suite/output/PrintInfos.out @@ -1,24 +1,24 @@ existT : forall [A : Type] (P : A -> Type) (x : A), P x -> {x : A & P x} existT is template universe polymorphic on sigT.u0 sigT.u1 -Arguments existT [A]%type_scope _%function_scope +Arguments existT [A]%type_scope _%function_scope _ _ Expands to: Constructor Coq.Init.Specif.existT Inductive sigT (A : Type) (P : A -> Type) : Type := existT : forall x : A, P x -> {x : A & P x} Arguments sigT [A]%type_scope _%type_scope -Arguments existT [A]%type_scope _%function_scope +Arguments existT [A]%type_scope _%function_scope _ _ existT : forall [A : Type] (P : A -> Type) (x : A), P x -> {x : A & P x} Argument A is implicit Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x -Arguments eq {A}%type_scope -Arguments eq_refl {A}%type_scope {x}, [A] _ +Arguments eq {A}%type_scope _ _ +Arguments eq_refl {A}%type_scope {x}, [_] _ eq_refl : forall {A : Type} {x : A}, x = x eq_refl is not universe polymorphic -Arguments eq_refl {A}%type_scope {x}, [A] _ +Arguments eq_refl {A}%type_scope {x}, [_] _ Expands to: Constructor Coq.Init.Logic.eq_refl eq_refl : forall {A : Type} {x : A}, x = x @@ -54,7 +54,7 @@ Inductive le (n : nat) : nat -> Prop := Arguments le (_ _)%nat_scope Arguments le_n _%nat_scope -Arguments le_S {n}%nat_scope [m]%nat_scope +Arguments le_S {n}%nat_scope [m]%nat_scope _ comparison : Set comparison is not universe polymorphic @@ -80,8 +80,8 @@ Notation sym_eq := eq_sym Expands to: Notation Coq.Init.Logic.sym_eq Inductive eq (A : Type) (x : A) : A -> Prop := eq_refl : x = x -Arguments eq {A}%type_scope -Arguments eq_refl {A}%type_scope {x}, {A} _ +Arguments eq {A}%type_scope _ _ +Arguments eq_refl {A}%type_scope {x}, {_} _ n:nat Hypothesis of the goal context. diff --git a/test-suite/output/Projections.out b/test-suite/output/Projections.out index 1dd89c9bcd..1cdb39b020 100644 --- a/test-suite/output/Projections.out +++ b/test-suite/output/Projections.out @@ -7,11 +7,11 @@ let B := A in fun (C : Type) (u : U A C) => (A, B, C, c _ _ u) let B := A in forall C : Type, U A C -> Type * Type * Type * (B * A * C) -Arguments a (_ _)%type_scope +Arguments a (_ _)%type_scope _ b = fun A : Type => let B := A in fun (C : Type) (u : U A C) => b _ _ u : forall A : Type, let B := A in forall (C : Type) (u : U A C), (A, B, C, c _ _ u) = (A, B, C, c _ _ u) -Arguments b (_ _)%type_scope +Arguments b (_ _)%type_scope _ diff --git a/test-suite/output/RecordMissingField.out b/test-suite/output/RecordMissingField.out index 7c80a6065f..28beee90b2 100644 --- a/test-suite/output/RecordMissingField.out +++ b/test-suite/output/RecordMissingField.out @@ -1,4 +1,16 @@ -File "stdin", line 8, characters 5-22: -Error: Cannot infer field y2p of record point2d in environment: -p : point2d - +The command has indeed failed with message: +The following term contains unresolved implicit arguments: + (fun p : point2d => {| x2p := x2p p + 1; y2p := ?y2p |}) +More precisely: +- ?y2p: Cannot infer field y2p of record point2d in environment: + p : point2d +The command has indeed failed with message: +The following term contains unresolved implicit arguments: + (fun p : point2d => {| x2p := x2p p + (fun n : nat => ?n) 1; y2p := ?y2p |}) +More precisely: +- ?n: Cannot infer this placeholder of type "nat" in + environment: + p : point2d + n : nat +- ?y2p: Cannot infer field y2p of record point2d in environment: + p : point2d diff --git a/test-suite/output/RecordMissingField.v b/test-suite/output/RecordMissingField.v index 84f1748fa0..8ca721564b 100644 --- a/test-suite/output/RecordMissingField.v +++ b/test-suite/output/RecordMissingField.v @@ -3,6 +3,10 @@ should contain missing field, and the inferred type of the record **) Record point2d := mkPoint { x2p: nat; y2p: nat }. - -Definition increment_x (p: point2d) : point2d := +Fail Definition increment_x (p: point2d) : point2d := {| x2p := x2p p + 1; |}. + +(* Here there is also an unresolved implicit, which should give an + understadable error as well *) +Fail Definition increment_x (p: point2d) : point2d := + {| x2p := x2p p + (fun n => _) 1; |}. diff --git a/test-suite/output/UnivBinders.out b/test-suite/output/UnivBinders.out index edd2c9674f..163ed15606 100644 --- a/test-suite/output/UnivBinders.out +++ b/test-suite/output/UnivBinders.out @@ -5,24 +5,24 @@ Record PWrap (A : Type@{u}) : Type@{u} := pwrap { punwrap : A } PWrap has primitive projections with eta conversion. Arguments PWrap _%type_scope -Arguments pwrap _%type_scope +Arguments pwrap _%type_scope _ punwrap@{u} = fun (A : Type@{u}) (p : PWrap@{u} A) => punwrap _ p : forall A : Type@{u}, PWrap@{u} A -> A (* u |= *) -Arguments punwrap _%type_scope +Arguments punwrap _%type_scope _ Record RWrap (A : Type@{u}) : Type@{u} := rwrap { runwrap : A } (* u |= *) Arguments RWrap _%type_scope -Arguments rwrap _%type_scope +Arguments rwrap _%type_scope _ runwrap@{u} = fun (A : Type@{u}) (r : RWrap@{u} A) => let (runwrap) := r in runwrap : forall A : Type@{u}, RWrap@{u} A -> A (* u |= *) -Arguments runwrap _%type_scope +Arguments runwrap _%type_scope _ Wrap@{u} = fun A : Type@{u} => A : Type@{u} -> Type@{u} (* u |= *) @@ -87,12 +87,12 @@ Record PWrap (A : Type@{E}) : Type@{E} := pwrap { punwrap : A } PWrap has primitive projections with eta conversion. Arguments PWrap _%type_scope -Arguments pwrap _%type_scope +Arguments pwrap _%type_scope _ punwrap@{K} : forall A : Type@{K}, PWrap@{K} A -> A (* K |= *) punwrap is universe polymorphic -Arguments punwrap _%type_scope +Arguments punwrap _%type_scope _ punwrap is transparent Expands to: Constant UnivBinders.punwrap The command has indeed failed with message: diff --git a/test-suite/output/ZSyntax.v b/test-suite/output/ZSyntax.v index be9dc543d6..7b2bb00ce0 100644 --- a/test-suite/output/ZSyntax.v +++ b/test-suite/output/ZSyntax.v @@ -19,7 +19,7 @@ Check (0 + Z.of_nat 11)%Z. (* Check hexadecimal printing *) Definition to_num_int n := Numeral.IntHex (Z.to_hex_int n). -Numeral Notation Z Z.of_num_int to_num_int : Z_scope. +Number Notation Z Z.of_num_int to_num_int : Z_scope. Check 42%Z. Check (-42)%Z. Check 0%Z. diff --git a/test-suite/output/bug_12159.v b/test-suite/output/bug_12159.v index 6ea90eab29..437b4a68e9 100644 --- a/test-suite/output/bug_12159.v +++ b/test-suite/output/bug_12159.v @@ -6,8 +6,8 @@ Definition to_unit (v : Numeral.uint) : option unit := match Nat.of_num_uint v with O => Some tt | _ => None end. Definition of_unit (v : unit) : Numeral.uint := Nat.to_num_uint 0. Definition of_unit' (v : unit) : Numeral.uint := Nat.to_num_uint 1. -Numeral Notation unit to_unit of_unit : A. -Numeral Notation unit to_unit of_unit' : B. +Number Notation unit to_unit of_unit : A. +Number Notation unit to_unit of_unit' : B. Definition f x : unit := x. Check f tt. Arguments f x%A. diff --git a/test-suite/output/bug_12887.out b/test-suite/output/bug_12887.out new file mode 100644 index 0000000000..5ea7722bc6 --- /dev/null +++ b/test-suite/output/bug_12887.out @@ -0,0 +1,10 @@ +The command has indeed failed with message: +Cannot infer this placeholder of type "Type" in +environment: +Functor : (Type -> Type) -> Type +F : Type -> Type +fmap : forall A B : Type, (A -> B) -> F A -> F B +The command has indeed failed with message: +Cannot infer an existential variable of type "nat" in +environment: +R : nat -> Type diff --git a/test-suite/output/bug_12887.v b/test-suite/output/bug_12887.v new file mode 100644 index 0000000000..4208c3e8e9 --- /dev/null +++ b/test-suite/output/bug_12887.v @@ -0,0 +1,10 @@ +Arguments id {_} _. + +Fail Record Functor (F : Type -> Type) := { + fmap : forall A B, (A -> B) -> F A -> F B; + fmap_identity : fmap _ _ id = id; +}. + +Fail Inductive R (x:nat) := { y : R ltac:(clear x) }. + +Inductive R (x:nat) := { y : bool; z : R _ }. diff --git a/test-suite/output/sint63Notation.v b/test-suite/output/sint63Notation.v index 331d74ed3d..66ffbf2278 100644 --- a/test-suite/output/sint63Notation.v +++ b/test-suite/output/sint63Notation.v @@ -18,8 +18,8 @@ Definition as_signed (bw : Z) (v : Z) := (((2 ^ (bw - 1) + v) mod (2 ^ bw)) - 2 ^ (bw - 1))%Z. Definition sto_Z (v : sint) := as_signed 31 (to_Z (unwraps v)). -Numeral Notation uint uof_Z uto_Z : uint_scope. -Numeral Notation sint sof_Z sto_Z : sint_scope. +Number Notation uint uof_Z uto_Z : uint_scope. +Number Notation sint sof_Z sto_Z : sint_scope. Open Scope uint_scope. Compute uof_Z 0. Compute uof_Z 1. diff --git a/test-suite/output/ssr_error_multiple_intro_after_case.out b/test-suite/output/ssr_error_multiple_intro_after_case.out new file mode 100644 index 0000000000..51fb208ae9 --- /dev/null +++ b/test-suite/output/ssr_error_multiple_intro_after_case.out @@ -0,0 +1,3 @@ +File "stdin", line 3, characters 0-11: +Error: x already used + diff --git a/test-suite/output/ssr_error_multiple_intro_after_case.v b/test-suite/output/ssr_error_multiple_intro_after_case.v new file mode 100644 index 0000000000..18997b8686 --- /dev/null +++ b/test-suite/output/ssr_error_multiple_intro_after_case.v @@ -0,0 +1,4 @@ +Require Import ssreflect. +Goal forall p : nat * nat , True. +case => x x. +Abort. diff --git a/test-suite/primitive/float/compare.v b/test-suite/primitive/float/compare.v index 23d1e5bbae..75fd5c426f 100644 --- a/test-suite/primitive/float/compare.v +++ b/test-suite/primitive/float/compare.v @@ -6,380 +6,380 @@ Definition min_denorm := Eval compute in ldexp one (-1074)%Z. Definition min_norm := Eval compute in ldexp one (-1024)%Z. -Check (eq_refl false : nan == nan = false). -Check (eq_refl false : nan == nan = false). -Check (eq_refl false : nan < nan = false). -Check (eq_refl false : nan < nan = false). -Check (eq_refl false : nan <= nan = false). -Check (eq_refl false : nan <= nan = false). +Check (eq_refl false : nan =? nan = false). +Check (eq_refl false : nan =? nan = false). +Check (eq_refl false : nan <? nan = false). +Check (eq_refl false : nan <? nan = false). +Check (eq_refl false : nan <=? nan = false). +Check (eq_refl false : nan <=? nan = false). Check (eq_refl FNotComparable : nan ?= nan = FNotComparable). Check (eq_refl FNotComparable : nan ?= nan = FNotComparable). -Check (eq_refl false <: nan == nan = false). -Check (eq_refl false <: nan == nan = false). -Check (eq_refl false <: nan < nan = false). -Check (eq_refl false <: nan < nan = false). -Check (eq_refl false <: nan <= nan = false). -Check (eq_refl false <: nan <= nan = false). +Check (eq_refl false <: nan =? nan = false). +Check (eq_refl false <: nan =? nan = false). +Check (eq_refl false <: nan <? nan = false). +Check (eq_refl false <: nan <? nan = false). +Check (eq_refl false <: nan <=? nan = false). +Check (eq_refl false <: nan <=? nan = false). Check (eq_refl FNotComparable <: nan ?= nan = FNotComparable). Check (eq_refl FNotComparable <: nan ?= nan = FNotComparable). -Check (eq_refl false <<: nan == nan = false). -Check (eq_refl false <<: nan == nan = false). -Check (eq_refl false <<: nan < nan = false). -Check (eq_refl false <<: nan < nan = false). -Check (eq_refl false <<: nan <= nan = false). -Check (eq_refl false <<: nan <= nan = false). +Check (eq_refl false <<: nan =? nan = false). +Check (eq_refl false <<: nan =? nan = false). +Check (eq_refl false <<: nan <? nan = false). +Check (eq_refl false <<: nan <? nan = false). +Check (eq_refl false <<: nan <=? nan = false). +Check (eq_refl false <<: nan <=? nan = false). Check (eq_refl FNotComparable <<: nan ?= nan = FNotComparable). Check (eq_refl FNotComparable <<: nan ?= nan = FNotComparable). -Check (eq_refl false : nan == - nan = false). -Check (eq_refl false : - nan == nan = false). -Check (eq_refl false : nan < - nan = false). -Check (eq_refl false : - nan < nan = false). -Check (eq_refl false : nan <= - nan = false). -Check (eq_refl false : - nan <= nan = false). +Check (eq_refl false : nan =? - nan = false). +Check (eq_refl false : - nan =? nan = false). +Check (eq_refl false : nan <? - nan = false). +Check (eq_refl false : - nan <? nan = false). +Check (eq_refl false : nan <=? - nan = false). +Check (eq_refl false : - nan <=? nan = false). Check (eq_refl FNotComparable : nan ?= - nan = FNotComparable). Check (eq_refl FNotComparable : - nan ?= nan = FNotComparable). -Check (eq_refl false <: nan == - nan = false). -Check (eq_refl false <: - nan == nan = false). -Check (eq_refl false <: nan < - nan = false). -Check (eq_refl false <: - nan < nan = false). -Check (eq_refl false <: nan <= - nan = false). -Check (eq_refl false <: - nan <= nan = false). +Check (eq_refl false <: nan =? - nan = false). +Check (eq_refl false <: - nan =? nan = false). +Check (eq_refl false <: nan <? - nan = false). +Check (eq_refl false <: - nan <? nan = false). +Check (eq_refl false <: nan <=? - nan = false). +Check (eq_refl false <: - nan <=? nan = false). Check (eq_refl FNotComparable <: nan ?= - nan = FNotComparable). Check (eq_refl FNotComparable <: - nan ?= nan = FNotComparable). -Check (eq_refl false <<: nan == - nan = false). -Check (eq_refl false <<: - nan == nan = false). -Check (eq_refl false <<: nan < - nan = false). -Check (eq_refl false <<: - nan < nan = false). -Check (eq_refl false <<: nan <= - nan = false). -Check (eq_refl false <<: - nan <= nan = false). +Check (eq_refl false <<: nan =? - nan = false). +Check (eq_refl false <<: - nan =? nan = false). +Check (eq_refl false <<: nan <? - nan = false). +Check (eq_refl false <<: - nan <? nan = false). +Check (eq_refl false <<: nan <=? - nan = false). +Check (eq_refl false <<: - nan <=? nan = false). Check (eq_refl FNotComparable <<: nan ?= - nan = FNotComparable). Check (eq_refl FNotComparable <<: - nan ?= nan = FNotComparable). -Check (eq_refl true : one == one = true). -Check (eq_refl true : one == one = true). -Check (eq_refl false : one < one = false). -Check (eq_refl false : one < one = false). -Check (eq_refl true : one <= one = true). -Check (eq_refl true : one <= one = true). +Check (eq_refl true : one =? one = true). +Check (eq_refl true : one =? one = true). +Check (eq_refl false : one <? one = false). +Check (eq_refl false : one <? one = false). +Check (eq_refl true : one <=? one = true). +Check (eq_refl true : one <=? one = true). Check (eq_refl FEq : one ?= one = FEq). Check (eq_refl FEq : one ?= one = FEq). -Check (eq_refl true <: one == one = true). -Check (eq_refl true <: one == one = true). -Check (eq_refl false <: one < one = false). -Check (eq_refl false <: one < one = false). -Check (eq_refl true <: one <= one = true). -Check (eq_refl true <: one <= one = true). +Check (eq_refl true <: one =? one = true). +Check (eq_refl true <: one =? one = true). +Check (eq_refl false <: one <? one = false). +Check (eq_refl false <: one <? one = false). +Check (eq_refl true <: one <=? one = true). +Check (eq_refl true <: one <=? one = true). Check (eq_refl FEq <: one ?= one = FEq). Check (eq_refl FEq <: one ?= one = FEq). -Check (eq_refl true <<: one == one = true). -Check (eq_refl true <<: one == one = true). -Check (eq_refl false <<: one < one = false). -Check (eq_refl false <<: one < one = false). -Check (eq_refl true <<: one <= one = true). -Check (eq_refl true <<: one <= one = true). +Check (eq_refl true <<: one =? one = true). +Check (eq_refl true <<: one =? one = true). +Check (eq_refl false <<: one <? one = false). +Check (eq_refl false <<: one <? one = false). +Check (eq_refl true <<: one <=? one = true). +Check (eq_refl true <<: one <=? one = true). Check (eq_refl FEq <<: one ?= one = FEq). Check (eq_refl FEq <<: one ?= one = FEq). -Check (eq_refl true : zero == zero = true). -Check (eq_refl true : zero == zero = true). -Check (eq_refl false : zero < zero = false). -Check (eq_refl false : zero < zero = false). -Check (eq_refl true : zero <= zero = true). -Check (eq_refl true : zero <= zero = true). +Check (eq_refl true : zero =? zero = true). +Check (eq_refl true : zero =? zero = true). +Check (eq_refl false : zero <? zero = false). +Check (eq_refl false : zero <? zero = false). +Check (eq_refl true : zero <=? zero = true). +Check (eq_refl true : zero <=? zero = true). Check (eq_refl FEq : zero ?= zero = FEq). Check (eq_refl FEq : zero ?= zero = FEq). -Check (eq_refl true <: zero == zero = true). -Check (eq_refl true <: zero == zero = true). -Check (eq_refl false <: zero < zero = false). -Check (eq_refl false <: zero < zero = false). -Check (eq_refl true <: zero <= zero = true). -Check (eq_refl true <: zero <= zero = true). +Check (eq_refl true <: zero =? zero = true). +Check (eq_refl true <: zero =? zero = true). +Check (eq_refl false <: zero <? zero = false). +Check (eq_refl false <: zero <? zero = false). +Check (eq_refl true <: zero <=? zero = true). +Check (eq_refl true <: zero <=? zero = true). Check (eq_refl FEq <: zero ?= zero = FEq). Check (eq_refl FEq <: zero ?= zero = FEq). -Check (eq_refl true <<: zero == zero = true). -Check (eq_refl true <<: zero == zero = true). -Check (eq_refl false <<: zero < zero = false). -Check (eq_refl false <<: zero < zero = false). -Check (eq_refl true <<: zero <= zero = true). -Check (eq_refl true <<: zero <= zero = true). +Check (eq_refl true <<: zero =? zero = true). +Check (eq_refl true <<: zero =? zero = true). +Check (eq_refl false <<: zero <? zero = false). +Check (eq_refl false <<: zero <? zero = false). +Check (eq_refl true <<: zero <=? zero = true). +Check (eq_refl true <<: zero <=? zero = true). Check (eq_refl FEq <<: zero ?= zero = FEq). Check (eq_refl FEq <<: zero ?= zero = FEq). -Check (eq_refl true : zero == - zero = true). -Check (eq_refl true : - zero == zero = true). -Check (eq_refl false : zero < - zero = false). -Check (eq_refl false : - zero < zero = false). -Check (eq_refl true : zero <= - zero = true). -Check (eq_refl true : - zero <= zero = true). +Check (eq_refl true : zero =? - zero = true). +Check (eq_refl true : - zero =? zero = true). +Check (eq_refl false : zero <? - zero = false). +Check (eq_refl false : - zero <? zero = false). +Check (eq_refl true : zero <=? - zero = true). +Check (eq_refl true : - zero <=? zero = true). Check (eq_refl FEq : zero ?= - zero = FEq). Check (eq_refl FEq : - zero ?= zero = FEq). -Check (eq_refl true <: zero == - zero = true). -Check (eq_refl true <: - zero == zero = true). -Check (eq_refl false <: zero < - zero = false). -Check (eq_refl false <: - zero < zero = false). -Check (eq_refl true <: zero <= - zero = true). -Check (eq_refl true <: - zero <= zero = true). +Check (eq_refl true <: zero =? - zero = true). +Check (eq_refl true <: - zero =? zero = true). +Check (eq_refl false <: zero <? - zero = false). +Check (eq_refl false <: - zero <? zero = false). +Check (eq_refl true <: zero <=? - zero = true). +Check (eq_refl true <: - zero <=? zero = true). Check (eq_refl FEq <: zero ?= - zero = FEq). Check (eq_refl FEq <: - zero ?= zero = FEq). -Check (eq_refl true <<: zero == - zero = true). -Check (eq_refl true <<: - zero == zero = true). -Check (eq_refl false <<: zero < - zero = false). -Check (eq_refl false <<: - zero < zero = false). -Check (eq_refl true <<: zero <= - zero = true). -Check (eq_refl true <<: - zero <= zero = true). +Check (eq_refl true <<: zero =? - zero = true). +Check (eq_refl true <<: - zero =? zero = true). +Check (eq_refl false <<: zero <? - zero = false). +Check (eq_refl false <<: - zero <? zero = false). +Check (eq_refl true <<: zero <=? - zero = true). +Check (eq_refl true <<: - zero <=? zero = true). Check (eq_refl FEq <<: zero ?= - zero = FEq). Check (eq_refl FEq <<: - zero ?= zero = FEq). -Check (eq_refl true : - zero == - zero = true). -Check (eq_refl true : - zero == - zero = true). -Check (eq_refl false : - zero < - zero = false). -Check (eq_refl false : - zero < - zero = false). -Check (eq_refl true : - zero <= - zero = true). -Check (eq_refl true : - zero <= - zero = true). +Check (eq_refl true : - zero =? - zero = true). +Check (eq_refl true : - zero =? - zero = true). +Check (eq_refl false : - zero <? - zero = false). +Check (eq_refl false : - zero <? - zero = false). +Check (eq_refl true : - zero <=? - zero = true). +Check (eq_refl true : - zero <=? - zero = true). Check (eq_refl FEq : - zero ?= - zero = FEq). Check (eq_refl FEq : - zero ?= - zero = FEq). -Check (eq_refl true <: - zero == - zero = true). -Check (eq_refl true <: - zero == - zero = true). -Check (eq_refl false <: - zero < - zero = false). -Check (eq_refl false <: - zero < - zero = false). -Check (eq_refl true <: - zero <= - zero = true). -Check (eq_refl true <: - zero <= - zero = true). +Check (eq_refl true <: - zero =? - zero = true). +Check (eq_refl true <: - zero =? - zero = true). +Check (eq_refl false <: - zero <? - zero = false). +Check (eq_refl false <: - zero <? - zero = false). +Check (eq_refl true <: - zero <=? - zero = true). +Check (eq_refl true <: - zero <=? - zero = true). Check (eq_refl FEq <: - zero ?= - zero = FEq). Check (eq_refl FEq <: - zero ?= - zero = FEq). -Check (eq_refl true <<: - zero == - zero = true). -Check (eq_refl true <<: - zero == - zero = true). -Check (eq_refl false <<: - zero < - zero = false). -Check (eq_refl false <<: - zero < - zero = false). -Check (eq_refl true <<: - zero <= - zero = true). -Check (eq_refl true <<: - zero <= - zero = true). +Check (eq_refl true <<: - zero =? - zero = true). +Check (eq_refl true <<: - zero =? - zero = true). +Check (eq_refl false <<: - zero <? - zero = false). +Check (eq_refl false <<: - zero <? - zero = false). +Check (eq_refl true <<: - zero <=? - zero = true). +Check (eq_refl true <<: - zero <=? - zero = true). Check (eq_refl FEq <<: - zero ?= - zero = FEq). Check (eq_refl FEq <<: - zero ?= - zero = FEq). -Check (eq_refl true : infinity == infinity = true). -Check (eq_refl true : infinity == infinity = true). -Check (eq_refl false : infinity < infinity = false). -Check (eq_refl false : infinity < infinity = false). -Check (eq_refl true : infinity <= infinity = true). -Check (eq_refl true : infinity <= infinity = true). +Check (eq_refl true : infinity =? infinity = true). +Check (eq_refl true : infinity =? infinity = true). +Check (eq_refl false : infinity <? infinity = false). +Check (eq_refl false : infinity <? infinity = false). +Check (eq_refl true : infinity <=? infinity = true). +Check (eq_refl true : infinity <=? infinity = true). Check (eq_refl FEq : infinity ?= infinity = FEq). Check (eq_refl FEq : infinity ?= infinity = FEq). -Check (eq_refl true <: infinity == infinity = true). -Check (eq_refl true <: infinity == infinity = true). -Check (eq_refl false <: infinity < infinity = false). -Check (eq_refl false <: infinity < infinity = false). -Check (eq_refl true <: infinity <= infinity = true). -Check (eq_refl true <: infinity <= infinity = true). +Check (eq_refl true <: infinity =? infinity = true). +Check (eq_refl true <: infinity =? infinity = true). +Check (eq_refl false <: infinity <? infinity = false). +Check (eq_refl false <: infinity <? infinity = false). +Check (eq_refl true <: infinity <=? infinity = true). +Check (eq_refl true <: infinity <=? infinity = true). Check (eq_refl FEq <: infinity ?= infinity = FEq). Check (eq_refl FEq <: infinity ?= infinity = FEq). -Check (eq_refl true <<: infinity == infinity = true). -Check (eq_refl true <<: infinity == infinity = true). -Check (eq_refl false <<: infinity < infinity = false). -Check (eq_refl false <<: infinity < infinity = false). -Check (eq_refl true <<: infinity <= infinity = true). -Check (eq_refl true <<: infinity <= infinity = true). +Check (eq_refl true <<: infinity =? infinity = true). +Check (eq_refl true <<: infinity =? infinity = true). +Check (eq_refl false <<: infinity <? infinity = false). +Check (eq_refl false <<: infinity <? infinity = false). +Check (eq_refl true <<: infinity <=? infinity = true). +Check (eq_refl true <<: infinity <=? infinity = true). Check (eq_refl FEq <<: infinity ?= infinity = FEq). Check (eq_refl FEq <<: infinity ?= infinity = FEq). -Check (eq_refl true : - infinity == - infinity = true). -Check (eq_refl true : - infinity == - infinity = true). -Check (eq_refl false : - infinity < - infinity = false). -Check (eq_refl false : - infinity < - infinity = false). -Check (eq_refl true : - infinity <= - infinity = true). -Check (eq_refl true : - infinity <= - infinity = true). +Check (eq_refl true : - infinity =? - infinity = true). +Check (eq_refl true : - infinity =? - infinity = true). +Check (eq_refl false : - infinity <? - infinity = false). +Check (eq_refl false : - infinity <? - infinity = false). +Check (eq_refl true : - infinity <=? - infinity = true). +Check (eq_refl true : - infinity <=? - infinity = true). Check (eq_refl FEq : - infinity ?= - infinity = FEq). Check (eq_refl FEq : - infinity ?= - infinity = FEq). -Check (eq_refl true <: - infinity == - infinity = true). -Check (eq_refl true <: - infinity == - infinity = true). -Check (eq_refl false <: - infinity < - infinity = false). -Check (eq_refl false <: - infinity < - infinity = false). -Check (eq_refl true <: - infinity <= - infinity = true). -Check (eq_refl true <: - infinity <= - infinity = true). +Check (eq_refl true <: - infinity =? - infinity = true). +Check (eq_refl true <: - infinity =? - infinity = true). +Check (eq_refl false <: - infinity <? - infinity = false). +Check (eq_refl false <: - infinity <? - infinity = false). +Check (eq_refl true <: - infinity <=? - infinity = true). +Check (eq_refl true <: - infinity <=? - infinity = true). Check (eq_refl FEq <: - infinity ?= - infinity = FEq). Check (eq_refl FEq <: - infinity ?= - infinity = FEq). -Check (eq_refl true <<: - infinity == - infinity = true). -Check (eq_refl true <<: - infinity == - infinity = true). -Check (eq_refl false <<: - infinity < - infinity = false). -Check (eq_refl false <<: - infinity < - infinity = false). -Check (eq_refl true <<: - infinity <= - infinity = true). -Check (eq_refl true <<: - infinity <= - infinity = true). +Check (eq_refl true <<: - infinity =? - infinity = true). +Check (eq_refl true <<: - infinity =? - infinity = true). +Check (eq_refl false <<: - infinity <? - infinity = false). +Check (eq_refl false <<: - infinity <? - infinity = false). +Check (eq_refl true <<: - infinity <=? - infinity = true). +Check (eq_refl true <<: - infinity <=? - infinity = true). Check (eq_refl FEq <<: - infinity ?= - infinity = FEq). Check (eq_refl FEq <<: - infinity ?= - infinity = FEq). -Check (eq_refl false : min_denorm == min_norm = false). -Check (eq_refl false : min_norm == min_denorm = false). -Check (eq_refl true : min_denorm < min_norm = true). -Check (eq_refl false : min_norm < min_denorm = false). -Check (eq_refl true : min_denorm <= min_norm = true). -Check (eq_refl false : min_norm <= min_denorm = false). +Check (eq_refl false : min_denorm =? min_norm = false). +Check (eq_refl false : min_norm =? min_denorm = false). +Check (eq_refl true : min_denorm <? min_norm = true). +Check (eq_refl false : min_norm <? min_denorm = false). +Check (eq_refl true : min_denorm <=? min_norm = true). +Check (eq_refl false : min_norm <=? min_denorm = false). Check (eq_refl FLt : min_denorm ?= min_norm = FLt). Check (eq_refl FGt : min_norm ?= min_denorm = FGt). -Check (eq_refl false <: min_denorm == min_norm = false). -Check (eq_refl false <: min_norm == min_denorm = false). -Check (eq_refl true <: min_denorm < min_norm = true). -Check (eq_refl false <: min_norm < min_denorm = false). -Check (eq_refl true <: min_denorm <= min_norm = true). -Check (eq_refl false <: min_norm <= min_denorm = false). +Check (eq_refl false <: min_denorm =? min_norm = false). +Check (eq_refl false <: min_norm =? min_denorm = false). +Check (eq_refl true <: min_denorm <? min_norm = true). +Check (eq_refl false <: min_norm <? min_denorm = false). +Check (eq_refl true <: min_denorm <=? min_norm = true). +Check (eq_refl false <: min_norm <=? min_denorm = false). Check (eq_refl FLt <: min_denorm ?= min_norm = FLt). Check (eq_refl FGt <: min_norm ?= min_denorm = FGt). -Check (eq_refl false <<: min_denorm == min_norm = false). -Check (eq_refl false <<: min_norm == min_denorm = false). -Check (eq_refl true <<: min_denorm < min_norm = true). -Check (eq_refl false <<: min_norm < min_denorm = false). -Check (eq_refl true <<: min_denorm <= min_norm = true). -Check (eq_refl false <<: min_norm <= min_denorm = false). +Check (eq_refl false <<: min_denorm =? min_norm = false). +Check (eq_refl false <<: min_norm =? min_denorm = false). +Check (eq_refl true <<: min_denorm <? min_norm = true). +Check (eq_refl false <<: min_norm <? min_denorm = false). +Check (eq_refl true <<: min_denorm <=? min_norm = true). +Check (eq_refl false <<: min_norm <=? min_denorm = false). Check (eq_refl FLt <<: min_denorm ?= min_norm = FLt). Check (eq_refl FGt <<: min_norm ?= min_denorm = FGt). -Check (eq_refl false : min_denorm == one = false). -Check (eq_refl false : one == min_denorm = false). -Check (eq_refl true : min_denorm < one = true). -Check (eq_refl false : one < min_denorm = false). -Check (eq_refl true : min_denorm <= one = true). -Check (eq_refl false : one <= min_denorm = false). +Check (eq_refl false : min_denorm =? one = false). +Check (eq_refl false : one =? min_denorm = false). +Check (eq_refl true : min_denorm <? one = true). +Check (eq_refl false : one <? min_denorm = false). +Check (eq_refl true : min_denorm <=? one = true). +Check (eq_refl false : one <=? min_denorm = false). Check (eq_refl FLt : min_denorm ?= one = FLt). Check (eq_refl FGt : one ?= min_denorm = FGt). -Check (eq_refl false <: min_denorm == one = false). -Check (eq_refl false <: one == min_denorm = false). -Check (eq_refl true <: min_denorm < one = true). -Check (eq_refl false <: one < min_denorm = false). -Check (eq_refl true <: min_denorm <= one = true). -Check (eq_refl false <: one <= min_denorm = false). +Check (eq_refl false <: min_denorm =? one = false). +Check (eq_refl false <: one =? min_denorm = false). +Check (eq_refl true <: min_denorm <? one = true). +Check (eq_refl false <: one <? min_denorm = false). +Check (eq_refl true <: min_denorm <=? one = true). +Check (eq_refl false <: one <=? min_denorm = false). Check (eq_refl FLt <: min_denorm ?= one = FLt). Check (eq_refl FGt <: one ?= min_denorm = FGt). -Check (eq_refl false <<: min_denorm == one = false). -Check (eq_refl false <<: one == min_denorm = false). -Check (eq_refl true <<: min_denorm < one = true). -Check (eq_refl false <<: one < min_denorm = false). -Check (eq_refl true <<: min_denorm <= one = true). -Check (eq_refl false <<: one <= min_denorm = false). +Check (eq_refl false <<: min_denorm =? one = false). +Check (eq_refl false <<: one =? min_denorm = false). +Check (eq_refl true <<: min_denorm <? one = true). +Check (eq_refl false <<: one <? min_denorm = false). +Check (eq_refl true <<: min_denorm <=? one = true). +Check (eq_refl false <<: one <=? min_denorm = false). Check (eq_refl FLt <<: min_denorm ?= one = FLt). Check (eq_refl FGt <<: one ?= min_denorm = FGt). -Check (eq_refl false : min_norm == one = false). -Check (eq_refl false : one == min_norm = false). -Check (eq_refl true : min_norm < one = true). -Check (eq_refl false : one < min_norm = false). -Check (eq_refl true : min_norm <= one = true). -Check (eq_refl false : one <= min_norm = false). +Check (eq_refl false : min_norm =? one = false). +Check (eq_refl false : one =? min_norm = false). +Check (eq_refl true : min_norm <? one = true). +Check (eq_refl false : one <? min_norm = false). +Check (eq_refl true : min_norm <=? one = true). +Check (eq_refl false : one <=? min_norm = false). Check (eq_refl FLt : min_norm ?= one = FLt). Check (eq_refl FGt : one ?= min_norm = FGt). -Check (eq_refl false <: min_norm == one = false). -Check (eq_refl false <: one == min_norm = false). -Check (eq_refl true <: min_norm < one = true). -Check (eq_refl false <: one < min_norm = false). -Check (eq_refl true <: min_norm <= one = true). -Check (eq_refl false <: one <= min_norm = false). +Check (eq_refl false <: min_norm =? one = false). +Check (eq_refl false <: one =? min_norm = false). +Check (eq_refl true <: min_norm <? one = true). +Check (eq_refl false <: one <? min_norm = false). +Check (eq_refl true <: min_norm <=? one = true). +Check (eq_refl false <: one <=? min_norm = false). Check (eq_refl FLt <: min_norm ?= one = FLt). Check (eq_refl FGt <: one ?= min_norm = FGt). -Check (eq_refl false <<: min_norm == one = false). -Check (eq_refl false <<: one == min_norm = false). -Check (eq_refl true <<: min_norm < one = true). -Check (eq_refl false <<: one < min_norm = false). -Check (eq_refl true <<: min_norm <= one = true). -Check (eq_refl false <<: one <= min_norm = false). +Check (eq_refl false <<: min_norm =? one = false). +Check (eq_refl false <<: one =? min_norm = false). +Check (eq_refl true <<: min_norm <? one = true). +Check (eq_refl false <<: one <? min_norm = false). +Check (eq_refl true <<: min_norm <=? one = true). +Check (eq_refl false <<: one <=? min_norm = false). Check (eq_refl FLt <<: min_norm ?= one = FLt). Check (eq_refl FGt <<: one ?= min_norm = FGt). -Check (eq_refl false : one == infinity = false). -Check (eq_refl false : infinity == one = false). -Check (eq_refl true : one < infinity = true). -Check (eq_refl false : infinity < one = false). -Check (eq_refl true : one <= infinity = true). -Check (eq_refl false : infinity <= one = false). +Check (eq_refl false : one =? infinity = false). +Check (eq_refl false : infinity =? one = false). +Check (eq_refl true : one <? infinity = true). +Check (eq_refl false : infinity <? one = false). +Check (eq_refl true : one <=? infinity = true). +Check (eq_refl false : infinity <=? one = false). Check (eq_refl FLt : one ?= infinity = FLt). Check (eq_refl FGt : infinity ?= one = FGt). -Check (eq_refl false <: one == infinity = false). -Check (eq_refl false <: infinity == one = false). -Check (eq_refl true <: one < infinity = true). -Check (eq_refl false <: infinity < one = false). -Check (eq_refl true <: one <= infinity = true). -Check (eq_refl false <: infinity <= one = false). +Check (eq_refl false <: one =? infinity = false). +Check (eq_refl false <: infinity =? one = false). +Check (eq_refl true <: one <? infinity = true). +Check (eq_refl false <: infinity <? one = false). +Check (eq_refl true <: one <=? infinity = true). +Check (eq_refl false <: infinity <=? one = false). Check (eq_refl FLt <: one ?= infinity = FLt). Check (eq_refl FGt <: infinity ?= one = FGt). -Check (eq_refl false <<: one == infinity = false). -Check (eq_refl false <<: infinity == one = false). -Check (eq_refl true <<: one < infinity = true). -Check (eq_refl false <<: infinity < one = false). -Check (eq_refl true <<: one <= infinity = true). -Check (eq_refl false <<: infinity <= one = false). +Check (eq_refl false <<: one =? infinity = false). +Check (eq_refl false <<: infinity =? one = false). +Check (eq_refl true <<: one <? infinity = true). +Check (eq_refl false <<: infinity <? one = false). +Check (eq_refl true <<: one <=? infinity = true). +Check (eq_refl false <<: infinity <=? one = false). Check (eq_refl FLt <<: one ?= infinity = FLt). Check (eq_refl FGt <<: infinity ?= one = FGt). -Check (eq_refl false : - infinity == infinity = false). -Check (eq_refl false : infinity == - infinity = false). -Check (eq_refl true : - infinity < infinity = true). -Check (eq_refl false : infinity < - infinity = false). -Check (eq_refl true : - infinity <= infinity = true). -Check (eq_refl false : infinity <= - infinity = false). +Check (eq_refl false : - infinity =? infinity = false). +Check (eq_refl false : infinity =? - infinity = false). +Check (eq_refl true : - infinity <? infinity = true). +Check (eq_refl false : infinity <? - infinity = false). +Check (eq_refl true : - infinity <=? infinity = true). +Check (eq_refl false : infinity <=? - infinity = false). Check (eq_refl FLt : - infinity ?= infinity = FLt). Check (eq_refl FGt : infinity ?= - infinity = FGt). -Check (eq_refl false <: - infinity == infinity = false). -Check (eq_refl false <: infinity == - infinity = false). -Check (eq_refl true <: - infinity < infinity = true). -Check (eq_refl false <: infinity < - infinity = false). -Check (eq_refl true <: - infinity <= infinity = true). -Check (eq_refl false <: infinity <= - infinity = false). +Check (eq_refl false <: - infinity =? infinity = false). +Check (eq_refl false <: infinity =? - infinity = false). +Check (eq_refl true <: - infinity <? infinity = true). +Check (eq_refl false <: infinity <? - infinity = false). +Check (eq_refl true <: - infinity <=? infinity = true). +Check (eq_refl false <: infinity <=? - infinity = false). Check (eq_refl FLt <: - infinity ?= infinity = FLt). Check (eq_refl FGt <: infinity ?= - infinity = FGt). -Check (eq_refl false <<: - infinity == infinity = false). -Check (eq_refl false <<: infinity == - infinity = false). -Check (eq_refl true <<: - infinity < infinity = true). -Check (eq_refl false <<: infinity < - infinity = false). -Check (eq_refl true <<: - infinity <= infinity = true). -Check (eq_refl false <<: infinity <= - infinity = false). +Check (eq_refl false <<: - infinity =? infinity = false). +Check (eq_refl false <<: infinity =? - infinity = false). +Check (eq_refl true <<: - infinity <? infinity = true). +Check (eq_refl false <<: infinity <? - infinity = false). +Check (eq_refl true <<: - infinity <=? infinity = true). +Check (eq_refl false <<: infinity <=? - infinity = false). Check (eq_refl FLt <<: - infinity ?= infinity = FLt). Check (eq_refl FGt <<: infinity ?= - infinity = FGt). -Check (eq_refl false : - infinity == one = false). -Check (eq_refl false : one == - infinity = false). -Check (eq_refl true : - infinity < one = true). -Check (eq_refl false : one < - infinity = false). -Check (eq_refl true : - infinity <= one = true). -Check (eq_refl false : one <= - infinity = false). +Check (eq_refl false : - infinity =? one = false). +Check (eq_refl false : one =? - infinity = false). +Check (eq_refl true : - infinity <? one = true). +Check (eq_refl false : one <? - infinity = false). +Check (eq_refl true : - infinity <=? one = true). +Check (eq_refl false : one <=? - infinity = false). Check (eq_refl FLt : - infinity ?= one = FLt). Check (eq_refl FGt : one ?= - infinity = FGt). -Check (eq_refl false <: - infinity == one = false). -Check (eq_refl false <: one == - infinity = false). -Check (eq_refl true <: - infinity < one = true). -Check (eq_refl false <: one < - infinity = false). -Check (eq_refl true <: - infinity <= one = true). -Check (eq_refl false <: one <= - infinity = false). +Check (eq_refl false <: - infinity =? one = false). +Check (eq_refl false <: one =? - infinity = false). +Check (eq_refl true <: - infinity <? one = true). +Check (eq_refl false <: one <? - infinity = false). +Check (eq_refl true <: - infinity <=? one = true). +Check (eq_refl false <: one <=? - infinity = false). Check (eq_refl FLt <: - infinity ?= one = FLt). Check (eq_refl FGt <: one ?= - infinity = FGt). -Check (eq_refl false <<: - infinity == one = false). -Check (eq_refl false <<: one == - infinity = false). -Check (eq_refl true <<: - infinity < one = true). -Check (eq_refl false <<: one < - infinity = false). -Check (eq_refl true <<: - infinity <= one = true). -Check (eq_refl false <<: one <= - infinity = false). +Check (eq_refl false <<: - infinity =? one = false). +Check (eq_refl false <<: one =? - infinity = false). +Check (eq_refl true <<: - infinity <? one = true). +Check (eq_refl false <<: one <? - infinity = false). +Check (eq_refl true <<: - infinity <=? one = true). +Check (eq_refl false <<: one <=? - infinity = false). Check (eq_refl FLt <<: - infinity ?= one = FLt). Check (eq_refl FGt <<: one ?= - infinity = FGt). diff --git a/test-suite/primitive/float/gen_compare.sh b/test-suite/primitive/float/gen_compare.sh index cd87eb4e5b..6e3dd6d04b 100755 --- a/test-suite/primitive/float/gen_compare.sh +++ b/test-suite/primitive/float/gen_compare.sh @@ -20,7 +20,7 @@ genTest() { echo >&2 "genTest expects 10 arguments" fi TACTICS=(":" "<:" "<<:") - OPS=("==" "<" "<=" "?=") + OPS=("=?" "<?" "<=?" "?=") x="$1" y="$2" OPS1=("$3" "$4" "$5" "$6") # for x y diff --git a/test-suite/primitive/uint63/eqb.v b/test-suite/primitive/uint63/eqb.v index dcc0b71f6d..43c98e2b6f 100644 --- a/test-suite/primitive/uint63/eqb.v +++ b/test-suite/primitive/uint63/eqb.v @@ -4,14 +4,14 @@ Set Implicit Arguments. Open Scope int63_scope. -Check (eq_refl : 1 == 1 = true). -Check (eq_refl true <: 1 == 1 = true). -Check (eq_refl true <<: 1 == 1 = true). -Definition compute1 := Eval compute in 1 == 1. +Check (eq_refl : 1 =? 1 = true). +Check (eq_refl true <: 1 =? 1 = true). +Check (eq_refl true <<: 1 =? 1 = true). +Definition compute1 := Eval compute in 1 =? 1. Check (eq_refl compute1 : true = true). -Check (eq_refl : 9223372036854775807 == 0 = false). -Check (eq_refl false <: 9223372036854775807 == 0 = false). -Check (eq_refl false <<: 9223372036854775807 == 0 = false). -Definition compute2 := Eval compute in 9223372036854775807 == 0. +Check (eq_refl : 9223372036854775807 =? 0 = false). +Check (eq_refl false <: 9223372036854775807 =? 0 = false). +Check (eq_refl false <<: 9223372036854775807 =? 0 = false). +Definition compute2 := Eval compute in 9223372036854775807 =? 0. Check (eq_refl compute2 : false = false). diff --git a/test-suite/primitive/uint63/leb.v b/test-suite/primitive/uint63/leb.v index 5354919978..e5142282ae 100644 --- a/test-suite/primitive/uint63/leb.v +++ b/test-suite/primitive/uint63/leb.v @@ -4,20 +4,20 @@ Set Implicit Arguments. Open Scope int63_scope. -Check (eq_refl : 1 <= 1 = true). -Check (eq_refl true <: 1 <= 1 = true). -Check (eq_refl true <<: 1 <= 1 = true). -Definition compute1 := Eval compute in 1 <= 1. +Check (eq_refl : 1 <=? 1 = true). +Check (eq_refl true <: 1 <=? 1 = true). +Check (eq_refl true <<: 1 <=? 1 = true). +Definition compute1 := Eval compute in 1 <=? 1. Check (eq_refl compute1 : true = true). -Check (eq_refl : 1 <= 2 = true). -Check (eq_refl true <: 1 <= 2 = true). -Check (eq_refl true <<: 1 <= 2 = true). -Definition compute2 := Eval compute in 1 <= 2. +Check (eq_refl : 1 <=? 2 = true). +Check (eq_refl true <: 1 <=? 2 = true). +Check (eq_refl true <<: 1 <=? 2 = true). +Definition compute2 := Eval compute in 1 <=? 2. Check (eq_refl compute2 : true = true). -Check (eq_refl : 9223372036854775807 <= 0 = false). -Check (eq_refl false <: 9223372036854775807 <= 0 = false). -Check (eq_refl false <<: 9223372036854775807 <= 0 = false). -Definition compute3 := Eval compute in 9223372036854775807 <= 0. +Check (eq_refl : 9223372036854775807 <=? 0 = false). +Check (eq_refl false <: 9223372036854775807 <=? 0 = false). +Check (eq_refl false <<: 9223372036854775807 <=? 0 = false). +Definition compute3 := Eval compute in 9223372036854775807 <=? 0. Check (eq_refl compute3 : false = false). diff --git a/test-suite/primitive/uint63/ltb.v b/test-suite/primitive/uint63/ltb.v index 7ae5ac6493..50cef6be66 100644 --- a/test-suite/primitive/uint63/ltb.v +++ b/test-suite/primitive/uint63/ltb.v @@ -4,20 +4,20 @@ Set Implicit Arguments. Open Scope int63_scope. -Check (eq_refl : 1 < 1 = false). -Check (eq_refl false <: 1 < 1 = false). -Check (eq_refl false <<: 1 < 1 = false). -Definition compute1 := Eval compute in 1 < 1. +Check (eq_refl : 1 <? 1 = false). +Check (eq_refl false <: 1 <? 1 = false). +Check (eq_refl false <<: 1 <? 1 = false). +Definition compute1 := Eval compute in 1 <? 1. Check (eq_refl compute1 : false = false). -Check (eq_refl : 1 < 2 = true). -Check (eq_refl true <: 1 < 2 = true). -Check (eq_refl true <<: 1 < 2 = true). -Definition compute2 := Eval compute in 1 < 2. +Check (eq_refl : 1 <? 2 = true). +Check (eq_refl true <: 1 <? 2 = true). +Check (eq_refl true <<: 1 <? 2 = true). +Definition compute2 := Eval compute in 1 <? 2. Check (eq_refl compute2 : true = true). -Check (eq_refl : 9223372036854775807 < 0 = false). -Check (eq_refl false <: 9223372036854775807 < 0 = false). -Check (eq_refl false <<: 9223372036854775807 < 0 = false). -Definition compute3 := Eval compute in 9223372036854775807 < 0. +Check (eq_refl : 9223372036854775807 <? 0 = false). +Check (eq_refl false <: 9223372036854775807 <? 0 = false). +Check (eq_refl false <<: 9223372036854775807 <? 0 = false). +Definition compute3 := Eval compute in 9223372036854775807 <? 0. Check (eq_refl compute3 : false = false). diff --git a/test-suite/primitive/uint63/mod.v b/test-suite/primitive/uint63/mod.v index 5307eed493..3ad6312c2c 100644 --- a/test-suite/primitive/uint63/mod.v +++ b/test-suite/primitive/uint63/mod.v @@ -4,14 +4,14 @@ Set Implicit Arguments. Open Scope int63_scope. -Check (eq_refl : 6 \% 3 = 0). -Check (eq_refl 0 <: 6 \% 3 = 0). -Check (eq_refl 0 <<: 6 \% 3 = 0). -Definition compute1 := Eval compute in 6 \% 3. +Check (eq_refl : 6 mod 3 = 0). +Check (eq_refl 0 <: 6 mod 3 = 0). +Check (eq_refl 0 <<: 6 mod 3 = 0). +Definition compute1 := Eval compute in 6 mod 3. Check (eq_refl compute1 : 0 = 0). -Check (eq_refl : 5 \% 3 = 2). -Check (eq_refl 2 <: 5 \% 3 = 2). -Check (eq_refl 2 <<: 5 \% 3 = 2). -Definition compute2 := Eval compute in 5 \% 3. +Check (eq_refl : 5 mod 3 = 2). +Check (eq_refl 2 <: 5 mod 3 = 2). +Check (eq_refl 2 <<: 5 mod 3 = 2). +Definition compute2 := Eval compute in 5 mod 3. Check (eq_refl compute2 : 2 = 2). diff --git a/test-suite/primitive/uint63/unsigned.v b/test-suite/primitive/uint63/unsigned.v index 82920bd201..6224e9d15b 100644 --- a/test-suite/primitive/uint63/unsigned.v +++ b/test-suite/primitive/uint63/unsigned.v @@ -11,8 +11,8 @@ Check (eq_refl 0 <<: 1/(0-1) = 0). Definition compute1 := Eval compute in 1/(0-1). Check (eq_refl compute1 : 0 = 0). -Check (eq_refl : 3 \% (0-1) = 3). -Check (eq_refl 3 <: 3 \% (0-1) = 3). -Check (eq_refl 3 <<: 3 \% (0-1) = 3). -Definition compute2 := Eval compute in 3 \% (0-1). +Check (eq_refl : 3 mod (0-1) = 3). +Check (eq_refl 3 <: 3 mod (0-1) = 3). +Check (eq_refl 3 <<: 3 mod (0-1) = 3). +Definition compute2 := Eval compute in 3 mod (0-1). Check (eq_refl compute2 : 3 = 3). diff --git a/test-suite/ssr/noting_to_inject.v b/test-suite/ssr/noting_to_inject.v new file mode 100644 index 0000000000..95bbd3e777 --- /dev/null +++ b/test-suite/ssr/noting_to_inject.v @@ -0,0 +1,9 @@ +Require Import ssreflect ssrfun ssrbool. + + +Goal forall b : bool, b -> False. +Set Warnings "+spurious-ssr-injection". +Fail move=> b []. +Set Warnings "-spurious-ssr-injection". +move=> b []. +Abort. diff --git a/test-suite/success/NumeralNotationsNoLocal.v b/test-suite/success/NumeralNotationsNoLocal.v index ea3907ef8a..fe97f10ddf 100644 --- a/test-suite/success/NumeralNotationsNoLocal.v +++ b/test-suite/success/NumeralNotationsNoLocal.v @@ -5,7 +5,7 @@ Delimit Scope unit11_scope with unit11. Goal True. evar (to_uint : unit11 -> Decimal.uint). evar (of_uint : Decimal.uint -> unit11). - Fail Numeral Notation unit11 of_uint to_uint : uint11_scope. + Fail Number Notation unit11 of_uint to_uint : uint11_scope. exact I. Unshelve. all: solve [ constructor ]. diff --git a/test-suite/success/Typeclasses.v b/test-suite/success/Typeclasses.v index 563651cfa5..7acaa92b89 100644 --- a/test-suite/success/Typeclasses.v +++ b/test-suite/success/Typeclasses.v @@ -190,7 +190,7 @@ Record Monad {m : Type -> Type} := { Print Visibility. Print unit. -Arguments unit {m m0 α}. +Arguments unit {m _ α}. Arguments Monad : clear implicits. Notation "'return' t" := (unit t). diff --git a/test-suite/success/induct.v b/test-suite/success/induct.v index 73fe53c757..a39b17e1f1 100644 --- a/test-suite/success/induct.v +++ b/test-suite/success/induct.v @@ -196,3 +196,13 @@ Goal forall m n:nat, n=m. double induction m n. Abort. +(* Mentioned as part of bug #12944 *) + +Inductive test : Set := cons : forall (IHv : nat) (v : test), test. + +Goal test -> test. +induction 1 as [? IHv]. +Undo. +destruct 1 as [? IHv]. +exact IHv. (* Check that the name is granted *) +Qed. diff --git a/test-suite/success/name_mangling.v b/test-suite/success/name_mangling.v index e982414206..d99e407b0d 100644 --- a/test-suite/success/name_mangling.v +++ b/test-suite/success/name_mangling.v @@ -1,7 +1,6 @@ -(* -*- coq-prog-args: ("-mangle-names" "_") -*- *) +Set Mangle Names. (* Check that refine policy of redefining previous names make these names private *) -(* abstract can change names in the environment! See bug #3146 *) Goal True -> True. intro. @@ -58,7 +57,7 @@ Abort. Goal False -> False. intro H. -Fail abstract exact H. +abstract exact H. Abort. (* Variant *) @@ -70,12 +69,11 @@ Abort. (* Example from Jason *) -Goal False -> False. +Lemma lem1 : False -> False. intro H. (* Name H' is from Ltac here, so it preserves the privacy *) (* But abstract messes everything up *) -Fail let H' := H in abstract exact H'. -let H' := H in exact H'. +let H' := H in abstract exact H'. Qed. (* Variant *) @@ -111,7 +109,7 @@ Goal forall b : False, b = b. Fail destruct b0. Abort. -Goal forall b : False, b = b. +Lemma lem2 : forall b : False, b = b. now destruct b. Qed. End foo. diff --git a/test-suite/unit-tests/.merlin.in b/test-suite/unit-tests/.merlin.in index b2279de74e..668b431d52 100644 --- a/test-suite/unit-tests/.merlin.in +++ b/test-suite/unit-tests/.merlin.in @@ -3,4 +3,4 @@ REC S ** B ** -PKG oUnit +PKG ounit2 diff --git a/theories/Array/PArray.v b/theories/Array/PArray.v index 282f56267c..3511ba0918 100644 --- a/theories/Array/PArray.v +++ b/theories/Array/PArray.v @@ -45,19 +45,19 @@ Local Open Scope array_scope. Primitive max_length := #array_max_length. (** Axioms *) -Axiom get_out_of_bounds : forall A (t:array A) i, (i < length t) = false -> t.[i] = default t. +Axiom get_out_of_bounds : forall A (t:array A) i, (i <? length t) = false -> t.[i] = default t. -Axiom get_set_same : forall A t i (a:A), (i < length t) = true -> t.[i<-a].[i] = a. +Axiom get_set_same : forall A t i (a:A), (i <? length t) = true -> t.[i<-a].[i] = a. Axiom get_set_other : forall A t i j (a:A), i <> j -> t.[i<-a].[j] = t.[j]. Axiom default_set : forall A t i (a:A), default t.[i<-a] = default t. Axiom get_make : forall A (a:A) size i, (make size a).[i] = a. -Axiom leb_length : forall A (t:array A), length t <= max_length = true. +Axiom leb_length : forall A (t:array A), length t <=? max_length = true. Axiom length_make : forall A size (a:A), - length (make size a) = if size <= max_length then size else max_length. + length (make size a) = if size <=? max_length then size else max_length. Axiom length_set : forall A t i (a:A), length t.[i<-a] = length t. @@ -69,7 +69,7 @@ Axiom length_reroot : forall A (t:array A), length (reroot t) = length t. Axiom array_ext : forall A (t1 t2:array A), length t1 = length t2 -> - (forall i, i < length t1 = true -> t1.[i] = t2.[i]) -> + (forall i, i <? length t1 = true -> t1.[i] = t2.[i]) -> default t1 = default t2 -> t1 = t2. @@ -77,7 +77,7 @@ Axiom array_ext : forall A (t1 t2:array A), Lemma default_copy A (t:array A) : default (copy t) = default t. Proof. - assert (irr_lt : length t < length t = false). + assert (irr_lt : length t <? length t = false). destruct (Int63.ltbP (length t) (length t)); try reflexivity. exfalso; eapply BinInt.Z.lt_irrefl; eassumption. assert (get_copy := get_copy A t (length t)). @@ -87,7 +87,7 @@ Qed. Lemma default_make A (a : A) size : default (make size a) = a. Proof. - assert (irr_lt : length (make size a) < length (make size a) = false). + assert (irr_lt : length (make size a) <? length (make size a) = false). destruct (Int63.ltbP (length (make size a)) (length (make size a))); try reflexivity. exfalso; eapply BinInt.Z.lt_irrefl; eassumption. assert (get_make := get_make A a size (length (make size a))). @@ -96,7 +96,7 @@ Qed. Lemma default_reroot A (t:array A) : default (reroot t) = default t. Proof. - assert (irr_lt : length t < length t = false). + assert (irr_lt : length t <? length t = false). destruct (Int63.ltbP (length t) (length t)); try reflexivity. exfalso; eapply BinInt.Z.lt_irrefl; eassumption. assert (get_reroot := get_reroot A t (length t)). @@ -107,16 +107,16 @@ Qed. Lemma get_set_same_default A (t : array A) (i : int) : t.[i <- default t].[i] = default t. Proof. - case_eq (i < length t); intros. + case_eq (i <? length t); intros. rewrite get_set_same; trivial. rewrite get_out_of_bounds, default_set; trivial. rewrite length_set; trivial. Qed. Lemma get_not_default_lt A (t:array A) x : - t.[x] <> default t -> (x < length t) = true. + t.[x] <> default t -> (x <? length t) = true. Proof. intros Hd. - case_eq (x < length t); intros Heq; [trivial | ]. + case_eq (x <? length t); intros Heq; [trivial | ]. elim Hd; rewrite get_out_of_bounds; trivial. Qed. diff --git a/theories/Bool/Bool.v b/theories/Bool/Bool.v index 9e10786fcd..0f62db42cf 100644 --- a/theories/Bool/Bool.v +++ b/theories/Bool/Bool.v @@ -258,7 +258,7 @@ Qed. Lemma orb_true_elim : forall b1 b2:bool, b1 || b2 = true -> {b1 = true} + {b2 = true}. Proof. - destruct b1; simpl; auto. + intro b1; destruct b1; simpl; auto. Defined. Lemma orb_prop : forall a b:bool, a || b = true -> a = true \/ b = true. @@ -424,7 +424,7 @@ Notation andb_true_b := andb_true_l (only parsing). Lemma andb_false_elim : forall b1 b2:bool, b1 && b2 = false -> {b1 = false} + {b2 = false}. Proof. - destruct b1; simpl; auto. + intro b1; destruct b1; simpl; auto. Defined. Hint Resolve andb_false_elim: bool. @@ -681,17 +681,17 @@ Qed. Lemma negb_xorb_l : forall b b', negb (xorb b b') = xorb (negb b) b'. Proof. - destruct b,b'; trivial. + intros b b'; destruct b,b'; trivial. Qed. Lemma negb_xorb_r : forall b b', negb (xorb b b') = xorb b (negb b'). Proof. - destruct b,b'; trivial. + intros b b'; destruct b,b'; trivial. Qed. Lemma xorb_negb_negb : forall b b', xorb (negb b) (negb b') = xorb b b'. Proof. - destruct b,b'; trivial. + intros b b'; destruct b,b'; trivial. Qed. (** Lemmas about the [b = true] embedding of [bool] to [Prop] *) diff --git a/theories/Classes/CMorphisms.v b/theories/Classes/CMorphisms.v index 598bd8b9c5..9a3a1d3709 100644 --- a/theories/Classes/CMorphisms.v +++ b/theories/Classes/CMorphisms.v @@ -20,7 +20,7 @@ Require Import Coq.Program.Tactics. Require Export Coq.Classes.CRelationClasses. Generalizable Variables A eqA B C D R RA RB RC m f x y. -Local Obligation Tactic := simpl_crelation. +Local Obligation Tactic := try solve [ simpl_crelation ]. Set Universe Polymorphism. @@ -268,6 +268,7 @@ Section GenericInstances. Next Obligation. Proof with auto. + intros A R H B R' H0 x y z X X0 x0 y0 X1. assert(R x0 x0). - transitivity y0... symmetry... - transitivity (y x0)... @@ -284,6 +285,7 @@ Section GenericInstances. Next Obligation. Proof. + intros A B C RA RB RC f mor x y X x0 y0 X0. apply mor ; auto. Qed. @@ -297,6 +299,7 @@ Section GenericInstances. Next Obligation. Proof with auto. + intros A R H x y X x0 y0 X0 X1. transitivity x... transitivity x0... Qed. @@ -309,6 +312,7 @@ Section GenericInstances. Next Obligation. Proof with auto. + intros A R H x x0 y X X0. transitivity y... Qed. @@ -318,6 +322,7 @@ Section GenericInstances. Next Obligation. Proof with auto. + intros A R H x x0 y X X0. transitivity x0... Qed. @@ -327,6 +332,7 @@ Section GenericInstances. Next Obligation. Proof with auto. + intros A R H x x0 y X X0. transitivity y... symmetry... Qed. @@ -335,6 +341,7 @@ Section GenericInstances. Next Obligation. Proof with auto. + intros A R H x x0 y X X0. transitivity x0... symmetry... Qed. @@ -343,6 +350,7 @@ Section GenericInstances. Next Obligation. Proof with auto. + intros A R H x x0 y X. split. - intros ; transitivity x0... - intros. @@ -358,6 +366,7 @@ Section GenericInstances. Next Obligation. Proof with auto. + intros A R H x y X y0 y1 e X0; destruct e. transitivity y... Qed. @@ -368,6 +377,7 @@ Section GenericInstances. Next Obligation. Proof with auto. + intros A R H x y X x0 y0 X0. split ; intros. - transitivity x0... transitivity x... symmetry... diff --git a/theories/Classes/CRelationClasses.v b/theories/Classes/CRelationClasses.v index a27919dd43..72a196ca7a 100644 --- a/theories/Classes/CRelationClasses.v +++ b/theories/Classes/CRelationClasses.v @@ -319,7 +319,7 @@ Section Binary. split; red; unfold relation_equivalence, iffT. - firstorder. - firstorder. - - intros. specialize (X x0 y0). specialize (X0 x0 y0). firstorder. + - intros x y z X X0 x0 y0. specialize (X x0 y0). specialize (X0 x0 y0). firstorder. Qed. Global Instance relation_implication_preorder : PreOrder (@subrelation A). @@ -346,7 +346,7 @@ Section Binary. Lemma PartialOrder_inverse `(PartialOrder eqA R) : PartialOrder eqA (flip R). Proof. unfold flip; constructor; unfold flip. - - intros. apply H. apply symmetry. apply X. + - intros X. apply H. apply symmetry. apply X. - unfold relation_conjunction. intros [H1 H2]. apply H. constructor; assumption. Qed. End Binary. diff --git a/theories/Classes/Morphisms.v b/theories/Classes/Morphisms.v index 43adb0b69f..c70e3fe478 100644 --- a/theories/Classes/Morphisms.v +++ b/theories/Classes/Morphisms.v @@ -21,7 +21,7 @@ Require Import Coq.Relations.Relation_Definitions. Require Export Coq.Classes.RelationClasses. Generalizable Variables A eqA B C D R RA RB RC m f x y. -Local Obligation Tactic := simpl_relation. +Local Obligation Tactic := try solve [ simpl_relation ]. (** * Morphisms. @@ -201,12 +201,12 @@ Section Relations. Global Instance pointwise_subrelation `(sub : subrelation B R R') : subrelation (pointwise_relation R) (pointwise_relation R') | 4. - Proof. reduce. unfold pointwise_relation in *. apply sub. apply H. Qed. + Proof. intros x y H a. unfold pointwise_relation in *. apply sub. apply H. Qed. (** For dependent function types. *) Lemma forall_subrelation (R S : forall x : A, relation (P x)) : (forall a, subrelation (R a) (S a)) -> subrelation (forall_relation R) (forall_relation S). - Proof. reduce. apply H. apply H0. Qed. + Proof. intros H x y H0 a. apply H. apply H0. Qed. End Relations. Typeclasses Opaque respectful pointwise_relation forall_relation. @@ -259,6 +259,7 @@ Section GenericInstances. Next Obligation. Proof with auto. + intros R H R' H0 x y z H1 H2 x0 y0 H3. assert(R x0 x0). - transitivity y0... symmetry... - transitivity (y x0)... @@ -272,6 +273,7 @@ Section GenericInstances. Next Obligation. Proof. + intros RA R mR x y H x0 y0 H0. unfold complement. pose (mR x y H x0 y0 H0). intuition. @@ -285,7 +287,7 @@ Section GenericInstances. Next Obligation. Proof. - apply mor ; auto. + intros RA RB RC f mor x y H x0 y0 H0; apply mor ; auto. Qed. @@ -298,6 +300,7 @@ Section GenericInstances. Next Obligation. Proof with auto. + intros R H x y H0 x0 y0 H1 H2. transitivity x... transitivity x0... Qed. @@ -310,6 +313,7 @@ Section GenericInstances. Next Obligation. Proof with auto. + intros R H x x0 y H0 H1. transitivity y... Qed. @@ -319,6 +323,7 @@ Section GenericInstances. Next Obligation. Proof with auto. + intros R H x x0 y H0 H1. transitivity x0... Qed. @@ -328,6 +333,7 @@ Section GenericInstances. Next Obligation. Proof with auto. + intros R H x x0 y H0 H1. transitivity y... symmetry... Qed. @@ -336,6 +342,7 @@ Section GenericInstances. Next Obligation. Proof with auto. + intros R H x x0 y H0 H1. transitivity x0... symmetry... Qed. @@ -344,6 +351,7 @@ Section GenericInstances. Next Obligation. Proof with auto. + intros R H x x0 y H0. split. - intros ; transitivity x0... - intros. @@ -359,6 +367,7 @@ Section GenericInstances. Next Obligation. Proof with auto. + intros R H x y H0 y0 y1 e H2; destruct e. transitivity y... Qed. @@ -369,6 +378,7 @@ Section GenericInstances. Next Obligation. Proof with auto. + intros R H x y H0 x0 y0 H1. split ; intros. - transitivity x0... transitivity x... symmetry... @@ -383,7 +393,7 @@ Section GenericInstances. Next Obligation. Proof. - simpl_relation. + intros RA RB RC x y H x0 y0 H0 x1 y1 H1. unfold compose. apply H. apply H0. apply H1. Qed. @@ -400,9 +410,9 @@ Section GenericInstances. Proper (relation_equivalence ++> relation_equivalence ++> relation_equivalence) (@respectful A B). Proof. - reduce. + intros x y H x0 y0 H0 x1 x2. unfold respectful, relation_equivalence, predicate_equivalence in * ; simpl in *. - split ; intros. + split ; intros H1 x3 y1 H2. - rewrite <- H0. apply H1. @@ -512,9 +522,9 @@ Ltac partial_application_tactic := Instance proper_proper : Proper (relation_equivalence ==> eq ==> iff) (@Proper A). Proof. - simpl_relation. + intros A x y H y0 y1 e; destruct e. reduce in H. - split ; red ; intros. + split ; red ; intros H0. - setoid_rewrite <- H. apply H0. - setoid_rewrite H. @@ -555,8 +565,7 @@ Section Normalize. Lemma proper_normalizes_proper `(Normalizes R0 R1, Proper A R1 m) : Proper R0 m. Proof. - red in H, H0. - rewrite H. + rewrite normalizes. assumption. Qed. @@ -571,10 +580,11 @@ Lemma flip_arrow {A : Type} {B : Type} `(NA : Normalizes A R (flip R'''), NB : Normalizes B R' (flip R'')) : Normalizes (A -> B) (R ==> R') (flip (R''' ==> R'')%signature). Proof. - unfold Normalizes in *. intros. + unfold Normalizes in *. unfold relation_equivalence in *. unfold predicate_equivalence in *. simpl in *. - unfold respectful. unfold flip in *. firstorder. + unfold respectful. unfold flip in *. + intros x x0; split; intros H x1 y H0. - apply NB. apply H. apply NA. apply H0. - apply NB. apply H. apply NA. apply H0. Qed. diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v index 9b92ade096..5381e91997 100644 --- a/theories/Classes/RelationClasses.v +++ b/theories/Classes/RelationClasses.v @@ -107,7 +107,7 @@ Section Defs. (** Any symmetric relation is equal to its inverse. *) Lemma subrelation_symmetric R `(Symmetric R) : subrelation (flip R) R. - Proof. hnf. intros. red in H0. apply symmetry. assumption. Qed. + Proof. hnf. intros x y H0. red in H0. apply symmetry. assumption. Qed. Section flip. @@ -212,7 +212,7 @@ Hint Extern 3 (PreOrder (flip _)) => class_apply flip_PreOrder : typeclass_insta Hint Extern 4 (subrelation (flip _) _) => class_apply @subrelation_symmetric : typeclass_instances. -Arguments irreflexivity {A R Irreflexive} [x] _. +Arguments irreflexivity {A R Irreflexive} [x] _ : rename. Arguments symmetry {A} {R} {_} [x] [y] _. Arguments asymmetry {A} {R} {_} [x] [y] _ _. Arguments transitivity {A} {R} {_} [x] [y] [z] _ _. @@ -260,7 +260,7 @@ Ltac simpl_relation := unfold flip, impl, arrow ; try reduce ; program_simpl ; try ( solve [ dintuition ]). -Local Obligation Tactic := simpl_relation. +Local Obligation Tactic := try solve [ simpl_relation ]. (** Logical implication. *) @@ -399,29 +399,30 @@ Program Instance predicate_equivalence_equivalence : Equivalence (@predicate_equivalence l). Next Obligation. - induction l ; firstorder. + intro l; induction l ; firstorder. Qed. Next Obligation. - induction l ; firstorder. + intro l; induction l ; firstorder. Qed. Next Obligation. + intro l. fold pointwise_lifting. - induction l. + induction l as [|T l IHl]. - firstorder. - - intros. simpl in *. pose (IHl (x x0) (y x0) (z x0)). + - intros x y z H H0 x0. pose (IHl (x x0) (y x0) (z x0)). firstorder. Qed. Program Instance predicate_implication_preorder : PreOrder (@predicate_implication l). Next Obligation. - induction l ; firstorder. + intro l; induction l ; firstorder. Qed. Next Obligation. - induction l. + intro l. + induction l as [|T l IHl]. - firstorder. - - unfold predicate_implication in *. simpl in *. - intro. pose (IHl (x x0) (y x0) (z x0)). firstorder. + - intros x y z H H0 x0. pose (IHl (x x0) (y x0) (z x0)). firstorder. Qed. (** We define the various operations which define the algebra on binary relations, diff --git a/theories/Floats/FloatAxioms.v b/theories/Floats/FloatAxioms.v index f4aa1f81c6..78df357c0f 100644 --- a/theories/Floats/FloatAxioms.v +++ b/theories/Floats/FloatAxioms.v @@ -38,9 +38,9 @@ Qed. Axiom opp_spec : forall x, Prim2SF (-x)%float = SFopp (Prim2SF x). Axiom abs_spec : forall x, Prim2SF (abs x) = SFabs (Prim2SF x). -Axiom eqb_spec : forall x y, (x == y)%float = SFeqb (Prim2SF x) (Prim2SF y). -Axiom ltb_spec : forall x y, (x < y)%float = SFltb (Prim2SF x) (Prim2SF y). -Axiom leb_spec : forall x y, (x <= y)%float = SFleb (Prim2SF x) (Prim2SF y). +Axiom eqb_spec : forall x y, (x =? y)%float = SFeqb (Prim2SF x) (Prim2SF y). +Axiom ltb_spec : forall x y, (x <? y)%float = SFltb (Prim2SF x) (Prim2SF y). +Axiom leb_spec : forall x y, (x <=? y)%float = SFleb (Prim2SF x) (Prim2SF y). Definition flatten_cmp_opt c := match c with diff --git a/theories/Floats/PrimFloat.v b/theories/Floats/PrimFloat.v index e5a9748481..ed7947aa63 100644 --- a/theories/Floats/PrimFloat.v +++ b/theories/Floats/PrimFloat.v @@ -27,9 +27,11 @@ Register float_class as kernel.ind_f_class. Primitive float := #float64_type. (** ** Syntax support *) +Module Import PrimFloatNotationsInternalA. Declare Scope float_scope. Delimit Scope float_scope with float. Bind Scope float_scope with float. +End PrimFloatNotationsInternalA. Declare ML Module "float_syntax_plugin". @@ -41,31 +43,34 @@ Primitive abs := #float64_abs. Primitive sqrt := #float64_sqrt. Primitive opp := #float64_opp. -Notation "- x" := (opp x) : float_scope. Primitive eqb := #float64_eq. -Notation "x == y" := (eqb x y) (at level 70, no associativity) : float_scope. Primitive ltb := #float64_lt. -Notation "x < y" := (ltb x y) (at level 70, no associativity) : float_scope. Primitive leb := #float64_le. -Notation "x <= y" := (leb x y) (at level 70, no associativity) : float_scope. Primitive compare := #float64_compare. -Notation "x ?= y" := (compare x y) (at level 70, no associativity) : float_scope. Primitive mul := #float64_mul. -Notation "x * y" := (mul x y) : float_scope. Primitive add := #float64_add. -Notation "x + y" := (add x y) : float_scope. Primitive sub := #float64_sub. -Notation "x - y" := (sub x y) : float_scope. Primitive div := #float64_div. + +Module Import PrimFloatNotationsInternalB. +Notation "- x" := (opp x) : float_scope. +Notation "x =? y" := (eqb x y) (at level 70, no associativity) : float_scope. +Notation "x <? y" := (ltb x y) (at level 70, no associativity) : float_scope. +Notation "x <=? y" := (leb x y) (at level 70, no associativity) : float_scope. +Notation "x ?= y" := (compare x y) (at level 70, no associativity) : float_scope. +Notation "x * y" := (mul x y) : float_scope. +Notation "x + y" := (add x y) : float_scope. +Notation "x - y" := (sub x y) : float_scope. Notation "x / y" := (div x y) : float_scope. +End PrimFloatNotationsInternalB. (** ** Conversions *) @@ -114,15 +119,27 @@ Definition neg_zero := Eval compute in (-zero)%float. Definition two := Eval compute in (of_int63 2). (** ** Predicates and helper functions *) -Definition is_nan f := negb (f == f)%float. +Definition is_nan f := negb (f =? f)%float. -Definition is_zero f := (f == zero)%float. (* note: 0 == -0 with floats *) +Definition is_zero f := (f =? zero)%float. (* note: 0 =? -0 with floats *) -Definition is_infinity f := (abs f == infinity)%float. +Definition is_infinity f := (abs f =? infinity)%float. Definition is_finite (x : float) := negb (is_nan x || is_infinity x). (** [get_sign]: return [true] for [-] sign, [false] for [+] sign. *) Definition get_sign f := let f := if is_zero f then (one / f)%float else f in - (f < zero)%float. + (f <? zero)%float. + +Module Export PrimFloatNotations. + Local Open Scope float_scope. + #[deprecated(since="8.13",note="use infix <? instead")] + Notation "x < y" := (x <? y) (at level 70, no associativity) : float_scope. + #[deprecated(since="8.13",note="use infix <=? instead")] + Notation "x <= y" := (x <=? y) (at level 70, no associativity) : float_scope. + #[deprecated(since="8.13",note="use infix =? instead")] + Notation "x == y" := (x =? y) (at level 70, no associativity) : float_scope. + Export PrimFloatNotationsInternalA. + Export PrimFloatNotationsInternalB. +End PrimFloatNotations. diff --git a/theories/Init/Datatypes.v b/theories/Init/Datatypes.v index 8ab12ae534..9984bff0c2 100644 --- a/theories/Init/Datatypes.v +++ b/theories/Init/Datatypes.v @@ -79,7 +79,7 @@ Register negb as core.bool.negb. (** Basic properties of [andb] *) -Lemma andb_prop : forall a b:bool, andb a b = true -> a = true /\ b = true. +Lemma andb_prop (a b:bool) : andb a b = true -> a = true /\ b = true. Proof. destruct a, b; repeat split; assumption. Qed. @@ -87,8 +87,8 @@ Hint Resolve andb_prop: bool. Register andb_prop as core.bool.andb_prop. -Lemma andb_true_intro : - forall b1 b2:bool, b1 = true /\ b2 = true -> andb b1 b2 = true. +Lemma andb_true_intro (b1 b2:bool) : + b1 = true /\ b2 = true -> andb b1 b2 = true. Proof. destruct b1; destruct b2; simpl; intros [? ?]; assumption. Qed. @@ -245,25 +245,22 @@ End projections. Hint Resolve pair inl inr: core. -Lemma surjective_pairing : - forall (A B:Type) (p:A * B), p = (fst p, snd p). +Lemma surjective_pairing (A B:Type) (p:A * B) : p = (fst p, snd p). Proof. destruct p; reflexivity. Qed. -Lemma injective_projections : - forall (A B:Type) (p1 p2:A * B), +Lemma injective_projections (A B:Type) (p1 p2:A * B) : fst p1 = fst p2 -> snd p1 = snd p2 -> p1 = p2. Proof. destruct p1; destruct p2; simpl; intros Hfst Hsnd. rewrite Hfst; rewrite Hsnd; reflexivity. Qed. -Lemma pair_equal_spec : - forall (A B : Type) (a1 a2 : A) (b1 b2 : B), +Lemma pair_equal_spec (A B : Type) (a1 a2 : A) (b1 b2 : B) : (a1, b1) = (a2, b2) <-> a1 = a2 /\ b1 = b2. Proof with auto. - split; intros. + split; intro H. - split. + replace a1 with (fst (a1, b1)); replace a2 with (fst (a2, b2))... rewrite H... @@ -272,15 +269,21 @@ Proof with auto. - destruct H; subst... Qed. -Definition prod_uncurry (A B C:Type) (f:A * B -> C) +Definition curry {A B C:Type} (f:A * B -> C) (x:A) (y:B) : C := f (x,y). -Definition prod_curry (A B C:Type) (f:A -> B -> C) +Definition uncurry {A B C:Type} (f:A -> B -> C) (p:A * B) : C := match p with (x, y) => f x y end. +#[deprecated(since = "8.13", note = "Use curry instead.")] +Definition prod_uncurry (A B C:Type) : (A * B -> C) -> A -> B -> C := curry. + +#[deprecated(since = "8.13", note = "Use uncurry instead.")] +Definition prod_curry (A B C:Type) : (A -> B -> C) -> A * B -> C := uncurry. + Import EqNotations. -Lemma rew_pair : forall A (P Q : A->Type) x1 x2 (y1:P x1) (y2:Q x1) (H:x1=x2), +Lemma rew_pair A (P Q : A->Type) x1 x2 (y1:P x1) (y2:Q x1) (H:x1=x2) : (rew H in y1, rew H in y2) = rew [fun x => (P x * Q x)%type] H in (y1,y2). Proof. destruct H. reflexivity. @@ -341,7 +344,7 @@ Register Eq as core.comparison.Eq. Register Lt as core.comparison.Lt. Register Gt as core.comparison.Gt. -Lemma comparison_eq_stable : forall c c' : comparison, ~~ c = c' -> c = c'. +Lemma comparison_eq_stable (c c' : comparison) : ~~ c = c' -> c = c'. Proof. destruct c, c'; intro H; reflexivity || destruct H; discriminate. Qed. @@ -353,12 +356,12 @@ Definition CompOpp (r:comparison) := | Gt => Lt end. -Lemma CompOpp_involutive : forall c, CompOpp (CompOpp c) = c. +Lemma CompOpp_involutive c : CompOpp (CompOpp c) = c. Proof. destruct c; reflexivity. Qed. -Lemma CompOpp_inj : forall c c', CompOpp c = CompOpp c' -> c = c'. +Lemma CompOpp_inj c c' : CompOpp c = CompOpp c' -> c = c'. Proof. destruct c; destruct c'; auto; discriminate. Qed. @@ -399,7 +402,7 @@ Register CompEqT as core.CompareSpecT.CompEqT. Register CompLtT as core.CompareSpecT.CompLtT. Register CompGtT as core.CompareSpecT.CompGtT. -Lemma CompareSpec2Type : forall Peq Plt Pgt c, +Lemma CompareSpec2Type Peq Plt Pgt c : CompareSpec Peq Plt Pgt c -> CompareSpecT Peq Plt Pgt c. Proof. destruct c; intros H; constructor; inversion_clear H; auto. diff --git a/theories/Init/Decimal.v b/theories/Init/Decimal.v index 5eae5567d7..025264ab01 100644 --- a/theories/Init/Decimal.v +++ b/theories/Init/Decimal.v @@ -12,7 +12,7 @@ (** These numbers coded in base 10 will be used for parsing and printing other Coq numeral datatypes in an human-readable way. - See the [Numeral Notation] command. + See the [Number Notation] command. We represent numbers in base 10 as lists of decimal digits, in big-endian order (most significant digit comes first). *) @@ -245,7 +245,7 @@ with succ_double d := End Little. (** Pseudo-conversion functions used when declaring - Numeral Notations on [uint] and [int]. *) + Number Notations on [uint] and [int]. *) Definition uint_of_uint (i:uint) := i. Definition int_of_int (i:int) := i. diff --git a/theories/Init/Hexadecimal.v b/theories/Init/Hexadecimal.v index a4ddad2875..36f5e5ad1f 100644 --- a/theories/Init/Hexadecimal.v +++ b/theories/Init/Hexadecimal.v @@ -12,7 +12,7 @@ (** These numbers coded in base 16 will be used for parsing and printing other Coq numeral datatypes in an human-readable way. - See the [Numeral Notation] command. + See the [Number Notation] command. We represent numbers in base 16 as lists of hexadecimal digits, in big-endian order (most significant digit comes first). *) diff --git a/theories/Init/Logic.v b/theories/Init/Logic.v index 8f9f68a292..8012235143 100644 --- a/theories/Init/Logic.v +++ b/theories/Init/Logic.v @@ -523,41 +523,28 @@ Section equality_dep. Variable f : forall x, B x. Variables x y : A. - Theorem f_equal_dep : forall (H: x = y), rew H in f x = f y. + Theorem f_equal_dep (H: x = y) : rew H in f x = f y. Proof. destruct H; reflexivity. Defined. End equality_dep. -Section equality_dep2. - - Variable A A' : Type. - Variable B : A -> Type. - Variable B' : A' -> Type. - Variable f : A -> A'. - Variable g : forall a:A, B a -> B' (f a). - Variables x y : A. - - Lemma f_equal_dep2 : forall {A A' B B'} (f : A -> A') (g : forall a:A, B a -> B' (f a)) - {x1 x2 : A} {y1 : B x1} {y2 : B x2} (H : x1 = x2), +Lemma f_equal_dep2 {A A' B B'} (f : A -> A') (g : forall a:A, B a -> B' (f a)) + {x1 x2 : A} {y1 : B x1} {y2 : B x2} (H : x1 = x2) : rew H in y1 = y2 -> rew f_equal f H in g x1 y1 = g x2 y2. - Proof. - destruct H, 1. reflexivity. - Defined. - -End equality_dep2. +Proof. + destruct H, 1. reflexivity. +Defined. -Lemma rew_opp_r : forall A (P:A->Type) (x y:A) (H:x=y) (a:P y), rew H in rew <- H in a = a. +Lemma rew_opp_r A (P:A->Type) (x y:A) (H:x=y) (a:P y) : rew H in rew <- H in a = a. Proof. -intros. destruct H. reflexivity. Defined. -Lemma rew_opp_l : forall A (P:A->Type) (x y:A) (H:x=y) (a:P x), rew <- H in rew H in a = a. +Lemma rew_opp_l A (P:A->Type) (x y:A) (H:x=y) (a:P x) : rew <- H in rew H in a = a. Proof. -intros. destruct H. reflexivity. Defined. @@ -597,7 +584,7 @@ Proof. destruct 1; destruct 1; destruct 1; destruct 1; destruct 1; reflexivity. Qed. -Theorem f_equal_compose : forall A B C (a b:A) (f:A->B) (g:B->C) (e:a=b), +Theorem f_equal_compose A B C (a b:A) (f:A->B) (g:B->C) (e:a=b) : f_equal g (f_equal f e) = f_equal (fun a => g (f a)) e. Proof. destruct e. reflexivity. @@ -605,68 +592,69 @@ Defined. (** The groupoid structure of equality *) -Theorem eq_trans_refl_l : forall A (x y:A) (e:x=y), eq_trans eq_refl e = e. +Theorem eq_trans_refl_l A (x y:A) (e:x=y) : eq_trans eq_refl e = e. Proof. destruct e. reflexivity. Defined. -Theorem eq_trans_refl_r : forall A (x y:A) (e:x=y), eq_trans e eq_refl = e. +Theorem eq_trans_refl_r A (x y:A) (e:x=y) : eq_trans e eq_refl = e. Proof. destruct e. reflexivity. Defined. -Theorem eq_sym_involutive : forall A (x y:A) (e:x=y), eq_sym (eq_sym e) = e. +Theorem eq_sym_involutive A (x y:A) (e:x=y) : eq_sym (eq_sym e) = e. Proof. destruct e; reflexivity. Defined. -Theorem eq_trans_sym_inv_l : forall A (x y:A) (e:x=y), eq_trans (eq_sym e) e = eq_refl. +Theorem eq_trans_sym_inv_l A (x y:A) (e:x=y) : eq_trans (eq_sym e) e = eq_refl. Proof. destruct e; reflexivity. Defined. -Theorem eq_trans_sym_inv_r : forall A (x y:A) (e:x=y), eq_trans e (eq_sym e) = eq_refl. +Theorem eq_trans_sym_inv_r A (x y:A) (e:x=y) : eq_trans e (eq_sym e) = eq_refl. Proof. destruct e; reflexivity. Defined. -Theorem eq_trans_assoc : forall A (x y z t:A) (e:x=y) (e':y=z) (e'':z=t), +Theorem eq_trans_assoc A (x y z t:A) (e:x=y) (e':y=z) (e'':z=t) : eq_trans e (eq_trans e' e'') = eq_trans (eq_trans e e') e''. Proof. destruct e''; reflexivity. Defined. -Theorem rew_map : forall A B (P:B->Type) (f:A->B) x1 x2 (H:x1=x2) (y:P (f x1)), +Theorem rew_map A B (P:B->Type) (f:A->B) x1 x2 (H:x1=x2) (y:P (f x1)) : rew [fun x => P (f x)] H in y = rew f_equal f H in y. Proof. destruct H; reflexivity. Defined. -Theorem eq_trans_map : forall {A B} {x1 x2 x3:A} {y1:B x1} {y2:B x2} {y3:B x3}, - forall (H1:x1=x2) (H2:x2=x3) (H1': rew H1 in y1 = y2) (H2': rew H2 in y2 = y3), +Theorem eq_trans_map {A B} {x1 x2 x3:A} {y1:B x1} {y2:B x2} {y3:B x3} + (H1:x1=x2) (H2:x2=x3) (H1': rew H1 in y1 = y2) (H2': rew H2 in y2 = y3) : rew eq_trans H1 H2 in y1 = y3. Proof. - intros. destruct H2. exact (eq_trans H1' H2'). + destruct H2. exact (eq_trans H1' H2'). Defined. -Lemma map_subst : forall {A} {P Q:A->Type} (f : forall x, P x -> Q x) {x y} (H:x=y) (z:P x), +Lemma map_subst {A} {P Q:A->Type} (f : forall x, P x -> Q x) {x y} (H:x=y) (z:P x) : rew H in f x z = f y (rew H in z). Proof. destruct H. reflexivity. Defined. -Lemma map_subst_map : forall {A B} {P:A->Type} {Q:B->Type} (f:A->B) (g : forall x, P x -> Q (f x)), - forall {x y} (H:x=y) (z:P x), rew f_equal f H in g x z = g y (rew H in z). +Lemma map_subst_map {A B} {P:A->Type} {Q:B->Type} (f:A->B) (g : forall x, P x -> Q (f x)) + {x y} (H:x=y) (z:P x) : + rew f_equal f H in g x z = g y (rew H in z). Proof. destruct H. reflexivity. Defined. -Lemma rew_swap : forall A (P:A->Type) x1 x2 (H:x1=x2) (y1:P x1) (y2:P x2), rew H in y1 = y2 -> y1 = rew <- H in y2. +Lemma rew_swap A (P:A->Type) x1 x2 (H:x1=x2) (y1:P x1) (y2:P x2) : rew H in y1 = y2 -> y1 = rew <- H in y2. Proof. destruct H. trivial. Defined. -Lemma rew_compose : forall A (P:A->Type) x1 x2 x3 (H1:x1=x2) (H2:x2=x3) (y:P x1), +Lemma rew_compose A (P:A->Type) x1 x2 x3 (H1:x1=x2) (H2:x2=x3) (y:P x1) : rew H2 in rew H1 in y = rew (eq_trans H1 H2) in y. Proof. destruct H2. reflexivity. @@ -674,9 +662,8 @@ Defined. (** Extra properties of equality *) -Theorem eq_id_comm_l : forall A (f:A->A) (Hf:forall a, a = f a), forall a, f_equal f (Hf a) = Hf (f a). +Theorem eq_id_comm_l A (f:A->A) (Hf:forall a, a = f a) a : f_equal f (Hf a) = Hf (f a). Proof. - intros. unfold f_equal. rewrite <- (eq_trans_sym_inv_l (Hf a)). destruct (Hf a) at 1 2. @@ -684,9 +671,8 @@ Proof. reflexivity. Defined. -Theorem eq_id_comm_r : forall A (f:A->A) (Hf:forall a, f a = a), forall a, f_equal f (Hf a) = Hf (f a). +Theorem eq_id_comm_r A (f:A->A) (Hf:forall a, f a = a) a : f_equal f (Hf a) = Hf (f a). Proof. - intros. unfold f_equal. rewrite <- (eq_trans_sym_inv_l (Hf (f (f a)))). set (Hfsymf := fun a => eq_sym (Hf a)). @@ -700,36 +686,36 @@ Proof. reflexivity. Defined. -Lemma eq_refl_map_distr : forall A B x (f:A->B), f_equal f (eq_refl x) = eq_refl (f x). +Lemma eq_refl_map_distr A B x (f:A->B) : f_equal f (eq_refl x) = eq_refl (f x). Proof. reflexivity. Qed. -Lemma eq_trans_map_distr : forall A B x y z (f:A->B) (e:x=y) (e':y=z), f_equal f (eq_trans e e') = eq_trans (f_equal f e) (f_equal f e'). +Lemma eq_trans_map_distr A B x y z (f:A->B) (e:x=y) (e':y=z) : f_equal f (eq_trans e e') = eq_trans (f_equal f e) (f_equal f e'). Proof. destruct e'. reflexivity. Defined. -Lemma eq_sym_map_distr : forall A B (x y:A) (f:A->B) (e:x=y), eq_sym (f_equal f e) = f_equal f (eq_sym e). +Lemma eq_sym_map_distr A B (x y:A) (f:A->B) (e:x=y) : eq_sym (f_equal f e) = f_equal f (eq_sym e). Proof. destruct e. reflexivity. Defined. -Lemma eq_trans_sym_distr : forall A (x y z:A) (e:x=y) (e':y=z), eq_sym (eq_trans e e') = eq_trans (eq_sym e') (eq_sym e). +Lemma eq_trans_sym_distr A (x y z:A) (e:x=y) (e':y=z) : eq_sym (eq_trans e e') = eq_trans (eq_sym e') (eq_sym e). Proof. destruct e, e'. reflexivity. Defined. -Lemma eq_trans_rew_distr : forall A (P:A -> Type) (x y z:A) (e:x=y) (e':y=z) (k:P x), +Lemma eq_trans_rew_distr A (P:A -> Type) (x y z:A) (e:x=y) (e':y=z) (k:P x) : rew (eq_trans e e') in k = rew e' in rew e in k. Proof. destruct e, e'; reflexivity. Qed. -Lemma rew_const : forall A P (x y:A) (e:x=y) (k:P), +Lemma rew_const A P (x y:A) (e:x=y) (k:P) : rew [fun _ => P] e in k = k. Proof. destruct e; reflexivity. @@ -797,9 +783,9 @@ Lemma forall_exists_coincide_unique_domain : -> (exists! x, P x). Proof. intros A P H. - destruct H with (Q:=P) as ((x & Hx & _),_); [trivial|]. + destruct (H P) as ((x & Hx & _),_); [trivial|]. exists x. split; [trivial|]. - destruct H with (Q:=fun x'=>x=x') as (_,Huniq). + destruct (H (fun x'=>x=x')) as (_,Huniq). apply Huniq. exists x; auto. Qed. diff --git a/theories/Init/Numeral.v b/theories/Init/Numeral.v index 8a0531e004..179547d0b3 100644 --- a/theories/Init/Numeral.v +++ b/theories/Init/Numeral.v @@ -27,7 +27,7 @@ Register int as num.num_int.type. Register numeral as num.numeral.type. (** Pseudo-conversion functions used when declaring - Numeral Notations on [uint] and [int]. *) + Number Notations on [uint] and [int]. *) Definition uint_of_uint (i:uint) := i. Definition int_of_int (i:int) := i. diff --git a/theories/Init/Peano.v b/theories/Init/Peano.v index 02903643d4..98fd52f351 100644 --- a/theories/Init/Peano.v +++ b/theories/Init/Peano.v @@ -77,7 +77,7 @@ Hint Resolve O_S: core. Theorem n_Sn : forall n:nat, n <> S n. Proof. - induction n; auto. + intro n; induction n; auto. Qed. Hint Resolve n_Sn: core. @@ -92,7 +92,7 @@ Hint Resolve f_equal2_nat: core. Lemma plus_n_O : forall n:nat, n = n + 0. Proof. - induction n; simpl; auto. + intro n; induction n; simpl; auto. Qed. Remove Hints eq_refl : core. @@ -129,13 +129,13 @@ Hint Resolve f_equal2_mult: core. Lemma mult_n_O : forall n:nat, 0 = n * 0. Proof. - induction n; simpl; auto. + intro n; induction n; simpl; auto. Qed. Hint Resolve mult_n_O: core. Lemma mult_n_Sm : forall n m:nat, n * m + n = n * S m. Proof. - intros; induction n as [| p H]; simpl; auto. + intros n m; induction n as [| p H]; simpl; auto. destruct H; rewrite <- plus_n_Sm; apply eq_S. pattern m at 1 3; elim m; simpl; auto. Qed. @@ -192,7 +192,7 @@ Register gt as num.nat.gt. Theorem le_pred : forall n m, n <= m -> pred n <= pred m. Proof. -induction 1; auto. destruct m; simpl; auto. +induction 1 as [|m _]; auto. destruct m; simpl; auto. Qed. Theorem le_S_n : forall n m, S n <= S m -> n <= m. @@ -202,7 +202,7 @@ Qed. Theorem le_0_n : forall n, 0 <= n. Proof. - induction n; constructor; trivial. + intro n; induction n; constructor; trivial. Qed. Theorem le_n_S : forall n m, n <= m -> S n <= S m. @@ -215,7 +215,7 @@ Qed. Theorem nat_case : forall (n:nat) (P:nat -> Prop), P 0 -> (forall m:nat, P (S m)) -> P n. Proof. - induction n; auto. + intros n P IH0 IHS; case n; auto. Qed. (** Principle of double induction *) @@ -226,8 +226,9 @@ Theorem nat_double_ind : (forall n:nat, R (S n) 0) -> (forall n m:nat, R n m -> R (S n) (S m)) -> forall n m:nat, R n m. Proof. + intros R ? ? ? n. induction n; auto. - destruct m; auto. + intro m; destruct m; auto. Qed. (** Maximum and minimum : definitions and specifications *) @@ -237,28 +238,28 @@ Notation min := Nat.min (only parsing). Lemma max_l n m : m <= n -> Nat.max n m = n. Proof. - revert m; induction n; destruct m; simpl; trivial. + revert m; induction n as [|n IHn]; intro m; destruct m; simpl; trivial. - inversion 1. - intros. apply f_equal, IHn, le_S_n; trivial. Qed. Lemma max_r n m : n <= m -> Nat.max n m = m. Proof. - revert m; induction n; destruct m; simpl; trivial. + revert m; induction n as [|n IHn]; intro m; destruct m; simpl; trivial. - inversion 1. - intros. apply f_equal, IHn, le_S_n; trivial. Qed. Lemma min_l n m : n <= m -> Nat.min n m = n. Proof. - revert m; induction n; destruct m; simpl; trivial. + revert m; induction n as [|n IHn]; intro m; destruct m; simpl; trivial. - inversion 1. - intros. apply f_equal, IHn, le_S_n; trivial. Qed. Lemma min_r n m : m <= n -> Nat.min n m = m. Proof. - revert m; induction n; destruct m; simpl; trivial. + revert m; induction n as [|n IHn]; intro m; destruct m; simpl; trivial. - inversion 1. - intros. apply f_equal, IHn, le_S_n; trivial. Qed. @@ -267,7 +268,7 @@ Qed. Lemma nat_rect_succ_r {A} (f: A -> A) (x:A) n : nat_rect (fun _ => A) x (fun _ => f) (S n) = nat_rect (fun _ => A) (f x) (fun _ => f) n. Proof. - induction n; intros; simpl; rewrite <- ?IHn; trivial. + induction n as [|n IHn]; intros; simpl; rewrite <- ?IHn; trivial. Qed. Theorem nat_rect_plus : @@ -275,5 +276,5 @@ Theorem nat_rect_plus : nat_rect (fun _ => A) x (fun _ => f) (n + m) = nat_rect (fun _ => A) (nat_rect (fun _ => A) x (fun _ => f) m) (fun _ => f) n. Proof. - induction n; intros; simpl; rewrite ?IHn; trivial. + intro n; induction n as [|n IHn]; intros; simpl; rewrite ?IHn; trivial. Qed. diff --git a/theories/Init/Prelude.v b/theories/Init/Prelude.v index 8f862e8cec..0fe3d5491e 100644 --- a/theories/Init/Prelude.v +++ b/theories/Init/Prelude.v @@ -35,22 +35,22 @@ Declare ML Module "string_notation_plugin". (* Parsing / printing of hexadecimal numbers *) Arguments Nat.of_hex_uint d%hex_uint_scope. Arguments Nat.of_hex_int d%hex_int_scope. -Numeral Notation Numeral.uint Numeral.uint_of_uint Numeral.uint_of_uint +Number Notation Numeral.uint Numeral.uint_of_uint Numeral.uint_of_uint : hex_uint_scope. -Numeral Notation Numeral.int Numeral.int_of_int Numeral.int_of_int +Number Notation Numeral.int Numeral.int_of_int Numeral.int_of_int : hex_int_scope. (* Parsing / printing of decimal numbers *) Arguments Nat.of_uint d%dec_uint_scope. Arguments Nat.of_int d%dec_int_scope. -Numeral Notation Numeral.uint Numeral.uint_of_uint Numeral.uint_of_uint +Number Notation Numeral.uint Numeral.uint_of_uint Numeral.uint_of_uint : dec_uint_scope. -Numeral Notation Numeral.int Numeral.int_of_int Numeral.int_of_int +Number Notation Numeral.int Numeral.int_of_int Numeral.int_of_int : dec_int_scope. (* Parsing / printing of [nat] numbers *) -Numeral Notation nat Nat.of_num_uint Nat.to_num_hex_uint : hex_nat_scope (abstract after 5001). -Numeral Notation nat Nat.of_num_uint Nat.to_num_uint : nat_scope (abstract after 5001). +Number Notation nat Nat.of_num_uint Nat.to_num_hex_uint : hex_nat_scope (abstract after 5001). +Number Notation nat Nat.of_num_uint Nat.to_num_uint : nat_scope (abstract after 5001). (* Printing/Parsing of bytes *) Export Byte.ByteSyntaxNotations. diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v index 4ff007570e..1fb6dabe6f 100644 --- a/theories/Init/Specif.v +++ b/theories/Init/Specif.v @@ -765,7 +765,7 @@ Section Dependent_choice_lemmas. exists f. split. - reflexivity. - - induction n; simpl; apply proj2_sig. + - intro n; induction n; simpl; apply proj2_sig. Defined. End Dependent_choice_lemmas. diff --git a/theories/Init/Tactics.v b/theories/Init/Tactics.v index b13206db94..e1db68aea9 100644 --- a/theories/Init/Tactics.v +++ b/theories/Init/Tactics.v @@ -135,8 +135,8 @@ lazymatch T with rename H2 into H; find_equiv H | clear H] | forall x : ?t, _ => - let a := fresh "a" with - H1 := fresh "H" in + let a := fresh "a" in + let H1 := fresh "H" in evar (a : t); pose proof (H a) as H1; unfold a in H1; clear a; clear H; rename H1 into H; find_equiv H | ?A <-> ?B => idtac @@ -203,7 +203,7 @@ Set Implicit Arguments. Lemma decide_left : forall (C:Prop) (decide:{C}+{~C}), C -> forall P:{C}+{~C}->Prop, (forall H:C, P (left _ H)) -> P decide. Proof. - intros; destruct decide. + intros C decide H P H0; destruct decide. - apply H0. - contradiction. Qed. @@ -211,7 +211,7 @@ Qed. Lemma decide_right : forall (C:Prop) (decide:{C}+{~C}), ~C -> forall P:{C}+{~C}->Prop, (forall H:~C, P (right _ H)) -> P decide. Proof. - intros; destruct decide. + intros C decide H P H0; destruct decide. - contradiction. - apply H0. Qed. diff --git a/theories/Init/Wf.v b/theories/Init/Wf.v index a305626eb3..60200ae0f6 100644 --- a/theories/Init/Wf.v +++ b/theories/Init/Wf.v @@ -85,8 +85,7 @@ Section Well_founded. Scheme Acc_inv_dep := Induction for Acc Sort Prop. - Lemma Fix_F_eq : - forall (x:A) (r:Acc x), + Lemma Fix_F_eq (x:A) (r:Acc x) : F (fun (y:A) (p:R y x) => Fix_F (x:=y) (Acc_inv r p)) = Fix_F (x:=x) r. Proof. destruct r using Acc_inv_dep; auto. @@ -104,7 +103,7 @@ Section Well_founded. Lemma Fix_F_inv : forall (x:A) (r s:Acc x), Fix_F r = Fix_F s. Proof. - intro x; induction (Rwf x); intros. + intro x; induction (Rwf x); intros r s. rewrite <- (Fix_F_eq r); rewrite <- (Fix_F_eq s); intros. apply F_ext; auto. Qed. diff --git a/theories/Lists/List.v b/theories/Lists/List.v index c3c69f46f3..76633ab201 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -207,24 +207,31 @@ Section Facts. now destruct Heq as [[Heq1 Heq2]|[Heq1 Heq2]]; inversion_clear Heq2. Qed. - Lemma app_inj_tail : - forall (x y:list A) (a b:A), x ++ [a] = y ++ [b] -> x = y /\ a = b. + Lemma app_inj_tail_iff : + forall (x y:list A) (a b:A), x ++ [a] = y ++ [b] <-> x = y /\ a = b. Proof. induction x as [| x l IHl]; [ destruct y as [| a l] | destruct y as [| a l0] ]; simpl; auto. - - intros a b [= ]. - auto. - - intros a0 b [= H1 H0]. - apply app_cons_not_nil in H0 as []. - - intros a b [= H1 H0]. - assert ([] = l ++ [a]) by auto. - apply app_cons_not_nil in H as []. - - intros a0 b [= <- H0]. - destruct (IHl l0 a0 b H0) as (<-,<-). - split; auto. + - intros a b. split. + + intros [= ]. auto. + + intros [H0 H1]. subst. auto. + - intros a0 b. split. + + intros [= H1 H0]. apply app_cons_not_nil in H0 as []. + + intros [H0 H1]. inversion H0. + - intros a b. split. + + intros [= H1 H0]. assert ([] = l ++ [a]) by auto. apply app_cons_not_nil in H as []. + + intros [H0 H1]. inversion H0. + - intros a0 b. split. + + intros [= <- H0]. specialize (IHl l0 a0 b). apply IHl in H0. destruct H0. subst. split; auto. + + intros [H0 H1]. inversion H0. subst. auto. Qed. + Lemma app_inj_tail : + forall (x y:list A) (a b:A), x ++ [a] = y ++ [b] -> x = y /\ a = b. + Proof. + apply app_inj_tail_iff. + Qed. (** Compatibility with other operations *) @@ -239,10 +246,18 @@ Section Facts. rewrite <- plus_n_Sm, plus_n_O; reflexivity. Qed. + Lemma app_inv_head_iff: + forall l l1 l2 : list A, l ++ l1 = l ++ l2 <-> l1 = l2. + Proof. + induction l; split; intros; simpl; auto. + - apply IHl. inversion H. auto. + - subst. auto. + Qed. + Lemma app_inv_head: forall l l1 l2 : list A, l ++ l1 = l ++ l2 -> l1 = l2. Proof. - induction l; simpl; auto; injection 1; auto. + apply app_inv_head_iff. Qed. Lemma app_inv_tail: @@ -260,6 +275,12 @@ Section Facts. injection H as [= H H0]; f_equal; eauto. Qed. + Lemma app_inv_tail_iff: + forall l l1 l2 : list A, l1 ++ l = l2 ++ l <-> l1 = l2. + Proof. + split; [apply app_inv_tail | now intros ->]. + Qed. + (************************) (** *** Facts about [In] *) (************************) @@ -3157,6 +3178,44 @@ Section Repeat. - f_equal; apply IHn. Qed. + Lemma repeat_app x n m : + repeat x (n + m) = repeat x n ++ repeat x m. + Proof. + induction n as [|n IHn]; simpl; auto. + now rewrite IHn. + Qed. + + Lemma repeat_eq_app x n l1 l2 : + repeat x n = l1 ++ l2 -> repeat x (length l1) = l1 /\ repeat x (length l2) = l2. + Proof. + revert n; induction l1 as [|a l1 IHl1]; simpl; intros n Hr; subst. + - repeat split; now rewrite repeat_length. + - destruct n; inversion Hr as [ [Heq Hr0] ]; subst. + now apply IHl1 in Hr0 as [-> ->]. + Qed. + + Lemma repeat_eq_cons x y n l : + repeat x n = y :: l -> x = y /\ repeat x (pred n) = l. + Proof. + intros Hr. + destruct n; inversion_clear Hr; auto. + Qed. + + Lemma repeat_eq_elt x y n l1 l2 : + repeat x n = l1 ++ y :: l2 -> x = y /\ repeat x (length l1) = l1 /\ repeat x (length l2) = l2. + Proof. + intros Hr; apply repeat_eq_app in Hr as [Hr1 Hr2]; subst. + apply repeat_eq_cons in Hr2; intuition. + Qed. + + Lemma Forall_eq_repeat x l : + Forall (eq x) l -> l = repeat x (length l). + Proof. + induction l as [|a l IHl]; simpl; intros HF; auto. + inversion_clear HF as [ | ? ? ? HF']; subst. + now rewrite (IHl HF') at 1. + Qed. + End Repeat. Lemma repeat_to_concat A n (a:A) : diff --git a/theories/NArith/BinNat.v b/theories/NArith/BinNat.v index 1881e387a2..28ba9daed0 100644 --- a/theories/NArith/BinNat.v +++ b/theories/NArith/BinNat.v @@ -1007,7 +1007,7 @@ Bind Scope N_scope with N.t N. (** Exportation of notations *) -Numeral Notation N N.of_num_uint N.to_num_uint : N_scope. +Number Notation N N.of_num_uint N.to_num_uint : N_scope. Infix "+" := N.add : N_scope. Infix "-" := N.sub : N_scope. diff --git a/theories/NArith/BinNatDef.v b/theories/NArith/BinNatDef.v index 8a0aee9cf4..222e76c3e7 100644 --- a/theories/NArith/BinNatDef.v +++ b/theories/NArith/BinNatDef.v @@ -434,9 +434,9 @@ Definition to_hex_int n := Hexadecimal.Pos (to_hex_uint n). Definition to_num_int n := Numeral.IntDec (to_int n). -Numeral Notation N of_num_uint to_num_uint : N_scope. +Number Notation N of_num_uint to_num_uint : N_scope. End N. (** Re-export the notation for those who just [Import NatIntDef] *) -Numeral Notation N N.of_num_uint N.to_num_uint : N_scope. +Number Notation N N.of_num_uint N.to_num_uint : N_scope. diff --git a/theories/Numbers/AltBinNotations.v b/theories/Numbers/AltBinNotations.v index 5585f478b3..7c846571a7 100644 --- a/theories/Numbers/AltBinNotations.v +++ b/theories/Numbers/AltBinNotations.v @@ -8,12 +8,12 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(** * Alternative Binary Numeral Notations *) +(** * Alternative Binary Number Notations *) (** Faster but less safe parsers and printers of [positive], [N], [Z]. *) (** By default, literals in types [positive], [N], [Z] are parsed and - printed via the [Numeral Notation] command, by conversion from/to + printed via the [Number Notation] command, by conversion from/to the [Decimal.int] representation. When working with numbers with thousands of digits and more, conversion from/to [Decimal.int] can become significantly slow. If that becomes a problem for your @@ -43,7 +43,7 @@ Definition pos_of_z z := Definition pos_to_z p := Zpos p. -Numeral Notation positive pos_of_z pos_to_z : positive_scope. +Number Notation positive pos_of_z pos_to_z : positive_scope. (** [N] *) @@ -60,10 +60,10 @@ Definition n_to_z n := | Npos p => Zpos p end. -Numeral Notation N n_of_z n_to_z : N_scope. +Number Notation N n_of_z n_to_z : N_scope. (** [Z] *) Definition z_of_z (z:Z) := z. -Numeral Notation Z z_of_z z_of_z : Z_scope. +Number Notation Z z_of_z z_of_z : Z_scope. diff --git a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v index 6470cd6c81..e3e8f532b3 100644 --- a/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v +++ b/theories/Numbers/Cyclic/Abstract/CyclicAxioms.v @@ -99,7 +99,7 @@ Module ZnZ. lxor : t -> t -> t }. Section Specs. - Context {t : Type}{ops : Ops t}. + Context {t : Set}{ops : Ops t}. Notation "[| x |]" := (to_Z x) (at level 0, x at level 99). @@ -221,7 +221,7 @@ Module ZnZ. Section WW. - Context {t : Type}{ops : Ops t}{specs : Specs ops}. + Context {t : Set}{ops : Ops t}{specs : Specs ops}. Let wB := base digits. @@ -284,7 +284,7 @@ Module ZnZ. Section Of_Z. - Context {t : Type}{ops : Ops t}{specs : Specs ops}. + Context {t : Set}{ops : Ops t}{specs : Specs ops}. Notation "[| x |]" := (to_Z x) (at level 0, x at level 99). @@ -325,7 +325,7 @@ End ZnZ. (** A modular specification grouping the earlier records. *) Module Type CyclicType. - Parameter t : Type. + Parameter t : Set. Declare Instance ops : ZnZ.Ops t. Declare Instance specs : ZnZ.Specs ops. End CyclicType. diff --git a/theories/Numbers/Cyclic/Abstract/DoubleType.v b/theories/Numbers/Cyclic/Abstract/DoubleType.v index 3232e3afe0..165f9893ca 100644 --- a/theories/Numbers/Cyclic/Abstract/DoubleType.v +++ b/theories/Numbers/Cyclic/Abstract/DoubleType.v @@ -54,7 +54,7 @@ Arguments W0 {znz}. (if depth = n). *) -Fixpoint word (w:Type) (n:nat) : Type := +Fixpoint word (w:Set) (n:nat) : Set := match n with | O => w | S n => zn2z (word w n) diff --git a/theories/Numbers/Cyclic/Int31/Int31.v b/theories/Numbers/Cyclic/Int31/Int31.v index cd814091a1..d3528ce87c 100644 --- a/theories/Numbers/Cyclic/Int31/Int31.v +++ b/theories/Numbers/Cyclic/Int31/Int31.v @@ -477,4 +477,4 @@ Definition tail031 (i:int31) := end) i On. -Numeral Notation int31 phi_inv_nonneg phi : int31_scope. +Number Notation int31 phi_inv_nonneg phi : int31_scope. diff --git a/theories/Numbers/Cyclic/Int63/Cyclic63.v b/theories/Numbers/Cyclic/Int63/Cyclic63.v index 5f903c41cb..2a26b6b12a 100644 --- a/theories/Numbers/Cyclic/Int63/Cyclic63.v +++ b/theories/Numbers/Cyclic/Int63/Cyclic63.v @@ -48,7 +48,7 @@ Definition mulc_WW x y := Notation "n '*c' m" := (mulc_WW n m) (at level 40, no associativity) : int63_scope. Definition pos_mod p x := - if p <= digits then + if p <=? digits then let p := digits - p in (x << p) >> p else x. diff --git a/theories/Numbers/Cyclic/Int63/Int63.v b/theories/Numbers/Cyclic/Int63/Int63.v index 2c112c3469..383c0aff3a 100644 --- a/theories/Numbers/Cyclic/Int63/Int63.v +++ b/theories/Numbers/Cyclic/Int63/Int63.v @@ -31,56 +31,61 @@ Declare Scope int63_scope. Definition id_int : int -> int := fun x => x. Declare ML Module "int63_syntax_plugin". +Module Import Int63NotationsInternalA. Delimit Scope int63_scope with int63. Bind Scope int63_scope with int. +End Int63NotationsInternalA. (* Logical operations *) Primitive lsl := #int63_lsl. -Infix "<<" := lsl (at level 30, no associativity) : int63_scope. Primitive lsr := #int63_lsr. -Infix ">>" := lsr (at level 30, no associativity) : int63_scope. Primitive land := #int63_land. -Infix "land" := land (at level 40, left associativity) : int63_scope. Primitive lor := #int63_lor. -Infix "lor" := lor (at level 40, left associativity) : int63_scope. Primitive lxor := #int63_lxor. -Infix "lxor" := lxor (at level 40, left associativity) : int63_scope. (* Arithmetic modulo operations *) Primitive add := #int63_add. -Notation "n + m" := (add n m) : int63_scope. Primitive sub := #int63_sub. -Notation "n - m" := (sub n m) : int63_scope. Primitive mul := #int63_mul. -Notation "n * m" := (mul n m) : int63_scope. Primitive mulc := #int63_mulc. Primitive div := #int63_div. -Notation "n / m" := (div n m) : int63_scope. Primitive mod := #int63_mod. -Notation "n '\%' m" := (mod n m) (at level 40, left associativity) : int63_scope. (* Comparisons *) Primitive eqb := #int63_eq. -Notation "m '==' n" := (eqb m n) (at level 70, no associativity) : int63_scope. Primitive ltb := #int63_lt. -Notation "m < n" := (ltb m n) : int63_scope. Primitive leb := #int63_le. -Notation "m <= n" := (leb m n) : int63_scope. -Notation "m ≤ n" := (leb m n) (at level 70, no associativity) : int63_scope. Local Open Scope int63_scope. +Module Import Int63NotationsInternalB. +Infix "<<" := lsl (at level 30, no associativity) : int63_scope. +Infix ">>" := lsr (at level 30, no associativity) : int63_scope. +Infix "land" := land (at level 40, left associativity) : int63_scope. +Infix "lor" := lor (at level 40, left associativity) : int63_scope. +Infix "lxor" := lxor (at level 40, left associativity) : int63_scope. +Infix "+" := add : int63_scope. +Infix "-" := sub : int63_scope. +Infix "*" := mul : int63_scope. +Infix "/" := div : int63_scope. +Infix "mod" := mod (at level 40, no associativity) : int63_scope. +Infix "=?" := eqb (at level 70, no associativity) : int63_scope. +Infix "<?" := ltb (at level 70, no associativity) : int63_scope. +Infix "<=?" := leb (at level 70, no associativity) : int63_scope. +Infix "≤?" := leb (at level 70, no associativity) : int63_scope. +End Int63NotationsInternalB. + (** The number of digits as a int *) Definition digits := 63. @@ -89,16 +94,16 @@ Definition max_int := Eval vm_compute in 0 - 1. Register Inline max_int. (** Access to the nth digits *) -Definition get_digit x p := (0 < (x land (1 << p))). +Definition get_digit x p := (0 <? (x land (1 << p))). Definition set_digit x p (b:bool) := - if if 0 <= p then p < digits else false then + if if 0 <=? p then p <? digits else false then if b then x lor (1 << p) else x land (max_int lxor (1 << p)) else x. (** Equality to 0 *) -Definition is_zero (i:int) := i == 0. +Definition is_zero (i:int) := i =? 0. Register Inline is_zero. (** Parity *) @@ -113,7 +118,6 @@ Definition bit i n := negb (is_zero ((i >> n) << (digits - 1))). (** Extra modulo operations *) Definition opp (i:int) := 0 - i. Register Inline opp. -Notation "- x" := (opp x) : int63_scope. Definition oppcarry i := max_int - i. Register Inline oppcarry. @@ -134,29 +138,27 @@ Register Inline subcarry. Definition addc_def x y := let r := x + y in - if r < x then C1 r else C0 r. + if r <? x then C1 r else C0 r. (* the same but direct implementation for efficiency *) Primitive addc := #int63_addc. -Notation "n '+c' m" := (addc n m) (at level 50, no associativity) : int63_scope. Definition addcarryc_def x y := let r := addcarry x y in - if r <= x then C1 r else C0 r. + if r <=? x then C1 r else C0 r. (* the same but direct implementation for efficiency *) Primitive addcarryc := #int63_addcarryc. Definition subc_def x y := - if y <= x then C0 (x - y) else C1 (x - y). + if y <=? x then C0 (x - y) else C1 (x - y). (* the same but direct implementation for efficiency *) Primitive subc := #int63_subc. -Notation "n '-c' m" := (subc n m) (at level 50, no associativity) : int63_scope. Definition subcarryc_def x y := - if y < x then C0 (x - y - 1) else C1 (x - y - 1). + if y <? x then C0 (x - y - 1) else C1 (x - y - 1). (* the same but direct implementation for efficiency *) Primitive subcarryc := #int63_subcarryc. -Definition diveucl_def x y := (x/y, x\%y). +Definition diveucl_def x y := (x/y, x mod y). (* the same but direct implementation for efficiency *) Primitive diveucl := #int63_diveucl. @@ -166,6 +168,12 @@ Definition addmuldiv_def p x y := (x << p) lor (y >> (digits - p)). Primitive addmuldiv := #int63_addmuldiv. +Module Import Int63NotationsInternalC. +Notation "- x" := (opp x) : int63_scope. +Notation "n '+c' m" := (addc n m) (at level 50, no associativity) : int63_scope. +Notation "n '-c' m" := (subc n m) (at level 50, no associativity) : int63_scope. +End Int63NotationsInternalC. + Definition oppc (i:int) := 0 -c i. Register Inline oppc. @@ -177,11 +185,10 @@ Register Inline predc. (** Comparison *) Definition compare_def x y := - if x < y then Lt - else if (x == y) then Eq else Gt. + if x <? y then Lt + else if (x =? y) then Eq else Gt. Primitive compare := #int63_compare. -Notation "n ?= m" := (compare n m) (at level 70, no associativity) : int63_scope. Import Bool ZArith. (** Translation to Z *) @@ -194,8 +201,6 @@ Fixpoint to_Z_rec (n:nat) (i:int) := Definition to_Z := to_Z_rec size. -Notation "'φ' x" := (to_Z x) (at level 0) : int63_scope. - Fixpoint of_pos_rec (n:nat) (p:positive) := match n, p with | O, _ => 0 @@ -215,8 +220,12 @@ Definition of_Z z := Definition wB := (2 ^ (Z.of_nat size))%Z. +Module Import Int63NotationsInternalD. +Notation "n ?= m" := (compare n m) (at level 70, no associativity) : int63_scope. +Notation "'φ' x" := (to_Z x) (at level 0) : int63_scope. Notation "'Φ' x" := (zn2z_to_Z wB to_Z x) (at level 0) : int63_scope. +End Int63NotationsInternalD. Lemma to_Z_rec_bounded size : forall x, (0 <= to_Z_rec size x < 2 ^ Z.of_nat size)%Z. Proof. @@ -347,16 +356,16 @@ Axiom mulc_spec : forall x y, φ x * φ y = φ (fst (mulc x y)) * wB + φ (snd ( Axiom div_spec : forall x y, φ (x / y) = φ x / φ y. -Axiom mod_spec : forall x y, φ (x \% y) = φ x mod φ y. +Axiom mod_spec : forall x y, φ (x mod y) = φ x mod φ y. (* Comparisons *) -Axiom eqb_correct : forall i j, (i == j)%int63 = true -> i = j. +Axiom eqb_correct : forall i j, (i =? j)%int63 = true -> i = j. -Axiom eqb_refl : forall x, (x == x)%int63 = true. +Axiom eqb_refl : forall x, (x =? x)%int63 = true. -Axiom ltb_spec : forall x y, (x < y)%int63 = true <-> φ x < φ y. +Axiom ltb_spec : forall x y, (x <? y)%int63 = true <-> φ x < φ y. -Axiom leb_spec : forall x y, (x <= y)%int63 = true <-> φ x <= φ y. +Axiom leb_spec : forall x y, (x <=? y)%int63 = true <-> φ x <= φ y. (** Exotic operations *) @@ -397,7 +406,7 @@ Local Open Scope int63_scope. Definition sqrt_step (rec: int -> int -> int) (i j: int) := let quo := i / j in - if quo < j then rec i ((j + quo) >> 1) + if quo <? j then rec i ((j + quo) >> 1) else j. Definition iter_sqrt := @@ -421,9 +430,9 @@ Definition high_bit := 1 << (digits - 1). Definition sqrt2_step (rec: int -> int -> int -> int) (ih il j: int) := - if ih < j then + if ih <? j then let (quo,_) := diveucl_21 ih il j in - if quo < j then + if quo <? j then match j +c quo with | C0 m1 => rec ih il (m1 >> 1) | C1 m1 => rec ih il ((m1 >> 1) + high_bit) @@ -448,48 +457,48 @@ Definition sqrt2 ih il := let (ih1, il1) := mulc s s in match il -c il1 with | C0 il2 => - if ih1 < ih then (s, C1 il2) else (s, C0 il2) + if ih1 <? ih then (s, C1 il2) else (s, C0 il2) | C1 il2 => - if ih1 < (ih - 1) then (s, C1 il2) else (s, C0 il2) + if ih1 <? (ih - 1) then (s, C1 il2) else (s, C0 il2) end. (** Gcd **) Fixpoint gcd_rec (guard:nat) (i j:int) {struct guard} := match guard with | O => 1 - | S p => if j == 0 then i else gcd_rec p j (i \% j) + | S p => if j =? 0 then i else gcd_rec p j (i mod j) end. Definition gcd := gcd_rec (2*size). (** equality *) -Lemma eqb_complete : forall x y, x = y -> (x == y) = true. +Lemma eqb_complete : forall x y, x = y -> (x =? y) = true. Proof. intros x y H; rewrite -> H, eqb_refl;trivial. Qed. -Lemma eqb_spec : forall x y, (x == y) = true <-> x = y. +Lemma eqb_spec : forall x y, (x =? y) = true <-> x = y. Proof. split;auto using eqb_correct, eqb_complete. Qed. -Lemma eqb_false_spec : forall x y, (x == y) = false <-> x <> y. +Lemma eqb_false_spec : forall x y, (x =? y) = false <-> x <> y. Proof. intros;rewrite <- not_true_iff_false, eqb_spec;split;trivial. Qed. -Lemma eqb_false_complete : forall x y, x <> y -> (x == y) = false. +Lemma eqb_false_complete : forall x y, x <> y -> (x =? y) = false. Proof. intros x y;rewrite eqb_false_spec;trivial. Qed. -Lemma eqb_false_correct : forall x y, (x == y) = false -> x <> y. +Lemma eqb_false_correct : forall x y, (x =? y) = false -> x <> y. Proof. intros x y;rewrite eqb_false_spec;trivial. Qed. Definition eqs (i j : int) : {i = j} + { i <> j } := - (if i == j as b return ((b = true -> i = j) -> (b = false -> i <> j) -> {i=j} + {i <> j} ) + (if i =? j as b return ((b = true -> i = j) -> (b = false -> i <> j) -> {i=j} + {i <> j} ) then fun (Heq : true = true -> i = j) _ => left _ (Heq (eq_refl true)) else fun _ (Hdiff : false = false -> i <> j) => right _ (Hdiff (eq_refl false))) (eqb_correct i j) @@ -503,7 +512,7 @@ Qed. (* Extra function on equality *) Definition cast i j := - (if i == j as b return ((b = true -> i = j) -> option (forall P : int -> Type, P i -> P j)) + (if i =? j as b return ((b = true -> i = j) -> option (forall P : int -> Type, P i -> P j)) then fun Heq : true = true -> i = j => Some (fun (P : int -> Type) (Hi : P i) => @@ -520,14 +529,14 @@ Proof. rewrite (Eqdep_dec.eq_proofs_unicity eq_dec (e (eq_refl true)) (eq_refl i));trivial. Qed. -Lemma cast_diff : forall i j, i == j = false -> cast i j = None. +Lemma cast_diff : forall i j, i =? j = false -> cast i j = None. Proof. intros;unfold cast;intros; generalize (eqb_correct i j). rewrite H;trivial. Qed. Definition eqo i j := - (if i == j as b return ((b = true -> i = j) -> option (i=j)) + (if i =? j as b return ((b = true -> i = j) -> option (i=j)) then fun Heq : true = true -> i = j => Some (Heq (eq_refl true)) else fun _ : false = true -> i = j => None) (eqb_correct i j). @@ -540,7 +549,7 @@ Proof. rewrite (Eqdep_dec.eq_proofs_unicity eq_dec (e (eq_refl true)) (eq_refl i));trivial. Qed. -Lemma eqo_diff : forall i j, i == j = false -> eqo i j = None. +Lemma eqo_diff : forall i j, i =? j = false -> eqo i j = None. Proof. unfold eqo;intros; generalize (eqb_correct i j). rewrite H;trivial. @@ -548,13 +557,13 @@ Qed. (** Comparison *) -Lemma eqbP x y : reflect (φ x = φ y ) (x == y). +Lemma eqbP x y : reflect (φ x = φ y ) (x =? y). Proof. apply iff_reflect; rewrite eqb_spec; split; [ apply to_Z_inj | apply f_equal ]. Qed. -Lemma ltbP x y : reflect (φ x < φ y )%Z (x < y). +Lemma ltbP x y : reflect (φ x < φ y )%Z (x <? y). Proof. apply iff_reflect; symmetry; apply ltb_spec. Qed. -Lemma lebP x y : reflect (φ x <= φ y )%Z (x ≤ y). +Lemma lebP x y : reflect (φ x <= φ y )%Z (x ≤? y). Proof. apply iff_reflect; symmetry; apply leb_spec. Qed. Lemma compare_spec x y : compare x y = (φ x ?= φ y)%Z. @@ -742,7 +751,7 @@ Proof. Qed. Lemma add_le_r m n: - if (n <= m + n)%int63 then (φ m + φ n < wB)%Z else (wB <= φ m + φ n)%Z. + if (n <=? m + n)%int63 then (φ m + φ n < wB)%Z else (wB <= φ m + φ n)%Z. Proof. case (to_Z_bounded m); intros H1m H2m. case (to_Z_bounded n); intros H1n H2n. @@ -753,11 +762,11 @@ Proof. rewrite -> Zplus_mod, Z_mod_same_full, Zplus_0_r, !Zmod_small; auto with zarith. rewrite !Zmod_small; auto with zarith. apply f_equal2 with (f := Zmod); auto with zarith. - case_eq (n <= m + n)%int63; auto. + case_eq (n <=? m + n)%int63; auto. rewrite leb_spec, H1; auto with zarith. assert (H1: (φ (m + n) = φ m + φ n)%Z). rewrite add_spec, Zmod_small; auto with zarith. - replace (n <= m + n)%int63 with true; auto. + replace (n <=? m + n)%int63 with true; auto. apply sym_equal; rewrite leb_spec, H1; auto with zarith. Qed. @@ -783,7 +792,7 @@ Proof. apply to_Z_inj; rewrite lsr_spec; reflexivity. Qed. Lemma lsr_0_r i: i >> 0 = i. Proof. apply to_Z_inj; rewrite lsr_spec, Zdiv_1_r; exact eq_refl. Qed. -Lemma lsr_1 n : 1 >> n = (n == 0). +Lemma lsr_1 n : 1 >> n = (n =? 0)%int63. Proof. case eqbP. intros h; rewrite (to_Z_inj _ _ h), lsr_0_r; reflexivity. @@ -798,12 +807,12 @@ Proof. lia. Qed. -Lemma lsr_add i m n: ((i >> m) >> n = if n <= m + n then i >> (m + n) else 0)%int63. +Lemma lsr_add i m n: ((i >> m) >> n = if n <=? m + n then i >> (m + n) else 0)%int63. Proof. case (to_Z_bounded m); intros H1m H2m. case (to_Z_bounded n); intros H1n H2n. case (to_Z_bounded i); intros H1i H2i. - generalize (add_le_r m n); case (n <= m + n)%int63; intros H. + generalize (add_le_r m n); case (n <=? m + n)%int63; intros H. apply to_Z_inj; rewrite -> !lsr_spec, Zdiv_Zdiv, <- Zpower_exp; auto with zarith. rewrite add_spec, Zmod_small; auto with zarith. apply to_Z_inj; rewrite -> !lsr_spec, Zdiv_Zdiv, <- Zpower_exp; auto with zarith. @@ -833,7 +842,7 @@ Proof. apply f_equal2 with (f := Zmod); auto with zarith. Qed. -Lemma lsr_M_r x i (H: (digits <= i = true)%int63) : x >> i = 0%int63. +Lemma lsr_M_r x i (H: (digits <=? i = true)%int63) : x >> i = 0%int63. Proof. apply to_Z_inj. rewrite lsr_spec, to_Z_0. @@ -889,22 +898,22 @@ Proof. Qed. Lemma bit_lsr x i j : - (bit (x >> i) j = if j <= i + j then bit x (i + j) else false)%int63. + (bit (x >> i) j = if j <=? i + j then bit x (i + j) else false)%int63. Proof. - unfold bit; rewrite lsr_add; case (_ ≤ _); auto. + unfold bit; rewrite lsr_add; case (_ ≤? _); auto. Qed. -Lemma bit_b2i (b: bool) i : bit b i = (i == 0) && b. +Lemma bit_b2i (b: bool) i : bit b i = (i =? 0)%int63 && b. Proof. case b; unfold bit; simpl b2i. - rewrite lsr_1; case (i == 0); auto. + rewrite lsr_1; case (i =? 0)%int63; auto. rewrite lsr0, lsl0, andb_false_r; auto. Qed. -Lemma bit_1 n : bit 1 n = (n == 0). +Lemma bit_1 n : bit 1 n = (n =? 0)%int63. Proof. unfold bit; rewrite lsr_1. - case (_ == _); simpl; auto. + case (_ =? _)%int63; simpl; auto. Qed. Local Hint Resolve Z.lt_gt Z.div_pos : zarith. @@ -929,14 +938,14 @@ Proof. case bit; discriminate. Qed. -Lemma bit_M i n (H: (digits <= n = true)%int63): bit i n = false. +Lemma bit_M i n (H: (digits <=? n = true)%int63): bit i n = false. Proof. unfold bit; rewrite lsr_M_r; auto. Qed. -Lemma bit_half i n (H: (n < digits = true)%int63) : bit (i>>1) n = bit i (n+1). +Lemma bit_half i n (H: (n <? digits = true)%int63) : bit (i>>1) n = bit i (n+1). Proof. unfold bit. rewrite lsr_add. - case_eq (n <= (1 + n))%int63. + case_eq (n <=? (1 + n))%int63. replace (1+n)%int63 with (n+1)%int63; [auto|idtac]. apply to_Z_inj; rewrite !add_spec, Zplus_comm; auto. intros H1; assert (H2: n = max_int). @@ -968,10 +977,10 @@ Proof. Qed. Lemma bit_lsl x i j : bit (x << i) j = -(if (j < i) || (digits <= j) then false else bit x (j - i))%int63. +(if (j <? i) || (digits <=? j) then false else bit x (j - i))%int63. Proof. assert (F1: 1 >= 0) by discriminate. - case_eq (digits <= j)%int63; intros H. + case_eq (digits <=? j)%int63; intros H. rewrite orb_true_r, bit_M; auto. set (d := φ digits). case (Zle_or_lt d (φ j)); intros H1. @@ -1039,10 +1048,10 @@ Lemma lor_lsr i1 i2 i: (i1 lor i2) >> i = (i1 >> i) lor (i2 >> i). Proof. apply bit_ext; intros n. rewrite -> lor_spec, !bit_lsr, lor_spec. - case (_ <= _)%int63; auto. + case (_ <=? _)%int63; auto. Qed. -Lemma lor_le x y : (y <= x lor y)%int63 = true. +Lemma lor_le x y : (y <=? x lor y)%int63 = true. Proof. generalize x y (to_Z_bounded x) (to_Z_bounded y); clear x y. unfold wB; elim size. @@ -1092,7 +1101,7 @@ Proof. rewrite lsr_spec, Z.pow_1_r; split; auto with zarith. apply Zdiv_lt_upper_bound; auto with zarith. intros m H1 H2. - case_eq (digits <= m)%int63; [idtac | rewrite <- not_true_iff_false]; + case_eq (digits <=? m)%int63; [idtac | rewrite <- not_true_iff_false]; intros Heq. rewrite bit_M in H1; auto; discriminate. rewrite leb_spec in Heq. @@ -1131,7 +1140,7 @@ Proof. rewrite lsr_spec, to_Z_1, Z.pow_1_r; split; auto with zarith. apply Zdiv_lt_upper_bound; auto with zarith. intros _ HH m; case (to_Z_bounded m); intros H1m H2m. - case_eq (digits <= m)%int63. + case_eq (digits <=? m)%int63. intros Hlm; rewrite bit_M; auto; discriminate. rewrite <- not_true_iff_false, leb_spec; intros Hlm. case (Zle_lt_or_eq 0 φ m); auto; intros Hm. @@ -1177,11 +1186,11 @@ Proof. rewrite (fun x y => Zmod_small (x - y)); auto with zarith. intros n; rewrite -> bit_lsl, bit_lsr. generalize (add_le_r (digits - p) n). - case (_ ≤ _); try discriminate. + case (_ ≤? _); try discriminate. rewrite -> sub_spec, Zmod_small; auto with zarith; intros H1. - case_eq (n < p)%int63; try discriminate. + case_eq (n <? p)%int63; try discriminate. rewrite <- not_true_iff_false, ltb_spec; intros H2. - case (_ ≤ _); try discriminate. + case (_ ≤? _); try discriminate. intros _; rewrite bit_M; try discriminate. rewrite -> leb_spec, add_spec, Zmod_small, sub_spec, Zmod_small; auto with zarith. rewrite -> sub_spec, Zmod_small; auto with zarith. @@ -1196,7 +1205,7 @@ Proof. apply bit_ext; intros n. rewrite bit_b2i, land_spec, bit_1. generalize (eqb_spec n 0). - case (n == 0); auto. + case (n =? 0)%int63; auto. intros(H,_); rewrite andb_true_r, H; auto. rewrite andb_false_r; auto. Qed. @@ -1373,9 +1382,9 @@ Qed. (* sqrt2 *) Lemma sqrt2_step_def rec ih il j: sqrt2_step rec ih il j = - if (ih < j)%int63 then + if (ih <? j)%int63 then let quo := fst (diveucl_21 ih il j) in - if (quo < j)%int63 then + if (quo <? j)%int63 then let m := match j +c quo with | C0 m1 => m1 >> 1 @@ -1453,7 +1462,7 @@ Proof. apply Zmult_lt_0_compat; auto with zarith. refine (Z.lt_le_trans _ _ _ _ Hih); auto with zarith. } cbv zeta. - case_eq (ih < j)%int63;intros Heq. + case_eq (ih <? j)%int63;intros Heq. rewrite -> ltb_spec in Heq. 2: rewrite <-not_true_iff_false, ltb_spec in Heq. 2: split; auto. @@ -1462,7 +1471,7 @@ Proof. 2: assert (0 <= φ il/φ j) by (apply Z_div_pos; auto with zarith). 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. + case_eq (fst (diveucl_21 ih il j) <? j)%int63;intros 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 _ _ _ Hjj Heq) in Heq0. @@ -1557,7 +1566,7 @@ Lemma sqrt2_spec : forall x y, generalize (subc_spec il il1). case subc; intros il2 Hil2. simpl interp_carry in Hil2. - case_eq (ih1 < ih)%int63; [idtac | rewrite <- not_true_iff_false]; + case_eq (ih1 <? ih)%int63; [idtac | rewrite <- not_true_iff_false]; rewrite ltb_spec; intros Heq. unfold interp_carry; rewrite Zmult_1_l. rewrite -> Z.pow_2_r, Hihl1, Hil2. @@ -1602,7 +1611,7 @@ Lemma sqrt2_spec : forall x y, case (to_Z_bounded ih); intros H1 H2. split; auto with zarith. apply Z.le_trans with (wB/4 - 1); auto with zarith. - case_eq (ih1 < ih - 1)%int63; [idtac | rewrite <- not_true_iff_false]; + case_eq (ih1 <? ih - 1)%int63; [idtac | rewrite <- not_true_iff_false]; rewrite ltb_spec, Hsih; intros Heq. rewrite Z.pow_2_r, Hihl1. case (Zle_lt_or_eq (φ ih1 + 2) φ ih); auto with zarith. @@ -1927,3 +1936,21 @@ Qed. Lemma lxor0_r i : i lxor 0 = i. Proof. rewrite lxorC; exact (lxor0 i). Qed. + +Module Export Int63Notations. + Local Open Scope int63_scope. + #[deprecated(since="8.13",note="use infix mod instead")] + Notation "a \% m" := (a mod m) (at level 40, left associativity) : int63_scope. + #[deprecated(since="8.13",note="use infix =? instead")] + Notation "m '==' n" := (m =? n) (at level 70, no associativity) : int63_scope. + #[deprecated(since="8.13",note="use infix <? instead")] + Notation "m < n" := (m <? n) : int63_scope. + #[deprecated(since="8.13",note="use infix <=? instead")] + Notation "m <= n" := (m <=? n) : int63_scope. + #[deprecated(since="8.13",note="use infix ≤? instead")] + Notation "m ≤ n" := (m <=? n) (at level 70, no associativity) : int63_scope. + Export Int63NotationsInternalA. + Export Int63NotationsInternalB. + Export Int63NotationsInternalC. + Export Int63NotationsInternalD. +End Int63Notations. diff --git a/theories/Numbers/NatInt/NZAdd.v b/theories/Numbers/NatInt/NZAdd.v index 7982411bdd..66cbba9e08 100644 --- a/theories/Numbers/NatInt/NZAdd.v +++ b/theories/Numbers/NatInt/NZAdd.v @@ -22,7 +22,7 @@ Ltac nzsimpl' := autorewrite with nz nz'. Theorem add_0_r : forall n, n + 0 == n. Proof. - nzinduct n. + intro n; nzinduct n. - now nzsimpl. - intro. nzsimpl. now rewrite succ_inj_wd. Qed. diff --git a/theories/Numbers/NatInt/NZBase.v b/theories/Numbers/NatInt/NZBase.v index 8bc393bbad..d4f70adbc5 100644 --- a/theories/Numbers/NatInt/NZBase.v +++ b/theories/Numbers/NatInt/NZBase.v @@ -74,7 +74,7 @@ Proof. intros z Base Step; revert Base; pattern z; apply bi_induction. - solve_proper. - intro; now apply bi_induction. -- intro; pose proof (Step n); tauto. +- intro n; pose proof (Step n); tauto. Qed. End CentralInduction. @@ -83,7 +83,7 @@ Tactic Notation "nzinduct" ident(n) := induction_maker n ltac:(apply bi_induction). Tactic Notation "nzinduct" ident(n) constr(u) := - induction_maker n ltac:(apply central_induction with (z := u)). + induction_maker n ltac:(apply (fun A A_wd => central_induction A A_wd u)). End NZBaseProp. diff --git a/theories/Numbers/NatInt/NZDiv.v b/theories/Numbers/NatInt/NZDiv.v index 1c45aa440f..e6249be8df 100644 --- a/theories/Numbers/NatInt/NZDiv.v +++ b/theories/Numbers/NatInt/NZDiv.v @@ -116,7 +116,7 @@ Qed. Theorem div_small: forall a b, 0<=a<b -> a/b == 0. Proof. -intros. symmetry. +intros a b ?. symmetry. apply div_unique with a; intuition; try order. now nzsimpl. Qed. @@ -149,7 +149,7 @@ Qed. Lemma mod_1_r: forall a, 0<=a -> a mod 1 == 0. Proof. -intros. symmetry. +intros a ?. symmetry. apply mod_unique with a; try split; try order; try apply lt_0_1. now nzsimpl. Qed. @@ -173,7 +173,7 @@ Qed. Lemma mod_mul : forall a b, 0<=a -> 0<b -> (a*b) mod b == 0. Proof. -intros; symmetry. +intros a b ? ?; symmetry. apply mod_unique with a; try split; try order. - apply mul_nonneg_nonneg; order. - nzsimpl; apply mul_comm. @@ -186,7 +186,7 @@ Qed. Theorem mod_le: forall a b, 0<=a -> 0<b -> a mod b <= a. Proof. -intros. destruct (le_gt_cases b a). +intros a b ? ?. destruct (le_gt_cases b a). - apply le_trans with b; auto. apply lt_le_incl. destruct (mod_bound_pos a b); auto. - rewrite lt_eq_cases; right. @@ -198,7 +198,7 @@ Qed. Lemma div_pos: forall a b, 0<=a -> 0<b -> 0 <= a/b. Proof. -intros. +intros a b ? ?. rewrite (mul_le_mono_pos_l _ _ b); auto; nzsimpl. rewrite (add_le_mono_r _ _ (a mod b)). rewrite <- div_mod by order. @@ -247,7 +247,7 @@ Qed. Lemma div_lt : forall a b, 0<a -> 1<b -> a/b < a. Proof. -intros. +intros a b ? ?. assert (0 < b) by (apply lt_trans with 1; auto using lt_0_1). destruct (lt_ge_cases a b). - rewrite div_small; try split; order. @@ -284,7 +284,7 @@ Qed. Lemma mul_div_le : forall a b, 0<=a -> 0<b -> b*(a/b) <= a. Proof. -intros. +intros a b ? ?. rewrite (add_le_mono_r _ _ (a mod b)), <- div_mod by order. rewrite <- (add_0_r a) at 1. rewrite <- add_le_mono_l. destruct (mod_bound_pos a b); order. @@ -292,7 +292,7 @@ Qed. Lemma mul_succ_div_gt : forall a b, 0<=a -> 0<b -> a < b*(S (a/b)). Proof. -intros. +intros a b ? ?. rewrite (div_mod a b) at 1 by order. rewrite (mul_succ_r). rewrite <- add_lt_mono_l. @@ -304,7 +304,7 @@ Qed. Lemma div_exact : forall a b, 0<=a -> 0<b -> (a == b*(a/b) <-> a mod b == 0). Proof. -intros. rewrite (div_mod a b) at 1 by order. +intros a b ? ?. rewrite (div_mod a b) at 1 by order. rewrite <- (add_0_r (b*(a/b))) at 2. apply add_cancel_l. Qed. @@ -314,7 +314,7 @@ Qed. Theorem div_lt_upper_bound: forall a b q, 0<=a -> 0<b -> a < b*q -> a/b < q. Proof. -intros. +intros a b q ? ? ?. rewrite (mul_lt_mono_pos_l b) by order. apply le_lt_trans with a; auto. apply mul_div_le; auto. @@ -323,7 +323,7 @@ Qed. Theorem div_le_upper_bound: forall a b q, 0<=a -> 0<b -> a <= b*q -> a/b <= q. Proof. -intros. +intros a b q ? ? ?. rewrite (mul_le_mono_pos_l _ _ b) by order. apply le_trans with a; auto. apply mul_div_le; auto. @@ -362,7 +362,7 @@ Qed. Lemma mod_add : forall a b c, 0<=a -> 0<=a+b*c -> 0<c -> (a + b * c) mod c == a mod c. Proof. - intros. + intros a b c ? ? ?. symmetry. apply mod_unique with (a/c+b); auto. - apply mod_bound_pos; auto. @@ -373,7 +373,7 @@ Qed. Lemma div_add : forall a b c, 0<=a -> 0<=a+b*c -> 0<c -> (a + b * c) / c == a / c + b. Proof. - intros. + intros a b c ? ? ?. apply (mul_cancel_l _ _ c); try order. apply (add_cancel_r _ _ ((a+b*c) mod c)). rewrite <- div_mod, mod_add by order. @@ -393,7 +393,7 @@ Qed. Lemma div_mul_cancel_r : forall a b c, 0<=a -> 0<b -> 0<c -> (a*c)/(b*c) == a/b. Proof. - intros. + intros a b c ? ? ?. symmetry. apply div_unique with ((a mod b)*c). - apply mul_nonneg_nonneg; order. @@ -409,13 +409,13 @@ Qed. Lemma div_mul_cancel_l : forall a b c, 0<=a -> 0<b -> 0<c -> (c*a)/(c*b) == a/b. Proof. - intros. rewrite !(mul_comm c); apply div_mul_cancel_r; auto. + intros a b c ? ? ?. rewrite !(mul_comm c); apply div_mul_cancel_r; auto. Qed. Lemma mul_mod_distr_l: forall a b c, 0<=a -> 0<b -> 0<c -> (c*a) mod (c*b) == c * (a mod b). Proof. - intros. + intros a b c ? ? ?. rewrite <- (add_cancel_l _ _ ((c*b)* ((c*a)/(c*b)))). rewrite <- div_mod. - rewrite div_mul_cancel_l; auto. @@ -427,7 +427,7 @@ Qed. Lemma mul_mod_distr_r: forall a b c, 0<=a -> 0<b -> 0<c -> (a*c) mod (b*c) == (a mod b) * c. Proof. - intros. rewrite !(mul_comm _ c); now rewrite mul_mod_distr_l. + intros a b c ? ? ?. rewrite !(mul_comm _ c); now rewrite mul_mod_distr_l. Qed. (** Operations modulo. *) @@ -435,7 +435,7 @@ Qed. Theorem mod_mod: forall a n, 0<=a -> 0<n -> (a mod n) mod n == a mod n. Proof. - intros. destruct (mod_bound_pos a n); auto. now rewrite mod_small_iff. + intros a n ? ?. destruct (mod_bound_pos a n); auto. now rewrite mod_small_iff. Qed. Lemma mul_mod_idemp_l : forall a b n, 0<=a -> 0<=b -> 0<n -> @@ -454,13 +454,14 @@ Qed. Lemma mul_mod_idemp_r : forall a b n, 0<=a -> 0<=b -> 0<n -> (a*(b mod n)) mod n == (a*b) mod n. Proof. - intros. rewrite !(mul_comm a). apply mul_mod_idemp_l; auto. + intros a b n ? ? ?. rewrite !(mul_comm a). apply mul_mod_idemp_l; auto. Qed. Theorem mul_mod: forall a b n, 0<=a -> 0<=b -> 0<n -> (a * b) mod n == ((a mod n) * (b mod n)) mod n. Proof. - intros. rewrite mul_mod_idemp_l, mul_mod_idemp_r; trivial. - reflexivity. + intros a b n ? ? ?. rewrite mul_mod_idemp_l, mul_mod_idemp_r; trivial. + - reflexivity. - now destruct (mod_bound_pos b n). Qed. @@ -478,13 +479,14 @@ Qed. Lemma add_mod_idemp_r : forall a b n, 0<=a -> 0<=b -> 0<n -> (a+(b mod n)) mod n == (a+b) mod n. Proof. - intros. rewrite !(add_comm a). apply add_mod_idemp_l; auto. + intros a b n ? ? ?. rewrite !(add_comm a). apply add_mod_idemp_l; auto. Qed. Theorem add_mod: forall a b n, 0<=a -> 0<=b -> 0<n -> (a+b) mod n == (a mod n + b mod n) mod n. Proof. - intros. rewrite add_mod_idemp_l, add_mod_idemp_r; trivial. - reflexivity. + intros a b n ? ? ?. rewrite add_mod_idemp_l, add_mod_idemp_r; trivial. + - reflexivity. - now destruct (mod_bound_pos b n). Qed. @@ -525,7 +527,7 @@ Qed. Theorem div_mul_le: forall a b c, 0<=a -> 0<b -> 0<=c -> c*(a/b) <= (c*a)/b. Proof. - intros. + intros a b c ? ? ?. apply div_le_lower_bound; auto. - apply mul_nonneg_nonneg; auto. - rewrite mul_assoc, (mul_comm b c), <- mul_assoc. @@ -538,7 +540,7 @@ Qed. Lemma mod_divides : forall a b, 0<=a -> 0<b -> (a mod b == 0 <-> exists c, a == b*c). Proof. - split. + intros a b ? ?; split. - intros. exists (a/b). rewrite div_exact; auto. - intros (c,Hc). rewrite Hc, mul_comm. apply mod_mul; auto. rewrite (mul_le_mono_pos_l _ _ b); auto. nzsimpl. order. diff --git a/theories/Numbers/NatInt/NZGcd.v b/theories/Numbers/NatInt/NZGcd.v index 63cc725aec..c542c3fc2c 100644 --- a/theories/Numbers/NatInt/NZGcd.v +++ b/theories/Numbers/NatInt/NZGcd.v @@ -147,7 +147,7 @@ Qed. Lemma mul_divide_cancel_r : forall n m p, p ~= 0 -> ((n * p | m * p) <-> (n | m)). Proof. - intros. rewrite 2 (mul_comm _ p). now apply mul_divide_cancel_l. + intros n m p ?. rewrite 2 (mul_comm _ p). now apply mul_divide_cancel_l. Qed. Lemma divide_add_r : forall n m p, (n | m) -> (n | p) -> (n | m + p). @@ -215,7 +215,7 @@ Qed. Lemma gcd_divide_iff : forall n m p, (p | gcd n m) <-> (p | n) /\ (p | m). Proof. - intros. split. - split. + intros n m p. split. - split. + transitivity (gcd n m); trivial using gcd_divide_l. + transitivity (gcd n m); trivial using gcd_divide_r. - intros (H,H'). now apply gcd_greatest. @@ -273,18 +273,18 @@ Qed. Lemma gcd_eq_0_l : forall n m, gcd n m == 0 -> n == 0. Proof. - intros. + intros n m H. generalize (gcd_divide_l n m). rewrite H. apply divide_0_l. Qed. Lemma gcd_eq_0_r : forall n m, gcd n m == 0 -> m == 0. Proof. - intros. apply gcd_eq_0_l with n. now rewrite gcd_comm. + intros n m ?. apply gcd_eq_0_l with n. now rewrite gcd_comm. Qed. Lemma gcd_eq_0 : forall n m, gcd n m == 0 <-> n == 0 /\ m == 0. Proof. - intros. split. + intros n m. split. - split. + now apply gcd_eq_0_l with m. + now apply gcd_eq_0_r with n. diff --git a/theories/Numbers/NatInt/NZLog.v b/theories/Numbers/NatInt/NZLog.v index 5491d7ab04..526af2f9df 100644 --- a/theories/Numbers/NatInt/NZLog.v +++ b/theories/Numbers/NatInt/NZLog.v @@ -335,7 +335,7 @@ Qed. Lemma log2_succ_or : forall a, log2 (S a) == S (log2 a) \/ log2 (S a) == log2 a. Proof. - intros. + intros a. destruct (le_gt_cases (log2 (S a)) (log2 a)) as [H|H]. - right. generalize (log2_le_mono _ _ (le_succ_diag_r a)); order. - left. apply le_succ_l in H. generalize (log2_succ_le a); order. @@ -601,7 +601,7 @@ Lemma log2_log2_up_exact : Proof. intros a Ha. split. - - intros. exists (log2 a). + - intros H. exists (log2 a). generalize (log2_log2_up_spec a Ha). rewrite <-H. destruct 1; order. - intros (b,Hb). rewrite Hb. @@ -806,8 +806,8 @@ Qed. Lemma log2_up_succ_or : forall a, log2_up (S a) == S (log2_up a) \/ log2_up (S a) == log2_up a. Proof. - intros. - destruct (le_gt_cases (log2_up (S a)) (log2_up a)). + intros a. + destruct (le_gt_cases (log2_up (S a)) (log2_up a)) as [H|H]. - right. generalize (log2_up_le_mono _ _ (le_succ_diag_r a)); order. - left. apply le_succ_l in H. generalize (log2_up_succ_le a); order. Qed. diff --git a/theories/Numbers/NatInt/NZMul.v b/theories/Numbers/NatInt/NZMul.v index 9ddf7cb0eb..3d6465191d 100644 --- a/theories/Numbers/NatInt/NZMul.v +++ b/theories/Numbers/NatInt/NZMul.v @@ -17,7 +17,7 @@ Include NZAddProp NZ NZBase. Theorem mul_0_r : forall n, n * 0 == 0. Proof. -nzinduct n; intros; now nzsimpl. +intro n; nzinduct n; intros; now nzsimpl. Qed. Theorem mul_succ_r : forall n m, n * (S m) == n * m + n. diff --git a/theories/Numbers/NatInt/NZMulOrder.v b/theories/Numbers/NatInt/NZMulOrder.v index 46749504a9..c67bbe38d8 100644 --- a/theories/Numbers/NatInt/NZMulOrder.v +++ b/theories/Numbers/NatInt/NZMulOrder.v @@ -46,7 +46,7 @@ Qed. Theorem mul_lt_mono_neg_l : forall p n m, p < 0 -> (n < m <-> p * m < p * n). Proof. -nzord_induct p. +intro p; nzord_induct p. - order. - intros p Hp _ n m Hp'. apply lt_succ_l in Hp'. order. - intros p Hp IH n m _. apply le_succ_l in Hp. @@ -196,7 +196,7 @@ Qed. Theorem mul_nonneg_nonneg : forall n m, 0 <= n -> 0 <= m -> 0 <= n*m. Proof. -intros. rewrite <- (mul_0_l m). apply mul_le_mono_nonneg; order. +intros n m Hn Hm. rewrite <- (mul_0_l m). apply mul_le_mono_nonneg; order. Qed. Theorem mul_pos_cancel_l : forall n m, 0 < n -> (0 < n*m <-> 0 < m). @@ -343,7 +343,7 @@ Qed. Lemma square_nonneg : forall a, 0 <= a * a. Proof. - intros. rewrite <- (mul_0_r a). destruct (le_gt_cases a 0). + intro a. rewrite <- (mul_0_r a). destruct (le_gt_cases a 0). - now apply mul_le_mono_nonpos_l. - apply mul_le_mono_nonneg_l; order. Qed. @@ -391,7 +391,7 @@ Qed. Lemma quadmul_le_squareadd : forall a b, 0<=a -> 0<=b -> 2*2*a*b <= (a+b)*(a+b). Proof. - intros. + intros a b Ha Hb. nzsimpl'. rewrite !mul_add_distr_l, !mul_add_distr_r. rewrite (add_comm _ (b*b)), add_assoc. diff --git a/theories/Numbers/NatInt/NZOrder.v b/theories/Numbers/NatInt/NZOrder.v index d576902c5c..68bb974c5d 100644 --- a/theories/Numbers/NatInt/NZOrder.v +++ b/theories/Numbers/NatInt/NZOrder.v @@ -65,7 +65,7 @@ Qed. Theorem le_succ_l : forall n m, S n <= m <-> n < m. Proof. -intro n; nzinduct m n. +intros n m; nzinduct m n. - split; intro H. + false_hyp H nle_succ_diag_l. + false_hyp H lt_irrefl. - intro m. rewrite (lt_eq_cases (S n) (S m)), !lt_succ_r, (lt_eq_cases n m), succ_inj_wd. @@ -362,7 +362,7 @@ induction does not go through, so we need to use strong Lemma lt_exists_pred_strong : forall z n m, z < m -> m <= n -> exists k, m == S k /\ z <= k. Proof. -intro z; nzinduct n z. +intros z n; nzinduct n z. - order. - intro n; split; intros IH m H1 H2. + apply le_succ_r in H2. destruct H2 as [H2 | H2]. @@ -373,7 +373,7 @@ Qed. Theorem lt_exists_pred : forall z n, z < n -> exists k, n == S k /\ z <= k. Proof. -intros z n H; apply lt_exists_pred_strong with (z := z) (n := n). +intros z n H; apply (lt_exists_pred_strong z n). - assumption. - apply le_refl. Qed. @@ -428,12 +428,12 @@ Qed. Lemma A'A_right : (forall n, A' n) -> forall n, z <= n -> A n. Proof. -intros H1 n H2. apply H1 with (n := S n); [assumption | apply lt_succ_diag_r]. +intros H1 n H2. apply (H1 (S n)); [assumption | apply lt_succ_diag_r]. Qed. Theorem strong_right_induction: right_step' -> forall n, z <= n -> A n. Proof. -intro RS'; apply A'A_right; unfold A'; nzinduct n z; +intro RS'; apply A'A_right; unfold A'; intro n; nzinduct n z; [apply rbase | apply rs'_rs''; apply RS']. Qed. @@ -504,7 +504,7 @@ Qed. Theorem strong_left_induction: left_step' -> forall n, n <= z -> A n. Proof. -intro LS'; apply A'A_left; unfold A'; nzinduct n (S z); +intro LS'; apply A'A_left; unfold A'; intro n; nzinduct n (S z); [apply lbase | apply ls'_ls''; apply LS']. Qed. @@ -629,8 +629,7 @@ Qed. Theorem lt_wf : well_founded Rlt. Proof. unfold well_founded. -apply strong_right_induction' with (z := z). -- auto with typeclass_instances. +apply (strong_right_induction' _ _ z). - intros n H; constructor; intros y [H1 H2]. apply nle_gt in H2. elim H2. now apply le_trans with z. - intros n H1 H2; constructor; intros m [H3 H4]. now apply H2. @@ -639,8 +638,7 @@ Qed. Theorem gt_wf : well_founded Rgt. Proof. unfold well_founded. -apply strong_left_induction' with (z := z). -- auto with typeclass_instances. +apply (strong_left_induction' _ _ z). - intros n H; constructor; intros y [H1 H2]. apply nle_gt in H2. + elim H2. diff --git a/theories/Numbers/NatInt/NZParity.v b/theories/Numbers/NatInt/NZParity.v index ee6f4014f0..07a33e3f67 100644 --- a/theories/Numbers/NatInt/NZParity.v +++ b/theories/Numbers/NatInt/NZParity.v @@ -47,7 +47,7 @@ Qed. Lemma Even_or_Odd : forall x, Even x \/ Odd x. Proof. - nzinduct x. + intro x; nzinduct x. - left. exists 0. now nzsimpl. - intros x. split; intros [(y,H)|(y,H)]. @@ -86,7 +86,7 @@ Qed. Lemma orb_even_odd : forall n, orb (even n) (odd n) = true. Proof. - intros. + intros n. destruct (Even_or_Odd n) as [H|H]. - rewrite <- even_spec in H. now rewrite H. - rewrite <- odd_spec in H. now rewrite H, orb_true_r. @@ -94,7 +94,7 @@ Qed. Lemma negb_odd : forall n, negb (odd n) = even n. Proof. - intros. + intros n. generalize (Even_or_Odd n) (Even_Odd_False n). rewrite <- even_spec, <- odd_spec. destruct (odd n), (even n) ; simpl; intuition. @@ -188,7 +188,7 @@ Qed. Lemma even_add : forall n m, even (n+m) = Bool.eqb (even n) (even m). Proof. - intros. + intros n m. case_eq (even n); case_eq (even m); rewrite <- ?negb_true_iff, ?negb_even, ?odd_spec, ?even_spec; intros (m',Hm) (n',Hn). @@ -200,7 +200,7 @@ Qed. Lemma odd_add : forall n m, odd (n+m) = xorb (odd n) (odd m). Proof. - intros. rewrite <- !negb_even. rewrite even_add. + intros n m. rewrite <- !negb_even. rewrite even_add. now destruct (even n), (even m). Qed. @@ -208,7 +208,7 @@ Qed. Lemma even_mul : forall n m, even (mul n m) = even n || even m. Proof. - intros. + intros n m. case_eq (even n); simpl; rewrite ?even_spec. - intros (n',Hn). exists (n'*m). now rewrite Hn, mul_assoc. - case_eq (even m); simpl; rewrite ?even_spec. @@ -222,7 +222,7 @@ Qed. Lemma odd_mul : forall n m, odd (mul n m) = odd n && odd m. Proof. - intros. rewrite <- !negb_even. rewrite even_mul. + intros n m. rewrite <- !negb_even. rewrite even_mul. now destruct (even n), (even m). Qed. diff --git a/theories/Numbers/NatInt/NZPow.v b/theories/Numbers/NatInt/NZPow.v index 01a15686e0..3b2a496229 100644 --- a/theories/Numbers/NatInt/NZPow.v +++ b/theories/Numbers/NatInt/NZPow.v @@ -238,7 +238,7 @@ Qed. Lemma pow_le_mono : forall a b c d, 0<a<=c -> b<=d -> a^b <= c^d. Proof. - intros. transitivity (a^d). + intros a b c d ? ?. transitivity (a^d). - apply pow_le_mono_r; intuition order. - apply pow_le_mono_l; intuition order. Qed. diff --git a/theories/Numbers/NatInt/NZSqrt.v b/theories/Numbers/NatInt/NZSqrt.v index 446ed07b53..4122632603 100644 --- a/theories/Numbers/NatInt/NZSqrt.v +++ b/theories/Numbers/NatInt/NZSqrt.v @@ -58,7 +58,7 @@ Qed. Lemma sqrt_nonneg : forall a, 0<=√a. Proof. - intros. destruct (lt_ge_cases a 0) as [Ha|Ha]. + intros a. destruct (lt_ge_cases a 0) as [Ha|Ha]. - now rewrite (sqrt_neg _ Ha). - apply sqrt_spec_nonneg. destruct (sqrt_spec a Ha). order. Qed. @@ -429,7 +429,7 @@ Qed. Lemma sqrt_up_nonneg : forall a, 0<=√°a. Proof. - intros. destruct (le_gt_cases a 0) as [Ha|Ha]. + intros a. destruct (le_gt_cases a 0) as [Ha|Ha]. - now rewrite sqrt_up_eqn0. - rewrite sqrt_up_eqn; trivial. apply le_le_succ_r, sqrt_nonneg. Qed. @@ -527,7 +527,7 @@ Lemma sqrt_sqrt_up_exact : forall a, 0<=a -> (√a == √°a <-> exists b, 0<=b /\ a == b²). Proof. intros a Ha. - split. - intros. exists √a. + split. - intros H. exists √a. split. + apply sqrt_nonneg. + generalize (sqrt_sqrt_up_spec a Ha). rewrite <-H. destruct 1; order. - intros (b & Hb & Hb'). rewrite Hb'. diff --git a/theories/PArith/BinPos.v b/theories/PArith/BinPos.v index c8414c241d..e73060af0b 100644 --- a/theories/PArith/BinPos.v +++ b/theories/PArith/BinPos.v @@ -1886,7 +1886,7 @@ Bind Scope positive_scope with Pos.t positive. (** Exportation of notations *) -Numeral Notation positive Pos.of_num_int Pos.to_num_uint : positive_scope. +Number Notation positive Pos.of_num_int Pos.to_num_uint : positive_scope. Infix "+" := Pos.add : positive_scope. Infix "-" := Pos.sub : positive_scope. diff --git a/theories/PArith/BinPosDef.v b/theories/PArith/BinPosDef.v index cdb9af542c..b41cd571dc 100644 --- a/theories/PArith/BinPosDef.v +++ b/theories/PArith/BinPosDef.v @@ -697,9 +697,9 @@ Definition to_hex_int p := Hexadecimal.Pos (to_hex_uint p). Definition to_num_int n := Numeral.IntDec (to_int n). -Numeral Notation positive of_num_int to_num_uint : positive_scope. +Number Notation positive of_num_int to_num_uint : positive_scope. End Pos. (** Re-export the notation for those who just [Import BinPosDef] *) -Numeral Notation positive Pos.of_num_int Pos.to_num_uint : positive_scope. +Number Notation positive Pos.of_num_int Pos.to_num_uint : positive_scope. diff --git a/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v index 84d70e56de..192dcd885b 100644 --- a/theories/QArith/QArith_base.v +++ b/theories/QArith/QArith_base.v @@ -129,7 +129,7 @@ Definition to_numeral (q:Q) : option Numeral.numeral := | Some q => Some (Numeral.Dec q) end. -Numeral Notation Q of_numeral to_numeral : Q_scope. +Number Notation Q of_numeral to_numeral : Q_scope. Definition inject_Z (x : Z) := Qmake x 1. Arguments inject_Z x%Z. diff --git a/theories/Relations/Operators_Properties.v b/theories/Relations/Operators_Properties.v index 72183f76e6..51be2bd956 100644 --- a/theories/Relations/Operators_Properties.v +++ b/theories/Relations/Operators_Properties.v @@ -54,8 +54,7 @@ Section Properties. Lemma clos_rt_idempotent : inclusion (R*)* R*. Proof. red. - induction 1; auto with sets. - intros. + induction 1 as [x y H|x|x y z H IH H0 IH0]; auto with sets. apply rt_trans with y; auto with sets. Qed. @@ -70,7 +69,7 @@ Section Properties. inclusion (clos_refl_trans R) (clos_refl_sym_trans R). Proof. red. - induction 1; auto with sets. + induction 1 as [x y H|x|x y z H IH H0 IH0]; auto with sets. apply rst_trans with y; auto with sets. Qed. @@ -90,7 +89,7 @@ Section Properties. clos_trans R x z. Proof. induction 1 as [b d H1|b|a b d H1 H2 IH1 IH2]; auto. - intro H. apply t_trans with (y:=d); auto. + intro H. apply (t_trans _ _ _ d); auto. constructor. auto. Qed. @@ -111,7 +110,7 @@ Section Properties. (clos_refl_sym_trans R). Proof. red. - induction 1; auto with sets. + induction 1 as [x y H|x|x y H IH|x y z H IH H0 IH0]; auto with sets. apply rst_trans with y; auto with sets. Qed. @@ -128,7 +127,7 @@ Section Properties. Lemma clos_t1n_trans : forall x y, clos_trans_1n R x y -> clos_trans R x y. Proof. - induction 1. + induction 1 as [x y H|x y z H H0 IH0]. - left; assumption. - right with y; auto. left; auto. @@ -136,9 +135,10 @@ Section Properties. Lemma clos_trans_t1n : forall x y, clos_trans R x y -> clos_trans_1n R x y. Proof. - induction 1. + induction 1 as [x y H|x y z H IHclos_trans1 H0 IHclos_trans2]. - left; assumption. - - generalize IHclos_trans2; clear IHclos_trans2; induction IHclos_trans1. + - generalize IHclos_trans2; clear IHclos_trans2. + induction IHclos_trans1 as [x y H1|x y z0 H1 ? IHIHclos_trans1]. + right with y; auto. + right with y; auto. eapply IHIHclos_trans1; auto. @@ -157,7 +157,7 @@ Section Properties. Lemma clos_tn1_trans : forall x y, clos_trans_n1 R x y -> clos_trans R x y. Proof. - induction 1. + induction 1 as [y H|y z H H0 ?]. - left; assumption. - right with y; auto. left; assumption. @@ -165,13 +165,13 @@ Section Properties. Lemma clos_trans_tn1 : forall x y, clos_trans R x y -> clos_trans_n1 R x y. Proof. - induction 1. + induction 1 as [x y H|x y z H IHclos_trans1 H0 IHclos_trans2]. - left; assumption. - elim IHclos_trans2. + intro y0; right with y. * auto. * auto. - + intros. + + intro y0; intros. right with y0; auto. Qed. @@ -201,7 +201,7 @@ Section Properties. Lemma clos_rt1n_rt : forall x y, clos_refl_trans_1n R x y -> clos_refl_trans R x y. Proof. - induction 1. + induction 1 as [|x y z]. - constructor 2. - constructor 3 with y; auto. constructor 1; auto. @@ -210,14 +210,14 @@ Section Properties. Lemma clos_rt_rt1n : forall x y, clos_refl_trans R x y -> clos_refl_trans_1n R x y. Proof. - induction 1. + induction 1 as [| |x y z H IHclos_refl_trans1 H0 IHclos_refl_trans2]. - apply clos_rt1n_step; assumption. - left. - generalize IHclos_refl_trans2; clear IHclos_refl_trans2; - induction IHclos_refl_trans1; auto. + induction IHclos_refl_trans1 as [|x y z0 H1 ? IH]; auto. right with y; auto. - eapply IHIHclos_refl_trans1; auto. + eapply IH; auto. apply clos_rt1n_rt; auto. Qed. @@ -235,7 +235,7 @@ Section Properties. Lemma clos_rtn1_rt : forall x y, clos_refl_trans_n1 R x y -> clos_refl_trans R x y. Proof. - induction 1. + induction 1 as [|y z]. - constructor 2. - constructor 3 with y; auto. constructor 1; assumption. @@ -244,11 +244,11 @@ Section Properties. Lemma clos_rt_rtn1 : forall x y, clos_refl_trans R x y -> clos_refl_trans_n1 R x y. Proof. - induction 1. + induction 1 as [| |x y z H1 IH1 H2 IH2]. - apply clos_rtn1_step; auto. - left. - - elim IHclos_refl_trans2; auto. - intros. + - elim IH2; auto. + intro y0; intros. right with y0; auto. Qed. @@ -267,16 +267,16 @@ Section Properties. (forall y z:A, clos_refl_trans R x y -> P y -> R y z -> P z) -> forall z:A, clos_refl_trans R x z -> P z. Proof. - intros. + intros x P H H0 z H1. revert H H0. - induction H1; intros; auto with sets. - - apply H1 with x; auto with sets. + induction H1 as [x| |x y z H1 IH1 H2 IH2]; intros HP HIS; auto with sets. + - apply HIS with x; auto with sets. - - apply IHclos_refl_trans2. - + apply IHclos_refl_trans1; auto with sets. + - apply IH2. + + apply IH1; auto with sets. - + intros. - apply H0 with y0; auto with sets. + + intro y0; intros; + apply HIS with y0; auto with sets. apply rt_trans with y; auto with sets. Qed. @@ -286,7 +286,7 @@ Section Properties. P z -> (forall x y, R x y -> clos_refl_trans_1n R y z -> P y -> P x) -> forall x, clos_refl_trans_1n R x z -> P x. - induction 3; auto. + intros P z H H0 x; induction 1 as [|x y z]; auto. apply H0 with y; auto. Qed. @@ -309,7 +309,7 @@ Section Properties. Lemma clos_rst1n_rst : forall x y, clos_refl_sym_trans_1n R x y -> clos_refl_sym_trans R x y. Proof. - induction 1. + induction 1 as [|x y z H]. - constructor 2. - constructor 4 with y; auto. case H;[constructor 1|constructor 3; constructor 1]; auto. @@ -317,7 +317,7 @@ Section Properties. Lemma clos_rst1n_trans : forall x y z, clos_refl_sym_trans_1n R x y -> clos_refl_sym_trans_1n R y z -> clos_refl_sym_trans_1n R x z. - induction 1. + induction 1 as [|x y z0]. - auto. - intros; right with y; eauto. Qed. @@ -335,7 +335,7 @@ Section Properties. Lemma clos_rst_rst1n : forall x y, clos_refl_sym_trans R x y -> clos_refl_sym_trans_1n R x y. - induction 1. + induction 1 as [x y| | |]. - constructor 2 with y; auto. constructor 1. - constructor 1. @@ -357,7 +357,7 @@ Section Properties. Lemma clos_rstn1_rst : forall x y, clos_refl_sym_trans_n1 R x y -> clos_refl_sym_trans R x y. Proof. - induction 1. + induction 1 as [|y z H]. - constructor 2. - constructor 4 with y; auto. case H;[constructor 1|constructor 3; constructor 1]; auto. @@ -367,10 +367,9 @@ Section Properties. clos_refl_sym_trans_n1 R y z -> clos_refl_sym_trans_n1 R x z. Proof. intros x y z H1 H2. - induction H2. + induction H2 as [|y0 z]. - auto. - - intros. - right with y0; eauto. + - right with y0; eauto. Qed. Lemma clos_rstn1_sym : forall x y, clos_refl_sym_trans_n1 R x y -> @@ -387,7 +386,7 @@ Section Properties. Lemma clos_rst_rstn1 : forall x y, clos_refl_sym_trans R x y -> clos_refl_sym_trans_n1 R x y. Proof. - induction 1. + induction 1 as [x| | |]. - constructor 2 with x; auto. constructor 1. - constructor 1. diff --git a/theories/Relations/Relations.v b/theories/Relations/Relations.v index 0a5128f093..dea76694f3 100644 --- a/theories/Relations/Relations.v +++ b/theories/Relations/Relations.v @@ -16,16 +16,16 @@ Lemma inverse_image_of_equivalence : forall (A B:Type) (f:A -> B) (r:relation B), equivalence B r -> equivalence A (fun x y:A => r (f x) (f y)). Proof. - intros; split; elim H; red; auto. + intros A B f r H; split; elim H; red; auto. intros _ equiv_trans _ x y z H0 H1; apply equiv_trans with (f y); assumption. Qed. Lemma inverse_image_of_eq : forall (A B:Type) (f:A -> B), equivalence A (fun x y:A => f x = f y). Proof. - split; red; + intros A B f; split; red; [ (* reflexivity *) reflexivity - | (* transitivity *) intros; transitivity (f y); assumption + | (* transitivity *) intros x y z; transitivity (f y); assumption | (* symmetry *) intros; symmetry ; assumption ]. Qed. diff --git a/theories/Setoids/Setoid.v b/theories/Setoids/Setoid.v index b10c4f3768..cec1033fdf 100644 --- a/theories/Setoids/Setoid.v +++ b/theories/Setoids/Setoid.v @@ -33,7 +33,7 @@ Defined. Definition Seq_trans A Aeq (s : Setoid_Theory A Aeq) : forall x y z:A, Aeq x y -> Aeq y z -> Aeq x z. Proof. - unfold Setoid_Theory in s. intros ; transitivity y ; assumption. + unfold Setoid_Theory in s. intros x y z H0 H1 ; transitivity y ; assumption. Defined. (** Some tactics for manipulating Setoid Theory not officially diff --git a/theories/Sorting/Permutation.v b/theories/Sorting/Permutation.v index 026cf32ceb..2f445c341a 100644 --- a/theories/Sorting/Permutation.v +++ b/theories/Sorting/Permutation.v @@ -522,6 +522,18 @@ Proof. repeat red; eauto using Permutation_NoDup. Qed. +Lemma Permutation_repeat x n l : + Permutation l (repeat x n) -> l = repeat x n. +Proof. + revert n; induction l as [|y l IHl] ; simpl; intros n HP; auto. + - now apply Permutation_nil in HP; inversion HP. + - assert (y = x) as Heq by (now apply repeat_spec with n, (Permutation_in _ HP); left); subst. + destruct n; simpl; simpl in HP. + + symmetry in HP; apply Permutation_nil in HP; inversion HP. + + f_equal; apply IHl. + now apply Permutation_cons_inv with x. +Qed. + End Permutation_properties. Section Permutation_map. diff --git a/theories/Structures/GenericMinMax.v b/theories/Structures/GenericMinMax.v index 8d20ce77f9..1af6aebec6 100644 --- a/theories/Structures/GenericMinMax.v +++ b/theories/Structures/GenericMinMax.v @@ -629,9 +629,9 @@ Module TOMaxEqDec_to_Compare if eq_dec x y then Eq else if eq_dec (M.max x y) y then Lt else Gt. - Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). + Lemma compare_spec x y : CompSpec eq lt x y (compare x y). Proof. - intros; unfold compare; repeat destruct eq_dec; auto; constructor. + unfold compare; repeat destruct eq_dec; auto; constructor. - destruct (lt_total x y); auto. absurd (x==y); auto. transitivity (max x y); auto. symmetry. apply max_l. rewrite le_lteq; intuition. diff --git a/theories/Structures/Orders.v b/theories/Structures/Orders.v index 94938c1d4d..b3e3b6e853 100644 --- a/theories/Structures/Orders.v +++ b/theories/Structures/Orders.v @@ -165,7 +165,7 @@ End OT_to_Full. Module OTF_LtIsTotal (Import O:OrderedTypeFull') <: LtIsTotal O. Lemma lt_total : forall x y, x<y \/ x==y \/ y<x. - Proof. intros; destruct (compare_spec x y); auto. Qed. + Proof. intros x y; destruct (compare_spec x y); auto. Qed. End OTF_LtIsTotal. Module OTF_to_TotalOrder (O:OrderedTypeFull) <: TotalOrder @@ -250,7 +250,7 @@ Module OTF_to_TTLB (Import O : OrderedTypeFull') <: TotalTransitiveLeBool. Lemma leb_le : forall x y, leb x y <-> x <= y. Proof. - intros. unfold leb. rewrite le_lteq. + intros x y. unfold leb. rewrite le_lteq. destruct (compare_spec x y) as [EQ|LT|GT]; split; auto. - discriminate. - intros LE. elim (StrictOrder_Irreflexive x). @@ -261,7 +261,7 @@ Module OTF_to_TTLB (Import O : OrderedTypeFull') <: TotalTransitiveLeBool. Lemma leb_total : forall x y, leb x y \/ leb y x. Proof. - intros. rewrite 2 leb_le. rewrite 2 le_lteq. + intros x y. rewrite 2 leb_le. rewrite 2 le_lteq. destruct (compare_spec x y); intuition. Qed. @@ -302,7 +302,7 @@ Module TTLB_to_OTF (Import O : TotalTransitiveLeBool') <: OrderedTypeFull. Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). Proof. - intros. unfold compare. + intros x y. unfold compare. case_eq (x <=? y). - case_eq (y <=? x). + constructor. split; auto. @@ -352,7 +352,7 @@ Module TTLB_to_OTF (Import O : TotalTransitiveLeBool') <: OrderedTypeFull. Definition le_lteq : forall x y, le x y <-> lt x y \/ eq x y. Proof. - intros. + intros x y. unfold lt, eq, le. split; [ | intuition ]. intros LE. diff --git a/theories/Structures/OrdersFacts.v b/theories/Structures/OrdersFacts.v index d5a76ee69f..4ac54d280a 100644 --- a/theories/Structures/OrdersFacts.v +++ b/theories/Structures/OrdersFacts.v @@ -102,10 +102,10 @@ Module OrderedTypeFullFacts (Import O:OrderedTypeFull'). Proof. iorder. Qed. Lemma le_or_gt : forall x y, x<=y \/ y<x. - Proof. intros. rewrite le_lteq; destruct (O.compare_spec x y); auto. Qed. + Proof. intros x y. rewrite le_lteq; destruct (O.compare_spec x y); auto. Qed. Lemma lt_or_ge : forall x y, x<y \/ y<=x. - Proof. intros. rewrite le_lteq; destruct (O.compare_spec x y); iorder. Qed. + Proof. intros x y. rewrite le_lteq; destruct (O.compare_spec x y); iorder. Qed. Lemma eq_is_le_ge : forall x y, x==y <-> x<=y /\ y<=x. Proof. iorder. Qed. @@ -175,11 +175,11 @@ Module OrderedTypeFacts (Import O: OrderedType'). Definition eqb x y : bool := if eq_dec x y then true else false. - Lemma if_eq_dec : forall x y (B:Type)(b b':B), + Lemma if_eq_dec x y (B:Type)(b b':B) : (if eq_dec x y then b else b') = (match compare x y with Eq => b | _ => b' end). Proof. - intros; destruct eq_dec; elim_compare x y; auto; order. + destruct eq_dec; elim_compare x y; auto; order. Qed. Lemma eqb_alt : @@ -257,7 +257,7 @@ Definition compare := flip O.compare. Lemma compare_spec : forall x y, CompSpec eq lt x y (compare x y). Proof. -intros; unfold compare, eq, lt, flip. +intros x y; unfold compare, eq, lt, flip. destruct (O.compare_spec y x); auto with relations. Qed. diff --git a/theories/Structures/OrdersTac.v b/theories/Structures/OrdersTac.v index 408348139d..1c8073972d 100644 --- a/theories/Structures/OrdersTac.v +++ b/theories/Structures/OrdersTac.v @@ -100,9 +100,9 @@ Definition interp_ord o := match o with OEQ => O.eq | OLT => O.lt | OLE => O.le end. Local Notation "#" := interp_ord. -Lemma trans : forall o o' x y z, #o x y -> #o' y z -> #(o+o') x z. +Lemma trans o o' x y z : #o x y -> #o' y z -> #(o+o') x z. Proof. -destruct o, o'; simpl; intros x y z; +destruct o, o'; simpl; rewrite ?P.le_lteq; intuition auto; subst_eqns; eauto using (StrictOrder_Transitive x y z) with *. Qed. diff --git a/theories/ZArith/BinInt.v b/theories/ZArith/BinInt.v index a566348dd5..9a30e011af 100644 --- a/theories/ZArith/BinInt.v +++ b/theories/ZArith/BinInt.v @@ -1297,7 +1297,7 @@ Bind Scope Z_scope with Z.t Z. (** Re-export Notations *) -Numeral Notation Z Z.of_num_int Z.to_num_int : Z_scope. +Number Notation Z Z.of_num_int Z.to_num_int : Z_scope. Infix "+" := Z.add : Z_scope. Notation "- x" := (Z.opp x) : Z_scope. diff --git a/theories/ZArith/BinIntDef.v b/theories/ZArith/BinIntDef.v index 8464ad1012..69ed101f24 100644 --- a/theories/ZArith/BinIntDef.v +++ b/theories/ZArith/BinIntDef.v @@ -668,9 +668,9 @@ Definition lxor a b := | neg a, neg b => of_N (N.lxor (Pos.pred_N a) (Pos.pred_N b)) end. -Numeral Notation Z of_num_int to_num_int : Z_scope. +Number Notation Z of_num_int to_num_int : Z_scope. End Z. (** Re-export the notation for those who just [Import BinIntDef] *) -Numeral Notation Z Z.of_num_int Z.to_num_int : Z_scope. +Number Notation Z Z.of_num_int Z.to_num_int : Z_scope. diff --git a/theories/micromega/Lia.v b/theories/micromega/Lia.v index b2c5884ed7..ef2f139133 100644 --- a/theories/micromega/Lia.v +++ b/theories/micromega/Lia.v @@ -20,7 +20,10 @@ Require Coq.micromega.Tauto. Declare ML Module "micromega_plugin". Ltac zchecker := - intros ?__wit ?__varmap ?__ff ; + let __wit := fresh "__wit" in + let __varmap := fresh "__varmap" in + let __ff := fresh "__ff" in + intros __wit __varmap __ff ; exact (ZTautoChecker_sound __ff __wit (@eq_refl bool true <: @eq bool (ZTautoChecker __ff __wit) true) (@find Z Z0 __varmap)). diff --git a/theories/nsatz/Nsatz.v b/theories/nsatz/Nsatz.v index 70180f47c7..b684775bb4 100644 --- a/theories/nsatz/Nsatz.v +++ b/theories/nsatz/Nsatz.v @@ -75,43 +75,3 @@ red. exact Rmult_comm. Defined. Instance Rdi : (Integral_domain (Rcr:=Rcri)). constructor. exact Rmult_integral. exact R_one_zero. Defined. - -(* Rational numbers *) -Require Import QArith. - -Instance Qops: (@Ring_ops Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq). -Defined. - -Instance Qri : (Ring (Ro:=Qops)). -constructor. -try apply Q_Setoid. -apply Qplus_comp. -apply Qmult_comp. -apply Qminus_comp. -apply Qopp_comp. - exact Qplus_0_l. exact Qplus_comm. apply Qplus_assoc. - exact Qmult_1_l. exact Qmult_1_r. apply Qmult_assoc. - apply Qmult_plus_distr_l. intros. apply Qmult_plus_distr_r. -reflexivity. exact Qplus_opp_r. -Defined. - -Lemma Q_one_zero: not (Qeq 1%Q 0%Q). -Proof. unfold Qeq. simpl. lia. Qed. - -Instance Qcri: (Cring (Rr:=Qri)). -red. exact Qmult_comm. Defined. - -Instance Qdi : (Integral_domain (Rcr:=Qcri)). -constructor. -exact Qmult_integral. exact Q_one_zero. Defined. - -(* Integers *) -Lemma Z_one_zero: 1%Z <> 0%Z. -Proof. lia. Qed. - -Instance Zcri: (Cring (Rr:=Zr)). -red. exact Z.mul_comm. Defined. - -Instance Zdi : (Integral_domain (Rcr:=Zcri)). -constructor. -exact Zmult_integral. exact Z_one_zero. Defined. diff --git a/theories/nsatz/NsatzTactic.v b/theories/nsatz/NsatzTactic.v index db7dab2c46..0d24de39d1 100644 --- a/theories/nsatz/NsatzTactic.v +++ b/theories/nsatz/NsatzTactic.v @@ -447,3 +447,43 @@ Tactic Notation "nsatz" "with" repeat equalities_to_goal; nsatz_generic radicalmax info lparam lvar end. + +(* Rational numbers *) +Require Import QArith. + +Instance Qops: (@Ring_ops Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq). +Defined. + +Instance Qri : (Ring (Ro:=Qops)). +constructor. +try apply Q_Setoid. +apply Qplus_comp. +apply Qmult_comp. +apply Qminus_comp. +apply Qopp_comp. + exact Qplus_0_l. exact Qplus_comm. apply Qplus_assoc. + exact Qmult_1_l. exact Qmult_1_r. apply Qmult_assoc. + apply Qmult_plus_distr_l. intros. apply Qmult_plus_distr_r. +reflexivity. exact Qplus_opp_r. +Defined. + +Lemma Q_one_zero: not (Qeq 1%Q 0%Q). +Proof. unfold Qeq. simpl. lia. Qed. + +Instance Qcri: (Cring (Rr:=Qri)). +red. exact Qmult_comm. Defined. + +Instance Qdi : (Integral_domain (Rcr:=Qcri)). +constructor. +exact Qmult_integral. exact Q_one_zero. Defined. + +(* Integers *) +Lemma Z_one_zero: 1%Z <> 0%Z. +Proof. lia. Qed. + +Instance Zcri: (Cring (Rr:=Zr)). +red. exact Z.mul_comm. Defined. + +Instance Zdi : (Integral_domain (Rcr:=Zcri)). +constructor. +exact Zmult_integral. exact Z_one_zero. Defined. diff --git a/theories/ssr/ssrbool.v b/theories/ssr/ssrbool.v index be84e217a5..f35da63fd6 100644 --- a/theories/ssr/ssrbool.v +++ b/theories/ssr/ssrbool.v @@ -546,6 +546,38 @@ Proof. by move/contra=> notb_notc /notb_notc/negbTE. Qed. Lemma contraFF (c b : bool) : (c -> b) -> b = false -> c = false. Proof. by move/contraFN=> bF_notc /bF_notc/negbTE. Qed. +(* additional contra lemmas involving [P,Q : Prop] *) +Lemma contra_not (P Q : Prop) : (Q -> P) -> (~ P -> ~ Q). Proof. by auto. Qed. + +Lemma contraPnot (P Q : Prop) : (Q -> ~ P) -> (P -> ~ Q). Proof. by auto. Qed. + +Lemma contraTnot (b : bool) (P : Prop) : (P -> ~~ b) -> (b -> ~ P). +Proof. by case: b; auto. Qed. + +Lemma contraNnot (P : Prop) (b : bool) : (P -> b) -> (~~ b -> ~ P). +Proof. rewrite -{1}[b]negbK; exact: contraTnot. Qed. + +Lemma contraPT (P : Prop) (b : bool) : (~~ b -> ~ P) -> P -> b. +Proof. by case: b => //= /(_ isT) nP /nP. Qed. + +Lemma contra_notT (P : Prop) (b : bool) : (~~ b -> P) -> ~ P -> b. +Proof. by case: b => //= /(_ isT) HP /(_ HP). Qed. + +Lemma contra_notN (P : Prop) (b : bool) : (b -> P) -> ~ P -> ~~ b. +Proof. rewrite -{1}[b]negbK; exact: contra_notT. Qed. + +Lemma contraPN (P : Prop) (b : bool) : (b -> ~ P) -> (P -> ~~ b). +Proof. by case: b => //=; move/(_ isT) => HP /HP. Qed. + +Lemma contraFnot (P : Prop) (b : bool) : (P -> b) -> b = false -> ~ P. +Proof. by case: b => //; auto. Qed. + +Lemma contraPF (P : Prop) (b : bool) : (b -> ~ P) -> P -> b = false. +Proof. by case: b => // /(_ isT). Qed. + +Lemma contra_notF (P : Prop) (b : bool) : (b -> P) -> ~ P -> b = false. +Proof. by case: b => // /(_ isT). Qed. + (** Coercion of sum-style datatypes into bool, which makes it possible to use ssr's boolean if rather than Coq's "generic" if. **) @@ -1310,7 +1342,8 @@ Definition SimplRel {T} (r : rel T) : simpl_rel T := fun x => SimplPred (r x). Definition relU {T} (r1 r2 : rel T) := SimplRel (xrelU r1 r2). Definition relpre {aT rT} (f : aT -> rT) (r : rel rT) := SimplRel (xrelpre f r). -Notation "[ 'rel' x y | E ]" := (SimplRel (fun x y => E%B)) : fun_scope. +Notation "[ 'rel' x y | E ]" := (SimplRel (fun x y => E%B)) + (only parsing) : fun_scope. Notation "[ 'rel' x y : T | E ]" := (SimplRel (fun x y : T => E%B)) (only parsing) : fun_scope. @@ -1980,12 +2013,10 @@ End MonoHomoMorphismTheory. Section MonoHomoMorphismTheory_in. -Variables (aT rT sT : predArgType) (f : aT -> rT) (g : rT -> aT). -Variable (aD : {pred aT}). +Variables (aT rT : predArgType) (f : aT -> rT) (g : rT -> aT). +Variables (aD : {pred aT}) (rD : {pred rT}). Variable (aP : pred aT) (rP : pred rT) (aR : rel aT) (rR : rel rT). -Notation rD := [pred x | g x \in aD]. - Lemma monoW_in : {in aD &, {mono f : x y / aR x y >-> rR x y}} -> {in aD &, {homo f : x y / aR x y >-> rR x y}}. @@ -1996,17 +2027,18 @@ Lemma mono2W_in : {in aD, {homo f : x / aP x >-> rP x}}. Proof. by move=> hf x hx ax; rewrite hf. Qed. -Hypothesis fgK_on : {on aD, cancel g & f}. +Hypothesis fgK : {in rD, {on aD, cancel g & f}}. +Hypothesis mem_g : {homo g : x / x \in rD >-> x \in aD}. Lemma homoRL_in : {in aD &, {homo f : x y / aR x y >-> rR x y}} -> {in rD & aD, forall x y, aR (g x) y -> rR x (f y)}. -Proof. by move=> Hf x y hx hy /Hf; rewrite fgK_on //; apply. Qed. +Proof. by move=> Hf x y hx hy /Hf; rewrite fgK ?mem_g// ?inE; apply. Qed. Lemma homoLR_in : {in aD &, {homo f : x y / aR x y >-> rR x y}} -> {in aD & rD, forall x y, aR x (g y) -> rR (f x) y}. -Proof. by move=> Hf x y hx hy /Hf; rewrite fgK_on //; apply. Qed. +Proof. by move=> Hf x y hx hy /Hf; rewrite fgK ?mem_g// ?inE; apply. Qed. Lemma homo_mono_in : {in aD &, {homo f : x y / aR x y >-> rR x y}} -> @@ -2014,22 +2046,119 @@ Lemma homo_mono_in : {in rD &, {mono g : x y / rR x y >-> aR x y}}. Proof. move=> mf mg x y hx hy; case: (boolP (rR _ _))=> [/mg //|]; first exact. -by apply: contraNF=> /mf; rewrite !fgK_on //; apply. +by apply: contraNF=> /mf; rewrite !fgK ?mem_g//; apply. Qed. Lemma monoLR_in : {in aD &, {mono f : x y / aR x y >-> rR x y}} -> {in aD & rD, forall x y, rR (f x) y = aR x (g y)}. -Proof. by move=> mf x y hx hy; rewrite -{1}[y]fgK_on // mf. Qed. +Proof. by move=> mf x y hx hy; rewrite -{1}[y]fgK ?mem_g// mf ?mem_g. Qed. Lemma monoRL_in : {in aD &, {mono f : x y / aR x y >-> rR x y}} -> {in rD & aD, forall x y, rR x (f y) = aR (g x) y}. -Proof. by move=> mf x y hx hy; rewrite -{1}[x]fgK_on // mf. Qed. +Proof. by move=> mf x y hx hy; rewrite -{1}[x]fgK ?mem_g// mf ?mem_g. Qed. Lemma can_mono_in : {in aD &, {mono f : x y / aR x y >-> rR x y}} -> {in rD &, {mono g : x y / rR x y >-> aR x y}}. -Proof. by move=> mf x y hx hy /=; rewrite -mf // !fgK_on. Qed. +Proof. by move=> mf x y hx hy; rewrite -mf ?mem_g// !fgK ?mem_g. Qed. End MonoHomoMorphismTheory_in. +Arguments homoRL_in {aT rT f g aD rD aR rR}. +Arguments homoLR_in {aT rT f g aD rD aR rR}. +Arguments homo_mono_in {aT rT f g aD rD aR rR}. +Arguments monoLR_in {aT rT f g aD rD aR rR}. +Arguments monoRL_in {aT rT f g aD rD aR rR}. +Arguments can_mono_in {aT rT f g aD rD aR rR}. + +Section HomoMonoMorphismFlip. +Variables (aT rT : Type) (aR : rel aT) (rR : rel rT) (f : aT -> rT). +Variable (aD aD' : {pred aT}). + +Lemma homo_sym : {homo f : x y / aR x y >-> rR x y} -> + {homo f : y x / aR x y >-> rR x y}. +Proof. by move=> fR y x; apply: fR. Qed. + +Lemma mono_sym : {mono f : x y / aR x y >-> rR x y} -> + {mono f : y x / aR x y >-> rR x y}. +Proof. by move=> fR y x; apply: fR. Qed. + +Lemma homo_sym_in : {in aD &, {homo f : x y / aR x y >-> rR x y}} -> + {in aD &, {homo f : y x / aR x y >-> rR x y}}. +Proof. by move=> fR y x yD xD; apply: fR. Qed. + +Lemma mono_sym_in : {in aD &, {mono f : x y / aR x y >-> rR x y}} -> + {in aD &, {mono f : y x / aR x y >-> rR x y}}. +Proof. by move=> fR y x yD xD; apply: fR. Qed. + +Lemma homo_sym_in11 : {in aD & aD', {homo f : x y / aR x y >-> rR x y}} -> + {in aD' & aD, {homo f : y x / aR x y >-> rR x y}}. +Proof. by move=> fR y x yD xD; apply: fR. Qed. + +Lemma mono_sym_in11 : {in aD & aD', {mono f : x y / aR x y >-> rR x y}} -> + {in aD' & aD, {mono f : y x / aR x y >-> rR x y}}. +Proof. by move=> fR y x yD xD; apply: fR. Qed. + +End HomoMonoMorphismFlip. +Arguments homo_sym {aT rT} [aR rR f]. +Arguments mono_sym {aT rT} [aR rR f]. +Arguments homo_sym_in {aT rT} [aR rR f aD]. +Arguments mono_sym_in {aT rT} [aR rR f aD]. +Arguments homo_sym_in11 {aT rT} [aR rR f aD aD']. +Arguments mono_sym_in11 {aT rT} [aR rR f aD aD']. + +Section CancelOn. + +Variables (aT rT : predArgType) (aD : {pred aT}) (rD : {pred rT}). +Variables (f : aT -> rT) (g : rT -> aT). + +Lemma onW_can : cancel g f -> {on aD, cancel g & f}. +Proof. by move=> fgK x xaD; apply: fgK. Qed. + +Lemma onW_can_in : {in rD, cancel g f} -> {in rD, {on aD, cancel g & f}}. +Proof. by move=> fgK x xrD xaD; apply: fgK. Qed. + +Lemma in_onW_can : cancel g f -> {in rD, {on aD, cancel g & f}}. +Proof. by move=> fgK x xrD xaD; apply: fgK. Qed. + +Lemma onS_can : (forall x, g x \in aD) -> {on aD, cancel g & f} -> cancel g f. +Proof. by move=> mem_g fgK x; apply: fgK. Qed. + +Lemma onS_can_in : {homo g : x / x \in rD >-> x \in aD} -> + {in rD, {on aD, cancel g & f}} -> {in rD, cancel g f}. +Proof. by move=> mem_g fgK x x_rD; apply/fgK/mem_g. Qed. + +Lemma in_onS_can : (forall x, g x \in aD) -> + {in rT, {on aD, cancel g & f}} -> cancel g f. +Proof. by move=> mem_g fgK x; apply/fgK. Qed. + +End CancelOn. +Arguments onW_can {aT rT} aD {f g}. +Arguments onW_can_in {aT rT} aD {rD f g}. +Arguments in_onW_can {aT rT} aD rD {f g}. +Arguments onS_can {aT rT} aD {f g}. +Arguments onS_can_in {aT rT} aD {rD f g}. +Arguments in_onS_can {aT rT} aD {f g}. + +Section inj_can_sym_in_on. +Variables (aT rT : predArgType) (aD : {pred aT}) (rD : {pred rT}). +Variables (f : aT -> rT) (g : rT -> aT). + +Lemma inj_can_sym_in_on : + {homo f : x / x \in aD >-> x \in rD} -> {in aD, {on rD, cancel f & g}} -> + {in rD &, {on aD &, injective g}} -> {in rD, {on aD, cancel g & f}}. +Proof. by move=> fD fK gI x x_rD gx_aD; apply: gI; rewrite ?inE ?fK ?fD. Qed. + +Lemma inj_can_sym_on : {in aD, cancel f g} -> + {on aD &, injective g} -> {on aD, cancel g & f}. +Proof. by move=> fK gI x gx_aD; apply: gI; rewrite ?inE ?fK. Qed. + +Lemma inj_can_sym_in : {homo f \o g : x / x \in rD} -> {on rD, cancel f & g} -> + {in rD &, injective g} -> {in rD, cancel g f}. +Proof. by move=> fgD fK gI x x_rD; apply: gI; rewrite ?fK ?fgD. Qed. + +End inj_can_sym_in_on. +Arguments inj_can_sym_in_on {aT rT aD rD f g}. +Arguments inj_can_sym_on {aT rT aD f g}. +Arguments inj_can_sym_in {aT rT rD f g}. diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in index 0086516785..02ababd928 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -104,7 +104,7 @@ BEFORE ?= AFTER ?= # FIXME this should be generated by Coq (modules already linked by Coq) -CAMLDONTLINK=num,str,unix,dynlink,threads +CAMLDONTLINK=str,unix,dynlink,threads,num,zarith # OCaml binaries CAMLC ?= "$(OCAMLFIND)" ocamlc -c diff --git a/tools/coqdoc/cpretty.mll b/tools/coqdoc/cpretty.mll index b801a3b06e..5d210b2e60 100644 --- a/tools/coqdoc/cpretty.mll +++ b/tools/coqdoc/cpretty.mll @@ -504,9 +504,9 @@ rule coq_bol = parse { Lexing.new_line lexbuf; begin_show (); coq_bol lexbuf } | space* end_show nl { Lexing.new_line lexbuf; end_show (); coq_bol lexbuf } - | space* begin_details nl - { Lexing.new_line lexbuf; - let s = details_body lexbuf in + | space* begin_details (* At this point, the comment remains open, + and will be closed by [details_body] *) + { let s = details_body lexbuf in Output.end_coq (); begin_details s; Output.start_coq (); coq_bol lexbuf } | space* end_details nl { Lexing.new_line lexbuf; diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 79de3c86b6..88924160ff 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -324,12 +324,12 @@ let loop_flush_all () = let pequal cmp1 cmp2 (a1,a2) (b1,b2) = cmp1 a1 b1 && cmp2 a2 b2 let evleq e1 e2 = CList.equal Evar.equal e1 e2 let cproof p1 p2 = - let Proof.{goals=a1;stack=a2;shelf=a3;given_up=a4} = Proof.data p1 in - let Proof.{goals=b1;stack=b2;shelf=b3;given_up=b4} = Proof.data p2 in + let Proof.{goals=a1;stack=a2;sigma=sigma1} = Proof.data p1 in + let Proof.{goals=b1;stack=b2;sigma=sigma2} = Proof.data p2 in evleq a1 b1 && CList.equal (pequal evleq evleq) a2 b2 && - CList.equal Evar.equal a3 b3 && - CList.equal Evar.equal a4 b4 + CList.equal Evar.equal (Evd.shelf sigma1) (Evd.shelf sigma2) && + Evar.Set.equal (Evd.given_up sigma1) (Evd.given_up sigma2) let drop_last_doc = ref None diff --git a/toplevel/dune b/toplevel/dune index 2d64ae303c..5f10346ac4 100644 --- a/toplevel/dune +++ b/toplevel/dune @@ -3,8 +3,9 @@ (public_name coq.toplevel) (synopsis "Coq's Interactive Shell [terminal-based]") (wrapped false) + ; num still here due to some plugins using it (libraries num coq.stm)) -; Coqlevel provides the `Num` library to plugins, we could also use +; Interp provides the `zarith` library to plugins, we could also use ; -linkall in the plugins file, to be discussed. (coq.pp (modules g_toplevel)) diff --git a/user-contrib/Ltac2/g_ltac2.mlg b/user-contrib/Ltac2/g_ltac2.mlg index bec9632e84..d42a935104 100644 --- a/user-contrib/Ltac2/g_ltac2.mlg +++ b/user-contrib/Ltac2/g_ltac2.mlg @@ -371,7 +371,7 @@ GRAMMAR EXTEND Gram ; syn_level: [ [ -> { None } - | ":"; n = Prim.integer -> { Some n } + | ":"; n = Prim.natural -> { Some n } ] ] ; tac2def_syn: diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index f47cdd8bf0..7a7e7d6e35 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -556,11 +556,17 @@ let list_id l = List.fold_left ( fun a decl -> let s' = Id.of_string (s'^"_lb")) ::a ) [] l + +let avoid_of_list_id list_id = + List.fold_left (fun avoid (s,seq,sbl,slb) -> + List.fold_left (fun avoid id -> Id.Set.add id avoid) + avoid [s;seq;sbl;slb]) + Id.Set.empty list_id + (* build the right eq_I A B.. N eq_A .. eq_N *) -let eqI ind l = - let list_id = list_id l in +let eqI ind list_id = let eA = Array.of_list((List.map (fun (s,_,_,_) -> mkVar s) list_id)@ (List.map (fun (_,seq,_,_)-> mkVar seq) list_id )) and e = match lookup_scheme beq_scheme_kind ind with @@ -568,7 +574,7 @@ let eqI ind l = | None -> user_err ~hdr:"AutoIndDecl.eqI" (str "The boolean equality on " ++ Printer.pr_inductive (Global.env ()) ind ++ str " is needed."); - in (if Array.equal Constr.equal eA [||] then e else mkApp(e,eA)) + in mkApp(e,eA) (**********************************************************************) (* Boolean->Leibniz *) @@ -576,12 +582,12 @@ let eqI ind l = open Namegen let compute_bl_goal ind lnamesparrec nparrec = - let eqI = eqI ind lnamesparrec in let list_id = list_id lnamesparrec in - let avoid = List.fold_right (Nameops.Name.fold_right (fun id l -> Id.Set.add id l)) (List.map RelDecl.get_name lnamesparrec) Id.Set.empty in + let eqI = eqI ind list_id in + let avoid = avoid_of_list_id list_id in + let x = next_ident_away (Id.of_string "x") avoid in + let y = next_ident_away (Id.of_string "y") (Id.Set.add x avoid) in let create_input c = - let x = next_ident_away (Id.of_string "x") avoid and - y = next_ident_away (Id.of_string "y") avoid in let bl_typ = List.map (fun (s,seq,_,_) -> mkNamedProd (make_annot x Sorts.Relevant) (mkVar s) ( mkNamedProd (make_annot y Sorts.Relevant) (mkVar s) ( @@ -607,88 +613,74 @@ let compute_bl_goal ind lnamesparrec nparrec = in mkNamedProd x (RelDecl.get_type decl) a) eq_input lnamesparrec in - let n = next_ident_away (Id.of_string "x") avoid and - m = next_ident_away (Id.of_string "y") avoid in let u = Univ.Instance.empty in create_input ( - mkNamedProd (make_annot n Sorts.Relevant) (mkFullInd (ind,u) nparrec) ( - mkNamedProd (make_annot m Sorts.Relevant) (mkFullInd (ind,u) (nparrec+1)) ( + mkNamedProd (make_annot x Sorts.Relevant) (mkFullInd (ind,u) nparrec) ( + mkNamedProd (make_annot y Sorts.Relevant) (mkFullInd (ind,u) (nparrec+1)) ( mkArrow - (mkApp(eq (),[|bb ();mkApp(eqI,[|mkVar n;mkVar m|]);tt ()|])) + (mkApp(eq (),[|bb ();mkApp(eqI,[|mkVar x;mkVar y|]);tt ()|])) Sorts.Relevant - (mkApp(eq (),[|mkFullInd (ind,u) (nparrec+3);mkVar n;mkVar m|])) + (mkApp(eq (),[|mkFullInd (ind,u) (nparrec+3);mkVar x;mkVar y|])) ))) let compute_bl_tact mode bl_scheme_key ind lnamesparrec nparrec = let list_id = list_id lnamesparrec in - let avoid = ref [] in - let first_intros = - ( List.map (fun (s,_,_,_) -> s ) list_id ) @ - ( List.map (fun (_,seq,_,_ ) -> seq) list_id ) @ - ( List.map (fun (_,_,sbl,_ ) -> sbl) list_id ) - in - let fresh_id s gl = - let fresh = fresh_id_in_env (Id.Set.of_list !avoid) s (Proofview.Goal.env gl) in - avoid := fresh::(!avoid); fresh - in - Proofview.Goal.enter begin fun gl -> - let fresh_first_intros = List.map (fun id -> fresh_id id gl) first_intros in - let freshn = fresh_id (Id.of_string "x") gl in - let freshm = fresh_id (Id.of_string "y") gl in - let freshz = fresh_id (Id.of_string "Z") gl in - (* try with *) - Tacticals.New.tclTHENLIST [ intros_using fresh_first_intros; - intro_using freshn ; - induct_on (EConstr.mkVar freshn); - intro_using freshm; - destruct_on (EConstr.mkVar freshm); - intro_using freshz; - intros; - Tacticals.New.tclTRY ( - Tacticals.New.tclORELSE reflexivity my_discr_tac - ); - simpl_in_hyp (freshz,Locus.InHyp); -(* + let first_intros = + ( List.map (fun (s,_,_,_) -> s ) list_id ) + @ ( List.map (fun (_,seq,_,_ ) -> seq) list_id ) + @ ( List.map (fun (_,_,sbl,_ ) -> sbl) list_id ) + in + intros_using_then first_intros begin fun fresh_first_intros -> + Tacticals.New.tclTHENLIST [ + intro_using_then (Id.of_string "x") (fun freshn -> induct_on (EConstr.mkVar freshn)); + intro_using_then (Id.of_string "y") (fun freshm -> destruct_on (EConstr.mkVar freshm)); + intro_using_then (Id.of_string "Z") begin fun freshz -> + Tacticals.New.tclTHENLIST [ + intros; + Tacticals.New.tclTRY ( + Tacticals.New.tclORELSE reflexivity my_discr_tac + ); + simpl_in_hyp (freshz,Locus.InHyp); + (* repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). -*) - Tacticals.New.tclREPEAT ( - Tacticals.New.tclTHENLIST [ - Simple.apply_in freshz (EConstr.of_constr (andb_prop())); - Proofview.Goal.enter begin fun gl -> - let fresht = fresh_id (Id.of_string "Z") gl in - destruct_on_as (EConstr.mkVar freshz) - (IntroOrPattern [[CAst.make @@ IntroNaming (IntroIdentifier fresht); - CAst.make @@ IntroNaming (IntroIdentifier freshz)]]) - end - ]); -(* + *) + Tacticals.New.tclREPEAT ( + Tacticals.New.tclTHENLIST [ + Simple.apply_in freshz (EConstr.of_constr (andb_prop())); + destruct_on_as (EConstr.mkVar freshz) + (IntroOrPattern [[CAst.make @@ IntroNaming (IntroFresh (Id.of_string "Z")); + CAst.make @@ IntroNaming (IntroIdentifier freshz)]]) + ]); + (* Ci a1 ... an = Ci b1 ... bn replace bi with ai; auto || replace bi with ai by apply typeofbi_prod ; auto -*) - Proofview.Goal.enter begin fun gl -> - let concl = Proofview.Goal.concl gl in - let sigma = Tacmach.New.project gl in - match EConstr.kind sigma concl with - | App (c,ca) -> ( - match EConstr.kind sigma c with - | Ind (indeq, u) -> - if GlobRef.equal (GlobRef.IndRef indeq) Coqlib.(lib_ref "core.eq.type") - then - Tacticals.New.tclTHEN - (do_replace_bl bl_scheme_key ind - (!avoid) - nparrec (ca.(2)) - (ca.(1))) - Auto.default_auto - else - Tacticals.New.tclZEROMSG (str "Failure while solving Boolean->Leibniz.") - | _ -> Tacticals.New.tclZEROMSG (str" Failure while solving Boolean->Leibniz.") - ) - | _ -> Tacticals.New.tclZEROMSG (str "Failure while solving Boolean->Leibniz.") - end + *) + Proofview.Goal.enter begin fun gl -> + let concl = Proofview.Goal.concl gl in + let sigma = Tacmach.New.project gl in + match EConstr.kind sigma concl with + | App (c,ca) -> ( + match EConstr.kind sigma c with + | Ind (indeq, u) -> + if GlobRef.equal (GlobRef.IndRef indeq) Coqlib.(lib_ref "core.eq.type") + then + Tacticals.New.tclTHEN + (do_replace_bl bl_scheme_key ind + (List.rev fresh_first_intros) + nparrec (ca.(2)) + (ca.(1))) + Auto.default_auto + else + Tacticals.New.tclZEROMSG (str "Failure while solving Boolean->Leibniz.") + | _ -> Tacticals.New.tclZEROMSG (str" Failure while solving Boolean->Leibniz.") + ) + | _ -> Tacticals.New.tclZEROMSG (str "Failure while solving Boolean->Leibniz.") + end - ] - end + ] + end + ] + end let bl_scheme_kind_aux = ref (fun _ -> failwith "Undefined") @@ -729,11 +721,11 @@ let _ = bl_scheme_kind_aux := fun () -> bl_scheme_kind let compute_lb_goal ind lnamesparrec nparrec = let list_id = list_id lnamesparrec in let eq = eq () and tt = tt () and bb = bb () in - let avoid = List.fold_right (Nameops.Name.fold_right (fun id l -> Id.Set.add id l)) (List.map RelDecl.get_name lnamesparrec) Id.Set.empty in - let eqI = eqI ind lnamesparrec in + let avoid = avoid_of_list_id list_id in + let eqI = eqI ind list_id in + let x = next_ident_away (Id.of_string "x") avoid in + let y = next_ident_away (Id.of_string "y") (Id.Set.add x avoid) in let create_input c = - let x = next_ident_away (Id.of_string "x") avoid and - y = next_ident_away (Id.of_string "y") avoid in let lb_typ = List.map (fun (s,seq,_,_) -> mkNamedProd (make_annot x Sorts.Relevant) (mkVar s) ( mkNamedProd (make_annot y Sorts.Relevant) (mkVar s) ( @@ -760,73 +752,62 @@ let compute_lb_goal ind lnamesparrec nparrec = in mkNamedProd x (RelDecl.get_type decl) a) eq_input lnamesparrec in - let n = next_ident_away (Id.of_string "x") avoid and - m = next_ident_away (Id.of_string "y") avoid in let u = Univ.Instance.empty in create_input ( - mkNamedProd (make_annot n Sorts.Relevant) (mkFullInd (ind,u) nparrec) ( - mkNamedProd (make_annot m Sorts.Relevant) (mkFullInd (ind,u) (nparrec+1)) ( + mkNamedProd (make_annot x Sorts.Relevant) (mkFullInd (ind,u) nparrec) ( + mkNamedProd (make_annot y Sorts.Relevant) (mkFullInd (ind,u) (nparrec+1)) ( mkArrow - (mkApp(eq,[|mkFullInd (ind,u) (nparrec+2);mkVar n;mkVar m|])) + (mkApp(eq,[|mkFullInd (ind,u) (nparrec+2);mkVar x;mkVar y|])) Sorts.Relevant - (mkApp(eq,[|bb;mkApp(eqI,[|mkVar n;mkVar m|]);tt|])) + (mkApp(eq,[|bb;mkApp(eqI,[|mkVar x;mkVar y|]);tt|])) ))) let compute_lb_tact mode lb_scheme_key ind lnamesparrec nparrec = let list_id = list_id lnamesparrec in - let avoid = ref [] in - let first_intros = - ( List.map (fun (s,_,_,_) -> s ) list_id ) @ - ( List.map (fun (_,seq,_,_) -> seq) list_id ) @ - ( List.map (fun (_,_,_,slb) -> slb) list_id ) - in - let fresh_id s gl = - let fresh = fresh_id_in_env (Id.Set.of_list !avoid) s (Proofview.Goal.env gl) in - avoid := fresh::(!avoid); fresh - in - Proofview.Goal.enter begin fun gl -> - let fresh_first_intros = List.map (fun id -> fresh_id id gl) first_intros in - let freshn = fresh_id (Id.of_string "x") gl in - let freshm = fresh_id (Id.of_string "y") gl in - let freshz = fresh_id (Id.of_string "Z") gl in - (* try with *) - Tacticals.New.tclTHENLIST [ intros_using fresh_first_intros; - intro_using freshn ; - induct_on (EConstr.mkVar freshn); - intro_using freshm; - destruct_on (EConstr.mkVar freshm); - intro_using freshz; - intros; - Tacticals.New.tclTRY ( - Tacticals.New.tclORELSE reflexivity my_discr_tac - ); - my_inj_tac freshz; - intros; simpl_in_concl; - Auto.default_auto; - Tacticals.New.tclREPEAT ( - Tacticals.New.tclTHENLIST [apply (EConstr.of_constr (andb_true_intro())); - simplest_split ;Auto.default_auto ] - ); - Proofview.Goal.enter begin fun gls -> - let concl = Proofview.Goal.concl gls in - let sigma = Tacmach.New.project gl in - (* assume the goal to be eq (eq_type ...) = true *) - match EConstr.kind sigma concl with - | App(c,ca) -> (match (EConstr.kind sigma ca.(1)) with - | App(c',ca') -> - let n = Array.length ca' in - do_replace_lb mode lb_scheme_key - (!avoid) - nparrec - ca'.(n-2) ca'.(n-1) - | _ -> - Tacticals.New.tclZEROMSG (str "Failure while solving Leibniz->Boolean.") - ) - | _ -> - Tacticals.New.tclZEROMSG (str "Failure while solving Leibniz->Boolean.") - end - ] - end + let first_intros = + ( List.map (fun (s,_,_,_) -> s ) list_id ) + @ ( List.map (fun (_,seq,_,_) -> seq) list_id ) + @ ( List.map (fun (_,_,_,slb) -> slb) list_id ) + in + intros_using_then first_intros begin fun fresh_first_intros -> + Tacticals.New.tclTHENLIST [ + intro_using_then (Id.of_string "x") (fun freshn -> induct_on (EConstr.mkVar freshn)); + intro_using_then (Id.of_string "y") (fun freshm -> destruct_on (EConstr.mkVar freshm)); + intro_using_then (Id.of_string "Z") begin fun freshz -> + Tacticals.New.tclTHENLIST [ + intros; + Tacticals.New.tclTRY ( + Tacticals.New.tclORELSE reflexivity my_discr_tac + ); + my_inj_tac freshz; + intros; simpl_in_concl; + Auto.default_auto; + Tacticals.New.tclREPEAT ( + Tacticals.New.tclTHENLIST [apply (EConstr.of_constr (andb_true_intro())); + simplest_split ;Auto.default_auto ] + ); + Proofview.Goal.enter begin fun gls -> + let concl = Proofview.Goal.concl gls in + let sigma = Tacmach.New.project gls in + (* assume the goal to be eq (eq_type ...) = true *) + match EConstr.kind sigma concl with + | App(c,ca) -> (match (EConstr.kind sigma ca.(1)) with + | App(c',ca') -> + let n = Array.length ca' in + do_replace_lb mode lb_scheme_key + (List.rev fresh_first_intros) + nparrec + ca'.(n-2) ca'.(n-1) + | _ -> + Tacticals.New.tclZEROMSG (str "Failure while solving Leibniz->Boolean.") + ) + | _ -> + Tacticals.New.tclZEROMSG (str "Failure while solving Leibniz->Boolean.") + end + ] + end + ] + end let lb_scheme_kind_aux = ref (fun () -> failwith "Undefined") @@ -868,10 +849,10 @@ let compute_dec_goal ind lnamesparrec nparrec = check_not_is_defined (); let eq = eq () and tt = tt () and bb = bb () in let list_id = list_id lnamesparrec in - let avoid = List.fold_right (Nameops.Name.fold_right (fun id l -> Id.Set.add id l)) (List.map RelDecl.get_name lnamesparrec) Id.Set.empty in + let avoid = avoid_of_list_id list_id in + let x = next_ident_away (Id.of_string "x") avoid in + let y = next_ident_away (Id.of_string "y") (Id.Set.add x avoid) in let create_input c = - let x = next_ident_away (Id.of_string "x") avoid and - y = next_ident_away (Id.of_string "y") avoid in let lb_typ = List.map (fun (s,seq,_,_) -> mkNamedProd (make_annot x Sorts.Relevant) (mkVar s) ( mkNamedProd (make_annot y Sorts.Relevant) (mkVar s) ( @@ -912,12 +893,10 @@ let compute_dec_goal ind lnamesparrec nparrec = in mkNamedProd x (RelDecl.get_type decl) a) eq_input lnamesparrec in - let n = next_ident_away (Id.of_string "x") avoid and - m = next_ident_away (Id.of_string "y") avoid in - let eqnm = mkApp(eq,[|mkFullInd ind (2*nparrec+2);mkVar n;mkVar m|]) in + let eqnm = mkApp(eq,[|mkFullInd ind (2*nparrec+2);mkVar x;mkVar y|]) in create_input ( - mkNamedProd (make_annot n Sorts.Relevant) (mkFullInd ind (2*nparrec)) ( - mkNamedProd (make_annot m Sorts.Relevant) (mkFullInd ind (2*nparrec+1)) ( + mkNamedProd (make_annot x Sorts.Relevant) (mkFullInd ind (2*nparrec)) ( + mkNamedProd (make_annot y Sorts.Relevant) (mkFullInd ind (2*nparrec+1)) ( mkApp(sumbool(),[|eqnm;mkApp (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.not.type",[|eqnm|])|]) ) ) @@ -925,83 +904,89 @@ let compute_dec_goal ind lnamesparrec nparrec = let compute_dec_tact ind lnamesparrec nparrec = let eq = eq () and tt = tt () - and ff = ff () and bb = bb () in + and ff = ff () and bb = bb () in let list_id = list_id lnamesparrec in find_scheme beq_scheme_kind ind >>= fun _ -> - let eqI = eqI ind lnamesparrec in - let avoid = ref [] in + let _non_fresh_eqI = eqI ind list_id in let eqtrue x = mkApp(eq,[|bb;x;tt|]) in let eqfalse x = mkApp(eq,[|bb;x;ff|]) in let first_intros = - ( List.map (fun (s,_,_,_) -> s ) list_id ) @ - ( List.map (fun (_,seq,_,_) -> seq) list_id ) @ - ( List.map (fun (_,_,sbl,_) -> sbl) list_id ) @ - ( List.map (fun (_,_,_,slb) -> slb) list_id ) - in - let fresh_id s gl = - let fresh = fresh_id_in_env (Id.Set.of_list !avoid) s (Proofview.Goal.env gl) in - avoid := fresh::(!avoid); fresh + ( List.map (fun (s,_,_,_) -> s ) list_id ) + @ ( List.map (fun (_,seq,_,_) -> seq) list_id ) + @ ( List.map (fun (_,_,sbl,_) -> sbl) list_id ) + @ ( List.map (fun (_,_,_,slb) -> slb) list_id ) in - Proofview.Goal.enter begin fun gl -> - let fresh_first_intros = List.map (fun id -> fresh_id id gl) first_intros in - let freshn = fresh_id (Id.of_string "x") gl in - let freshm = fresh_id (Id.of_string "y") gl in - let freshH = fresh_id (Id.of_string "H") gl in - let eqbnm = mkApp(eqI,[|mkVar freshn;mkVar freshm|]) in - let arfresh = Array.of_list fresh_first_intros in - let xargs = Array.sub arfresh 0 (2*nparrec) in - find_scheme bl_scheme_kind ind >>= fun c -> - let blI = mkConst c in - find_scheme lb_scheme_kind ind >>= fun c -> - let lbI = mkConst c in - Tacticals.New.tclTHENLIST [ - intros_using fresh_first_intros; - intros_using [freshn;freshm]; - (*we do this so we don't have to prove the same goal twice *) - assert_by (Name freshH) (EConstr.of_constr ( - mkApp(sumbool(),[|eqtrue eqbnm; eqfalse eqbnm|]) - )) - (Tacticals.New.tclTHEN (destruct_on (EConstr.of_constr eqbnm)) Auto.default_auto); - + let fresh_id s gl = fresh_id_in_env (Id.Set.empty) s (Proofview.Goal.env gl) in + intros_using_then first_intros begin fun fresh_first_intros -> + let eqI = + let a = Array.of_list fresh_first_intros in + let n = List.length list_id in + assert (Int.equal (Array.length a) (4 * n)); + let fresh_list_id = + List.init n (fun i -> (Array.get a i, Array.get a (i+n), + Array.get a (i+2*n), Array.get a (i+3*n))) in + eqI ind fresh_list_id + in + intro_using_then (Id.of_string "x") begin fun freshn -> + intro_using_then (Id.of_string "y") begin fun freshm -> Proofview.Goal.enter begin fun gl -> - let freshH2 = fresh_id (Id.of_string "H") gl in - Tacticals.New.tclTHENS (destruct_on_using (EConstr.mkVar freshH) freshH2) [ - (* left *) - Tacticals.New.tclTHENLIST [ - simplest_left; - apply (EConstr.of_constr (mkApp(blI,Array.map mkVar xargs))); - Auto.default_auto - ] - ; - - (*right *) - Proofview.Goal.enter begin fun gl -> - let freshH3 = fresh_id (Id.of_string "H") gl in - Tacticals.New.tclTHENLIST [ - simplest_right ; - unfold_constr (Coqlib.lib_ref "core.not.type"); - intro; - Equality.subst_all (); - assert_by (Name freshH3) - (EConstr.of_constr (mkApp(eq,[|bb;mkApp(eqI,[|mkVar freshm;mkVar freshm|]);tt|]))) - (Tacticals.New.tclTHENLIST [ - apply (EConstr.of_constr (mkApp(lbI,Array.map mkVar xargs))); - Auto.default_auto - ]); - Equality.general_rewrite_bindings_in true - Locus.AllOccurrences true false - (List.hd !avoid) - ((EConstr.mkVar (List.hd (List.tl !avoid))), - NoBindings - ) - true; - my_discr_tac + let freshH = fresh_id (Id.of_string "H") gl in + let eqbnm = mkApp(eqI,[|mkVar freshn;mkVar freshm|]) in + let arfresh = Array.of_list fresh_first_intros in + let xargs = Array.sub arfresh 0 (2*nparrec) in + find_scheme bl_scheme_kind ind >>= fun c -> + let blI = mkConst c in + find_scheme lb_scheme_kind ind >>= fun c -> + let lbI = mkConst c in + Tacticals.New.tclTHENLIST [ + (*we do this so we don't have to prove the same goal twice *) + assert_by (Name freshH) (EConstr.of_constr ( + mkApp(sumbool(),[|eqtrue eqbnm; eqfalse eqbnm|]) + )) + (Tacticals.New.tclTHEN (destruct_on (EConstr.of_constr eqbnm)) Auto.default_auto); + + Proofview.Goal.enter begin fun gl -> + let freshH2 = fresh_id (Id.of_string "H") gl in + Tacticals.New.tclTHENS (destruct_on_using (EConstr.mkVar freshH) freshH2) [ + (* left *) + Tacticals.New.tclTHENLIST [ + simplest_left; + apply (EConstr.of_constr (mkApp(blI,Array.map mkVar xargs))); + Auto.default_auto + ] + ; + + (*right *) + Proofview.Goal.enter begin fun gl -> + let freshH3 = fresh_id (Id.of_string "H") gl in + Tacticals.New.tclTHENLIST [ + simplest_right ; + unfold_constr (Coqlib.lib_ref "core.not.type"); + intro; + Equality.subst_all (); + assert_by (Name freshH3) + (EConstr.of_constr (mkApp(eq,[|bb;mkApp(eqI,[|mkVar freshm;mkVar freshm|]);tt|]))) + (Tacticals.New.tclTHENLIST [ + apply (EConstr.of_constr (mkApp(lbI,Array.map mkVar xargs))); + Auto.default_auto + ]); + Equality.general_rewrite_bindings_in true + Locus.AllOccurrences true false + freshH3 + ((EConstr.mkVar freshH2), + NoBindings + ) + true; + my_discr_tac + ] + end + ] + end ] - end - ] + end end - ] - end + end + end let make_eq_decidability mode mind = let mib = Global.lookup_mind mind in diff --git a/vernac/classes.ml b/vernac/classes.ml index f454c389dc..02cb60f1cf 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -358,8 +358,9 @@ let declare_instance_open sigma ?hook ~tac ~global ~poly id pri impargs udecl id the pretyping after the proof has opened. As a consequence, we use the low-level primitives to code the refinement manually.*) - let gls = List.rev (Evd.future_goals sigma) in - let sigma = Evd.reset_future_goals sigma in + let future_goals, sigma = Evd.pop_future_goals sigma in + let gls = List.rev future_goals.Evd.FutureGoals.comb in + let sigma = Evd.push_future_goals sigma in let kind = Decls.(IsDefinition Instance) in let hook = Declare.Hook.(make (fun { S.dref ; _ } -> instance_hook pri global ?hook dref)) in let info = Declare.Info.make ~hook ~kind ~udecl ~poly () in diff --git a/vernac/comArguments.ml b/vernac/comArguments.ml index 360e228bfc..adf1f42beb 100644 --- a/vernac/comArguments.ml +++ b/vernac/comArguments.ml @@ -213,22 +213,13 @@ let vernac_arguments ~section_local reference args more_implicits flags = in CErrors.user_err ~hdr:"vernac_declare_arguments" msg end; - let duplicate_names = - List.duplicates Name.equal (List.filter ((!=) Anonymous) names) - in - if not (List.is_empty duplicate_names) then begin - CErrors.user_err Pp.(strbrk "Some argument names are duplicated: " ++ - prlist_with_sep pr_comma Name.print duplicate_names) - end; - let implicits = List.map (fun { name; implicit_status = i } -> (name,i)) args in let implicits = implicits :: more_implicits in - let implicits = List.map (List.map snd) implicits in let implicits_specified = match implicits with - | [l] -> List.exists (function Glob_term.Explicit -> false | _ -> true) l + | [l] -> List.exists (function _, Glob_term.Explicit -> false | _ -> true) l | _ -> true in if implicits_specified && clear_implicits_flag then diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index 0f34adf1c7..564d24c1ea 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -247,6 +247,7 @@ let interp_fixpoint ?(check_recursivity=true) ~cofix l : (EConstr.rel_context * Impargs.manual_implicits * int option) list) = let (env,_,pl,evd),fix,info = interp_recursive ~program_mode:false ~cofix l in if check_recursivity then check_recursive true env evd fix; + let evd = Pretyping.(solve_remaining_evars all_no_fail_flags env evd) in let uctx,fix = ground_fixpoint env evd fix in (fix,pl,uctx,info) diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index 673124296d..452de69b1d 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -451,7 +451,7 @@ let interp_params env udecl uparamsl paramsl = do the unification. [env_ar_par] is [uparams; inds; params] *) -let maybe_unify_params_in env_ar_par sigma ~ninds ~nparams c = +let maybe_unify_params_in env_ar_par sigma ~ninds ~nparams ~binders:k c = let is_ind sigma k c = match EConstr.kind sigma c with | Constr.Rel n -> (* env is [uparams; inds; params; k other things] *) @@ -462,14 +462,18 @@ let maybe_unify_params_in env_ar_par sigma ~ninds ~nparams c = | Constr.App (h,args) when is_ind sigma k h -> Array.fold_left_i (fun i sigma arg -> if i >= nparams || not (EConstr.isEvar sigma arg) then sigma - else Evarconv.unify_delay env sigma arg (EConstr.mkRel (k+nparams-i))) + else begin try Evarconv.unify_delay env sigma arg (EConstr.mkRel (k+nparams-i)) + with Evarconv.UnableToUnify _ -> + (* ignore errors, we will get a "Cannot infer ..." error instead *) + sigma + end) sigma args | _ -> Termops.fold_constr_with_full_binders sigma (fun d (env,k) -> EConstr.push_rel d env, k+1) aux envk sigma c in - aux (env_ar_par,0) sigma c + aux (env_ar_par,k) sigma c let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) notations ~cumulative ~poly ~private_ind finite = check_all_names_different indl; @@ -527,7 +531,7 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not let sigma = List.fold_left (fun sigma (_,ctyps,_) -> List.fold_left (fun sigma ctyp -> - maybe_unify_params_in env_ar_params sigma ~ninds ~nparams ctyp) + maybe_unify_params_in env_ar_params sigma ~ninds ~nparams ~binders:0 ctyp) sigma ctyps) sigma constructors in diff --git a/vernac/comInductive.mli b/vernac/comInductive.mli index 9c876787a3..91e8f609d5 100644 --- a/vernac/comInductive.mli +++ b/vernac/comInductive.mli @@ -81,8 +81,8 @@ val template_polymorphism_candidate monomorphic universe context that can be made parametric in its conclusion sort, if one is given. *) -val maybe_unify_params_in : Environ.env -> Evd.evar_map -> ninds:int -> nparams:int +val maybe_unify_params_in : Environ.env -> Evd.evar_map -> ninds:int -> nparams:int -> binders:int -> EConstr.t -> Evd.evar_map (** [nparams] is the number of parameters which aren't treated as uniform, ie the length of params (including letins) where the env - is [uniform params, inductives, params]. *) + is [uniform params, inductives, params, binders]. *) diff --git a/vernac/declare.ml b/vernac/declare.ml index eedbee852b..099a63cf8f 100644 --- a/vernac/declare.ml +++ b/vernac/declare.ml @@ -642,14 +642,32 @@ let declare_assumption ~name ~scope ~hook ~impargs ~uctx pe = dref (* Preparing proof entries *) +let error_unresolved_evars env sigma t evars = + let pr_unresolved_evar e = + hov 2 (str"- " ++ Printer.pr_existential_key sigma e ++ str ": " ++ + Himsg.explain_pretype_error env sigma + (Pretype_errors.UnsolvableImplicit (e,None))) + in + CErrors.user_err (hov 0 begin + str "The following term contains unresolved implicit arguments:"++ fnl () ++ + str " " ++ Printer.pr_econstr_env env sigma t ++ fnl () ++ + str "More precisely: " ++ fnl () ++ + v 0 (prlist_with_sep cut pr_unresolved_evar (Evar.Set.elements evars)) + end) + +let check_evars_are_solved env sigma t = + let t = EConstr.of_constr t in + let evars = Evarutil.undefined_evars_of_term sigma t in + if not (Evar.Set.is_empty evars) then error_unresolved_evars env sigma t evars let prepare_definition ~info ~opaque ~body ~typ sigma = let { Info.poly; udecl; inline; _ } = info in let env = Global.env () in - Pretyping.check_evars_are_solved ~program_mode:false env sigma; - let sigma, (body, types) = Evarutil.finalize ~abort_on_undefined_evars:true + let sigma, (body, types) = Evarutil.finalize ~abort_on_undefined_evars:false sigma (fun nf -> nf body, Option.map nf typ) in + Option.iter (check_evars_are_solved env sigma) types; + check_evars_are_solved env sigma body; let univs = Evd.check_univ_decl ~poly sigma udecl in let entry = definition_entry ~opaque ~inline ?types ~univs body in let uctx = Evd.evar_universe_context sigma in @@ -1535,11 +1553,11 @@ let set_used_variables ps l = ctx, { ps with section_vars = Some (Context.Named.to_vars ctx) } let get_open_goals ps = - let Proof.{ goals; stack; shelf } = Proof.data ps.proof in + let Proof.{ goals; stack; sigma } = Proof.data ps.proof in List.length goals + List.fold_left (+) 0 (List.map (fun (l1,l2) -> List.length l1 + List.length l2) stack) + - List.length shelf + List.length (Evd.shelf sigma) type proof_object = { name : Names.Id.t @@ -1716,12 +1734,8 @@ let return_proof ps = let p, uctx = prepare_proof ~unsafe_typ:false ps in List.map (fun (((_ub, body),eff),_) -> (body,eff)) p, uctx -let update_global_env = - map ~f:(fun p -> - let { Proof.sigma } = Proof.data p in - let tac = Proofview.Unsafe.tclEVARS (Evd.update_sigma_env sigma (Global.env ())) in - let p, (status,info), _ = Proof.run_tactic (Global.env ()) tac p in - p) +let update_sigma_univs ugraph p = + map ~f:(Proof.update_sigma_univs ugraph) p let next = let n = ref 0 in fun () -> incr n; !n @@ -2000,7 +2014,7 @@ let finish_derived ~f ~name ~entries = let lemma_def = Internal.map_entry_body lemma_def ~f:(fun ((b,ctx),fx) -> (substf b, ctx), fx) in let lemma_def = DefinitionEntry lemma_def in let ct = declare_constant ~name ~kind:Decls.(IsProof Proposition) lemma_def in - [GlobRef.ConstRef ct] + [GlobRef.ConstRef f_kn; GlobRef.ConstRef ct] let finish_proved_equations ~pm ~kind ~hook i proof_obj types sigma0 = @@ -2237,7 +2251,7 @@ let rec solve_obligation prg num tac = let scope = Locality.Global Locality.ImportNeedQualified in let kind = kind_of_obligation (snd obl.obl_status) in let evd = Evd.from_ctx (Internal.get_uctx prg) in - let evd = Evd.update_sigma_env evd (Global.env ()) in + let evd = Evd.update_sigma_univs (Global.universes ()) evd in let auto ~pm n oblset tac = auto_solve_obligations ~pm n ~oblset tac in let proof_ending = let name = Internal.get_name prg in @@ -2278,7 +2292,7 @@ and solve_obligation_by_tac prg obls i tac = | None -> !default_tactic in let uctx = Internal.get_uctx prg in - let uctx = UState.update_sigma_env uctx (Global.env ()) in + let uctx = UState.update_sigma_univs uctx (Global.universes ()) in let poly = Internal.get_poly prg in match solve_by_tac ?loc:(fst obl.obl_location) obl.obl_name (evar_of_obligation obl) tac ~poly ~uctx with | None -> None diff --git a/vernac/declare.mli b/vernac/declare.mli index c5a8afbad5..1ad79928d5 100644 --- a/vernac/declare.mli +++ b/vernac/declare.mli @@ -117,8 +117,7 @@ end normalized w.r.t. the passed [evar_map] [sigma]. Universes should be handled properly, including minimization and restriction. Note that [sigma] is checked for unresolved evars, thus you should be - careful not to submit open terms or evar maps with stale, - unresolved existentials *) + careful not to submit open terms *) val declare_definition : info:Info.t -> cinfo:EConstr.t option CInfo.t @@ -247,10 +246,10 @@ module Proof : sig val compact : t -> t - (** Update the proofs global environment after a side-effecting command - (e.g. a sublemma definition) has been run inside it. Assumes - there_are_pending_proofs. *) - val update_global_env : t -> t + (** Update the proof's universe information typically after a + side-effecting command (e.g. a sublemma definition) has been run + inside it. *) + val update_sigma_univs : UGraph.t -> t -> t val get_open_goals : t -> int diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 6cc48d0e48..0bdcd53c92 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -665,15 +665,21 @@ let expand_list_rule s typ tkl x n p ll = aux (i+1) (main :: tks @ hds) ll in aux 0 [] ll -let is_constr_typ typ x etyps = +let is_constr_typ (s,lev) x etyps = match List.assoc x etyps with - | ETConstr (_,_,typ') -> typ = typ' + (* TODO: factorize these rules with the ones computing the effective + sublevel sent to camlp5, so as to include the case of + DefaultLevel which are valid *) + | ETConstr (s',_,(lev',InternalProd | (NumLevel _ | NextLevel as lev'), _)) -> + Notation.notation_entry_eq s s' && production_level_eq lev lev' | _ -> false let include_possible_similar_trailing_pattern typ etyps sl l = let rec aux n = function | Terminal s :: sl, Terminal s'::l' when s = s' -> aux n (sl,l') | [], NonTerminal x ::l' when is_constr_typ typ x etyps -> try_aux n l' + | Break _ :: sl, l -> aux n (sl,l) + | sl, Break _ :: l -> aux n (sl,l) | _ -> raise Exit and try_aux n l = try aux (n+1) (sl,l) @@ -704,8 +710,8 @@ let make_production etyps symbols = | Break _ -> [] | _ -> anomaly (Pp.str "Found a non terminal token in recursive notation separator.")) sl) in match List.assoc x etyps with - | ETConstr (s,_,typ) -> - let p,l' = include_possible_similar_trailing_pattern typ etyps sl l in + | ETConstr (s,_,(lev,_ as typ)) -> + let p,l' = include_possible_similar_trailing_pattern (s,lev) etyps sl l in expand_list_rule s typ tkl x 1 p (aux l') | ETBinder o -> check_open_binder o sl x; diff --git a/vernac/prettyp.ml b/vernac/prettyp.ml index 2b46542287..8b00484b4a 100644 --- a/vernac/prettyp.ml +++ b/vernac/prettyp.ml @@ -75,12 +75,12 @@ let print_ref reduce ref udecl = let inst = Univ.make_abstract_instance univs in let bl = Printer.universe_binders_with_opt_names (Environ.universes_of_global env ref) udecl in let sigma = Evd.from_ctx (UState.of_binders bl) in - let typ = EConstr.of_constr typ in let typ = if reduce then - let ctx,ccl = Reductionops.splay_prod_assum env sigma typ - in EConstr.it_mkProd_or_LetIn ccl ctx + let ctx,ccl = Reductionops.splay_prod_assum env sigma (EConstr.of_constr typ) + in EConstr.to_constr sigma (EConstr.it_mkProd_or_LetIn ccl ctx) else typ in + let typ = Arguments_renaming.rename_type typ ref in let impargs = select_stronger_impargs (implicits_of_global ref) in let impargs = List.map binding_kind_of_status impargs in let variance = let open GlobRef in match ref with @@ -95,7 +95,7 @@ let print_ref reduce ref udecl = else mt () in let priv = None in (* We deliberately don't print private univs in About. *) - hov 0 (pr_global ref ++ inst ++ str " :" ++ spc () ++ pr_letype_env env sigma ~impargs typ ++ + hov 0 (pr_global ref ++ inst ++ str " :" ++ spc () ++ pr_ltype_env env sigma ~impargs typ ++ Printer.pr_abstract_universe_ctx sigma ?variance univs ?priv) (********************************) @@ -261,6 +261,10 @@ let implicit_kind_of_status = function | None -> Anonymous, Glob_term.Explicit | Some (pos,_,(maximal,_)) -> implicit_name_of_pos pos, if maximal then Glob_term.MaxImplicit else Glob_term.NonMaxImplicit +let extra_implicit_kind_of_status imp = + let _,imp = implicit_kind_of_status imp in + (Anonymous, imp) + let dummy = { Vernacexpr.implicit_status = Glob_term.Explicit; name = Anonymous; @@ -268,8 +272,10 @@ let dummy = { notation_scope = None; } -let is_dummy {Vernacexpr.implicit_status; name; recarg_like; notation_scope} = - name = Anonymous && not recarg_like && notation_scope = None && implicit_status = Glob_term.Explicit +let is_dummy = function + | Vernacexpr.(RealArg {implicit_status; name; recarg_like; notation_scope}) -> + name = Anonymous && not recarg_like && notation_scope = None && implicit_status = Glob_term.Explicit + | _ -> false let rec main_implicits i renames recargs scopes impls = if renames = [] && recargs = [] && scopes = [] && impls = [] then [] @@ -292,9 +298,7 @@ let rec main_implicits i renames recargs scopes impls = let tl = function [] -> [] | _::tl -> tl in (* recargs is special -> tl handled above *) let rest = main_implicits (i+1) (tl renames) recargs (tl scopes) (tl impls) in - if is_dummy status && rest = [] - then [] (* we may have a trail of dummies due to eg "clear scopes" *) - else status :: rest + status :: rest let rec insert_fake_args volatile bidi impls = let open Vernacexpr in @@ -320,11 +324,7 @@ let print_arguments ref = | Some (UnfoldWhen { nargs; recargs }) -> [], recargs, nargs | Some (UnfoldWhenNoMatch { nargs; recargs }) -> [`ReductionDontExposeCase], recargs, nargs in - let flags, renames = match Arguments_renaming.arguments_names ref with - | exception Not_found -> flags, [] - | [] -> flags, [] - | renames -> `Rename::flags, renames - in + let renames = try Arguments_renaming.arguments_names ref with Not_found -> [] in let scopes = Notation.find_arguments_scope ref in let flags = if needs_extra_scopes ref scopes then `ExtraScopes::flags else flags in let impls = Impargs.extract_impargs_data (Impargs.implicits_of_global ref) in @@ -333,15 +333,17 @@ let print_arguments ref = | [] -> assert false in let impls = main_implicits 0 renames recargs scopes impls in - let moreimpls = List.map (fun (_,i) -> List.map implicit_kind_of_status i) moreimpls in + let moreimpls = List.map (fun (_,i) -> List.map extra_implicit_kind_of_status i) moreimpls in let bidi = Pretyping.get_bidirectionality_hint ref in let impls = insert_fake_args nargs_for_red bidi impls in - if impls = [] && moreimpls = [] && flags = [] then [] + if List.for_all is_dummy impls && moreimpls = [] && flags = [] then [] else let open Constrexpr in let open Vernacexpr in [Ppvernac.pr_vernac_expr - (VernacArguments (CAst.make (AN qid), impls, moreimpls, flags))] + (VernacArguments (CAst.make (AN qid), impls, moreimpls, flags)) ++ + (if renames = [] then mt () else + fnl () ++ str " (where some original arguments have been renamed)")] let print_name_infos ref = let type_info_for_implicit = diff --git a/vernac/proof_using.ml b/vernac/proof_using.ml index 2130a398e9..95680c2a4e 100644 --- a/vernac/proof_using.ml +++ b/vernac/proof_using.ml @@ -41,28 +41,27 @@ let set_of_type env ty = let full_set env = List.fold_right Id.Set.add (List.map NamedDecl.get_id (named_context env)) Id.Set.empty -let rec process_expr env e ty = +let process_expr env e v_ty = let rec aux = function | SsEmpty -> Id.Set.empty - | SsType -> set_of_type env ty - | SsSingl { CAst.v = id } -> set_of_id env id + | SsType -> v_ty + | SsSingl { CAst.v = id } -> set_of_id id | SsUnion(e1,e2) -> Id.Set.union (aux e1) (aux e2) | SsSubstr(e1,e2) -> Id.Set.diff (aux e1) (aux e2) | SsCompl e -> Id.Set.diff (full_set env) (aux e) | SsFwdClose e -> close_fwd env (aux e) + and set_of_id id = + if Id.to_string id = "All" then + full_set env + else if CList.mem_assoc_f Id.equal id !known_names then + aux (CList.assoc_f Id.equal id !known_names) + else Id.Set.singleton id in - aux e - -and set_of_id env id = - if Id.to_string id = "All" then - List.fold_right Id.Set.add (List.map NamedDecl.get_id (named_context env)) Id.Set.empty - else if CList.mem_assoc_f Id.equal id !known_names then - process_expr env (CList.assoc_f Id.equal id !known_names) [] - else Id.Set.singleton id + aux e let process_expr env e ty = let v_ty = set_of_type env ty in - let s = Id.Set.union v_ty (process_expr env e ty) in + let s = Id.Set.union v_ty (process_expr env e v_ty) in Id.Set.elements s let name_set id expr = known_names := (id,expr) :: !known_names diff --git a/vernac/record.ml b/vernac/record.ml index d0036e40f9..bd5b71cd6b 100644 --- a/vernac/record.ml +++ b/vernac/record.ml @@ -81,12 +81,12 @@ let interp_fields_evars env sigma ~ninds ~nparams impls_env nots l = (EConstr.push_rel d env, sigma, impl :: uimpls, d::params, impls)) (env, sigma, [], [], impls_env) nots l in - let _, sigma = Context.Rel.fold_outside ~init:(env,sigma) (fun f (env,sigma) -> + let _, _, sigma = Context.Rel.fold_outside ~init:(env,0,sigma) (fun f (env,k,sigma) -> let sigma = RelDecl.fold_constr (fun c sigma -> - ComInductive.maybe_unify_params_in env sigma ~ninds ~nparams c) + ComInductive.maybe_unify_params_in env sigma ~ninds ~nparams ~binders:k c) f sigma in - EConstr.push_rel f env, sigma) + EConstr.push_rel f env, k+1, sigma) newfs in sigma, (impls, newfs) diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index d540e7f93d..6a4c2a626d 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -112,7 +112,9 @@ let show_proof ~pstate = let show_top_evars ~proof = (* spiwack: new as of Feb. 2010: shows goal evars in addition to non-goal evars. *) - let Proof.{goals;shelf;given_up;sigma} = Proof.data proof in + let Proof.{goals; sigma} = Proof.data proof in + let shelf = Evd.shelf sigma in + let given_up = Evar.Set.elements @@ Evd.given_up sigma in pr_evars_int sigma ~shelf ~given_up 1 (Evd.undefined_map sigma) let show_universes ~proof = @@ -345,17 +347,21 @@ let dump_universes_gen prl g s = close (); Exninfo.iraise reraise -let universe_subgraph ?loc g univ = +let universe_subgraph ?loc kept univ = let open Univ in let sigma = Evd.from_env (Global.env()) in - let univs_of q = + let parse q = let q = Glob_term.(GType q) in (* this function has a nice error message for not found univs *) - LSet.singleton (Pretyping.interp_known_glob_level ?loc sigma q) + Pretyping.interp_known_glob_level ?loc sigma q in - let univs = List.fold_left (fun univs q -> LSet.union univs (univs_of q)) LSet.empty g in - let csts = UGraph.constraints_for ~kept:(LSet.add Level.prop (LSet.add Level.set univs)) univ in - let univ = LSet.fold UGraph.add_universe_unconstrained univs UGraph.initial_universes in + let kept = List.fold_left (fun kept q -> LSet.add (parse q) kept) LSet.empty kept in + let csts = UGraph.constraints_for ~kept univ in + let add u newgraph = + let strict = UGraph.check_constraint univ (Level.set,Lt,u) in + UGraph.add_universe u ~lbound:UGraph.Bound.Set ~strict newgraph + in + let univ = LSet.fold add kept UGraph.initial_universes in UGraph.merge_constraints csts univ let print_universes ?loc ~sort ~subgraph dst = @@ -1511,15 +1517,15 @@ let () = declare_bool_option { optdepr = false; optkey = ["Dump";"Bytecode"]; - optread = (fun () -> !Cbytegen.dump_bytecode); - optwrite = (:=) Cbytegen.dump_bytecode } + optread = (fun () -> !Vmbytegen.dump_bytecode); + optwrite = (:=) Vmbytegen.dump_bytecode } let () = declare_bool_option { optdepr = false; optkey = ["Dump";"Lambda"]; - optread = (fun () -> !Clambda.dump_lambda); - optwrite = (:=) Clambda.dump_lambda } + optread = (fun () -> !Vmlambda.dump_lambda); + optwrite = (:=) Vmlambda.dump_lambda } let () = declare_bool_option diff --git a/vernac/vernacinterp.ml b/vernac/vernacinterp.ml index 6be2fb0d43..edf48fef1a 100644 --- a/vernac/vernacinterp.ml +++ b/vernac/vernacinterp.ml @@ -211,8 +211,11 @@ and interp_control ~st ({ CAst.v = cmd } as vernac) = (fun ~st -> let before_univs = Global.universes () in let pstack, pm = interp_expr ~atts:cmd.attrs ~st cmd.expr in - if before_univs == Global.universes () then pstack, pm - else Option.map (Vernacstate.LemmaStack.map_top ~f:Declare.Proof.update_global_env) pstack, pm) + let after_univs = Global.universes () in + if before_univs == after_univs then pstack, pm + else + let f = Declare.Proof.update_sigma_univs after_univs in + Option.map (Vernacstate.LemmaStack.map ~f) pstack, pm) ~st (* XXX: This won't properly set the proof mode, as of today, it is diff --git a/vernac/vernacstate.ml b/vernac/vernacstate.ml index ee06205427..204008997d 100644 --- a/vernac/vernacstate.ml +++ b/vernac/vernacstate.ml @@ -80,7 +80,7 @@ module LemmaStack = struct type t = Declare.Proof.t * Declare.Proof.t list - let map f (pf, pfl) = (f pf, List.map f pfl) + let map ~f (pf, pfl) = (f pf, List.map f pfl) let map_top ~f (pf, pfl) = (f pf, pfl) let pop (ps, p) = match p with @@ -96,7 +96,7 @@ module LemmaStack = struct let get_all_proof_names (pf : t) = let prj x = Declare.Proof.get x in - let (pn, pns) = map Proof.(function pf -> (data (prj pf)).name) pf in + let (pn, pns) = map ~f:Proof.(function pf -> (data (prj pf)).name) pf in pn :: pns let copy_info src tgt = @@ -218,7 +218,7 @@ module Declare_ = struct Declare.Proof.info pt) let discard_all () = s_lemmas := None - let update_global_env () = dd (Declare.Proof.update_global_env) + let update_sigma_univs ugraph = dd (Declare.Proof.update_sigma_univs ugraph) let get_current_context () = cc Declare.Proof.get_current_context @@ -267,6 +267,7 @@ module Stm = struct end } + type non_pstate = Summary.frozen * Lib.frozen let non_pstate { system } = let st = System.Stm.summary system in let st = Summary.remove_from_summary st Evarutil.meta_counter_summary_tag in diff --git a/vernac/vernacstate.mli b/vernac/vernacstate.mli index 16fab3782b..e1b13dcb73 100644 --- a/vernac/vernacstate.mli +++ b/vernac/vernacstate.mli @@ -40,6 +40,7 @@ module LemmaStack : sig val pop : t -> Declare.Proof.t * t option val push : t option -> Declare.Proof.t -> t + val map : f:(Declare.Proof.t -> Declare.Proof.t) -> t -> t val map_top : f:(Declare.Proof.t -> Declare.Proof.t) -> t -> t val with_top : t -> f:(Declare.Proof.t -> 'a ) -> 'a @@ -64,15 +65,23 @@ val unfreeze_interp_state : t -> unit (* WARNING: Do not use, it will go away in future releases *) val invalidate_cache : unit -> unit -(* STM-specific state handling *) +(** STM-specific state handling *) module Stm : sig + + (** Proof state + meta/evar counters *) type pstate - (** Surgery on states related to proof state *) val pstate : t -> pstate val set_pstate : t -> pstate -> t - val non_pstate : t -> Summary.frozen * Lib.frozen + + (** Rest of the state, unfortunately this is used in low-level so we need to expose it *) + type non_pstate = Summary.frozen * Lib.frozen + val non_pstate : t -> non_pstate + + (** Checks if two states have the same Environ.env (physical eq) *) val same_env : t -> t -> bool + + (** Call [Lib.drop_objects] on the state *) val make_shallow : t -> t end @@ -104,7 +113,7 @@ module Declare : sig val close_proof : opaque:Vernacexpr.opacity_flag -> keep_body_ucst_separate:bool -> closed_proof val discard_all : unit -> unit - val update_global_env : unit -> unit + val update_sigma_univs : UGraph.t -> unit val get_current_context : unit -> Evd.evar_map * Environ.env |