diff options
643 files changed, 22086 insertions, 9937 deletions
diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index 8dbdf43e52..56bd34f6fd 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 @@ -156,7 +160,7 @@ /plugins/nsatz/ @coq/nsatz-maintainers /theories/nsatz/ @coq/nsatz-maintainers -/plugins/setoid_ring/ @coq/ring-maintainers +/plugins/ring/ @coq/ring-maintainers /theories/setoid_ring/ @coq/ring-maintainers /plugins/ssrmatching/ @coq/ssreflect-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..b1709e1921 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-10-12-V89" 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 @@ -76,6 +79,7 @@ before_script: - config/coq_config.py - config/coq_config.ml - test-suite/misc/universes/all_stdlib.v + - dmesg.txt expire_in: 1 week script: - set -e @@ -239,6 +243,11 @@ before_script: - make -f Makefile.ci -j "$NJOBS" "${CI_JOB_NAME#*:}" - echo 'end:coq.test' - set +e + artifacts: + name: "$CI_JOB_NAME" + paths: + - _build_ci + when: always needs: - build:base dependencies: @@ -322,22 +331,30 @@ build:base+async: variables: COQ_EXTRA_CONF: "-native-compiler yes -coqide opt" COQUSERFLAGS: "-async-proofs on" + after_script: + - dmesg > dmesg.txt timeout: 100m allow_failure: true # See https://github.com/coq/coq/issues/9658 only: variables: - $UNRELIABLE =~ /enabled/ + artifacts: + when: always build:quick: extends: .build-template variables: COQ_EXTRA_CONF: "-native-compiler no" QUICK: "1" + after_script: + - dmesg > dmesg.txt timeout: 100m allow_failure: true # See https://github.com/coq/coq/issues/9637 only: variables: - $UNRELIABLE =~ /enabled/ + artifacts: + when: always windows64: extends: .windows-template @@ -443,6 +460,8 @@ pkg:nix:deploy:channel: - pkg:nix:deploy script: - echo "$CACHIX_DEPLOYMENT_KEY" | tr -d '\r' | ssh-add - > /dev/null + # Remove all pr branches because they could be missing when we run git fetch --unshallow + - git branch --list 'pr-*' | xargs -r git branch -d - git fetch --unshallow - git branch -v - git push git@github.com:coq/coq-on-cachix "${CI_COMMIT_SHA}":"refs/heads/${CI_COMMIT_REF_NAME}" @@ -597,7 +616,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 zarith - eval $(opam env) - export COQ_UNIT_TEST=noop - make -f Makefile.dune test-suite @@ -612,12 +631,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: @@ -686,10 +699,6 @@ library:ci-bbv: library:ci-bedrock2: extends: .ci-template-flambda - artifacts: - name: "$CI_JOB_NAME" - paths: - - _build_ci variables: NJOBS: "1" @@ -715,10 +724,6 @@ library:ci-coq_tools: library:ci-coqprime: stage: stage-3 extends: .ci-template-flambda - artifacts: - name: "$CI_JOB_NAME" - paths: - - _build_ci needs: - build:edge+flambda - plugin:ci-bignums @@ -744,10 +749,6 @@ library:ci-fcsl_pcm: library:ci-fiat_crypto: extends: .ci-template-flambda stage: stage-4 - artifacts: - name: "$CI_JOB_NAME" - paths: - - _build_ci needs: - build:edge+flambda - library:ci-coqprime @@ -784,10 +785,6 @@ library:ci-fiat_crypto_ocaml: library:ci-flocq: extends: .ci-template-flambda - artifacts: - name: "$CI_JOB_NAME" - paths: - - _build_ci library:ci-corn: extends: .ci-template-flambda @@ -806,16 +803,12 @@ library:ci-geocoq: library:ci-hott: extends: .ci-template -library:ci-lambda_rust: +library:ci-iris: extends: .ci-template-flambda library:ci-math_classes: extends: .ci-template-flambda stage: stage-3 - artifacts: - name: "$CI_JOB_NAME" - paths: - - _build_ci needs: - build:edge+flambda - plugin:ci-bignums @@ -858,10 +851,6 @@ plugin:ci-aac_tactics: plugin:ci-bignums: extends: .ci-template-flambda - artifacts: - name: "$CI_JOB_NAME" - paths: - - _build_ci plugin:ci-coq_dpdgraph: extends: .ci-template @@ -874,10 +863,6 @@ plugin:ci-elpi: plugin:ci-equations: extends: .ci-template - artifacts: - name: "$CI_JOB_NAME" - paths: - - _build_ci plugin:ci-fiat_parsers: extends: .ci-template @@ -923,7 +908,3 @@ plugin:ci-relation_algebra: plugin:ci-rewriter: extends: .ci-template-flambda - artifacts: - name: "$CI_JOB_NAME" - paths: - - _build_ci diff --git a/.merlin.in b/.merlin.in index fa3473765d..80b0b600eb 100644 --- a/.merlin.in +++ b/.merlin.in @@ -54,3 +54,4 @@ S plugins/** B plugins/** PKG threads.posix +PKG zarith
\ No newline at end of file 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 @@ -46,7 +46,7 @@ plugins/omega developed by Pierre Crégut (France Telecom R&D, 1996) plugins/rtauto developed by Pierre Corbineau (LRI, 2005) -plugins/setoid_ring +plugins/ring developed by Benjamin Grégoire (INRIA-Everest, 2005-2006), Assia Mahboubi, Laurent Théry (INRIA-Marelle, 2006) and Bruno Barras (INRIA LogiCal, 2005-2006), diff --git a/INSTALL.md b/INSTALL.md index c44c3dde7d..f672bb45d3 100644 --- a/INSTALL.md +++ b/INSTALL.md @@ -1,16 +1,21 @@ 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.10 - The [findlib](http://projects.camlcity.org/projects/findlib.html) library (version >= 1.8.0) @@ -24,18 +29,18 @@ To compile Coq yourself, you need: - for CoqIDE, the [lablgtk3-sourceview3](https://github.com/garrigue/lablgtk) library - (version >= 3.0.beta8), and the corresponding GTK 3.x libraries, as + (version >= 3.1.0), and the corresponding GTK 3.x libraries, as of today (gtk+3 >= 3.18 and gtksourceview3 >= 3.18) -The IEEE-754 compliance is required by primitive floating-point -numbers (`Require Import Floats`). Common sources of incompatibility -are checked at configure time, preventing compilation. In the, -unlikely, event an incompatibility remains undetected, using Floats -would enable to prove False on this architecture. +Primitive floating-point numbers require IEEE-754 compliance +(`Require Import Floats`). Common sources of incompatibility +are checked at configure time, preventing compilation. In the +unlikely event an incompatibility remains undetected, using `Floats` +would enable proving `False` on this architecture. -Note that `num` and `lablgtk3-sourceview3` should be properly -registered with `findlib/ocamlfind` as Coq's makefile will use it to -locate the libraries during the build. +Note that OCaml dependencies (`zarith` and `lablgtk3-sourceview3` at +this moment) must be properly registered with `findlib/ocamlfind` +since Coq's build system uses `findlib` to locate them. Debian / Ubuntu users can get the necessary system packages for CoqIDE with: @@ -45,9 +50,9 @@ 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 + $ opam install ocamlfind zarith lablgtk3-sourceview3 should get you a reasonable OCaml environment to compile Coq. See the OPAM documentation for more help. diff --git a/META.coq.in b/META.coq.in index 095f54dde7..29b3ecbcb3 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" @@ -223,7 +223,7 @@ package "toplevel" ( description = "Coq Toplevel" version = "8.13" - requires = "num, coq.stm" + requires = "coq.stm" directory = "toplevel" archive(byte) = "toplevel.cma" @@ -327,7 +327,7 @@ package "plugins" ( description = "Coq micromega plugin" version = "8.13" - requires = "num,coq.plugins.ltac" + requires = "coq.plugins.ltac" directory = "micromega" archive(byte) = "micromega_plugin.cmo" @@ -352,19 +352,19 @@ package "plugins" ( plugin(native) = "zify_plugin.cmxs" ) - package "setoid_ring" ( + package "ring" ( - description = "Coq newring plugin" + description = "Coq ring plugin" version = "8.13" requires = "" - directory = "setoid_ring" + directory = "ring" - archive(byte) = "newring_plugin.cmo" - archive(native) = "newring_plugin.cmx" + archive(byte) = "ring_plugin.cmo" + archive(native) = "ring_plugin.cmx" - plugin(byte) = "newring_plugin.cmo" - plugin(native) = "newring_plugin.cmxs" + plugin(byte) = "ring_plugin.cmo" + plugin(native) = "ring_plugin.cmxs" ) package "extraction" ( @@ -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..eed3c2813a 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,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 > $@ @@ -587,11 +587,11 @@ CSDPCERTCMO:=clib/clib.cma $(addprefix plugins/micromega/, \ $(CSDPCERT): $(call bestobj, $(CSDPCERTCMO)) $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml, -package num,unix) + $(HIDE)$(call bestocaml, -package unix) $(CSDPCERTBYTE): $(CSDPCERTCMO) $(SHOW)'OCAMLC -o $@' - $(HIDE)$(call ocamlbyte, -package num,unix) + $(HIDE)$(call ocamlbyte, -package unix) ########################################################################### # tests @@ -707,11 +707,7 @@ COND_OPTFLAGS= \ 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 $< + $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -package unix -c $< %.cmi: %.mli $(SHOW)'OCAMLC $<' @@ -719,11 +715,7 @@ plugins/nsatz/%.cmi: plugins/nsatz/%.mli 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 $< + $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -package unix -c $< %.cmo: %.ml $(SHOW)'OCAMLC $<' @@ -760,11 +752,7 @@ plugins/micromega/csdpcert_FORPACK:= 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 $< + $(HIDE)$(OCAMLOPT) $(COND_OPTFLAGS) $(HACKMLI) $($(@:.cmx=_FORPACK)) -package unix -c $< plugins/%.cmx: plugins/%.ml $(SHOW)'OCAMLOPT $<' 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.common b/Makefile.common index 8f880e93fb..a482b9b963 100644 --- a/Makefile.common +++ b/Makefile.common @@ -103,7 +103,7 @@ CORESRCDIRS:=\ PLUGINDIRS:=\ omega micromega \ - setoid_ring extraction \ + ring extraction \ cc funind firstorder derive \ rtauto nsatz syntax btauto \ ssrmatching ltac ssr ssrsearch @@ -140,7 +140,7 @@ CORECMA:=config/config.cma clib/clib.cma lib/lib.cma kernel/kernel.cma library/l OMEGACMO:=plugins/omega/omega_plugin.cmo MICROMEGACMO:=plugins/micromega/micromega_plugin.cmo -RINGCMO:=plugins/setoid_ring/newring_plugin.cmo +RINGCMO:=plugins/ring/ring_plugin.cmo NSATZCMO:=plugins/nsatz/nsatz_plugin.cmo EXTRACTIONCMO:=plugins/extraction/extraction_plugin.cmo FUNINDCMO:=plugins/funind/recdef_plugin.cmo diff --git a/Makefile.dev b/Makefile.dev index f48a6f0d8f..5825a884c2 100644 --- a/Makefile.dev +++ b/Makefile.dev @@ -154,7 +154,7 @@ LTACVO:=$(filter theories/ltac/%, $(THEORIESVO)) omega: $(OMEGAVO) $(OMEGACMO) micromega: $(MICROMEGAVO) $(MICROMEGACMO) $(CSDPCERT) -setoid_ring: $(RINGVO) $(RINGCMO) +ring: $(RINGVO) $(RINGCMO) nsatz: $(NSATZVO) $(NSATZCMO) extraction: $(EXTRACTIONCMO) $(EXTRACTIONVO) funind: $(FUNINDCMO) $(FUNINDVO) @@ -163,7 +163,7 @@ rtauto: $(RTAUTOVO) $(RTAUTOCMO) btauto: $(BTAUTOVO) $(BTAUTOCMO) ltac: $(LTACVO) $(LTACCMO) -.PHONY: omega micromega setoid_ring nsatz extraction +.PHONY: omega micromega ring nsatz extraction .PHONY: funind cc rtauto btauto ltac # For emacs: 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..41b5210f45 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" ocamlfind${FINDLIB_VER} ounit lablgtk3-sourceview3 zarith.1.10 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/cUnix.ml b/clib/cUnix.ml index 75ed73540e..3a10e33369 100644 --- a/clib/cUnix.ml +++ b/clib/cUnix.ml @@ -69,7 +69,7 @@ let canonical_path_name p = p' with Sys_error _ -> (* We give up to find a canonical name and just simplify it... *) - strip_path p + current ^ dirsep ^ strip_path p let make_suffix name suffix = if Filename.check_suffix name suffix then name else (name ^ suffix) 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..83d1364b0c 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)))) + (action (chdir %{project_root} (run %{ocaml} configure.ml -no-ask -native-compiler no -bin-annot)))) 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..7fd1acb53e 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,22 +688,22 @@ 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) -*) - -let check_for_numlib () = - 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!" +(** Zarith library *) + +let check_for_zarith () = + let zarith,_ = tryrun camlexec.find ["query";"zarith"] in + let zarith_version, _ = run camlexec.find ["query"; "zarith"; "-format"; "%v"] in + match zarith with + | "" -> + die "Zarith library not installed, required" + | _ -> + let zarith_version_int = List.map int_of_string (numeric_prefix_list zarith_version) in + if zarith_version_int >= [1;10;0] then + cprintf "You have the Zarith library %s installed. Good!" zarith_version + else + die ("Zarith version 1.10 is required, you have " ^ zarith_version) -let numlib = - check_for_numlib () +let numlib = check_for_zarith () (** * lablgtk3 and CoqIDE *) @@ -714,20 +716,14 @@ let get_lablgtkdir () = let check_lablgtk_version () = let v, _ = tryrun camlexec.find ["query"; "-format"; "%v"; "lablgtk3"] in - (true, v) - -(* ejgallego: we wait to do version checks until an official release is out *) -(* try - let vi = numeric_prefix_list v in - (* Temporary hack *) - if vi = ["3";"0";"beta3"] then (false, v) else - let vi = List.map s2i vi in - if vi < [3; 0; 0] then + try + let vl = numeric_prefix_list v in + let vn = List.map int_of_string vl in + if vn < [3; 1; 0] then (false, v) else (true, v) with _ -> (false, v) -*) let pr_ide = function No -> "no" | Byte -> "only bytecode" | Opt -> "native" @@ -755,7 +751,7 @@ let check_coqide () = else let (ok, version) = check_lablgtk_version () in let found = sprintf "LablGtk3 and LablGtkSourceView3 found (%s)" version in - if not ok then set_ide No (found^", but too old (required >= 3.0, found " ^ version ^ ")"); + if not ok then set_ide No (found^", but too old (required >= 3.1.0, found " ^ version ^ ")"); (* We're now sure to produce at least one kind of coqide *) lablgtkdir := shorten_camllib dir; if !prefs.coqide = Some Byte then set_ide Byte (found^", bytecode requested"); @@ -1108,11 +1104,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 @@ -24,7 +24,7 @@ depends: [ "ocaml" { >= "4.05.0" } "dune" { >= "2.5.0" } "ocamlfind" { build } - "num" + "zarith" { >= "1.10" } ] build: [ diff --git a/coq.opam.docker b/coq.opam.docker index 229a47a87b..74ca68ac0b 100644 --- a/coq.opam.docker +++ b/coq.opam.docker @@ -23,7 +23,7 @@ version: "dev" depends: [ "ocaml" { >= "4.05.0" } "ocamlfind" { build } - "num" + "zarith" { >= "1.10" } "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..ffee77f1f7 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 ]) ++ optionals buildIde [ ocamlPackages.lablgtk3-sourceview3 glib gnome3.defaultIconTheme wrapGAppsHook @@ -69,6 +69,11 @@ 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) + # Same for zarith which is needed since its introduction as a dependency of Coq + propagatedBuildInputs = with ocamlPackages; [ zarith ]; + 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..41f204385f --- /dev/null +++ b/dev/bench/gitlab.sh @@ -0,0 +1,500 @@ +#! /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 ]; then + echo "$coq_opam_package/$vo $(stat -c%s $old_opam_root/$old_base_path/$vo) $(stat -c%s $new_opam_root/$new_base_path/$vo)" >> "$log_dir/vosize.log" + fi + 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..fc8921e63d 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.10 tar.gz 1 zarith-1.10; then + logn configure ./configure + log1 make + log2 make install + build_post + fi +} + ##### OCAMLBUILD ##### function make_ocamlbuild { @@ -1193,7 +1204,7 @@ function make_elpi { make_dune make_re - if build_prep https://github.com/LPCIC/elpi/archive v1.11.0 tar.gz 1 elpi; then + if build_prep https://github.com/LPCIC/elpi/archive v1.11.4 tar.gz 1 elpi; then log2 dune build -p elpi log2 dune install elpi diff --git a/dev/build/windows/patches_coq/ocaml-4.08.1.patch b/dev/build/windows/patches_coq/ocaml-4.08.1.patch new file mode 100644 index 0000000000..a79033a061 --- /dev/null +++ b/dev/build/windows/patches_coq/ocaml-4.08.1.patch @@ -0,0 +1,25 @@ +diff --git a/runtime/caml/misc.h b/runtime/caml/misc.h +index 6aa98516b..8184c2797 100644 +--- a/runtime/caml/misc.h ++++ b/runtime/caml/misc.h +@@ -327,7 +327,6 @@ extern void caml_set_fields (intnat v, uintnat, uintnat); + + #if defined(_WIN32) && !defined(_UCRT) + extern int caml_snprintf(char * buf, size_t size, const char * format, ...); +-#define snprintf caml_snprintf + #endif + + #ifdef CAML_INSTR +@@ -336,6 +335,12 @@ extern int caml_snprintf(char * buf, size_t size, const char * format, ...); + #include <time.h> + #include <stdio.h> + ++/* snprintf emulation for Win32 - do define after stdio.h, in case snprintf is defined */ ++ ++#if defined(_WIN32) && !defined(_UCRT) ++#define snprintf caml_snprintf ++#endif ++ + extern intnat caml_stat_minor_collections; + extern intnat caml_instr_starttime, caml_instr_stoptime; + 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-common.sh b/dev/ci/ci-common.sh index c01bc57f72..f9187d53a6 100644 --- a/dev/ci/ci-common.sh +++ b/dev/ci/ci-common.sh @@ -97,9 +97,9 @@ make() if [ -z "${MAKEFLAGS+x}" ] && [ -n "${NJOBS}" ]; then # Not submake and parallel make requested - command make -j "$NJOBS" "$@" + command make --output-sync -j "$NJOBS" "$@" else - command make "$@" + command make --output-sync "$@" fi } 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..9616f3ce00 --- /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/coq-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/coq-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..c17ec502e7 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-10-12-V89" # ^^ 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,12 +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 +ENV BASE_OPAM="zarith.1.10 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" + BASE_ONLY_OPAM="elpi.1.11.4" # BASE switch; CI_OPAM contains Coq's CI dependencies. ENV COQIDE_OPAM="cairo2.0.6.1 lablgtk3-sourceview3.3.1.0" @@ -52,13 +55,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.10 && \ + 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..7863af842a 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 @@ -130,7 +131,8 @@ stdenv.mkDerivation { name = "shell-for-${project}-in-${branch}"; buildInputs = - optional withCoq coq + [ python ] + ++ optional withCoq coq ++ (prj.buildInputs or []) ++ optionals withCoq (prj.coqBuildInputs or []) ; 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/12449-SkySkimmer-minim-prop-toset.sh b/dev/ci/user-overlays/12449-SkySkimmer-minim-prop-toset.sh new file mode 100644 index 0000000000..fb5947d218 --- /dev/null +++ b/dev/ci/user-overlays/12449-SkySkimmer-minim-prop-toset.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "12449" ] || [ "$CI_BRANCH" = "minim-prop-toset" ]; then + + mtac2_CI_REF=janno/coq-12449 + mtac2_CI_GITURL=https://github.com/mtac2/mtac2 + +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/ci/user-overlays/12977-ppedrot-static-hint-poly.sh b/dev/ci/user-overlays/12977-ppedrot-static-hint-poly.sh new file mode 100644 index 0000000000..7bed43afe1 --- /dev/null +++ b/dev/ci/user-overlays/12977-ppedrot-static-hint-poly.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "12977" ] || [ "$CI_BRANCH" = "static-hint-poly" ]; then + + equations_CI_REF=static-hint-poly + equations_CI_GITURL=https://github.com/ppedrot/Coq-Equations + + fiat_parsers_CI_REF=static-hint-poly + fiat_parsers_CI_GITURL=https://github.com/ppedrot/fiat + +fi diff --git a/dev/ci/user-overlays/13028-herbelin-master+fix-quotations-printing.sh b/dev/ci/user-overlays/13028-herbelin-master+fix-quotations-printing.sh new file mode 100644 index 0000000000..3407c2db39 --- /dev/null +++ b/dev/ci/user-overlays/13028-herbelin-master+fix-quotations-printing.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "13028" ] || [ "$CI_BRANCH" = "master+fix-quotations-printing" ]; then + + equations_CI_REF=master+adapt-coq-pr13028-quotation-qualifier-printing + equations_CI_GITURL=https://github.com/herbelin/Coq-Equations + +fi diff --git a/dev/ci/user-overlays/13088-gares-par-to-tactic.sh b/dev/ci/user-overlays/13088-gares-par-to-tactic.sh new file mode 100644 index 0000000000..4108a1aed1 --- /dev/null +++ b/dev/ci/user-overlays/13088-gares-par-to-tactic.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "13088" ] || [ "$CI_BRANCH" = "par-to-tactic" ]; then + + mtac2_CI_REF=par-to-tactic + mtac2_CI_GITURL=https://github.com/gares/Mtac2 + +fi diff --git a/dev/ci/user-overlays/13128-SkySkimmer-noinstance.sh b/dev/ci/user-overlays/13128-SkySkimmer-noinstance.sh new file mode 100644 index 0000000000..654d95f205 --- /dev/null +++ b/dev/ci/user-overlays/13128-SkySkimmer-noinstance.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "13128" ] || [ "$CI_BRANCH" = "noinstance" ]; then + + elpi_CI_REF=noinstance + elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi + +fi diff --git a/dev/ci/user-overlays/13143-herbelin-master+drop-misleading-arg-hbox.sh b/dev/ci/user-overlays/13143-herbelin-master+drop-misleading-arg-hbox.sh new file mode 100644 index 0000000000..1b3121781b --- /dev/null +++ b/dev/ci/user-overlays/13143-herbelin-master+drop-misleading-arg-hbox.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "13143" ] || [ "$CI_BRANCH" = "master+drop-misleading-arg-hbox" ]; then + + aac_tactics_CI_REF=master+adapt-coq-pr13143-hbox-no-argument + aac_tactics_CI_GITURL=https://github.com/herbelin/aac-tactics + + equations_CI_REF=master+adapt-coq-pr13143-hbox-no-argument + equations_CI_GITURL=https://github.com/herbelin/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/changes.md b/dev/doc/changes.md index ae4c6328b5..fb5d7cc244 100644 --- a/dev/doc/changes.md +++ b/dev/doc/changes.md @@ -1,5 +1,22 @@ ## Changes between Coq 8.12 and Coq 8.13 +- Tactic language: TacGeneric now takes an argument to tell if it + comes from a notation. Use `None` if not and `Some foo` to tell to + print such TacGeneric surrounded with `foo:( )`. + +### Code formatting + +- The automatic code formatting tool `ocamlformat` has been disabled and its + git hook removed. If desired, automatic formatting can be achieved by calling + the `fmt` target of the dune build system. + +### Pp library + +- `Pp.h` does not take a `int` argument anymore (the argument was + not used). In general, where `h n` for `n` non zero was used, `hv n` + was instead intended. If cancelling the breaking role of cuts in the + box was intended, turn `h n c` into `h c`. + ## Changes between Coq 8.11 and Coq 8.12 ### Code formatting diff --git a/dev/doc/parsing.md b/dev/doc/parsing.md new file mode 100644 index 0000000000..4982e3e94d --- /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 "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/include_printers b/dev/include_printers index 30529b5fd6..7583762970 100644 --- a/dev/include_printers +++ b/dev/include_printers @@ -26,6 +26,8 @@ #install_printer (* judgement *) ppj;; #install_printer (* id set *) ppidset;; #install_printer (* int set *) ppintset;; +#install_printer (* id set *) ppidmapgen;; +#install_printer (* int set *) ppintmapgen;; #install_printer (* Reductionops machine stack *) pp_stack_t;; diff --git a/dev/lint-repository.sh b/dev/lint-repository.sh index 553696410c..2e8a7455de 100755 --- a/dev/lint-repository.sh +++ b/dev/lint-repository.sh @@ -32,7 +32,4 @@ find . "(" -path ./.git -prune ")" -o -type f -print0 | echo Checking overlays dev/tools/check-overlays.sh || CODE=1 -echo Checking ocamlformat -make -f Makefile.dune fmt || CODE=1 - exit $CODE diff --git a/dev/nixpkgs.nix b/dev/nixpkgs.nix index bfb25e72dd..a582a70e0a 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/0bbeca2ff952e6a171534793ddd0fa97c8f9546a.tar.gz"; + sha256 = "0h1y4ffvyvkqs6k2pak02pby25va7c6c1y4p8xkwlzqwswxqxvfl"; }) diff --git a/dev/ocamldebug-coq.run b/dev/ocamldebug-coq.run index a11269e059..534f20f85b 100644 --- a/dev/ocamldebug-coq.run +++ b/dev/ocamldebug-coq.run @@ -30,8 +30,9 @@ exec $OCAMLDEBUG \ -I $COQTOP/plugins/interface -I $COQTOP/plugins/micromega \ -I $COQTOP/plugins/omega -I $COQTOP/plugins/quote \ -I $COQTOP/plugins/ring \ - -I $COQTOP/plugins/rtauto -I $COQTOP/plugins/setoid_ring \ + -I $COQTOP/plugins/rtauto \ -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/tools/pre-commit b/dev/tools/pre-commit index 448e224f2e..74fcceb038 100755 --- a/dev/tools/pre-commit +++ b/dev/tools/pre-commit @@ -7,25 +7,7 @@ set -e dev/tools/check-overlays.sh -# Can we check and fix formatting? -# NB: we will ignore errors from ocamlformat as it fails when -# encountering OCaml syntax errors -ocamlformat=$(command -v ocamlformat || echo true) -if [ "$ocamlformat" = true ] -then - 1>&2 echo "Warning: ocamlformat is not in path. Cannot check formatting." -fi - -# Verify that the version of ocamlformat matches the one in .ocamlformat -# The following command will print an error message if that's not the case -# (and will print nothing if the versions match) -if ! echo "let () = ()" | "$ocamlformat" --impl - > /dev/null -then - 1>&2 echo "Warning: Cannot check formatting." - ocamlformat=true -fi - -1>&2 echo "Auto fixing whitespace and formatting issues..." +1>&2 echo "Auto fixing whitespace issues..." # We fix whitespace in the index and in the working tree # separately to preserve non-added changes. @@ -52,7 +34,6 @@ if [ -s "$index" ]; then git apply --cached --whitespace=fix "$index" git apply --whitespace=fix "$index" 2>/dev/null # no need to repeat yourself git diff --cached --name-only -z | xargs -0 dev/tools/check-eof-newline.sh --fix - { git diff --cached --name-only -z | grep -E '.*\.mli?$' -z | xargs -0 "$ocamlformat" -i || true; } 2> /dev/null git add -u 1>&2 echo #newline fi @@ -68,12 +49,11 @@ if [ -s "$tree" ]; then 1>&2 echo "Fixing unstaged changes..." git apply --whitespace=fix "$tree" git diff --name-only -z | xargs -0 dev/tools/check-eof-newline.sh --fix - { git diff --name-only -z | grep -E '.*\.mli?$' -z | xargs -0 "$ocamlformat" -i || true; } 2> /dev/null 1>&2 echo #newline fi if [ -s "$index" ] && ! [ -s "$fixed_index" ]; then - 1>&2 echo "Fixing whitespace and formatting issues cancelled all changes." + 1>&2 echo "Fixing whitespace issues cancelled all changes." exit 1 fi @@ -84,7 +64,7 @@ if ! git diff-index --check --cached HEAD; then 1>&2 echo "(Consider whether the number of errors decreases after each run.)" exit 1 fi -1>&2 echo "Whitespace and formatting pass complete." +1>&2 echo "Whitespace pass complete." # clean up temporary files rm "$index" "$tree" "$fixed_index" diff --git a/dev/top_printers.dbg b/dev/top_printers.dbg index 63071bba72..21d6fbe9aa 100644 --- a/dev/top_printers.dbg +++ b/dev/top_printers.dbg @@ -23,12 +23,12 @@ 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 install_printer Top_printers.ppidset install_printer Top_printers.ppidmapgen +install_printer Top_printers.ppintmapgen install_printer Top_printers.ppididmap install_printer Top_printers.ppconstrunderbindersidmap install_printer Top_printers.ppevarsubst diff --git a/dev/top_printers.ml b/dev/top_printers.ml index ea90e83a83..e4dd7ef52c 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) @@ -95,11 +94,13 @@ let pridmap pr l = prset' pr (Id.Map.fold (fun a b l -> (a,b)::l) l []) let ppidmap pr l = pp (pridmap pr l) -let pridmapgen l = - let dom = Id.Set.elements (Id.Map.domain l) in +let prmapgen pr dom = if dom = [] then str "[]" else - str "[domain= " ++ hov 0 (prlist_with_sep spc Id.print dom) ++ str "]" + str "[domain= " ++ hov 0 (prlist_with_sep spc pr dom) ++ str "]" +let pridmapgen l = prmapgen Id.print (Id.Set.elements (Id.Map.domain l)) let ppidmapgen l = pp (pridmapgen l) +let printmapgen l = prmapgen int (Int.Set.elements (Int.Map.domain l)) +let ppintmapgen l = pp (printmapgen l) let ppevarsubst = ppidmap (fun id0 -> prset (fun (c,copt,id) -> hov 0 diff --git a/dev/top_printers.mli b/dev/top_printers.mli index 65eab8daa3..712f66112c 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 @@ -66,6 +65,9 @@ val ppidmap : (Names.Id.Map.key -> 'a -> Pp.t) -> 'a Names.Id.Map.t -> unit val pridmapgen : 'a Names.Id.Map.t -> Pp.t val ppidmapgen : 'a Names.Id.Map.t -> unit +val printmapgen : 'a Int.Map.t -> Pp.t +val ppintmapgen : 'a Int.Map.t -> unit + val prididmap : Names.Id.t Names.Id.Map.t -> Pp.t val ppididmap : Names.Id.t Names.Id.Map.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/10331-minim-prop-toset.rst b/doc/changelog/02-specification-language/10331-minim-prop-toset.rst new file mode 100644 index 0000000000..6c442ca1aa --- /dev/null +++ b/doc/changelog/02-specification-language/10331-minim-prop-toset.rst @@ -0,0 +1,5 @@ +- **Changed:** Heuristics for universe minimization to :g:`Set`: also + use constraints ``Prop <= i`` (`#10331 + <https://github.com/coq/coq/pull/10331>`_, by Gaëtan Gilbert with + help from Maxime Dénès and Matthieu Sozeau, fixes `#12414 + <https://github.com/coq/coq/issues/12414>`_). 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/02-specification-language/13106-doc-and-changelog-for-13106.rst b/doc/changelog/02-specification-language/13106-doc-and-changelog-for-13106.rst new file mode 100644 index 0000000000..7fe69c39c1 --- /dev/null +++ b/doc/changelog/02-specification-language/13106-doc-and-changelog-for-13106.rst @@ -0,0 +1,5 @@ +- **Removed:** + Undocumented and experimental forward class hint feature ``:>>``. + Use ``:>`` (see :n:`@of_type`) instead + (`#13106 <https://github.com/coq/coq/pull/13106>`_, + by Pierre-Marie Pédrot). diff --git a/doc/changelog/03-notations/12946-master+fix12908-part1-collision-lonely-notation-printing.rst b/doc/changelog/03-notations/12946-master+fix12908-part1-collision-lonely-notation-printing.rst new file mode 100644 index 0000000000..95a9093272 --- /dev/null +++ b/doc/changelog/03-notations/12946-master+fix12908-part1-collision-lonely-notation-printing.rst @@ -0,0 +1,6 @@ +- **Fixed:** + Undetected collision between a lonely notation and a notation in + scope at printing time + (`#12946 <https://github.com/coq/coq/pull/12946>`_, + fixes the first part of `#12908 <https://github.com/coq/coq/issues/12908>`_, + by Hugo Herbelin). diff --git a/doc/changelog/03-notations/12950-master+reorganization-notations-only-parsing-only-printing.rst b/doc/changelog/03-notations/12950-master+reorganization-notations-only-parsing-only-printing.rst new file mode 100644 index 0000000000..16fc91f911 --- /dev/null +++ b/doc/changelog/03-notations/12950-master+reorganization-notations-only-parsing-only-printing.rst @@ -0,0 +1,10 @@ +- **Changed:** + New model for ``only parsing`` and ``only printing`` notations with + support for at most one parsing-and-printing or only-parsing + notation per notation and scope, but an arbitrary number of + only-printing notations + (`#12950 <https://github.com/coq/coq/pull/12950>`_, + fixes `#4738 <https://github.com/coq/coq/issues/4738>`_ + and `#9682 <https://github.com/coq/coq/issues/9682>`_ + and part 2 of `#12908 <https://github.com/coq/coq/issues/12908>`_, + by Hugo Herbelin). diff --git a/doc/changelog/03-notations/12960-master+fix9403-missing-flattening-app-notations.rst b/doc/changelog/03-notations/12960-master+fix9403-missing-flattening-app-notations.rst new file mode 100644 index 0000000000..fc909e7a1d --- /dev/null +++ b/doc/changelog/03-notations/12960-master+fix9403-missing-flattening-app-notations.rst @@ -0,0 +1,8 @@ +- **Fixed:** + Issues in the presence of notations recursively referring to another + applicative notations, such as missing scope propagation, or failure + to use a notation for printing + (`#12960 <https://github.com/coq/coq/pull/12960>`_, + fixes `#9403 <https://github.com/coq/coq/issues/9403>`_ + and `#10803 <https://github.com/coq/coq/issues/10803>`_, + by Hugo Herbelin). 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/03-notations/13026-master+fix-printing-custom-no-level-8.2.rst b/doc/changelog/03-notations/13026-master+fix-printing-custom-no-level-8.2.rst new file mode 100644 index 0000000000..42b62eed75 --- /dev/null +++ b/doc/changelog/03-notations/13026-master+fix-printing-custom-no-level-8.2.rst @@ -0,0 +1,7 @@ +- **Fixed:** + Fixing printing of notations in custom entries with + variables not mentioning an explicit level + (`#13026 <https://github.com/coq/coq/pull/13026>`_, + fixes `#12775 <https://github.com/coq/coq/issues/12775>`_ + and `#13018 <https://github.com/coq/coq/issues/13018>`_, + by Hugo Herbelin). diff --git a/doc/changelog/03-notations/13067-master+fix-display-parentheses-default-coqide.rst b/doc/changelog/03-notations/13067-master+fix-display-parentheses-default-coqide.rst new file mode 100644 index 0000000000..50aa4a9052 --- /dev/null +++ b/doc/changelog/03-notations/13067-master+fix-display-parentheses-default-coqide.rst @@ -0,0 +1,5 @@ +- **Fixed:** + Repairing option :g:`Display parentheses` in CoqIDE + (`#12794 <https://github.com/coq/coq/pull/12794>`_ and `#13067 <https://github.com/coq/coq/pull/13067>`_, + fixes `#12793 <https://github.com/coq/coq/issues/12793>`_, + by Jean-Christophe Léchenet and Hugo Herbelin). 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/12847-master+inversion-works-with-eq-in-type.rst b/doc/changelog/04-tactics/12847-master+inversion-works-with-eq-in-type.rst new file mode 100644 index 0000000000..b444a2f436 --- /dev/null +++ b/doc/changelog/04-tactics/12847-master+inversion-works-with-eq-in-type.rst @@ -0,0 +1,6 @@ +- **Added:** + :tacn:`replace` and :tacn:`inversion` support registration of a + :g:`core.identity`-like equality in :g:`Type`, such as HoTT's :g:`path` + (`#12847 <https://github.com/coq/coq/pull/12847>`_, + partially fixes `#12846 <https://github.com/coq/coq/issues/12846>`_, + 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/05-tactic-language/13028-master+fix-quotations-printing.rst b/doc/changelog/05-tactic-language/13028-master+fix-quotations-printing.rst new file mode 100644 index 0000000000..a191716b2f --- /dev/null +++ b/doc/changelog/05-tactic-language/13028-master+fix-quotations-printing.rst @@ -0,0 +1,6 @@ +- **Fixed:** + printing of the quotation qualifiers when printing :g:`Ltac` functions + (`#13028 <https://github.com/coq/coq/pull/13028>`_, + fixes `#9716 <https://github.com/coq/coq/issues/9716>`_ + and `#13004 <https://github.com/coq/coq/issues/13004>`_, + by Hugo Herbelin). 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/07-commands-and-options/13016-remove-Ocaml-value.rst b/doc/changelog/07-commands-and-options/13016-remove-Ocaml-value.rst new file mode 100644 index 0000000000..c67b0f6e80 --- /dev/null +++ b/doc/changelog/07-commands-and-options/13016-remove-Ocaml-value.rst @@ -0,0 +1,4 @@ +- **Removed:** + In the :cmd:`Extraction Language` command, remove `Ocaml` as a valid value. + Use `OCaml` instead. This was deprecated in Coq 8.8, `#6261 <https://github.com/coq/coq/pull/6261>`_ + (`#13016 <https://github.com/coq/coq/pull/13016>`_, by Jim Fehrle). diff --git a/doc/changelog/07-commands-and-options/13096-drop-grammar-prefixes.rst b/doc/changelog/07-commands-and-options/13096-drop-grammar-prefixes.rst new file mode 100644 index 0000000000..0ab9a58e6f --- /dev/null +++ b/doc/changelog/07-commands-and-options/13096-drop-grammar-prefixes.rst @@ -0,0 +1,6 @@ +- **Changed:** + Drop prefixes from grammar non-terminal names, + e.g. "constr:global" -> "global", "Prim.name" -> "name". + Visible in the output of :cmd:`Print Grammar` and :cmd:`Print Custom Grammar`. + (`#13096 <https://github.com/coq/coq/pull/13096>`_, + by Jim Fehrle). 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/08-tools/13063-fix-no-output-sync-make-file.rst b/doc/changelog/08-tools/13063-fix-no-output-sync-make-file.rst new file mode 100644 index 0000000000..75b1e26248 --- /dev/null +++ b/doc/changelog/08-tools/13063-fix-no-output-sync-make-file.rst @@ -0,0 +1,6 @@ +- **Fixed:** + Targets such as ``print-pretty-timed`` in ``coq_makefile``-made + ``Makefile``\s no longer error in rare cases where ``--output-sync`` is not + passed to make and the timing output gets interleaved in just the wrong way + (`#13063 <https://github.com/coq/coq/pull/13063>`_, fixes `#13062 + <https://github.com/coq/coq/issues/13062>`_, 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/13007-zarith+goodbye_num.rst b/doc/changelog/11-infrastructure-and-dependencies/13007-zarith+goodbye_num.rst new file mode 100644 index 0000000000..c142eec561 --- /dev/null +++ b/doc/changelog/11-infrastructure-and-dependencies/13007-zarith+goodbye_num.rst @@ -0,0 +1,4 @@ +- **Removed:** + The `num` library is not linked to Coq anymore + (`#13007 <https://github.com/coq/coq/pull/13007>`_, + 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/ring.rst b/doc/sphinx/addendum/ring.rst index 479fa674f5..cda8a1b679 100644 --- a/doc/sphinx/addendum/ring.rst +++ b/doc/sphinx/addendum/ring.rst @@ -387,8 +387,8 @@ The syntax for adding a new ring is interpretation via ``Cp_phi`` (the evaluation function of power coefficient) is the original term, or returns ``InitialRing.NotConstant`` if not a constant coefficient (i.e. |L_tac| is the inverse function of - ``Cp_phi``). See files ``plugins/setoid_ring/ZArithRing.v`` - and ``plugins/setoid_ring/RealField.v`` for examples. By default the tactic + ``Cp_phi``). See files ``plugins/ring/ZArithRing.v`` + and ``plugins/ring/RealField.v`` for examples. By default the tactic does not recognize power expressions as ring expressions. :n:`sign @one_term` @@ -396,7 +396,7 @@ The syntax for adding a new ring is outputting its normal form, i.e writing ``x − y`` instead of ``x + (− y)``. The term :token:`term` is a proof that a given sign function indicates expressions that are signed (:token:`term` has to be a proof of ``Ring_theory.get_sign``). See - ``plugins/setoid_ring/InitialRing.v`` for examples of sign function. + ``plugins/ring/InitialRing.v`` for examples of sign function. :n:`div @one_term` allows :tacn:`ring` and :tacn:`ring_simplify` to use monomials with @@ -405,7 +405,7 @@ The syntax for adding a new ring is euclidean division function (:n:`@one_term` has to be a proof of ``Ring_theory.div_theory``). For example, this function is called when trying to rewrite :math:`7x` by :math:`2x = z` to tell that :math:`7 = 3 \times 2 + 1`. See - ``plugins/setoid_ring/InitialRing.v`` for examples of div function. + ``plugins/ring/InitialRing.v`` for examples of div function. :n:`closed [ {+ @qualid } ]` to be documented @@ -538,7 +538,7 @@ Dealing with fields The tactic must be loaded by ``Require Import Field``. New field structures can be declared to the system with the ``Add Field`` command (see below). The field of real numbers is defined in module ``RealField`` - (in ``plugins/setoid_ring``). It is exported by module ``Rbase``, so + (in ``plugins/ring``). It is exported by module ``Rbase``, so that requiring ``Rbase`` or ``Reals`` is enough to use the field tactics on real numbers. Rational numbers in canonical form are also declared as a field in the module ``Qcanon``. diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index 903aa266e2..d533470f22 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -298,7 +298,7 @@ Summary of the commands .. cmd:: Class @inductive_definition {* with @inductive_definition } The :cmd:`Class` command is used to declare a typeclass with parameters - :token:`binders` and fields the declared record fields. + :n:`{* @binder }` and fields the declared record fields. Like any command declaring a record, this command supports the :attr:`universes(polymorphic)`, :attr:`universes(monomorphic)`, @@ -330,17 +330,17 @@ 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 fields defined by :token:`field_def`, where each field must be a declared field of the class. - An arbitrary context of :token:`binders` can be put after the name of the + An arbitrary context of :n:`{* @binder }` 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..a8a574c861 100755 --- a/doc/sphinx/conf.py +++ b/doc/sphinx/conf.py @@ -183,10 +183,17 @@ todo_include_todos = False nitpicky = True nitpick_ignore = [ ('token', token) for token in [ - 'binders', 'collection', - 'modpath', 'tactic', + '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/cic.rst b/doc/sphinx/language/cic.rst index 768c83150e..f1ed64e52a 100644 --- a/doc/sphinx/language/cic.rst +++ b/doc/sphinx/language/cic.rst @@ -274,7 +274,7 @@ following rules. .. inference:: Prod-Type \WTEG{T}{s} - s \in \{\SProp, \Type{i}\} + s \in \{\SProp, \Type(i)\} \WTE{\Gamma::(x:T)}{U}{\Type(i)} -------------------------------- \WTEG{∀ x:T,~U}{\Type(i)} diff --git a/doc/sphinx/language/coq-library.rst b/doc/sphinx/language/coq-library.rst index f9d24fde0e..485dfd964d 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 @@ -677,7 +677,7 @@ fixpoint equation can be proved. .. index:: single: Fix_F (term) - single: fix_eq (term) + single: Fix_eq (term) single: Fix_F_inv (term) single: Fix_F_eq (term) @@ -696,7 +696,7 @@ fixpoint equation can be proved. forall (x:A) (r:Acc x), F x (fun (y:A) (p:R y x) => Fix_F y (Acc_inv x r y p)) = Fix_F x r. Lemma Fix_F_inv : forall (x:A) (r s:Acc x), Fix_F x r = Fix_F x s. - Lemma fix_eq : forall x:A, Fix x = F x (fun (y:A) (p:R y x) => Fix y). + Lemma Fix_eq : forall x:A, Fix x = F x (fun (y:A) (p:R y x) => Fix y). End FixPoint. End Well_founded. @@ -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..41e1c30f0d 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 @@ -138,7 +138,7 @@ has type :n:`@type`. | {| Variable | Variables } assumpt ::= {+ @ident_decl } @of_type ident_decl ::= @ident {? @univ_decl } - of_type ::= {| : | :> | :>> } @type + of_type ::= {| : | :> } @type These commands bind one or more :n:`@ident`\(s) to specified :n:`@type`\(s) as their specifications in the global context. The fact asserted by the :n:`@type` (or, equivalently, the existence 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/primitive.rst b/doc/sphinx/language/core/primitive.rst index 727177b23a..48647deeff 100644 --- a/doc/sphinx/language/core/primitive.rst +++ b/doc/sphinx/language/core/primitive.rst @@ -133,7 +133,7 @@ follows: 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]. -The complete set of such operators can be obtained looking at the :g:`PArray` module. +The rest of these operators can be found in the :g:`PArray` module. These primitive declarations are regular axioms. As such, they must be trusted and are listed by the :g:`Print Assumptions` command. @@ -150,7 +150,16 @@ extraction. Instead, it has to be provided by the user (if they want to compile or execute the extracted code). For instance, an implementation of this module can be taken from the kernel of Coq (see ``kernel/parray.ml``). -Primitive arrays expose a functional interface, but they are internally -implemented using a persistent data structure :cite:`ConchonFilliatre07wml`. -Update and access to an element in the most recent copy of an array are -constant time operations. +Coq's primitive arrays are persistent data structures. Semantically, a set operation +``t.[i <- a]`` represents a new array that has the same values as ``t``, except +at position ``i`` where its value is ``a``. The array ``t`` still exists, can +still be used and its values were not modified. Operationally, the implementation +of Coq's primitive arrays is optimized so that the new array ``t.[i <- a]`` does not +copy all of ``t``. The details are in section 2.3 of :cite:`ConchonFilliatre07wml`. +In short, the implementation keeps one version of ``t`` as an OCaml native array and +other versions as lists of modifications to ``t``. Accesses to the native array +version are constant time operations. However, accesses to versions where all the cells of +the array are modified have O(n) access time, the same as a list. The version that is kept as the native array +changes dynamically upon each get and set call: the current list of modifications +is applied to the native array and the lists of modifications of the other versions +are updated so that they still represent the same values. 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..f8375e93ce 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:: @@ -217,7 +217,7 @@ usual implicit arguments disambiguation syntax. The syntax is also supported in internal binders. For instance, in the following kinds of expressions, the type of each declaration present -in :token:`binders` can be bracketed to mark the declaration as +in :n:`{* @binder }` can be bracketed to mark the declaration as implicit: * :n:`fun (@ident:forall {* @binder }, @type) => @term`, * :n:`forall (@ident:forall {* @binder }, @type), @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 2cf436b27e..f722ddda79 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 @@ -854,7 +858,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 @@ -878,19 +882,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..4b1f312105 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 @@ -734,12 +732,13 @@ Applying theorems does not succeed because it would require the conversion of ``id ?foo`` and :g:`O`. + .. _simple_apply_ex: .. example:: .. coqtop:: all Definition id (x : nat) := x. - Parameter H : forall y, id y = y. + Parameter H : forall x y, id x = y. Goal O = O. Fail simple apply H. @@ -909,13 +908,8 @@ Applying theorems .. tacv:: simple apply @term in @ident This behaves like :tacn:`apply … in` but it reasons modulo conversion - only on subterms that contain no variables to instantiate. For instance, - if :g:`id := fun x:nat => x` and :g:`H: forall y, id y = y -> True` and - :g:`H0 : O = O` then :g:`simple apply H in H0` does not succeed because it - would require the conversion of :g:`id ?x` and :g:`O` where :g:`?x` is - an existential variable to instantiate. - Tactic :n:`simple apply @term in @ident` does not - either traverse tuples as :n:`apply @term in @ident` does. + only on subterms that contain no variables to instantiate and does not + traverse tuples. See :ref:`the corresponding example <simple_apply_ex>`. .. tacv:: {? simple} apply {+, @term {? with @bindings_list}} in @ident {? as @simple_intropattern} {? simple} eapply {+, @term {? with @bindings_list}} in @ident {? as @simple_intropattern} @@ -923,11 +917,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 +938,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 +1069,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 +1087,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 +1572,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 +1583,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 +1615,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 +1724,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 +1823,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 +1857,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 +2020,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 +2033,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 +2142,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 +2153,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 +2221,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 +2228,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 +2242,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 +2259,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 +2274,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 +2326,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 +2371,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 +2621,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 +2629,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 +2642,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 +2752,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 +2813,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 +2933,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 +2975,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 +2986,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 +3224,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 +3239,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 +3370,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 +3390,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 +3552,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 +3605,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 +3660,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 +3823,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 +3926,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 +3969,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 +4355,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 +4392,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 +4594,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 +4605,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 +4666,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. @@ -4750,19 +4726,23 @@ Automating .. seealso:: - File plugins/setoid_ring/RealField.v for an example of instantiation, + File plugins/ring/RealField.v for an example of instantiation, theory theories/Reals for many examples of use of field. 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 +4757,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 +4779,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 +4909,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/proof-schemes.rst b/doc/sphinx/user-extensions/proof-schemes.rst index e05be7c2c2..8e23e61018 100644 --- a/doc/sphinx/user-extensions/proof-schemes.rst +++ b/doc/sphinx/user-extensions/proof-schemes.rst @@ -203,7 +203,7 @@ Generation of inversion principles with ``Derive`` ``Inversion`` This command generates an inversion principle for the :tacn:`inversion ... using ...` tactic. The first :token:`ident` is the name of the generated principle. The second :token:`ident` should be an inductive - predicate, and :token:`binders` the variables occurring in the term + predicate, and :n:`{* @binder }` the variables occurring in the term :token:`term`. This command generates the inversion lemma for the sort :token:`sort` corresponding to the instance :n:`forall {* @binder }, @ident @term`. When applied, it is equivalent to having inverted the instance with the diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index 18149a690a..d6db305300 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -57,15 +57,14 @@ to represent :g:`(and A B)`: Notations must be in double quotes, except when the abbreviation has the form of an ordinary applicative expression; see :ref:`Abbreviations`. The notation consists of *tokens* separated by -spaces. Alphanumeric strings (such as ``A`` and ``B``) are the *parameters* +spaces. Tokens which are identifiers (such as ``A``, ``x0'``, etc.) are the *parameters* of the notation. Each of them must occur at least once in the abbreviated term. The other elements of the string (such as ``/\``) are the *symbols*. -Substrings enclosed in single quotes are treated as literals. This is necessary -for substrings that would otherwise be interpreted as :n:`@ident`\s. Similarly, -every symbol of at least 3 characters and starting with a simple quote -must be quoted (then it starts by two single quotes). Here is an -example. +Identifiers enclosed in single quotes are treated as symbols and thus +lose their role of parameters. In the same vein, every symbol of at +least 3 characters and starting with a simple quote must be quoted +(then it starts with two single quotes). Here is an example. .. coqtop:: in @@ -82,7 +81,8 @@ associativity rules have to be given. The right-hand side of a notation is interpreted at the time the notation is given. In particular, disambiguation of constants, :ref:`implicit arguments <ImplicitArguments>` and other notations are resolved at the - time of the declaration of the notation. + time of the declaration of the notation. The right-hand side is + currently typed only at use time but this may change in the future. Precedences and associativity ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -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 @@ -299,12 +299,29 @@ Notations disappear when a section is closed. No typing of the denoted expression is performed at definition time. Type checking is done only at the time of use of the notation. -.. note:: Sometimes, a notation is expected only for the parser. To do - so, the option ``only parsing`` is allowed in the list of :n:`@syntax_modifier`\s - in :cmd:`Notation`. Conversely, the ``only printing`` :n:`@syntax_modifier` can be - used to declare that a notation should only be used for printing and - should not declare a parsing rule. In particular, such notations do - not modify the parser. +.. note:: + + The default for a notation is to be used both for parsing and + printing. It is possible to declare a notation only for parsing by + adding the option ``only parsing`` to the list of + :n:`@syntax_modifier`\s of :cmd:`Notation`. Symmetrically, the + ``only printing`` :n:`@syntax_modifier` can be used to declare that + a notation should only be used for printing. + + If a notation to be used both for parsing and printing is + overriden, both the parsing and printing are invalided, even if the + overriding rule is only parsing. + + If a given notation string occurs only in ``only printing`` rules, + the parser is not modified at all. + + To a given notation string and scope can be attached at most one + notation with both parsing and printing or with only + parsing. Contrastingly, an arbitrary number of ``only printing`` + notations differing in their right-hand sides but only a unique + right-hand side can be attached to a given string and + scope. Obviously, expressions printed by means of such extra + printing rules will not be reparsed to the same form. The Infix command ~~~~~~~~~~~~~~~~~~ @@ -425,16 +442,94 @@ 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. + + 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_expr is + [ "5" RIGHTA + [ binder_tactic ] + | "4" LEFTA + [ SELF; ";"; 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`. - 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. + `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 + + 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 +944,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 +967,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 +1053,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 +1066,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 +1081,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 +1137,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 +1306,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 +1326,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 +1361,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 +1529,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 +1606,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 +1672,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 +1762,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 +1793,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 +1806,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 +1904,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..56464851ba 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 @@ -1418,11 +1424,11 @@ def setup(app): app.connect('doctree-resolved', CoqtopBlocksTransform.merge_consecutive_coqtop_blocks) # Add extra styles - app.add_stylesheet("ansi.css") - app.add_stylesheet("coqdoc.css") - app.add_javascript("notations.js") - app.add_stylesheet("notations.css") - app.add_stylesheet("pre-text.css") + app.add_css_file("ansi.css") + app.add_css_file("coqdoc.css") + app.add_js_file("notations.js") + app.add_css_file("notations.css") + app.add_css_file("pre-text.css") # Tell Sphinx about extra settings app.add_config_value("report_undocumented_coq_objects", None, '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..a9f9c805d8 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: [ @@ -521,7 +615,7 @@ of_type_with_opt_coercion: [ ] of_type_with_opt_coercion: [ -| [ ":" | ":>" | ":>>" ] type +| [ ":" | ":>" ] type ] attribute_value: [ @@ -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..2a7b283f55 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) @@ -24,8 +24,9 @@ (glob_files %{project_root}/plugins/nsatz/*.mlg) (glob_files %{project_root}/plugins/omega/*.mlg) (glob_files %{project_root}/plugins/rtauto/*.mlg) - (glob_files %{project_root}/plugins/setoid_ring/*.mlg) + (glob_files %{project_root}/plugins/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..067050b4f5 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 *) +| "Add" "Ring" ident ":" constr OPT ring_mods (* ring plugin *) +| "Print" "Rings" (* ring plugin *) +| "Add" "Field" ident ":" constr OPT field_mods (* ring plugin *) +| "Print" "Fields" (* 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: [ @@ -971,10 +986,7 @@ constructor: [ ] of_type_with_opt_coercion: [ -| ":>>" -| ":>" ">" | ":>" -| ":" ">" ">" | ":" ">" | ":" ] @@ -1353,12 +1365,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 +1399,11 @@ syntax_modifier: [ | IDENT syntax_extension_type ] +syntax_modifiers: [ +| "(" LIST1 syntax_modifier SEP "," ")" +| +] + syntax_extension_type: [ | "ident" | "global" @@ -1416,9 +1433,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 +1533,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 +1713,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 @@ -1726,10 +1741,10 @@ simple_tactic: [ | "nsatz_compute" constr (* nsatz plugin *) | "omega" (* omega plugin *) | "rtauto" -| "protect_fv" string "in" ident (* setoid_ring plugin *) -| "protect_fv" string (* setoid_ring plugin *) -| "ring_lookup" tactic0 "[" LIST0 constr "]" LIST1 constr (* setoid_ring plugin *) -| "field_lookup" tactic "[" LIST0 constr "]" LIST1 constr (* setoid_ring plugin *) +| "protect_fv" string "in" ident (* ring plugin *) +| "protect_fv" string (* ring plugin *) +| "ring_lookup" tactic0 "[" LIST0 constr "]" LIST1 constr (* ring plugin *) +| "field_lookup" tactic "[" LIST0 constr "]" LIST1 constr (* ring plugin *) ] mlname: [ @@ -1743,7 +1758,6 @@ int_or_id: [ ] language: [ -| "Ocaml" (* extraction plugin *) | "OCaml" (* extraction plugin *) | "Haskell" (* extraction plugin *) | "Scheme" (* extraction plugin *) @@ -1791,6 +1805,10 @@ orient: [ | ] +EXTRAARGS_natural: [ +| _natural +] + occurrences: [ | LIST1 integer | var @@ -1800,8 +1818,12 @@ glob: [ | constr ] +EXTRAARGS_lconstr: [ +| l_constr +] + lglob: [ -| lconstr +| EXTRAARGS_lconstr ] casted_constr: [ @@ -1829,18 +1851,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 +2007,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 +2096,7 @@ match_list: [ message_token: [ | identref | STRING -| integer +| natural ] ltac_def_kind: [ @@ -2124,6 +2145,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 +2223,10 @@ rewstrategy: [ | "fold" constr ] +G_REWRITE_binders: [ +| Pcoq.Constr.binders +] + int_or_var: [ | integer | identref @@ -2372,19 +2405,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 | ] @@ -2488,31 +2528,31 @@ induction_clause_list: [ ] ring_mod: [ -| "decidable" constr (* setoid_ring plugin *) -| "abstract" (* setoid_ring plugin *) -| "morphism" constr (* setoid_ring plugin *) -| "constants" "[" tactic "]" (* setoid_ring plugin *) -| "closed" "[" LIST1 global "]" (* setoid_ring plugin *) -| "preprocess" "[" tactic "]" (* setoid_ring plugin *) -| "postprocess" "[" tactic "]" (* setoid_ring plugin *) -| "setoid" constr constr (* setoid_ring plugin *) -| "sign" constr (* setoid_ring plugin *) -| "power" constr "[" LIST1 global "]" (* setoid_ring plugin *) -| "power_tac" constr "[" tactic "]" (* setoid_ring plugin *) -| "div" constr (* setoid_ring plugin *) +| "decidable" constr (* ring plugin *) +| "abstract" (* ring plugin *) +| "morphism" constr (* ring plugin *) +| "constants" "[" tactic "]" (* ring plugin *) +| "closed" "[" LIST1 global "]" (* ring plugin *) +| "preprocess" "[" tactic "]" (* ring plugin *) +| "postprocess" "[" tactic "]" (* ring plugin *) +| "setoid" constr constr (* ring plugin *) +| "sign" constr (* ring plugin *) +| "power" constr "[" LIST1 global "]" (* ring plugin *) +| "power_tac" constr "[" tactic "]" (* ring plugin *) +| "div" constr (* ring plugin *) ] ring_mods: [ -| "(" LIST1 ring_mod SEP "," ")" (* setoid_ring plugin *) +| "(" LIST1 ring_mod SEP "," ")" (* ring plugin *) ] field_mod: [ -| ring_mod (* setoid_ring plugin *) -| "completeness" constr (* setoid_ring plugin *) +| ring_mod (* ring plugin *) +| "completeness" constr (* ring plugin *) ] field_mods: [ -| "(" LIST1 field_mod SEP "," ")" (* setoid_ring plugin *) +| "(" LIST1 field_mod SEP "," ")" (* ring plugin *) ] numnotoption: [ @@ -2521,3 +2561,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..cbef29fb39 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 ] @@ -113,7 +114,7 @@ ident_decl: [ ] of_type: [ -| [ ":" | ":>" | ":>>" ] type +| [ ":" | ":>" ] type ] qualid: [ @@ -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 *) +| "Add" "Ring" ident ":" one_term OPT ( "(" LIST1 ring_mod SEP "," ")" ) (* ring plugin *) +| "Print" "Rings" (* ring plugin *) +| "Add" "Field" ident ":" one_term OPT ( "(" LIST1 field_mod SEP "," ")" ) (* ring plugin *) +| "Print" "Fields" (* 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,13 +1100,174 @@ 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: [ -| "Ocaml" (* extraction plugin *) | "OCaml" (* extraction plugin *) | "Haskell" (* extraction plugin *) | "Scheme" (* extraction plugin *) @@ -1062,28 +1279,28 @@ fun_scheme_arg: [ ] ring_mod: [ -| "decidable" one_term (* setoid_ring plugin *) -| "abstract" (* setoid_ring plugin *) -| "morphism" one_term (* setoid_ring plugin *) -| "constants" "[" ltac_expr "]" (* setoid_ring plugin *) -| "preprocess" "[" ltac_expr "]" (* setoid_ring plugin *) -| "postprocess" "[" ltac_expr "]" (* setoid_ring plugin *) -| "setoid" one_term one_term (* setoid_ring plugin *) -| "sign" one_term (* setoid_ring plugin *) -| "power" one_term "[" LIST1 qualid "]" (* setoid_ring plugin *) -| "power_tac" one_term "[" ltac_expr "]" (* setoid_ring plugin *) -| "div" one_term (* setoid_ring plugin *) -| "closed" "[" LIST1 qualid "]" (* setoid_ring plugin *) +| "decidable" one_term (* ring plugin *) +| "abstract" (* ring plugin *) +| "morphism" one_term (* ring plugin *) +| "constants" "[" ltac_expr "]" (* ring plugin *) +| "preprocess" "[" ltac_expr "]" (* ring plugin *) +| "postprocess" "[" ltac_expr "]" (* ring plugin *) +| "setoid" one_term one_term (* ring plugin *) +| "sign" one_term (* ring plugin *) +| "power" one_term "[" LIST1 qualid "]" (* ring plugin *) +| "power_tac" one_term "[" ltac_expr "]" (* ring plugin *) +| "div" one_term (* ring plugin *) +| "closed" "[" LIST1 qualid "]" (* ring plugin *) ] field_mod: [ -| ring_mod (* setoid_ring plugin *) -| "completeness" one_term (* setoid_ring plugin *) +| ring_mod (* ring plugin *) +| "completeness" one_term (* ring plugin *) ] numeral_modifier: [ -| "(" "warning" "after" numeral ")" -| "(" "abstract" "after" numeral ")" +| "(" "warning" "after" bignat ")" +| "(" "abstract" "after" bignat ")" ] hints_path: [ @@ -1109,8 +1326,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 +1344,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 +1359,7 @@ binder_interp: [ ] level: [ -| "level" num +| "level" natural | "next" "level" ] @@ -1151,7 +1368,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 +1396,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 +1425,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 +1437,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 +1453,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 +1470,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 +1509,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 +1547,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 +1559,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 +1593,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 +1614,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 @@ -1423,8 +1641,8 @@ simple_tactic: [ | "nsatz_compute" one_term (* nsatz plugin *) | "omega" (* omega plugin *) | "protect_fv" string OPT ( "in" ident ) -| "ring_lookup" ltac_expr0 "[" LIST0 one_term "]" LIST1 one_term (* setoid_ring plugin *) -| "field_lookup" ltac_expr "[" LIST0 one_term "]" LIST1 one_term (* setoid_ring plugin *) +| "ring_lookup" ltac_expr0 "[" LIST0 one_term "]" LIST1 one_term (* ring plugin *) +| "field_lookup" ltac_expr "[" LIST0 one_term "]" LIST1 one_term (* ring plugin *) | match_key OPT "reverse" "goal" "with" OPT "|" LIST1 ( goal_pattern "=>" ltac_expr ) SEP "|" "end" | match_key ltac_expr "with" OPT "|" LIST1 ( match_pattern "=>" ltac_expr ) SEP "|" "end" | "classical_left" @@ -1453,6 +1671,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 +1684,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 +1706,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 +1748,9 @@ naming_intropattern: [ ] intropattern: [ -| simple_intropattern | "*" | "**" +| simple_intropattern ] simple_intropattern: [ @@ -1572,7 +1766,7 @@ simple_intropattern_closed: [ simple_binding: [ | "(" ident ":=" term ")" -| "(" num ":=" term ")" +| "(" natural ":=" term ")" ] bindings: [ @@ -1597,9 +1791,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 +2188,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 +2209,7 @@ with_names: [ ] occurrences: [ -| LIST1 int +| LIST1 integer | ident ] @@ -1763,7 +2304,7 @@ ltac_expr0: [ ] tactic_atom: [ -| int +| integer | qualid | "()" ] @@ -1795,8 +2336,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..467b269e37 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -233,13 +233,13 @@ let pr_evar_universe_context ctx = if UState.is_empty ctx then mt () else (str"UNIVERSES:"++brk(0,1)++ - h 0 (Univ.pr_universe_context_set prl (UState.context_set ctx)) ++ fnl () ++ + h (Univ.pr_universe_context_set prl (UState.context_set ctx)) ++ fnl () ++ str"ALGEBRAIC UNIVERSES:"++brk(0,1)++ - h 0 (Univ.LSet.pr prl (UState.algebraics ctx)) ++ fnl() ++ + h (Univ.LSet.pr prl (UState.algebraics ctx)) ++ fnl() ++ str"UNDEFINED UNIVERSES:"++brk(0,1)++ - h 0 (UnivSubst.pr_universe_opt_subst (UState.subst ctx)) ++ fnl() ++ + h (UnivSubst.pr_universe_opt_subst (UState.subst ctx)) ++ fnl() ++ str "WEAK CONSTRAINTS:"++brk(0,1)++ - h 0 (UState.pr_weak prl ctx) ++ fnl ()) + h (UState.pr_weak prl ctx) ++ fnl ()) let print_env_short env sigma = let print_constr = print_kconstr in @@ -301,25 +301,29 @@ 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 ++ + h (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 ())) in - h 0 (prlist_with_sep fnl pr l) + hv 0 (prlist_with_sep fnl pr l) let to_list d = let open Evd in diff --git a/engine/uState.ml b/engine/uState.ml index d4cb59da26..9557111cfd 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -286,6 +286,10 @@ let process_universe_constraints ctx cstrs = if not (drop_weak_constraints ()) then weak := UPairSet.add (l,r) !weak; local | UEq (l, r) -> equalize_universes l r local in + let unify_universes cst local = + if not (UGraph.type_in_type univs) then unify_universes cst local + else try unify_universes cst local with UniverseInconsistency _ -> local + in let local = UnivProblem.Set.fold unify_universes cstrs Constraint.empty in @@ -568,8 +572,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; @@ -671,7 +675,7 @@ let subst_univs_context_with_def def usubst (ctx, cst) = (LSet.diff ctx def, UnivSubst.subst_univs_constraints usubst cst) let is_trivial_leq (l,d,r) = - Level.is_prop l && (d == Le || (d == Lt && Level.is_set r)) + Level.is_prop l && (d == Le || d == Lt) && Level.is_set r (* Prop < i <-> Set+1 <= i <-> Set < i *) let translate_cstr (l,d,r as cstr) = @@ -718,35 +722,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/engine/univMinim.ml b/engine/univMinim.ml index 1c7e716fc2..4ed6e97526 100644 --- a/engine/univMinim.ml +++ b/engine/univMinim.ml @@ -292,22 +292,29 @@ let is_bound l lbound = match lbound with | UGraph.Bound.Prop -> Level.is_prop l | UGraph.Bound.Set -> Level.is_set l +(* if [is_minimal u] then constraints [u <= v] may be dropped and get + used only for set_minimization. *) +let is_minimal ~lbound u = + Level.is_sprop u || Level.is_prop u || is_bound u lbound + (* TODO check is_small/sprop *) let normalize_context_set ~lbound g ctx us algs weak = let (ctx, csts) = ContextSet.levels ctx, ContextSet.constraints ctx in (* Keep the Prop/Set <= i constraints separate for minimization *) let smallles, csts = - Constraint.partition (fun (l,d,r) -> d == Le && (is_bound l lbound || Level.is_sprop l)) csts + Constraint.partition (fun (l,d,r) -> d == Le && is_minimal ~lbound l) csts in let smallles = if get_set_minimization () then Constraint.filter (fun (l,d,r) -> LMap.mem r us && not (Level.is_sprop l)) smallles else Constraint.empty in + let smallles = Constraint.map (fun (_,_,r) -> Level.set, Le, r) smallles in let csts, partition = (* We first put constraints in a normal-form: all self-loops are collapsed to equalities. *) + let g = UGraph.initial_universes_with g in let g = LSet.fold (fun v g -> UGraph.add_universe ~lbound ~strict:false v g) - ctx UGraph.initial_universes + ctx g in let add_soft u g = if not (Level.is_small u || LSet.mem u ctx) diff --git a/ide/coqide/coq.ml b/ide/coqide/coq.ml index 6e5d57c9a5..1167b8199e 100644 --- a/ide/coqide/coq.ml +++ b/ide/coqide/coq.ml @@ -545,6 +545,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"] @@ -559,7 +560,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 = false; label = "Display _parentheses" }; { opts = [all_basic]; init = false; label = "Display _all basic low-level contents" }; { opts = [existential]; init = false; diff --git a/ide/coqide/coq_lex.mll b/ide/coqide/coq_lex.mll index a65954d566..5d5e5f0e14 100644 --- a/ide/coqide/coq_lex.mll +++ b/ide/coqide/coq_lex.mll @@ -50,52 +50,40 @@ and comment = parse | utf8_extra_byte { incr utf8_adjust; comment lexbuf } | _ { comment lexbuf } -and quotation o c n l = parse +and quotation n l = parse | eof { raise Unterminated } -| utf8_extra_byte { incr utf8_adjust; quotation o c n l lexbuf } -| _ { - let x = Lexing.lexeme lexbuf in - if x = o then quotation_nesting o c n l 1 lexbuf - else if x = c then - if n = 1 && l = 1 then () - else quotation_closing o c n l 1 lexbuf - else quotation o c n l lexbuf -} +| utf8_extra_byte { incr utf8_adjust; quotation n l lexbuf } +| "{" { quotation_nesting n l 1 lexbuf } +| "}" { quotation_closing n l 1 lexbuf } +| _ { quotation n l lexbuf } -and quotation_nesting o c n l v = parse +and quotation_nesting n l v = parse | eof { raise Unterminated } -| utf8_extra_byte { incr utf8_adjust; quotation o c n l lexbuf } -| _ { - let x = Lexing.lexeme lexbuf in - if x = o then - if n = v+1 then quotation o c n (l+1) lexbuf - else quotation_nesting o c n l (v+1) lexbuf - else if x = c then quotation_closing o c n l 1 lexbuf - else quotation o c n l lexbuf +| utf8_extra_byte { incr utf8_adjust; quotation n l lexbuf } +| "{" { + if n = v+1 then quotation n (l+1) lexbuf + else quotation_nesting n l (v+1) lexbuf } +| "}" { quotation_closing n l 1 lexbuf } +| _ { quotation n l lexbuf } -and quotation_closing o c n l v = parse +and quotation_closing n l v = parse | eof { raise Unterminated } -| utf8_extra_byte { incr utf8_adjust; quotation o c n l lexbuf } -| _ { - let x = Lexing.lexeme lexbuf in - if x = c then - if n = v+1 then - if l = 1 then () - else quotation o c n (l-1) lexbuf - else quotation_closing o c n l (v+1) lexbuf - else if x = o then quotation_nesting o c n l 1 lexbuf - else quotation o c n l lexbuf +| utf8_extra_byte { incr utf8_adjust; quotation n l lexbuf } +| "}" { + if n = v+1 then + if l = 1 then () + else quotation n (l-1) lexbuf + else quotation_closing n l (v+1) lexbuf } +| "{" { quotation_nesting n l 1 lexbuf } +| _ { quotation n l lexbuf } -and quotation_start o c n = parse +and quotation_start n = parse | eof { raise Unterminated } -| utf8_extra_byte { incr utf8_adjust; quotation o c n 1 lexbuf } -| _ { - let x = Lexing.lexeme lexbuf in - if x = o then quotation_start o c (n+1) lexbuf - else quotation o c n 1 lexbuf -} +| utf8_extra_byte { incr utf8_adjust; quotation n 1 lexbuf } +| "{" { quotation_start (n+1) lexbuf } +| _ { quotation n 1 lexbuf } (** NB : [mkiter] should be called on increasing offsets *) @@ -130,16 +118,8 @@ and sentence initial stamp = parse if initial then stamp (utf8_lexeme_start lexbuf + String.length (Lexing.lexeme lexbuf) - 1) Tags.Script.sentence; sentence initial stamp lexbuf } - | ['a'-'z' 'A'-'Z'] ":{" { - quotation_start "{" "}" 1 lexbuf; - sentence false stamp lexbuf - } - | ['a'-'z' 'A'-'Z'] ":[" { - quotation_start "[" "]" 1 lexbuf; - sentence false stamp lexbuf - } - | ['a'-'z' 'A'-'Z'] ":(" { - quotation_start "(" ")" 1 lexbuf; + | ['a'-'z' 'A'-'Z'] ":{{" { + quotation_start 2 lexbuf; sentence false stamp lexbuf } | space+ { diff --git a/ide/coqide/idetop.ml b/ide/coqide/idetop.ml index 2be8f862ea..297dc3a706 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/ide/coqide/protocol/serialize.ml b/ide/coqide/protocol/serialize.ml index bdbec5b30f..6a0a3d7f5d 100644 --- a/ide/coqide/protocol/serialize.ml +++ b/ide/coqide/protocol/serialize.ml @@ -35,6 +35,11 @@ let singleton = function | l -> raise (Marshal_error ("singleton",PCData ("list of length " ^ string_of_int (List.length l)))) +let empty = function + | [] -> () + | l -> raise (Marshal_error + ("empty",PCData ("list of length " ^ string_of_int (List.length l)))) + let raw_string = function | [] -> "" | [PCData s] -> s diff --git a/ide/coqide/protocol/serialize.mli b/ide/coqide/protocol/serialize.mli index 5d88defe55..9d09b81d1e 100644 --- a/ide/coqide/protocol/serialize.mli +++ b/ide/coqide/protocol/serialize.mli @@ -16,6 +16,7 @@ val massoc: string -> (string * string) list -> string val constructor: string -> string -> xml list -> xml val do_match: string -> (string -> xml list -> 'b) -> xml -> 'b val singleton: 'a list -> 'a +val empty: 'a list -> unit val raw_string: xml list -> string val of_unit: unit -> xml val to_unit: xml -> unit diff --git a/ide/coqide/protocol/xmlprotocol.ml b/ide/coqide/protocol/xmlprotocol.ml index 0780f03903..6a33ff8abc 100644 --- a/ide/coqide/protocol/xmlprotocol.ml +++ b/ide/coqide/protocol/xmlprotocol.ml @@ -43,7 +43,7 @@ let to_search_cst = do_match "search_cst" (fun s args -> match s with | "type_pattern" -> Type_Pattern (to_string (singleton args)) | "subtype_pattern" -> SubType_Pattern (to_string (singleton args)) | "in_module" -> In_Module (to_list to_string (singleton args)) - | "include_blacklist" -> Include_Blacklist + | "include_blacklist" -> empty args; Include_Blacklist | x -> raise (Marshal_error("search",PCData x))) let of_coq_object f ans = @@ -103,14 +103,14 @@ let to_routeid = function let of_routeid i = Element ("route_id",["val",string_of_int i],[]) let of_box (ppb : Pp.block_type) = let open Pp in match ppb with - | Pp_hbox i -> constructor "ppbox" "hbox" [of_int i] + | Pp_hbox -> constructor "ppbox" "hbox" [] | Pp_vbox i -> constructor "ppbox" "vbox" [of_int i] | Pp_hvbox i -> constructor "ppbox" "hvbox" [of_int i] | Pp_hovbox i -> constructor "ppbox" "hovbox" [of_int i] let to_box = let open Pp in do_match "ppbox" (fun s args -> match s with - | "hbox" -> Pp_hbox (to_int (singleton args)) + | "hbox" -> empty args; Pp_hbox | "vbox" -> Pp_vbox (to_int (singleton args)) | "hvbox" -> Pp_hvbox (to_int (singleton args)) | "hovbox" -> Pp_hovbox (to_int (singleton args)) @@ -132,7 +132,7 @@ let rec of_pp (pp : Pp.t) = let open Pp in match Pp.repr pp with let rec to_pp xpp = let open Pp in Pp.unrepr @@ do_match "ppdoc" (fun s args -> match s with - | "empty" -> Ppcmd_empty + | "empty" -> empty args; Ppcmd_empty | "string" -> Ppcmd_string (to_string (singleton args)) | "glue" -> Ppcmd_glue (to_list to_pp (singleton args)) | "box" -> let (bt,s) = to_pair to_box to_pp (singleton args) in @@ -883,11 +883,11 @@ let of_message_level = function | Error -> Serialize.constructor "message_level" "error" [] let to_message_level = Serialize.do_match "message_level" (fun s args -> match s with - | "debug" -> Debug - | "info" -> Info - | "notice" -> Notice - | "warning" -> Warning - | "error" -> Error + | "debug" -> empty args; Debug + | "info" -> empty args; Info + | "notice" -> empty args; Notice + | "warning" -> empty args; Warning + | "error" -> empty args; Error | x -> raise Serialize.(Marshal_error("error level",PCData x))) let of_message lvl loc msg = diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 3667757a2f..167ea3ecdf 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -551,7 +551,7 @@ and extern_notation_pattern allscopes vars t = function | [] -> raise No_match | (keyrule,pat,n as _rule)::rules -> try - if is_inactive_rule keyrule then raise No_match; + if is_inactive_rule keyrule || is_printing_inactive_rule keyrule pat then raise No_match; let loc = t.loc in match DAst.get t with | PatCstr (cstr,args,na) -> @@ -568,7 +568,7 @@ let rec extern_notation_ind_pattern allscopes vars ind args = function | [] -> raise No_match | (keyrule,pat,n as _rule)::rules -> try - if is_inactive_rule keyrule then raise No_match; + if is_inactive_rule keyrule || is_printing_inactive_rule keyrule pat then raise No_match; apply_notation_to_pattern (GlobRef.IndRef ind) (match_notation_constr_ind_pattern ind args pat) allscopes vars keyrule with @@ -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,20 +1225,20 @@ 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 -> let loc = Glob_ops.loc_of_glob_constr t in try - if is_inactive_rule keyrule then raise No_match; + if is_inactive_rule keyrule || is_printing_inactive_rule keyrule pat then raise No_match; let f,args = match DAst.get t with | GApp (f,args) -> f,args @@ -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..48fb4a4a5d 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 -> @@ -2531,12 +2530,12 @@ let intern_context env impl_env binders = binder_block_names = Some (Some AbsPi,ids)}, []) binders in (lenv.impls, List.map glob_local_binder_of_extended bl) -let interp_glob_context_evars ?(program_mode=false) env sigma k bl = +let interp_glob_context_evars ?(program_mode=false) env sigma bl = let open EConstr in let flags = { Pretyping.all_no_fail_flags with program_mode } in - let env, sigma, par, _, impls = + let env, sigma, par, impls = List.fold_left - (fun (env,sigma,params,n,impls) (na, k, b, t) -> + (fun (env,sigma,params,impls) (na, k, b, t) -> let t' = if Option.is_empty b then locate_if_hole ?loc:(loc_of_glob_constr t) na t else t @@ -2552,16 +2551,17 @@ let interp_glob_context_evars ?(program_mode=false) env sigma k bl = | MaxImplicit -> CAst.make (Some (na,true)) :: impls | Explicit -> CAst.make None :: impls in - (push_rel d env, sigma, d::params, succ n, impls) + (push_rel d env, sigma, d::params, impls) | Some b -> let sigma, c = understand_tcc ~flags env sigma ~expected_type:(OfType t) b in let r = Retyping.relevance_of_type env sigma t in let d = LocalDef (make_annot na r, c, t) in - (push_rel d env, sigma, d::params, n, impls)) - (env,sigma,[],k+1,[]) (List.rev bl) - in sigma, ((env, par), List.rev impls) + (push_rel d env, sigma, d::params, impls)) + (env,sigma,[],[]) (List.rev bl) + in + sigma, ((env, par), List.rev impls) -let interp_context_evars ?program_mode ?(impl_env=empty_internalization_env) ?(shift=0) env sigma params = +let interp_context_evars ?program_mode ?(impl_env=empty_internalization_env) env sigma params = let int_env,bl = intern_context env impl_env params in - let sigma, x = interp_glob_context_evars ?program_mode env sigma shift bl in + let sigma, x = interp_glob_context_evars ?program_mode env sigma bl in sigma, (int_env, x) diff --git a/interp/constrintern.mli b/interp/constrintern.mli index 2eb96aad56..898a3e09c8 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -156,7 +156,7 @@ val interp_binder_evars : env -> evar_map -> Name.t -> constr_expr -> evar_map * (** Interpret contexts: returns extended env and context *) val interp_context_evars : - ?program_mode:bool -> ?impl_env:internalization_env -> ?shift:int -> + ?program_mode:bool -> ?impl_env:internalization_env -> env -> evar_map -> local_binder_expr list -> evar_map * (internalization_env * ((env * rel_context) * Impargs.manual_implicits)) 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..d57c4f3abf 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -58,6 +58,31 @@ let notation_with_optional_scope_eq inscope1 inscope2 = match (inscope1,inscope2 let notation_eq (from1,ntn1) (from2,ntn2) = notation_entry_eq from1 from2 && String.equal ntn1 ntn2 +let pair_eq f g (x1, y1) (x2, y2) = f x1 x2 && g y1 y2 + +let notation_binder_source_eq s1 s2 = match s1, s2 with +| NtnParsedAsIdent, NtnParsedAsIdent -> true +| NtnParsedAsPattern b1, NtnParsedAsPattern b2 -> b1 = b2 +| NtnBinderParsedAsConstr bk1, NtnBinderParsedAsConstr bk2 -> bk1 = bk2 +| (NtnParsedAsIdent | NtnParsedAsPattern _ | NtnBinderParsedAsConstr _), _ -> false + +let ntpe_eq t1 t2 = match t1, t2 with +| NtnTypeConstr, NtnTypeConstr -> true +| NtnTypeBinder s1, NtnTypeBinder s2 -> notation_binder_source_eq s1 s2 +| NtnTypeConstrList, NtnTypeConstrList -> true +| NtnTypeBinderList, NtnTypeBinderList -> true +| (NtnTypeConstr | NtnTypeBinder _ | NtnTypeConstrList | NtnTypeBinderList), _ -> false + +let var_attributes_eq (_, ((entry1, sc1), tp1)) (_, ((entry2, sc2), tp2)) = + notation_entry_level_eq entry1 entry2 && + pair_eq (Option.equal String.equal) (List.equal String.equal) sc1 sc2 && + ntpe_eq tp1 tp2 + +let interpretation_eq (vars1, t1 as x1) (vars2, t2 as x2) = + x1 == x2 || + List.equal var_attributes_eq vars1 vars2 && + Notation_ops.eq_notation_constr (List.map fst vars1, List.map fst vars2) t1 t2 + let pr_notation (from,ntn) = qstring ntn ++ match from with InConstrEntry -> mt () | InCustomEntry s -> str " in custom " ++ str s module NotationOrd = @@ -90,8 +115,21 @@ type notation_data = { not_deprecation : Deprecation.t option; } +type activation = bool + +type extra_printing_notation_data = + (activation * notation_data) list + +type parsing_notation_data = + | NoParsingData + | OnlyParsingData of activation * notation_data + | ParsingAndPrintingData of + activation (* for parsing*) * + activation (* for printing *) * + notation_data (* common data for both *) + type scope = { - notations: notation_data NotationMap.t; + notations: (parsing_notation_data * extra_printing_notation_data) NotationMap.t; delimiters: delimiters option } @@ -300,10 +338,19 @@ type notation_applicative_status = type notation_rule = interp_rule * interpretation * notation_applicative_status +let notation_rule_eq (rule1,pat1,s1 as x1) (rule2,pat2,s2 as x2) = + x1 == x2 || (rule1 = rule2 && interpretation_eq pat1 pat2 && s1 = s2) + let keymap_add key interp map = let old = try KeyMap.find key map with Not_found -> [] in + (* In case of re-import, no need to keep the previous copy *) + let old = try List.remove_first (notation_rule_eq interp) old with Not_found -> old in KeyMap.add key (interp :: old) map +let keymap_remove key interp map = + let old = try KeyMap.find key map with Not_found -> [] in + KeyMap.add key (List.remove_first (notation_rule_eq interp) old) map + let keymap_find key map = try KeyMap.find key map with Not_found -> [] @@ -388,7 +435,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 +457,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 +659,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 +848,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 +875,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 +909,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 = @@ -1198,10 +1245,25 @@ let rec find_without_delimiters find (ntn_scope,ntn) = function find_without_delimiters find (ntn_scope,ntn) scopes end | LonelyNotationItem ntn' :: scopes -> - begin match ntn_scope, ntn with - | LastLonelyNotation, Some ntn when notation_eq ntn ntn' -> - Some (None, None) + begin match ntn with + | Some ntn'' when notation_eq ntn' ntn'' -> + begin match ntn_scope with + | LastLonelyNotation -> + (* If the first notation with same string in the visibility stack + is the one we want to print, then it can be used without + risking a collision *) + Some (None, None) + | NotationInScope _ -> + (* A lonely notation is liable to hide the scoped notation + to print, we check if the lonely notation is active to + know if the delimiter of the scoped notationis needed *) + if find default_scope then + find_with_delimiters ntn_scope + else + find_without_delimiters find (ntn_scope,ntn) scopes + end | _ -> + (* A lonely notation which does not interfere with the notation to use *) find_without_delimiters find (ntn_scope,ntn) scopes end | [] -> @@ -1210,40 +1272,90 @@ let rec find_without_delimiters find (ntn_scope,ntn) = function (* The mapping between notations and their interpretation *) +let pr_optional_scope = function + | LastLonelyNotation -> mt () + | NotationInScope scope -> spc () ++ strbrk "in scope" ++ spc () ++ str scope + let warn_notation_overridden = CWarnings.create ~name:"notation-overridden" ~category:"parsing" - (fun (ntn,which_scope) -> + (fun (scope,ntn) -> str "Notation" ++ spc () ++ pr_notation ntn ++ spc () - ++ strbrk "was already used" ++ which_scope ++ str ".") + ++ strbrk "was already used" ++ pr_optional_scope scope ++ str ".") -let declare_notation_interpretation ntn scopt pat df ~onlyprint deprecation = - let scope = match scopt with Some s -> s | None -> default_scope in - let sc = find_scope scope in - if not onlyprint then begin - let () = - if NotationMap.mem ntn sc.notations then - let which_scope = match scopt with - | None -> mt () - | Some _ -> spc () ++ strbrk "in scope" ++ spc () ++ str scope in - warn_notation_overridden (ntn,which_scope) - in - let notdata = { - not_interp = pat; - not_location = df; - not_deprecation = deprecation; - } in - let sc = { sc with notations = NotationMap.add ntn notdata sc.notations } in - scope_map := String.Map.add scope sc !scope_map - end; - begin match scopt with - | None -> scope_stack := LonelyNotationItem ntn :: !scope_stack - | Some _ -> () - end +let warn_deprecation_overridden = + CWarnings.create ~name:"notation-overridden" ~category:"parsing" + (fun ((scope,ntn),old,now) -> + match old, now with + | None, None -> assert false + | None, Some _ -> + (str "Notation" ++ spc () ++ pr_notation ntn ++ pr_optional_scope scope ++ spc () + ++ strbrk "is now marked as deprecated" ++ str ".") + | Some _, None -> + (str "Cancelling previous deprecation of notation" ++ spc () ++ + pr_notation ntn ++ pr_optional_scope scope ++ str ".") + | Some _, Some _ -> + (str "Amending deprecation of notation" ++ spc () ++ + pr_notation ntn ++ pr_optional_scope scope ++ str ".")) + +type notation_use = + | OnlyPrinting + | OnlyParsing + | ParsingAndPrinting + +let warn_override_if_needed (scopt,ntn) overridden data old_data = + if overridden then warn_notation_overridden (scopt,ntn) + else + if data.not_deprecation <> old_data.not_deprecation then + warn_deprecation_overridden ((scopt,ntn),old_data.not_deprecation,data.not_deprecation) + +let check_parsing_override (scopt,ntn) data = function + | OnlyParsingData (_,old_data) -> + let overridden = not (interpretation_eq data.not_interp old_data.not_interp) in + warn_override_if_needed (scopt,ntn) overridden data old_data; + None, not overridden + | ParsingAndPrintingData (_,on_printing,old_data) -> + let overridden = not (interpretation_eq data.not_interp old_data.not_interp) in + warn_override_if_needed (scopt,ntn) overridden data old_data; + (if on_printing then Some old_data.not_interp else None), not overridden + | NoParsingData -> None, false + +let check_printing_override (scopt,ntn) data parsingdata printingdata = + let parsing_update = match parsingdata with + | OnlyParsingData _ | NoParsingData -> parsingdata + | ParsingAndPrintingData (_,on_printing,old_data) -> + let overridden = not (interpretation_eq data.not_interp old_data.not_interp) in + warn_override_if_needed (scopt,ntn) overridden data old_data; + if overridden then NoParsingData else parsingdata in + let exists = List.exists (fun (on_printing,old_data) -> + let exists = interpretation_eq data.not_interp old_data.not_interp in + if exists && data.not_deprecation <> old_data.not_deprecation then + warn_deprecation_overridden ((scopt,ntn),old_data.not_deprecation,data.not_deprecation); + exists) printingdata in + parsing_update, exists + +let remove_uninterpretation rule (metas,c as pat) = + let (key,n) = notation_constr_key c in + notations_key_table := keymap_remove key (rule,pat,n) !notations_key_table let declare_uninterpretation rule (metas,c as pat) = let (key,n) = notation_constr_key c in notations_key_table := keymap_add key (rule,pat,n) !notations_key_table +let update_notation_data (scopt,ntn) use data table = + let (parsingdata,printingdata) = + try NotationMap.find ntn table with Not_found -> (NoParsingData, []) in + match use with + | OnlyParsing -> + let printing_update, exists = check_parsing_override (scopt,ntn) data parsingdata in + NotationMap.add ntn (OnlyParsingData (true,data), printingdata) table, printing_update, exists + | ParsingAndPrinting -> + let printing_update, exists = check_parsing_override (scopt,ntn) data parsingdata in + NotationMap.add ntn (ParsingAndPrintingData (true,true,data), printingdata) table, printing_update, exists + | OnlyPrinting -> + let parsingdata, exists = check_printing_override (scopt,ntn) data parsingdata printingdata in + let printingdata = if exists then printingdata else (true,data) :: printingdata in + NotationMap.add ntn (parsingdata, printingdata) table, None, exists + let rec find_interpretation ntn find = function | [] -> raise Not_found | OpenScopeItem scope :: scopes -> @@ -1258,7 +1370,9 @@ let rec find_interpretation ntn find = function find_interpretation ntn find scopes let find_notation ntn sc = - NotationMap.find ntn (find_scope sc).notations + match fst (NotationMap.find ntn (find_scope sc).notations) with + | OnlyParsingData (true,data) | ParsingAndPrintingData (true,_,data) -> data + | _ -> raise Not_found let notation_of_prim_token = function | Constrexpr.Numeral (SPlus,n) -> InConstrEntry, NumTok.Unsigned.sprint n @@ -1343,10 +1457,37 @@ let uninterp_cases_pattern_notations c = let uninterp_ind_pattern_notations ind = keymap_find (RefKey (canonical_gr (GlobRef.IndRef ind))) !notations_key_table +let has_active_parsing_rule_in_scope ntn sc = + try + match NotationMap.find ntn (String.Map.find sc !scope_map).notations with + | OnlyParsingData (active,_),_ | ParsingAndPrintingData (active,_,_),_ -> active + | _ -> false + with Not_found -> false + +let is_printing_active_in_scope (scope,ntn) pat = + let sc = match scope with NotationInScope sc -> sc | LastLonelyNotation -> default_scope in + let is_active extra = + try + let (_,(active,_)) = List.extract_first (fun (active,d) -> interpretation_eq d.not_interp pat) extra in + active + with Not_found -> false in + try + match NotationMap.find ntn (String.Map.find sc !scope_map).notations with + | ParsingAndPrintingData (_,active,d), extra -> + if interpretation_eq d.not_interp pat then active + else is_active extra + | _, extra -> is_active extra + with Not_found -> false + +let is_printing_inactive_rule rule pat = + match rule with + | NotationRule (scope,ntn) -> + not (is_printing_active_in_scope (scope,ntn) pat) + | SynDefRule kn -> + try let _ = Nametab.path_of_syndef kn in false with Not_found -> true + let availability_of_notation (ntn_scope,ntn) scopes = - let f scope = - NotationMap.mem ntn (String.Map.find scope !scope_map).notations in - find_without_delimiters f (ntn_scope,Some ntn) (make_current_scopes scopes) + find_without_delimiters (has_active_parsing_rule_in_scope ntn) (ntn_scope,Some ntn) (make_current_scopes scopes) (* We support coercions from a custom entry at some level to an entry at some level (possibly the same), and from and to the constr entry. E.g.: @@ -1429,7 +1570,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 := @@ -1469,6 +1610,49 @@ let entry_has_ident = function | InCustomEntryLevel (s,n) -> try String.Map.find s !entry_has_ident_map <= n with Not_found -> false +type entry_coercion_kind = + | IsEntryCoercion of notation_entry_level + | IsEntryGlobal of string * int + | IsEntryIdent of string * int + +let declare_notation (scopt,ntn) pat df ~use coe deprecation = + (* Register the interpretation *) + let scope = match scopt with NotationInScope s -> s | LastLonelyNotation -> default_scope in + let sc = find_scope scope in + let notdata = { + not_interp = pat; + not_location = df; + not_deprecation = deprecation; + } in + let notation_update,printing_update, exists = update_notation_data (scopt,ntn) use notdata sc.notations in + if not exists then + let sc = { sc with notations = notation_update } in + scope_map := String.Map.add scope sc !scope_map; + (* Update the uninterpretation cache *) + begin match printing_update with + | Some pat -> remove_uninterpretation (NotationRule (scopt,ntn)) pat + | None -> () + end; + if not exists && use <> OnlyParsing then declare_uninterpretation (NotationRule (scopt,ntn)) pat; + (* Register visibility of lonely notations *) + if not exists then begin match scopt with + | LastLonelyNotation -> scope_stack := LonelyNotationItem ntn :: !scope_stack + | NotationInScope _ -> () + end; + (* Declare a possible coercion *) + if not exists then begin match coe with + | Some (IsEntryCoercion entry) -> + let (_,level,_) = level_of_notation ntn in + let level = match fst ntn with + | InConstrEntry -> None + | InCustomEntry _ -> Some level + in + declare_entry_coercion (scopt,ntn) level entry + | Some (IsEntryGlobal (entry,n)) -> declare_custom_entry_has_global entry n + | Some (IsEntryIdent (entry,n)) -> declare_custom_entry_has_ident entry n + | None -> () + end + let availability_of_prim_token n printer_scope local_scopes = let f scope = try @@ -1546,38 +1730,6 @@ let uninterp_prim_token_cases_pattern c local_scopes = (* Miscellaneous *) -let pair_eq f g (x1, y1) (x2, y2) = f x1 x2 && g y1 y2 - -let notation_binder_source_eq s1 s2 = match s1, s2 with -| NtnParsedAsIdent, NtnParsedAsIdent -> true -| NtnParsedAsPattern b1, NtnParsedAsPattern b2 -> b1 = b2 -| NtnBinderParsedAsConstr bk1, NtnBinderParsedAsConstr bk2 -> bk1 = bk2 -| (NtnParsedAsIdent | NtnParsedAsPattern _ | NtnBinderParsedAsConstr _), _ -> false - -let ntpe_eq t1 t2 = match t1, t2 with -| NtnTypeConstr, NtnTypeConstr -> true -| NtnTypeBinder s1, NtnTypeBinder s2 -> notation_binder_source_eq s1 s2 -| NtnTypeConstrList, NtnTypeConstrList -> true -| NtnTypeBinderList, NtnTypeBinderList -> true -| (NtnTypeConstr | NtnTypeBinder _ | NtnTypeConstrList | NtnTypeBinderList), _ -> false - -let var_attributes_eq (_, ((entry1, sc1), tp1)) (_, ((entry2, sc2), tp2)) = - notation_entry_level_eq entry1 entry2 && - pair_eq (Option.equal String.equal) (List.equal String.equal) sc1 sc2 && - ntpe_eq tp1 tp2 - -let interpretation_eq (vars1, t1) (vars2, t2) = - List.equal var_attributes_eq vars1 vars2 && - Notation_ops.eq_notation_constr (List.map fst vars1, List.map fst vars2) t1 t2 - -let exists_notation_in_scope scopt ntn onlyprint r = - let scope = match scopt with Some s -> s | None -> default_scope in - try - let sc = String.Map.find scope !scope_map in - let n = NotationMap.find ntn sc.notations in - interpretation_eq n.not_interp r - with Not_found -> false - let isNVar_or_NHole = function NVar _ | NHole _ -> true | _ -> false (**********************************************************************) @@ -1831,38 +1983,63 @@ let pr_scope_classes sc = | _ :: ll -> let opt_s = match ll with [] -> mt () | _ -> str "es" in hov 0 (str "Bound to class" ++ opt_s ++ - spc() ++ prlist_with_sep spc pr_scope_class l) ++ fnl() + spc() ++ prlist_with_sep spc pr_scope_class l) let pr_notation_info prglob ntn c = - str "\"" ++ str ntn ++ str "\" := " ++ + str "\"" ++ str ntn ++ str "\" :=" ++ brk (1,2) ++ prglob (Notation_ops.glob_constr_of_notation_constr c) -let pr_named_scope prglob scope sc = +let pr_notation_status on_parsing on_printing = + let deactivated b = if b then [] else ["deactivated"] in + let l = match on_parsing, on_printing with + | Some on, None -> "only parsing" :: deactivated on + | None, Some on -> "only printing" :: deactivated on + | Some false, Some false -> ["deactivated"] + | Some true, Some false -> ["deactivated for printing"] + | Some false, Some true -> ["deactivated for parsing"] + | Some true, Some true -> [] + | None, None -> assert false in + match l with + | [] -> mt () + | l -> str "(" ++ prlist_with_sep pr_comma str l ++ str ")" + +let pr_non_empty spc pp = + if pp = mt () then mt () else spc ++ pp + +let pr_notation_data prglob (on_parsing,on_printing,{ not_interp = (_, r); not_location = (_, df) }) = + hov 0 (pr_notation_info prglob df r ++ pr_non_empty (brk(1,2)) (pr_notation_status on_parsing on_printing)) + +let extract_notation_data (main,extra) = + let main = match main with + | NoParsingData -> [] + | ParsingAndPrintingData (on_parsing, on_printing, d) -> + [Some on_parsing, Some on_printing, d] + | OnlyParsingData (on_parsing, d) -> + [Some on_parsing, None, d] in + let extra = List.map (fun (on_printing, d) -> (None, Some on_printing, d)) extra in + main @ extra + +let pr_named_scope prglob (scope,sc) = (if String.equal scope default_scope then match NotationMap.cardinal sc.notations with | 0 -> str "No lonely notation" | n -> str "Lonely notation" ++ (if Int.equal n 1 then mt() else str"s") else str "Scope " ++ str scope ++ fnl () ++ pr_delimiters_info sc.delimiters) - ++ fnl () - ++ pr_scope_classes scope - ++ NotationMap.fold - (fun ntn { not_interp = (_, r); not_location = (_, df) } strm -> - pr_notation_info prglob df r ++ fnl () ++ strm) - sc.notations (mt ()) + ++ pr_non_empty (fnl ()) (pr_scope_classes scope) + ++ prlist (fun a -> fnl () ++ pr_notation_data prglob a) + (NotationMap.fold (fun ntn data l -> extract_notation_data data @ l) sc.notations []) -let pr_scope prglob scope = pr_named_scope prglob scope (find_scope scope) +let pr_scope prglob scope = pr_named_scope prglob (scope, find_scope scope) let pr_scopes prglob = - String.Map.fold - (fun scope sc strm -> pr_named_scope prglob scope sc ++ fnl () ++ strm) - !scope_map (mt ()) + let l = String.Map.bindings !scope_map in + prlist_with_sep (fun () -> fnl () ++ fnl ()) (pr_named_scope prglob) l let rec find_default ntn = function | [] -> None | OpenScopeItem scope :: scopes -> - if NotationMap.mem ntn (find_scope scope).notations then - Some scope + if has_active_parsing_rule_in_scope ntn scope then Some scope else find_default ntn scopes | LonelyNotationItem ntn' :: scopes -> if notation_eq ntn ntn' then Some default_scope @@ -1870,12 +2047,12 @@ let rec find_default ntn = function let factorize_entries = function | [] -> [] - | (ntn,c)::l -> + | (ntn,sc',c)::l -> let (ntn,l_of_ntn,rest) = List.fold_left - (fun (a',l,rest) (a,c) -> - if notation_eq a a' then (a',c::l,rest) else (a,[c],(a',l)::rest)) - (ntn,[c],[]) l in + (fun (a',l,rest) (a,sc,c) -> + if notation_eq a a' then (a',(sc,c)::l,rest) else (a,[sc,c],(a',l)::rest)) + (ntn,[sc',c],[]) l in (ntn,l_of_ntn)::rest type symbol_token = WhiteSpace of int | String of string @@ -1946,16 +2123,18 @@ let browse_notation strict ntn map = let l = String.Map.fold (fun scope_name sc -> - NotationMap.fold (fun ntn { not_interp = (_, r); not_location = df } l -> - if List.exists (find ntn) ntns then (ntn,(scope_name,r,df))::l else l) sc.notations) + NotationMap.fold (fun ntn data l -> + if List.exists (find ntn) ntns + then List.map (fun d -> (ntn,scope_name,d)) (extract_notation_data data) @ l + else l) sc.notations) map [] in - List.sort (fun x y -> String.compare (snd (fst x)) (snd (fst y))) l + List.sort (fun x y -> String.compare (snd (pi1 x)) (snd (pi1 y))) l -let global_reference_of_notation ~head test (ntn,(sc,c,_)) = +let global_reference_of_notation ~head test (ntn,sc,(on_parsing,on_printing,{not_interp = (_,c)})) = match c with - | NRef ref when test ref -> Some (ntn,sc,ref) + | NRef ref when test ref -> Some (on_parsing,on_printing,ntn,sc,ref) | NApp (NRef ref, l) when head || List.for_all isNVar_or_NHole l && test ref -> - Some (ntn,sc,ref) + Some (on_parsing,on_printing,ntn,sc,ref) | _ -> None let error_ambiguous_notation ?loc _ntn = @@ -1975,17 +2154,17 @@ let interp_notation_as_global_reference ?loc ~head test ntn sc = let ntns = browse_notation true ntn scopes in let refs = List.map (global_reference_of_notation ~head test) ntns in match Option.List.flatten refs with - | [_,_,ref] -> ref + | [Some true,_ (* why not if the only one? *),_,_,ref] -> ref | [] -> error_notation_not_reference ?loc ntn | refs -> - let f (ntn,sc,ref) = + let f (on_parsing,_,ntn,sc,ref) = let def = find_default ntn !scope_stack in match def with | None -> false - | Some sc' -> String.equal sc sc' + | Some sc' -> on_parsing = Some true && String.equal sc sc' in match List.filter f refs with - | [_,_,ref] -> ref + | [_,_,_,_,ref] -> ref | [] -> error_notation_not_reference ?loc ntn | _ -> error_ambiguous_notation ?loc ntn @@ -1995,24 +2174,25 @@ let locate_notation prglob ntn scope = match ntns with | [] -> str "Unknown notation" | _ -> - str "Notation" ++ fnl () ++ prlist_with_sep fnl (fun (ntn,l) -> let scope = find_default ntn scopes in prlist_with_sep fnl - (fun (sc,r,(_,df)) -> + (fun (sc,(on_parsing,on_printing,{ not_interp = (_, r); not_location = (_, df) })) -> hov 0 ( + str "Notation" ++ brk (1,2) ++ pr_notation_info prglob df r ++ (if String.equal sc default_scope then mt () - else (spc () ++ str ": " ++ str sc)) ++ + else (brk (1,2) ++ str ": " ++ str sc)) ++ (if Option.equal String.equal (Some sc) scope - then spc () ++ str "(default interpretation)" else mt ()))) + then brk (1,2) ++ str "(default interpretation)" else mt ()) ++ + pr_non_empty (brk (1,2)) (pr_notation_status on_parsing on_printing))) l) ntns let collect_notation_in_scope scope sc known = assert (not (String.equal scope default_scope)); NotationMap.fold - (fun ntn { not_interp = (_, r); not_location = (_, df) } (l,known as acc) -> - if List.mem_f notation_eq ntn known then acc else ((df,r)::l,ntn::known)) + (fun ntn d (l,known as acc) -> + if List.mem_f notation_eq ntn known then acc else (extract_notation_data d @ l,ntn::known)) sc.notations ([],known) let collect_notations stack = @@ -2028,13 +2208,13 @@ let collect_notations stack = if List.mem_f notation_eq ntn knownntn then (all,knownntn) else try - let { not_interp = (_, r); not_location = (_, df) } = - NotationMap.find ntn (find_scope default_scope).notations in + let datas = extract_notation_data + (NotationMap.find ntn (find_scope default_scope).notations) in let all' = match all with | (s,lonelyntn)::rest when String.equal s default_scope -> - (s,(df,r)::lonelyntn)::rest + (s,datas@lonelyntn)::rest | _ -> - (default_scope,[df,r])::all in + (default_scope,datas)::all in (all',ntn::knownntn) with Not_found -> (* e.g. if only printing *) (all,knownntn)) ([],[]) stack) @@ -2042,7 +2222,7 @@ let collect_notations stack = let pr_visible_in_scope prglob (scope,ntns) = let strm = List.fold_right - (fun (df,r) strm -> pr_notation_info prglob df r ++ fnl () ++ strm) + (fun d strm -> pr_notation_data prglob d ++ fnl () ++ strm) ntns (mt ()) in (if String.equal scope default_scope then str "Lonely notation" ++ (match ntns with [_] -> mt () | _ -> str "s") @@ -2051,9 +2231,7 @@ let pr_visible_in_scope prglob (scope,ntns) = ++ fnl () ++ strm let pr_scope_stack prglob stack = - List.fold_left - (fun strm scntns -> strm ++ pr_visible_in_scope prglob scntns ++ fnl ()) - (mt ()) (collect_notations stack) + prlist_with_sep fnl (pr_visible_in_scope prglob) (collect_notations stack) let pr_visibility prglob = function | Some scope -> pr_scope_stack prglob (push_scope scope !scope_stack) diff --git a/interp/notation.mli b/interp/notation.mli index 05ddd25a62..d744ff41d9 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 @@ -229,12 +229,24 @@ type interp_rule = | NotationRule of specific_notation | SynDefRule of KerName.t -val declare_notation_interpretation : notation -> scope_name option -> - interpretation -> notation_location -> onlyprint:bool -> - Deprecation.t option -> unit +type notation_use = + | OnlyPrinting + | OnlyParsing + | ParsingAndPrinting val declare_uninterpretation : interp_rule -> interpretation -> unit +type entry_coercion_kind = + | IsEntryCoercion of notation_entry_level + | IsEntryGlobal of string * int + | IsEntryIdent of string * int + +val declare_notation : notation_with_optional_scope * notation -> + interpretation -> notation_location -> use:notation_use -> + entry_coercion_kind option -> + Deprecation.t option -> unit + + (** Return the interpretation bound to a notation *) val interp_notation : ?loc:Loc.t -> notation -> subscopes -> interpretation * (notation_location * scope_name option) @@ -257,16 +269,14 @@ val uninterp_ind_pattern_notations : inductive -> notation_rule list val availability_of_notation : specific_notation -> subscopes -> (scope_name option * delimiters option) option +val is_printing_inactive_rule : interp_rule -> interpretation -> bool + (** {6 Miscellaneous} *) (** If head is true, also allows applied global references. *) val interp_notation_as_global_reference : ?loc:Loc.t -> head:bool -> (GlobRef.t -> bool) -> notation_key -> delimiters option -> GlobRef.t -(** Checks for already existing notations *) -val exists_notation_in_scope : scope_name option -> notation -> - bool -> interpretation -> bool - (** Declares and looks for scopes associated to arguments of a global ref *) val declare_arguments_scope : bool (** true=local *) -> GlobRef.t -> scope_name option list -> unit @@ -349,4 +359,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/notation_ops.ml b/interp/notation_ops.ml index 6422e184b5..354809252e 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -27,7 +27,9 @@ open Notation_term (* helper for NVar, NVar case in eq_notation_constr *) let get_var_ndx id vs = try Some (List.index Id.equal id vs) with Not_found -> None -let rec eq_notation_constr (vars1,vars2 as vars) t1 t2 = match t1, t2 with +let rec eq_notation_constr (vars1,vars2 as vars) t1 t2 = +(vars1 == vars2 && t1 == t2) || +match t1, t2 with | NRef gr1, NRef gr2 -> GlobRef.equal gr1 gr2 | NVar id1, NVar id2 -> ( match (get_var_ndx id1 vars1,get_var_ndx id2 vars2) with @@ -187,7 +189,7 @@ let apply_cases_pattern ?loc (ids_disjpat,id) c = let glob_constr_of_notation_constr_with_binders ?loc g f ?(h=default_binder_status_fun) e nc = let lt x = DAst.make ?loc x in lt @@ match nc with | NVar id -> GVar id - | NApp (a,args) -> let e = h.no e in GApp (f e a, List.map (f e) args) + | NApp (a,args) -> let e = h.no e in DAst.get (mkGApp (f e a) (List.map (f e) args)) | NList (x,y,iter,tail,swap) -> let t = f e tail in let it = f e iter in let innerl = (ldots_var,t)::(if swap then [y, lt @@ GVar x] else []) in 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/byterun/coq_fix_code.c b/kernel/byterun/coq_fix_code.c index 814cdfe1d8..9118410549 100644 --- a/kernel/byterun/coq_fix_code.c +++ b/kernel/byterun/coq_fix_code.c @@ -33,12 +33,12 @@ void init_arity () { arity[ACC0]=arity[ACC1]=arity[ACC2]=arity[ACC3]=arity[ACC4]=arity[ACC5]= arity[ACC6]=arity[ACC7]=arity[PUSH]=arity[PUSHACC0]=arity[PUSHACC1]= arity[PUSHACC2]=arity[PUSHACC3]=arity[PUSHACC4]=arity[PUSHACC5]= - arity[PUSHACC6]=arity[PUSHACC7]=arity[ENVACC1]=arity[ENVACC2]= - arity[ENVACC3]=arity[ENVACC4]=arity[PUSHENVACC1]=arity[PUSHENVACC2]= - arity[PUSHENVACC3]=arity[PUSHENVACC4]=arity[APPLY1]=arity[APPLY2]= - arity[APPLY3]=arity[APPLY4]=arity[RESTART]=arity[OFFSETCLOSUREM2]= - arity[OFFSETCLOSURE0]=arity[OFFSETCLOSURE2]=arity[PUSHOFFSETCLOSUREM2]= - arity[PUSHOFFSETCLOSURE0]=arity[PUSHOFFSETCLOSURE2]= + arity[PUSHACC6]=arity[PUSHACC7]= + arity[ENVACC0]=arity[ENVACC1]=arity[ENVACC2]=arity[ENVACC3]= + arity[PUSHENVACC0]=arity[PUSHENVACC1]=arity[PUSHENVACC2]=arity[PUSHENVACC3]= + arity[APPLY1]=arity[APPLY2]=arity[APPLY3]=arity[APPLY4]=arity[RESTART]= + arity[OFFSETCLOSURE0]=arity[OFFSETCLOSURE1]= + arity[PUSHOFFSETCLOSURE0]=arity[PUSHOFFSETCLOSURE1]= arity[GETFIELD0]=arity[GETFIELD1]=arity[SETFIELD0]=arity[SETFIELD1]= arity[CONST0]=arity[CONST1]=arity[CONST2]=arity[CONST3]= arity[PUSHCONST0]=arity[PUSHCONST1]=arity[PUSHCONST2]=arity[PUSHCONST3]= diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index 15cc451ea8..1b6da7dd6f 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -193,6 +193,8 @@ if (sp - num_args < coq_stack_threshold) { \ #endif #endif +#define Is_accu(v) (Is_block(v) && Tag_val(v) == Closure_tag && Code_val(v) == accumulate) + #define CheckPrimArgs(cond, apply_lbl) do{ \ if (cond) pc++; \ else{ \ @@ -383,37 +385,49 @@ value coq_interprete } /* Access in heap-allocated environment */ + Instruct(ENVACC0){ + print_instr("ENVACC0"); + accu = Field(coq_env, 2); + Next; + } Instruct(ENVACC1){ print_instr("ENVACC1"); - accu = Field(coq_env, 1); Next; + accu = Field(coq_env, 3); + Next; } Instruct(ENVACC2){ print_instr("ENVACC2"); - accu = Field(coq_env, 2); Next; + accu = Field(coq_env, 4); + Next; } Instruct(ENVACC3){ print_instr("ENVACC3"); - accu = Field(coq_env, 3); Next; + accu = Field(coq_env, 5); + Next; } - Instruct(ENVACC4){ - print_instr("ENVACC4"); - accu = Field(coq_env, 4); Next; + Instruct(PUSHENVACC0){ + print_instr("PUSHENVACC0"); + *--sp = accu; + accu = Field(coq_env, 2); + Next; } Instruct(PUSHENVACC1){ print_instr("PUSHENVACC1"); - *--sp = accu; accu = Field(coq_env, 1); Next; + *--sp = accu; + accu = Field(coq_env, 3); + Next; } Instruct(PUSHENVACC2){ print_instr("PUSHENVACC2"); - *--sp = accu; accu = Field(coq_env, 2); Next; + *--sp = accu; + accu = Field(coq_env, 4); + Next; } Instruct(PUSHENVACC3){ print_instr("PUSHENVACC3"); - *--sp = accu; accu = Field(coq_env, 3); Next; - } - Instruct(PUSHENVACC4){ - print_instr("PUSHENVACC4"); - *--sp = accu; accu = Field(coq_env, 4); Next; + *--sp = accu; + accu = Field(coq_env, 5); + Next; } Instruct(PUSHENVACC){ print_instr("PUSHENVACC"); @@ -423,7 +437,7 @@ value coq_interprete Instruct(ENVACC){ print_instr("ENVACC"); print_int(*pc); - accu = Field(coq_env, *pc++); + accu = Field(coq_env, 2 + *pc++); Next; } /* Function application */ @@ -598,7 +612,6 @@ value coq_interprete sp[0] = arg1; sp[1] = arg2; pc = Code_val(accu); - print_lint(accu); coq_env = accu; coq_extra_args += 1; goto check_stack; @@ -643,13 +656,13 @@ value coq_interprete } Instruct(RESTART) { - int num_args = Wosize_val(coq_env) - 2; + int num_args = Wosize_val(coq_env) - 3; int i; print_instr("RESTART"); CHECK_STACK(num_args); sp -= num_args; - for (i = 0; i < num_args; i++) sp[i] = Field(coq_env, i + 2); - coq_env = Field(coq_env, 1); + for (i = 0; i < num_args; i++) sp[i] = Field(coq_env, i + 3); + coq_env = Field(coq_env, 2); coq_extra_args += num_args; Next; } @@ -663,9 +676,10 @@ value coq_interprete } else { mlsize_t num_args, i; num_args = 1 + coq_extra_args; /* arg1 + extra args */ - Alloc_small(accu, num_args + 2, Closure_tag); - Field(accu, 1) = coq_env; - for (i = 0; i < num_args; i++) Field(accu, i + 2) = sp[i]; + Alloc_small(accu, num_args + 3, Closure_tag); + Field(accu, 1) = Val_int(2); + Field(accu, 2) = coq_env; + for (i = 0; i < num_args; i++) Field(accu, i + 3) = sp[i]; Code_val(accu) = pc - 3; /* Point to the preceding RESTART instr. */ sp += num_args; pc = (code_t)(sp[0]); @@ -680,16 +694,18 @@ value coq_interprete int rec_pos = *pc++; /* commence a zero */ print_instr("GRABREC"); if (rec_pos <= coq_extra_args && !Is_accu(sp[rec_pos])) { - pc++;/* On saute le Restart */ + pc++; /* Skip the next RESTART, then point coq_env at the free variables. */ + coq_env = coq_env + (Int_val(Field(coq_env, 1)) - 2) * sizeof(value); } else { if (coq_extra_args < rec_pos) { /* Partial application */ mlsize_t num_args, i; num_args = 1 + coq_extra_args; /* arg1 + extra args */ - Alloc_small(accu, num_args + 2, Closure_tag); - Field(accu, 1) = coq_env; - for (i = 0; i < num_args; i++) Field(accu, i + 2) = sp[i]; - Code_val(accu) = pc - 3; + Alloc_small(accu, num_args + 3, Closure_tag); + Code_val(accu) = pc - 3; /* Point to the preceding RESTART instr. */ + Field(accu, 1) = Val_int(2); + Field(accu, 2) = coq_env; + for (i = 0; i < num_args; i++) Field(accu, i + 3) = sp[i]; sp += num_args; pc = (code_t)(sp[0]); coq_env = sp[1]; @@ -698,25 +714,26 @@ value coq_interprete } else { /* The recursif argument is an accumulator */ mlsize_t num_args, i; + value block; /* Construction of fixpoint applied to its [rec_pos-1] first arguments */ - Alloc_small(accu, rec_pos + 2, Closure_tag); - Field(accu, 1) = coq_env; // We store the fixpoint in the first field - for (i = 0; i < rec_pos; i++) Field(accu, i + 2) = sp[i]; // Storing args - Code_val(accu) = pc; - sp += rec_pos; - *--sp = accu; - /* Construction of the atom */ - Alloc_small(accu, 2, ATOM_FIX_TAG); - Field(accu,1) = sp[0]; - Field(accu,0) = sp[1]; - sp++; sp[0] = accu; - /* Construction of the accumulator */ + Alloc_small(accu, rec_pos + 3, Closure_tag); + Code_val(accu) = pc; /* Point to the next RESTART instr. */ + Field(accu, 1) = Val_int(2); + Field(accu, 2) = coq_env; // We store the fixpoint in the first field + for (i = 0; i < rec_pos; i++) Field(accu, i + 3) = *sp++; // Storing args + /* Construction of the atom */ + Alloc_small(block, 2, ATOM_FIX_TAG); + Field(block, 0) = *sp++; + Field(block, 1) = accu; + accu = block; + /* Construction of the accumulator */ num_args = coq_extra_args - rec_pos; - Alloc_small(accu, 2+num_args, Accu_tag); - Code_val(accu) = accumulate; - Field(accu,1) = sp[0]; sp++; - for (i = 0; i < num_args;i++)Field(accu, i + 2) = sp[i]; - sp += num_args; + Alloc_small(block, 3 + num_args, Closure_tag); + Code_val(block) = accumulate; + Field(block, 1) = Val_int(2); + Field(block, 2) = accu; + for (i = 0; i < num_args; i++) Field(block, i + 3) = *sp++; + accu = block; pc = (code_t)(sp[0]); coq_env = sp[1]; coq_extra_args = Long_val(sp[2]); @@ -732,12 +749,13 @@ value coq_interprete print_instr("CLOSURE"); print_int(nvars); if (nvars > 0) *--sp = accu; - Alloc_small(accu, 1 + nvars, Closure_tag); + Alloc_small(accu, 2 + nvars, Closure_tag); + Field(accu, 1) = Val_int(2); Code_val(accu) = pc + *pc; pc++; for (i = 0; i < nvars; i++) { print_lint(sp[i]); - Field(accu, i + 1) = sp[i]; + Field(accu, i + 2) = sp[i]; } sp += nvars; Next; @@ -758,24 +776,19 @@ value coq_interprete } pc += nfuncs; *--sp=accu; - Alloc_small(accu, nfuncs * 2 + nvars, Closure_tag); - Field(accu, nfuncs * 2 + nvars - 1) = *sp++; - /* On remplie la partie pour les variables libres */ - p = &Field(accu, nfuncs * 2 - 1); - for (i = 0; i < nvars; i++) { - *p++ = *sp++; - } + Alloc_small(accu, nfuncs * 3 + nvars, Closure_tag); + Field(accu, nfuncs * 3 + nvars - 1) = *sp++; p = &Field(accu, 0); - *p = (value) (pc + pc[0]); - p++; + *p++ = (value) (pc + pc[0]); + *p++ = Val_int(nfuncs * 3 - 1); for (i = 1; i < nfuncs; i++) { - *p = Make_header(i * 2, Infix_tag, Caml_white); - p++; /* color irrelevant. */ - *p = (value) (pc + pc[i]); - p++; + *p++ = Make_header(i * 3, Infix_tag, Caml_white); /* color irrelevant. */ + *p++ = (value) (pc + pc[i]); + *p++ = Val_int((nfuncs - i) * 3 - 1); } + for (i = 0; i < nvars; i++) *p++ = *sp++; pc += nfuncs; - accu = accu + 2 * start * sizeof(value); + accu = accu + start * 3 * sizeof(value); Next; } @@ -797,31 +810,28 @@ value coq_interprete /* Creation des blocks accumulate */ for(i=0; i < nfunc; i++) { - Alloc_small(accu, 2, Accu_tag); + Alloc_small(accu, 3, Closure_tag); Code_val(accu) = accumulate; - Field(accu,1) = Val_int(1); + Field(accu, 1) = Val_int(2); + Field(accu, 2) = Val_int(1); *--sp=accu; } /* creation des fonction cofix */ p = sp; - size = nfunc + nvars + 2; + size = nfunc + nvars + 3; for (i=0; i < nfunc; i++) { - + value block; Alloc_small(accu, size, Closure_tag); Code_val(accu) = pc+pc[i]; - for (j = 0; j < nfunc; j++) Field(accu, j+1) = p[j]; + Field(accu, 1) = Val_int(2); + for (j = 0; j < nfunc; ++j) Field(accu, j + 2) = p[j]; Field(accu, size - 1) = p[nfunc]; - for (j = nfunc+1; j <= nfunc+nvars; j++) Field(accu, j) = p[j]; - *--sp = accu; - /* creation du block contenant le cofix */ - - Alloc_small(accu,1, ATOM_COFIX_TAG); - Field(accu, 0) = sp[0]; - *sp = accu; - /* mise a jour du block accumulate */ - caml_modify(&Field(p[i], 1),*sp); - sp++; + for (j = nfunc + 1; j <= nfunc + nvars; ++j) Field(accu, j + 1) = p[j]; + Alloc_small(block, 1, ATOM_COFIX_TAG); + Field(block, 0) = accu; + /* update the accumulate block */ + caml_modify(&Field(p[i], 2), block); } pc += nfunc; accu = p[start]; @@ -837,15 +847,8 @@ value coq_interprete } /* fallthrough */ Instruct(OFFSETCLOSURE) { print_instr("OFFSETCLOSURE"); - accu = coq_env + *pc++ * sizeof(value); Next; - } - Instruct(PUSHOFFSETCLOSUREM2) { - print_instr("PUSHOFFSETCLOSUREM2"); - *--sp = accu; - } /* fallthrough */ - Instruct(OFFSETCLOSUREM2) { - print_instr("OFFSETCLOSUREM2"); - accu = coq_env - 2 * sizeof(value); Next; + accu = coq_env - *pc++ * 3 * sizeof(value); + Next; } Instruct(PUSHOFFSETCLOSURE0) { print_instr("PUSHOFFSETCLOSURE0"); @@ -853,15 +856,17 @@ value coq_interprete }/* fallthrough */ Instruct(OFFSETCLOSURE0) { print_instr("OFFSETCLOSURE0"); - accu = coq_env; Next; + accu = coq_env; + Next; } - Instruct(PUSHOFFSETCLOSURE2){ - print_instr("PUSHOFFSETCLOSURE2"); + Instruct(PUSHOFFSETCLOSURE1){ + print_instr("PUSHOFFSETCLOSURE1"); *--sp = accu; /* fallthrough */ } - Instruct(OFFSETCLOSURE2) { - print_instr("OFFSETCLOSURE2"); - accu = coq_env + 2 * sizeof(value); Next; + Instruct(OFFSETCLOSURE1) { + print_instr("OFFSETCLOSURE1"); + accu = coq_env - 3 * sizeof(value); + Next; } /* Access to global variables */ @@ -954,6 +959,7 @@ value coq_interprete print_int(sizes & 0xFFFFFF); if (Is_block(accu)) { long index = Tag_val(accu); + if (index == Closure_tag) index = 0; print_instr("block"); print_lint(index); pc += pc[(sizes & 0xFFFFFF) + index]; @@ -1021,7 +1027,7 @@ value coq_interprete print_instr("PROJ"); if (Is_accu (accu)) { *--sp = accu; // Save matched block on stack - accu = Field(accu, 1); // Save atom to accu register + accu = Field(accu, 2); // Save atom to accu register switch (Tag_val(accu)) { case ATOM_COFIX_TAG: // We are forcing a cofix { @@ -1033,11 +1039,11 @@ value coq_interprete coq_env = Field(accu, 0); // Pointer to suspension accu = sp[2]; // Save accumulator to accu register sp[2] = Val_long(coq_extra_args); // Push number of args for return - nargs = Wosize_val(accu) - 2; // Number of args = size of accumulator - 1 (accumulator code) - 1 (atom) + nargs = Wosize_val(accu) - 3; // Number of args = size of accumulator - 2 (accumulator closure) - 1 (atom) // Push arguments to stack CHECK_STACK(nargs + 1); sp -= nargs; - for (i = 0; i < nargs; ++i) sp[i] = Field(accu, i + 2); + for (i = 0; i < nargs; ++i) sp[i] = Field(accu, i + 3); *--sp = accu; // Last argument is the pointer to the suspension coq_extra_args = nargs; pc = Code_val(coq_env); // Trigger evaluation @@ -1059,9 +1065,10 @@ value coq_interprete Field(accu, 0) = Field(coq_global_data, *pc++); Field(accu, 1) = *sp++; /* Create accumulator */ - Alloc_small(block, 2, Accu_tag); + Alloc_small(block, 3, Closure_tag); Code_val(block) = accumulate; - Field(block, 1) = accu; + Field(block, 1) = Val_int(2); + Field(block, 2) = accu; accu = block; } } @@ -1122,7 +1129,7 @@ value coq_interprete mlsize_t i, size; print_instr("ACCUMULATE"); size = Wosize_val(coq_env); - Alloc_small(accu, size + coq_extra_args + 1, Accu_tag); + Alloc_small(accu, size + coq_extra_args + 1, Closure_tag); for(i = 0; i < size; i++) Field(accu, i) = Field(coq_env, i); for(i = size; i <= coq_extra_args + size; i++) Field(accu, i) = *sp++; @@ -1135,7 +1142,7 @@ value coq_interprete Instruct(MAKESWITCHBLOCK) { print_instr("MAKESWITCHBLOCK"); *--sp = accu; // Save matched block on stack - accu = Field(accu,1); // Save atom to accu register + accu = Field(accu, 2); // Save atom to accu register switch (Tag_val(accu)) { case ATOM_COFIX_TAG: // We are forcing a cofix { @@ -1149,11 +1156,11 @@ value coq_interprete coq_env = Field(accu,0); // Pointer to suspension accu = sp[2]; // Save accumulator to accu register sp[2] = Val_long(coq_extra_args); // Push number of args for return - nargs = Wosize_val(accu) - 2; // Number of args = size of accumulator - 1 (accumulator code) - 1 (atom) + nargs = Wosize_val(accu) - 3; // Number of args = size of accumulator - 2 (accumulator closure) - 1 (atom) // Push arguments to stack CHECK_STACK(nargs+1); sp -= nargs; - for (i = 0; i < nargs; i++) sp[i] = Field(accu, i + 2); + for (i = 0; i < nargs; i++) sp[i] = Field(accu, i + 3); *--sp = accu; // Leftmost argument is the pointer to the suspension print_lint(nargs); coq_extra_args = nargs; @@ -1174,6 +1181,7 @@ value coq_interprete mlsize_t sz; int i, annot; code_t typlbl,swlbl; + value block; print_instr("MAKESWITCHBLOCK"); typlbl = (code_t)pc + *pc; @@ -1200,24 +1208,26 @@ value coq_interprete *--sp = accu; Alloc_small(accu, 1, Abstract_tag); Code_val(accu) = swlbl; - *--sp = accu; /* We create the switch zipper */ - Alloc_small(accu, 5, Default_tag); - Field(accu, 0) = sp[1]; - Field(accu, 1) = sp[0]; - Field(accu, 2) = sp[3]; - Field(accu, 3) = sp[2]; - Field(accu, 4) = coq_env; + Alloc_small(block, 5, Default_tag); + Field(block, 0) = sp[0]; + Field(block, 1) = accu; + Field(block, 2) = sp[2]; + Field(block, 3) = sp[1]; + Field(block, 4) = coq_env; sp += 3; - sp[0] = accu; + accu = block; /* We create the atom */ - Alloc_small(accu, 2, ATOM_SWITCH_TAG); - Field(accu, 0) = sp[1]; Field(accu, 1) = sp[0]; - sp++;sp[0] = accu; + Alloc_small(block, 2, ATOM_SWITCH_TAG); + Field(block, 0) = *sp++; + Field(block, 1) = accu; + accu = block; /* We create the accumulator */ - Alloc_small(accu, 2, Accu_tag); - Code_val(accu) = accumulate; - Field(accu,1) = *sp++; + Alloc_small(block, 3, Closure_tag); + Code_val(block) = accumulate; + Field(block, 1) = Val_int(2); + Field(block, 2) = accu; + accu = block; } } Next; @@ -1228,10 +1238,11 @@ value coq_interprete Instruct(MAKEACCU) { int i; print_instr("MAKEACCU"); - Alloc_small(accu, coq_extra_args + 3, Accu_tag); + Alloc_small(accu, coq_extra_args + 4, Closure_tag); Code_val(accu) = accumulate; - Field(accu,1) = Field(coq_atom_tbl, *pc); - for(i = 2; i < coq_extra_args + 3; i++) Field(accu, i) = *sp++; + Field(accu, 1) = Val_int(2); + Field(accu, 2) = Field(coq_atom_tbl, *pc); + for (i = 2; i < coq_extra_args + 3; i++) Field(accu, i + 1) = *sp++; pc = (code_t)(sp[0]); coq_env = sp[1]; coq_extra_args = Long_val(sp[2]); @@ -1875,11 +1886,11 @@ value coq_push_val(value v) { value coq_push_arguments(value args) { int nargs,i; value * sp = coq_sp; - nargs = Wosize_val(args) - 2; + nargs = Wosize_val(args) - 3; CHECK_STACK(nargs); coq_sp -= nargs; print_instr("push_args");print_int(nargs); - for(i = 0; i < nargs; i++) coq_sp[i] = Field(args, i+2); + for (i = 0; i < nargs; i++) coq_sp[i] = Field(args, i + 3); return Val_unit; } diff --git a/kernel/byterun/coq_memory.c b/kernel/byterun/coq_memory.c index 6233675c66..ae5251c252 100644 --- a/kernel/byterun/coq_memory.c +++ b/kernel/byterun/coq_memory.c @@ -108,7 +108,7 @@ value init_coq_vm(value unit) /* ML */ init_coq_interpreter(); /* Some predefined pointer code. - * It is typically contained in accumulator blocks whose tag is 0 and thus + * It is typically contained in accumulator blocks and thus might be * scanned by the GC, so make it look like an OCaml block. */ value accu_block = (value) coq_stat_alloc(2 * sizeof(value)); Hd_hp (accu_block) = Make_header (1, Abstract_tag, Caml_black); \ diff --git a/kernel/byterun/coq_values.c b/kernel/byterun/coq_values.c index bbe91da628..adfd4e8954 100644 --- a/kernel/byterun/coq_values.c +++ b/kernel/byterun/coq_values.c @@ -38,9 +38,9 @@ value coq_closure_arity(value clos) { opcode_t * c = Code_val(clos); if (Is_instruction(c,RESTART)) { c++; - if (Is_instruction(c,GRAB)) return Val_int(3 + c[1] - Wosize_val(clos)); + if (Is_instruction(c,GRAB)) return Val_int(4 + c[1] - Wosize_val(clos)); else { - if (Wosize_val(clos) != 2) caml_failwith("Coq Values : coq_closure_arity"); + if (Wosize_val(clos) != 3) caml_failwith("Coq Values : coq_closure_arity"); return Val_int(1); } } @@ -50,13 +50,17 @@ value coq_closure_arity(value clos) { /* Fonction sur les fix */ -value coq_offset(value v) { +value coq_current_fix(value v) { if (Tag_val(v) == Closure_tag) return Val_int(0); - else return Val_long(-Wsize_bsize(Infix_offset_val(v))); + else return Val_long(Wsize_bsize(Infix_offset_val(v)) / 3); } -value coq_offset_closure(value v, value offset){ - return (value)&Field(v, Int_val(offset)); +value coq_shift_fix(value v, value offset) { + return v + Int_val(offset) * 3 * sizeof(value); +} + +value coq_last_fix(value v) { + return v + (Int_val(Field(v, 1)) - 2) * sizeof(value); } value coq_set_bytecode_field(value v, value i, value code) { diff --git a/kernel/byterun/coq_values.h b/kernel/byterun/coq_values.h index a19f9b56c1..f07018711b 100644 --- a/kernel/byterun/coq_values.h +++ b/kernel/byterun/coq_values.h @@ -17,7 +17,6 @@ #include <float.h> #define Default_tag 0 -#define Accu_tag 0 #define ATOM_ID_TAG 0 #define ATOM_INDUCTIVE_TAG 1 @@ -28,9 +27,6 @@ #define ATOM_COFIX_TAG 6 #define ATOM_COFIXEVALUATED_TAG 7 -/* Les blocs accumulate */ -#define Is_accu(v) (Is_block(v) && (Tag_val(v) == Accu_tag)) -#define IS_EVALUATED_COFIX(v) (Is_accu(v) && Is_block(Field(v,1)) && (Tag_val(Field(v,1)) == ATOM_COFIXEVALUATED_TAG)) #define Is_double(v) (Tag_val(v) == Double_tag) #define Is_tailrec_switch(v) (Field(v,1) == Val_true) diff --git a/kernel/cClosure.mli b/kernel/cClosure.mli index ada0fc9780..3e8916673d 100644 --- a/kernel/cClosure.mli +++ b/kernel/cClosure.mli @@ -159,7 +159,7 @@ val inject : constr -> fconstr (** mk_atom: prevents a term from being evaluated *) val mk_atom : constr -> fconstr -(** mk_red: makes a reducible term (used in newring) *) +(** mk_red: makes a reducible term (used in ring) *) val mk_red : fterm -> fconstr val fterm_of : fconstr -> fterm 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..dec9e1deb8 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} @@ -271,6 +274,11 @@ let is_impredicative_sort env = function let is_impredicative_univ env u = is_impredicative_sort env (Sorts.sort_of_univ u) +let is_impredicative_family env = function + | Sorts.InSProp | Sorts.InProp -> true + | Sorts.InSet -> is_impredicative_set env + | Sorts.InType -> false + let type_in_type env = not (typing_flags env).check_universes let deactivated_guard env = not (typing_flags env).check_guarded @@ -464,14 +472,22 @@ let same_flags { [@warning "+9"] let set_cumulative_sprop b = map_universes (UGraph.set_cumulative_sprop b) +let set_type_in_type b = map_universes (UGraph.set_type_in_type b) let set_typing_flags c env = if same_flags env.env_typing_flags c then env - else set_cumulative_sprop c.cumulative_sprop { env with env_typing_flags = c } + else + let env = { env with env_typing_flags = c } in + let env = set_cumulative_sprop c.cumulative_sprop env in + let env = set_type_in_type (not c.check_universes) env in + env let set_cumulative_sprop b env = set_typing_flags {env.env_typing_flags with cumulative_sprop=b} env +let set_type_in_type b env = + set_typing_flags {env.env_typing_flags with check_universes=not b} env + let set_allow_sprop b env = { env with env_stratification = { env.env_stratification with env_sprop_allowed = b } } diff --git a/kernel/environ.mli b/kernel/environ.mli index 5cb56a2a29..f443ba38e1 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 { @@ -117,6 +122,7 @@ val indices_matter : env -> bool val is_impredicative_sort : env -> Sorts.t -> bool val is_impredicative_univ : env -> Univ.Universe.t -> bool +val is_impredicative_family : env -> Sorts.family -> bool (** is the local context empty *) val empty_context : env -> bool @@ -315,6 +321,7 @@ val push_subgraph : Univ.ContextSet.t -> env -> env val set_engagement : engagement -> env -> env val set_typing_flags : typing_flags -> env -> env val set_cumulative_sprop : bool -> env -> env +val set_type_in_type : bool -> env -> env val set_allow_sprop : bool -> env -> env val sprop_allowed : env -> bool diff --git a/kernel/genOpcodeFiles.ml b/kernel/genOpcodeFiles.ml index 67a672c349..f052e03cde 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. @@ -38,15 +38,15 @@ let opcodes = "PUSHACC7"; "PUSHACC"; "POP"; + "ENVACC0"; "ENVACC1"; "ENVACC2"; "ENVACC3"; - "ENVACC4"; "ENVACC"; + "PUSHENVACC0"; "PUSHENVACC1"; "PUSHENVACC2"; "PUSHENVACC3"; - "PUSHENVACC4"; "PUSHENVACC"; "PUSH_RETADDR"; "APPLY"; @@ -65,13 +65,11 @@ let opcodes = "CLOSURE"; "CLOSUREREC"; "CLOSURECOFIX"; - "OFFSETCLOSUREM2"; "OFFSETCLOSURE0"; - "OFFSETCLOSURE2"; + "OFFSETCLOSURE1"; "OFFSETCLOSURE"; - "PUSHOFFSETCLOSUREM2"; "PUSHOFFSETCLOSURE0"; - "PUSHOFFSETCLOSURE2"; + "PUSHOFFSETCLOSURE1"; "PUSHOFFSETCLOSURE"; "GETGLOBAL"; "PUSHGETGLOBAL"; @@ -196,7 +194,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 +208,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/indTyping.ml b/kernel/indTyping.ml index 179353d3f0..b2520b780f 100644 --- a/kernel/indTyping.ml +++ b/kernel/indTyping.ml @@ -77,7 +77,7 @@ let check_univ_leq ?(is_real_arg=false) env u info = else info in (* Inductive types provide explicit lifting from SProp to other universes, so allow SProp <= any. *) - if type_in_type env || Univ.Universe.is_sprop u || UGraph.check_leq (universes env) u ind_univ + if Univ.Universe.is_sprop u || UGraph.check_leq (universes env) u ind_univ then { info with ind_min_univ = Option.map (Universe.sup u) info.ind_min_univ } else if is_impredicative_univ env ind_univ && Option.is_empty info.ind_min_univ then { info with ind_squashed = true } 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..096e458ec4 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -29,7 +29,12 @@ module G = AcyclicGraph.Make(struct code (eg add_universe with a constraint vs G.add with no constraint) *) -type t = { graph: G.t; sprop_cumulative : bool } +type t = { + graph: G.t; + sprop_cumulative : bool; + type_in_type : bool; +} + type 'a check_function = t -> 'a -> 'a -> bool let g_map f g = @@ -39,6 +44,10 @@ let g_map f g = let set_cumulative_sprop b g = {g with sprop_cumulative=b} +let set_type_in_type b g = {g with type_in_type=b} + +let type_in_type g = g.type_in_type + let check_smaller_expr g (u,n) (v,m) = let diff = n - m in match diff with @@ -55,28 +64,33 @@ let real_check_leq g u v = Universe.for_all (fun ul -> exists_bigger g ul v) u let check_leq g u v = + type_in_type g || Universe.equal u v || (g.sprop_cumulative && Universe.is_sprop u) || (not (Universe.is_sprop u) && not (Universe.is_sprop v) && (is_type0m_univ u || real_check_leq g u v)) let check_eq g u v = + type_in_type g || Universe.equal u v || (not (Universe.is_sprop u || Universe.is_sprop v) && (real_check_leq g u v && real_check_leq g v u)) let check_eq_level g u v = u == v || + type_in_type g || (not (Level.is_sprop u || Level.is_sprop v) && G.check_eq g.graph u v) -let empty_universes = {graph=G.empty; sprop_cumulative=false} +let empty_universes = {graph=G.empty; sprop_cumulative=false; type_in_type=false} let initial_universes = let big_rank = 1000000 in let g = G.empty in let g = G.add ~rank:big_rank Level.prop g in let g = G.add ~rank:big_rank Level.set g in - {graph=G.enforce_lt Level.prop Level.set g; sprop_cumulative=false} + {empty_universes with graph=G.enforce_lt Level.prop Level.set g} + +let initial_universes_with g = {g with graph=initial_universes.graph} let enforce_constraint (u,d,v) g = match d with @@ -91,6 +105,10 @@ let enforce_constraint (u,d,v as cst) g = | true, Le, false when g.sprop_cumulative -> g | _ -> raise (UniverseInconsistency (d,Universe.make u, Universe.make v, None)) +let enforce_constraint cst g = + if not (type_in_type g) then enforce_constraint cst g + else try enforce_constraint cst g with UniverseInconsistency _ -> g + let merge_constraints csts g = Constraint.fold enforce_constraint csts g let check_constraint g (u,d,v) = @@ -103,8 +121,8 @@ let check_constraint g (u,d,v as cst) = match Level.is_sprop u, d, Level.is_sprop v with | false, _, false -> check_constraint g.graph cst | true, (Eq|Le), true -> true - | true, Le, false -> g.sprop_cumulative - | _ -> false + | true, Le, false -> g.sprop_cumulative || type_in_type g + | _ -> type_in_type g let check_constraints csts g = Constraint.for_all (check_constraint g) csts @@ -142,6 +160,14 @@ 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 + | false, false -> enforce_leq_alg u v g + | left, _ -> + if left && g.sprop_cumulative then Constraint.empty, g + else raise (UniverseInconsistency (Le, u, v, None)) + (* 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/uGraph.mli b/kernel/uGraph.mli index c9fbd7f694..87b3634e28 100644 --- a/kernel/uGraph.mli +++ b/kernel/uGraph.mli @@ -16,6 +16,15 @@ type t val set_cumulative_sprop : bool -> t -> t (** Makes the system incomplete. *) +val set_type_in_type : bool -> t -> t + +(** When [type_in_type], functions adding constraints do not fail and + may instead ignore inconsistent constraints. + + Checking functions such as [check_leq] always return [true]. +*) +val type_in_type : t -> bool + type 'a check_function = t -> 'a -> 'a -> bool val check_leq : Universe.t check_function @@ -25,6 +34,9 @@ val check_eq_level : Level.t check_function (** The initial graph of universes: Prop < Set *) val initial_universes : t +(** Initial universes, but keeping options such as type in type from the argument. *) +val initial_universes_with : t -> t + (** Check equality of instances w.r.t. a universe graph *) val check_eq_instances : Instance.t check_function diff --git a/kernel/univ.ml b/kernel/univ.ml index 6d8aa02dff..a2fd14025e 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -205,12 +205,6 @@ module Level = struct let pr u = str (to_string u) - let apart u v = - match data u, data v with - | SProp, _ | _, SProp - | Prop, Set | Set, Prop -> true - | _ -> false - let vars = Array.init 20 (fun i -> make (Var i)) let var n = @@ -250,7 +244,7 @@ module LMap = struct ext empty let pr f m = - h 0 (prlist_with_sep fnl (fun (u, v) -> + h (prlist_with_sep fnl (fun (u, v) -> Level.pr u ++ f v) (bindings m)) end @@ -568,16 +562,6 @@ let constraint_type_ord c1 c2 = match c1, c2 with | Eq, Eq -> 0 | Eq, _ -> 1 -(* Universe inconsistency: error raised when trying to enforce a relation - that would create a cycle in the graph of universes. *) - -type univ_inconsistency = constraint_type * universe * universe * explanation Lazy.t option - -exception UniverseInconsistency of univ_inconsistency - -let error_inconsistency o u v p = - raise (UniverseInconsistency (o,Universe.make u,Universe.make v,p)) - (* Constraints and sets of constraints. *) type univ_constraint = Level.t * constraint_type * Level.t @@ -660,8 +644,6 @@ type 'a constraint_function = 'a -> 'a -> constraints -> constraints let enforce_eq_level u v c = (* We discard trivial constraints like u=u *) if Level.equal u v then c - else if Level.apart u v then - error_inconsistency Eq u v None else Constraint.add (u,Eq,v) c let enforce_eq u v c = @@ -684,9 +666,9 @@ let constraint_add_leq v u c = let j = m - n in if j = -1 (* n = m+1, v+1 <= u <-> v < u *) then Constraint.add (x,Lt,y) c - else if j <= -1 (* n = m+k, v+k <= u <-> v+(k-1) < u *) then - if Level.equal x y then (* u+(k+1) <= u *) - raise (UniverseInconsistency (Le, Universe.tip v, Universe.tip u, None)) + else if j <= -1 (* n = m+k, v+k <= u and k>0 *) then + if Level.equal x y then (* u+k <= u with k>0 *) + Constraint.add (x,Lt,x) c else anomaly (Pp.str"Unable to handle arbitrary u+k <= v constraints.") else if j = 0 then Constraint.add (x,Le,y) c @@ -703,8 +685,8 @@ let check_univ_leq u v = let enforce_leq u v c = match Universe.is_sprop u, Universe.is_sprop v with | true, true -> c - | true, false | false, true -> - raise (UniverseInconsistency (Le, u, v, None)) + | true, false -> Constraint.add (Level.sprop,Le,Level.prop) c + | false, true -> Constraint.add (Level.prop,Le,Level.sprop) c | false, false -> List.fold_left (fun c v -> (List.fold_left (fun c u -> constraint_add_leq u v c) c u)) c v @@ -961,7 +943,7 @@ struct let pr prl ?variance (univs, cst as ctx) = if is_empty ctx then mt() else - h 0 (Instance.pr prl ?variance univs ++ str " |= ") ++ h 0 (v 0 (Constraint.pr prl cst)) + h (Instance.pr prl ?variance univs ++ str " |= ") ++ h (v 0 (Constraint.pr prl cst)) let hcons (univs, cst) = (Instance.hcons univs, hcons_constraints cst) @@ -1076,7 +1058,7 @@ struct let pr prl (univs, cst as ctx) = if is_empty ctx then mt() else - h 0 (LSet.pr prl univs ++ str " |= ") ++ h 0 (v 0 (Constraint.pr prl cst)) + h (LSet.pr prl univs ++ str " |= ") ++ h (v 0 (Constraint.pr prl cst)) let constraints (_univs, cst) = cst let levels (univs, _cst) = univs @@ -1232,6 +1214,14 @@ let hcons_universe_context_set (v, c) = let hcons_univ x = Universe.hcons x +(* Universe inconsistency: error raised when trying to enforce a relation + that would create a cycle in the graph of universes. *) + +type univ_inconsistency = constraint_type * universe * universe * explanation Lazy.t option + +(* Do not use in this file as we may be type-in-type *) +exception UniverseInconsistency of univ_inconsistency + let explain_universe_inconsistency prl (o,u,v,p : univ_inconsistency) = let pr_uni = Universe.pr_with prl in let pr_rel = function 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..3adb2f2113 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 *) @@ -95,7 +95,7 @@ let reduce_fix k vf = (* computing types *) let fc_typ = fix_types fb in let ndef = Array.length fc_typ in - let et = offset_closure_fix fb (2*(ndef - 1)) in + let et = fix_env fb in let ftyp = Array.map (fun c -> interprete c crazy_val et 0) fc_typ in diff --git a/kernel/cbytecodes.ml b/kernel/vmbytecodes.ml index 74405a0105..c156a21c86 100644 --- a/kernel/cbytecodes.ml +++ b/kernel/vmbytecodes.ml @@ -106,14 +106,14 @@ let rec pp_instr i = | Kclosure(lbl, n) -> str "closure " ++ pp_lbl lbl ++ str ", " ++ int n | Kclosurerec(fv,init,lblt,lblb) -> - h 1 (str "closurerec " ++ + hv 1 (str "closurerec " ++ int fv ++ str ", " ++ int init ++ str " types = " ++ prlist_with_sep spc pp_lbl (Array.to_list lblt) ++ str " bodies = " ++ prlist_with_sep spc pp_lbl (Array.to_list lblb)) | Kclosurecofix (fv,init,lblt,lblb) -> - h 1 (str "closurecofix " ++ + hv 1 (str "closurecofix " ++ int fv ++ str ", " ++ int init ++ str " types = " ++ prlist_with_sep spc pp_lbl (Array.to_list lblt) ++ @@ -129,7 +129,7 @@ let rec pp_instr i = str "makeswitchblock " ++ pp_lbl lblt ++ str ", " ++ pp_lbl lbls ++ str ", " ++ int sz | Kswitch(lblc,lblb) -> - h 1 (str "switch " ++ + hv 1 (str "switch " ++ prlist_with_sep spc pp_lbl (Array.to_list lblc) ++ str " | " ++ prlist_with_sep spc pp_lbl (Array.to_list lblb)) 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..375b1aface 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 @@ -28,10 +28,10 @@ open Environ (* The virtual machine doesn't distinguish closures and their environment *) (* Representation of function environments : *) -(* [clos_t | code | fv1 | fv2 | ... | fvn ] *) +(* [clos_t | code | envofs=2 | fv1 | fv2 | ... | fvn ] *) (* ^ *) -(* The offset for accessing free variables is 1 (we must skip the code *) -(* pointer). *) +(* The offset for accessing free variables is 2 (we must skip the code *) +(* pointer and the environment offset). *) (* While compiling, free variables are stored in [in_env] in order *) (* opposite to machine representation, so we can add new free variables *) (* easily (i.e. without changing the position of previous variables) *) @@ -42,9 +42,9 @@ open Environ (* In the function body [arg1] is represented by de Bruijn [n], and *) (* [argn] by de Bruijn [1] *) -(* Representation of environments of mutual fixpoints : *) -(* [t1|C1| ... |tc|Cc| ... |t(nbr)|C(nbr)| fv1 | fv2 | .... | fvn | type] *) -(* ^<----------offset---------> *) +(* Representation of environments of mutual fixpoints : *) +(* [clos_t|C1|envofs1| ... |infix_t|Ci|envofsi| ... |infix_t|Cnbr|envofsnbr=2| fv1 | fv2 | .... | fvn | type] *) +(* ^ *) (* type = [Ct1 | .... | Ctn] *) (* Ci is the code pointer of the i-th body *) (* At runtime, a fixpoint environment (which is the same as the fixpoint *) @@ -52,45 +52,45 @@ open Environ (* In each fixpoint body, de Bruijn [nbr] represents the first fixpoint *) (* and de Bruijn [1] the last one. *) (* Access to these variables is performed by the [Koffsetclosure n] *) -(* instruction that shifts the environment pointer of [n] fields. *) +(* instruction that shifts the environment pointer by [n] closuress. *) (* This allows representing mutual fixpoints in just one block. *) (* [Ct1 | ... | Ctn] is an array holding code pointers of the fixpoint *) (* types. They are used in conversion tests (which requires that *) (* fixpoint types must be convertible). Their environment is the one of *) (* the last fixpoint : *) -(* [t1|C1| ... |tc|Cc| ... |t(nbr)|C(nbr)| fv1 | fv2 | .... | fvn | type] *) -(* ^ *) +(* [clos_t|C1| ... |infix_t|Ci| ... |infix_t|Cnbr|envofsnbr=2| fv1 | fv2 | .... | fvn | type] *) +(* ^ *) (* Representation of mutual cofix : *) (* a1 = [A_t | accumulate | [Cfx_t | fcofix1 ] ] *) (* ... *) (* anbr = [A_t | accumulate | [Cfx_t | fcofixnbr ] ] *) (* *) -(* fcofix1 = [clos_t | code1 | a1 |...| anbr | fv1 |...| fvn | type] *) +(* fcofix1 = [clos_t | code1 | envofs=2 | a1 |...| anbr | fv1 |...| fvn | type] *) (* ^ *) (* ... *) -(* fcofixnbr = [clos_t | codenbr | a1 |...| anbr | fv1 |...| fvn | type] *) +(* fcofixnbr = [clos_t | codenbr | envofs=2 | a1 |...| anbr | fv1 |...| fvn | type] *) (* ^ *) (* The [ai] blocks are functions that accumulate their arguments: *) (* ai arg1 argp ---> *) -(* ai' = [A_t | accumulate | [Cfx_t | fcofixi] | arg1 | ... | argp ] *) +(* ai' = [A_t | accumulate | envofs | [Cfx_t | fcofixi] | arg1 | ... | argp ] *) (* If such a block is matched against, we have to force evaluation, *) (* function [fcofixi] is then applied to [ai'] [arg1] ... [argp] *) (* (note that [ai'] is a pointer to the closure, passed as argument) *) (* Once evaluation is completed [ai'] is updated with the result: *) (* ai' <-- *) -(* [A_t | accumulate | [Cfxe_t |fcofixi|result] | arg1 | ... | argp ] *) +(* [A_t | accumulate | envofs | [Cfxe_t |fcofixi|result] | arg1 | ... | argp ] *) (* This representation is nice because the application of the cofix is *) (* evaluated only once (it simulates a lazy evaluation) *) (* Moreover, when cofix don't have arguments, it is possible to create *) (* a cycle, e.g.: *) (* cofix one := cons 1 one *) -(* a1 = [A_t | accumulate | [Cfx_t|fcofix1] ] *) -(* fcofix1 = [clos_t | code | a1] *) +(* a1 = [A_t | accumulate | envofs | [Cfx_t|fcofix1] ] *) +(* fcofix1 = [clos_t | code | envofs | a1] *) (* The result of evaluating [a1] is [cons_t | 1 | a1]. *) (* When [a1] is updated : *) -(* a1 = [A_t | accumulate | [Cfxe_t | fcofix1 | [cons_t | 1 | a1]] ] *) +(* a1 = [A_t | accumulate | envofs | [Cfxe_t | fcofix1 | [cons_t | 1 | a1]] ] *) (* The cycle is created ... *) (* *) (* In Cfxe_t accumulators, we need to store [fcofixi] for testing *) @@ -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] *) @@ -131,9 +131,7 @@ type comp_env = { (* universes are always at the bottom. *) nb_stack : int; (* number of variables on the stack *) in_stack : int Range.t; (* position in the stack *) - nb_rec : int; (* number of mutually recursive functions *) - pos_rec : instruction list; (* instruction d'acces pour les variables *) - (* de point fix ou de cofix *) + pos_rec : instruction array; (* instruction to access mutually-defined functions *) offset : int; in_env : vm_env ref (* The free variables of the expression *) } @@ -159,8 +157,7 @@ let empty_comp_env ()= nb_uni_stack = 0; nb_stack = 0; in_stack = Range.empty; - nb_rec = 0; - pos_rec = []; + pos_rec = [||]; offset = 0; in_env = ref empty_fv } @@ -195,9 +192,8 @@ let comp_env_fun ?(univs=0) arity = nb_uni_stack = univs ; nb_stack = arity; in_stack = add_param arity 0 Range.empty; - nb_rec = 0; - pos_rec = []; - offset = 1; + pos_rec = [||]; + offset = 0; in_env = ref empty_fv } @@ -207,24 +203,18 @@ let comp_env_fix_type rfv = nb_uni_stack = 0; nb_stack = 0; in_stack = Range.empty; - nb_rec = 0; - pos_rec = []; - offset = 1; + pos_rec = [||]; + offset = 0; in_env = rfv } -let comp_env_fix ndef curr_pos arity rfv = - let prec = ref [] in - for i = ndef downto 1 do - prec := Koffsetclosure (2 * (ndef - curr_pos - i)) :: !prec - done; +let comp_env_fix ndef arity rfv = { arity; nb_uni_stack = 0; nb_stack = arity; in_stack = add_param arity 0 Range.empty; - nb_rec = ndef; - pos_rec = !prec; - offset = 2 * (ndef - curr_pos - 1)+1; + pos_rec = Array.init ndef (fun i -> Koffsetclosure i); + offset = 0; in_env = rfv } @@ -233,24 +223,18 @@ let comp_env_cofix_type ndef rfv = nb_uni_stack = 0; nb_stack = 0; in_stack = Range.empty; - nb_rec = 0; - pos_rec = []; - offset = 1+ndef; + pos_rec = [||]; + offset = ndef; in_env = rfv } let comp_env_cofix ndef arity rfv = - let prec = ref [] in - for i = 1 to ndef do - prec := Kenvacc i :: !prec - done; { arity; nb_uni_stack = 0; nb_stack = arity; in_stack = add_param arity 0 Range.empty; - nb_rec = ndef; - pos_rec = !prec; - offset = ndef+1; + pos_rec = Array.init ndef (fun i -> Kenvacc (ndef - 1 - i)); + offset = ndef; in_env = rfv } @@ -283,11 +267,11 @@ let pos_rel i r sz = Kacc(sz - (Range.get r.in_stack (i-1))) else let i = i - r.nb_stack in - if i <= r.nb_rec then - try List.nth r.pos_rec (i-1) - with (Failure _|Invalid_argument _) -> assert false + let nb_rec = Array.length r.pos_rec in + if i <= nb_rec then + r.pos_rec.(i - 1) else - let i = i - r.nb_rec in + let i = i - nb_rec in let db = FVrel(i) in let env = !(r.in_env) in try Kenvacc(r.offset + find_at db env) @@ -410,16 +394,16 @@ let add_grabrec rec_arg arity lbl cont = let cont_cofix arity = (* accu = res *) (* stk = ai::args::ra::... *) - (* ai = [At|accumulate|[Cfx_t|fcofix]|args] *) + (* ai = [At|accumulate|envofs|[Cfx_t|fcofix]|args] *) [ Kpush; Kpush; (* stk = res::res::ai::args::ra::... *) Kacc 2; - Kfield 1; + Kfield 2; Kfield 0; Kmakeblock(2, cofix_evaluated_tag); Kpush; (* stk = [Cfxe_t|fcofix|res]::res::ai::args::ra::...*) Kacc 2; - Ksetfield 1; (* ai = [At|accumulate|[Cfxe_t|fcofix|res]|args] *) + Ksetfield 2; (* ai = [At|accumulate|envofs|[Cfxe_t|fcofix|res]|args] *) (* stk = res::ai::args::ra::... *) Kacc 0; (* accu = res *) Kreturn (arity+2) ] @@ -512,7 +496,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) @@ -627,7 +611,7 @@ let rec compile_lam env cenv lam sz cont = for i = 0 to ndef - 1 do let params,body = decompose_Llam bodies.(i) in let arity = Array.length params in - let env_body = comp_env_fix ndef i arity rfv in + let env_body = comp_env_fix ndef arity rfv in let cont1 = ensure_stack_capacity (compile_lam env env_body body arity) [Kreturn arity] in 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..f913cb906c 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 @@ -270,12 +270,12 @@ let emit_instr env = function | Kacc n -> if n < 8 then out env(opACC0 + n) else (out env opACC; out_int env n) | Kenvacc n -> - if n >= 1 && n <= 4 - then out env(opENVACC1 + n - 1) + if n >= 0 && n <= 3 + then out env(opENVACC0 + n) else (out env opENVACC; out_int env n) | Koffsetclosure ofs -> - if Int.equal ofs (-2) || Int.equal ofs 0 || Int.equal ofs 2 - then out env (opOFFSETCLOSURE0 + ofs / 2) + if Int.equal ofs 0 || Int.equal ofs 1 + then out env (opOFFSETCLOSURE0 + ofs) else (out env opOFFSETCLOSURE; out_int env ofs) | Kpush -> out env opPUSH @@ -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 @@ -385,13 +385,13 @@ let rec emit env insns remaining = match insns with if n < 8 then out env(opPUSHACC0 + n) else (out env opPUSHACC; out_int env n); emit env c remaining | Kpush :: Kenvacc n :: c -> - if n >= 1 && n <= 4 - then out env(opPUSHENVACC1 + n - 1) + if n >= 0 && n <= 3 + then out env(opPUSHENVACC0 + n) else (out env opPUSHENVACC; out_int env n); emit env c remaining | Kpush :: Koffsetclosure ofs :: c -> - if Int.equal ofs (-2) || Int.equal ofs 0 || Int.equal ofs 2 - then out env(opPUSHOFFSETCLOSURE0 + ofs / 2) + if Int.equal ofs 0 || Int.equal ofs 1 + then out env(opPUSHOFFSETCLOSURE0 + ofs) else (out env opPUSHOFFSETCLOSURE; out_int env ofs); emit env c remaining | Kpush :: Kgetglobal id :: c -> 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..4ad830a298 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 @@ -206,15 +206,11 @@ and eval_to_patch env (buff,pl,fv) = in let tc = patch buff pl slots in let vm_env = - (* Beware, this may look like a call to [Array.map], but it's not. - Calling [Array.map f] when the first argument returned by [f] - is a float would lead to [vm_env] being an unboxed Double_array - (Tag_val = Double_array_tag) whereas eval_tcode expects a - regular array (Tag_val = 0). - See test-suite/primitive/float/coq_env_double_array.v - for an actual instance. *) - let a = Array.make (Array.length fv) crazy_val in - Array.iteri (fun i v -> a.(i) <- slot_for_fv env v) fv; a in + (* Environment should look like a closure, so free variables start at slot 2. *) + let a = Array.make (Array.length fv + 2) crazy_val in + a.(1) <- Obj.magic 2; + Array.iteri (fun i v -> a.(i + 2) <- slot_for_fv env v) fv; + a in eval_tcode tc (get_atom_rel ()) (vm_global global_data.glob_val) vm_env and val_of_constr env c = 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/kernel/vmvalues.ml b/kernel/vmvalues.ml index de604176cb..0678f37a0b 100644 --- a/kernel/vmvalues.ml +++ b/kernel/vmvalues.ml @@ -34,8 +34,6 @@ let crazy_val = (val_of_obj (Obj.repr 0)) type tag = int -let accu_tag = 0 - let type_atom_tag = 2 let max_atom_tag = 2 let proj_tag = 3 @@ -166,7 +164,6 @@ let cofix_upd_val v = (Obj.magic v : values) type vm_env type vm_global let fun_env v = (Obj.magic v : vm_env) -let fix_env v = (Obj.magic v : vm_env) let cofix_env v = (Obj.magic v : vm_env) let cofix_upd_env v = (Obj.magic v : vm_env) type vstack = values array @@ -207,13 +204,13 @@ type vswitch = { (* dom : values, codom : vfun *) (* *) (* + Functions have two representations : *) -(* - unapplied fun : vf = Ct_[ C | fv1 | ... | fvn] *) +(* - unapplied fun : vf = Ct_[ C | envofs=2 | fv1 | ... | fvn] *) (* C:tcode, fvi : values *) (* Remark : a function and its environment is the same value. *) -(* - partially applied fun : Ct_[Restart:C| vf | arg1 | ... argn] *) +(* - partially applied fun : Ct_[ Restart::C | envofs=2 | vf | arg1 | ... | argn] *) (* *) (* + Fixpoints : *) -(* - Ct_[C1|Infix_t|C2|...|Infix_t|Cn|fv1|...|fvn] *) +(* - Ct_[C1|envofs1=3*n-1 | Infix_t|C2|envofs2 | ... | Infix_t|Cn|envofsn=2 | fv1|...|fvn] *) (* One single block to represent all of the fixpoints, each fixpoint *) (* is the pointer to the field holding the pointer to its code, and *) (* the infix tag is used to know where the block starts. *) @@ -226,13 +223,12 @@ type vswitch = { (* + Cofixpoints : see cbytegen.ml *) (* *) (* + vblock's encode (non constant) constructors as in Ocaml, but *) -(* starting from 0 up. tag 0 ( = accu_tag) is reserved for *) -(* accumulators. *) +(* starting from 0 up. *) (* *) (* + vm_env is the type of the machine environments (i.e. a function or *) (* a fixpoint) *) (* *) -(* + Accumulators : At_[accumulate| accu | arg1 | ... | argn ] *) +(* + Accumulators : At_[accumulate | envofs=2 | accu | arg1 | ... | argn ] *) (* - representation of [accu] : tag_[....] *) (* -- tag <= 3 : encoding atom type (sorts, free vars, etc.) *) (* -- 10_[accu|proj name] : a projection blocked by an accu *) @@ -291,10 +287,10 @@ type whd = | Vuniv_level of Univ.Level.t (* Functions over arguments *) -let nargs : arguments -> int = fun args -> (Obj.size (Obj.repr args)) - 2 +let nargs : arguments -> int = fun args -> Obj.size (Obj.repr args) - 3 let arg args i = if 0 <= i && i < (nargs args) then - val_of_obj (Obj.field (Obj.repr args) (i+2)) + val_of_obj (Obj.field (Obj.repr args) (i + 3)) else invalid_arg ("Vm.arg size = "^(string_of_int (nargs args))^ " acces "^(string_of_int i)) @@ -329,9 +325,9 @@ let uni_lvl_val (v : values) : Univ.Level.t = let rec whd_accu a stk = let stk = - if Int.equal (Obj.size a) 2 then stk + if Int.equal (Obj.size a) 3 then stk else Zapp (Obj.obj a) :: stk in - let at = Obj.field a 1 in + let at = Obj.field a 2 in match Obj.tag at with | i when Int.equal i type_atom_tag -> begin match stk with @@ -356,7 +352,7 @@ let rec whd_accu a stk = | i when Int.equal i fix_app_tag -> let fa = Obj.field at 1 in let zfix = - Zfix (Obj.obj (Obj.field fa 1), Obj.obj fa) in + Zfix (Obj.obj (Obj.field fa 2), Obj.obj fa) in whd_accu (Obj.field at 0) (zfix :: stk) | i when Int.equal i switch_tag -> let zswitch = Zswitch (Obj.obj (Obj.field at 1)) in @@ -392,29 +388,28 @@ external accumulate : unit -> tcode = "accumulate_code" external set_bytecode_field : Obj.t -> int -> tcode -> unit = "coq_set_bytecode_field" let accumulate = accumulate () -let whd_val : values -> whd = - fun v -> - let o = Obj.repr v in - if Obj.is_int o then Vconstr_const (Obj.obj o) +let whd_val (v: values) = + let o = Obj.repr v in + if Obj.is_int o then Vconstr_const (Obj.obj o) + else + let tag = Obj.tag o in + if Int.equal tag 0 then + if Int.equal (Obj.size o) 1 then + Varray (Obj.obj o) + else Vprod (Obj.obj o) + else if Int.equal tag Obj.closure_tag && is_accumulate (fun_code o) then + whd_accu o [] + else if Int.equal tag Obj.closure_tag || Int.equal tag Obj.infix_tag then + (match kind_of_closure o with + | 0 -> Vfun(Obj.obj o) + | 1 -> Vfix(Obj.obj o, None) + | 2 -> Vfix(Obj.obj (Obj.field o 2), Some (Obj.obj o)) + | 3 -> Vatom_stk(Aid(RelKey(int_tcode (fun_code o) 1)), []) + | _ -> CErrors.anomaly ~label:"Vm.whd " (Pp.str "kind_of_closure does not work.")) + else if Int.equal tag Obj.custom_tag then Vint64 (Obj.magic v) + else if Int.equal tag Obj.double_tag then Vfloat64 (Obj.magic v) else - let tag = Obj.tag o in - if tag = accu_tag then - if Int.equal (Obj.size o) 1 then - Varray(Obj.obj o) - else if is_accumulate (fun_code o) then whd_accu o [] - else Vprod(Obj.obj o) - else - if tag = Obj.closure_tag || tag = Obj.infix_tag then - (match kind_of_closure o with - | 0 -> Vfun(Obj.obj o) - | 1 -> Vfix(Obj.obj o, None) - | 2 -> Vfix(Obj.obj (Obj.field o 1), Some (Obj.obj o)) - | 3 -> Vatom_stk(Aid(RelKey(int_tcode (fun_code o) 1)), []) - | _ -> CErrors.anomaly ~label:"Vm.whd " (Pp.str "kind_of_closure does not work.")) - else if Int.equal tag Obj.custom_tag then Vint64 (Obj.magic v) - else if Int.equal tag Obj.double_tag then Vfloat64 (Obj.magic v) - else - Vconstr_block(Obj.obj o) + Vconstr_block (Obj.obj o) (**********************************************) (* Constructors *******************************) @@ -422,9 +417,10 @@ let whd_val : values -> whd = let obj_of_atom : atom -> Obj.t = fun a -> - let res = Obj.new_block accu_tag 2 in + let res = Obj.new_block Obj.closure_tag 3 in set_bytecode_field res 0 accumulate; - Obj.set_field res 1 (Obj.repr a); + Obj.set_field res 1 (Obj.repr 2); + Obj.set_field res 2 (Obj.repr a); res (* obj_of_str_const : structured_constant -> Obj.t *) @@ -516,29 +512,23 @@ external closure_arity : vfun -> int = "coq_closure_arity" (* Functions over fixpoint *) -external offset : Obj.t -> int = "coq_offset" -external offset_closure : Obj.t -> int -> Obj.t = "coq_offset_closure" -external offset_closure_fix : vfix -> int -> vm_env = "coq_offset_closure" +external current_fix : vfix -> int = "coq_current_fix" +external shift_fix : vfix -> int -> vfix = "coq_shift_fix" +external last_fix : vfix -> vfix = "coq_last_fix" external tcode_array : tcode_array -> tcode array = "coq_tcode_array" -let first o = (offset_closure o (offset o)) -let first_fix (v:vfix) = (Obj.magic (first (Obj.repr v)) : vfix) +let first_fix o = shift_fix o (- current_fix o) +let fix_env v = (Obj.magic (last_fix v) : vm_env) let last o = (Obj.field o (Obj.size o - 1)) let fix_types (v:vfix) = tcode_array (Obj.magic (last (Obj.repr v)) : tcode_array) let cofix_types (v:vcofix) = tcode_array (Obj.magic (last (Obj.repr v)) : tcode_array) -let current_fix vf = - (offset (Obj.repr vf) / 2) - -let unsafe_fb_code fb i = - let off = (2 * i) * (Sys.word_size / 8) in - Obj.obj (Obj.add_offset (Obj.repr fb) (Int32.of_int off)) - -let unsafe_rec_arg fb i = int_tcode (unsafe_fb_code fb i) 1 +let unsafe_rec_arg fb i = int_tcode (Obj.magic (shift_fix fb i)) 1 let rec_args vf = - let fb = first (Obj.repr vf) in - let size = Obj.size (last fb) in + let fb = first_fix vf in + let size = Obj.size (last (Obj.repr fb)) in Array.init size (unsafe_rec_arg fb) exception FALSE @@ -547,10 +537,10 @@ let check_fix f1 f2 = let i1, i2 = current_fix f1, current_fix f2 in (* Checking starting point *) if i1 = i2 then - let fb1,fb2 = first (Obj.repr f1), first (Obj.repr f2) in - let n = Obj.size (last fb1) in + let fb1,fb2 = first_fix f1, first_fix f2 in + let n = Obj.size (last (Obj.repr fb1)) in (* Checking number of definitions *) - if n = Obj.size (last fb2) then + if n = Obj.size (last (Obj.repr fb2)) then (* Checking recursive arguments *) try for i = 0 to n - 1 do @@ -593,21 +583,23 @@ let relaccu_code i = let mk_fix_body k ndef fb = let e = Obj.dup (Obj.repr fb) in + let env = Obj.repr (fix_env (Obj.obj e)) in for i = 0 to ndef - 1 do - set_bytecode_field e (2 * i) (relaccu_code (k + i)) + set_bytecode_field e (3 * i) (relaccu_code (k + i)) done; let fix_body i = - let c = offset_tcode (unsafe_fb_code fb i) 2 in - let res = Obj.new_block Obj.closure_tag 2 in + let c = offset_tcode (Obj.magic (shift_fix fb i)) 2 in + let res = Obj.new_block Obj.closure_tag 3 in set_bytecode_field res 0 c; - Obj.set_field res 1 (offset_closure e (2*i)); + Obj.set_field res 1 (Obj.repr 2); + Obj.set_field res 2 env; ((Obj.obj res) : vfun) in Array.init ndef fix_body (* Functions over vcofix *) let get_fcofix vcf i = - match whd_val (Obj.obj (Obj.field (Obj.repr vcf) (i+1))) with + match whd_val (Obj.obj (Obj.field (Obj.repr vcf) (i+2))) with | Vcofix(vcfi, _, _) -> vcfi | _ -> assert false @@ -628,7 +620,7 @@ let check_cofix vcf1 vcf2 = let mk_cofix_body apply_varray k ndef vcf = let e = Obj.dup (Obj.repr vcf) in for i = 0 to ndef - 1 do - Obj.set_field e (i+1) (Obj.repr (val_of_rel (k+i))) + Obj.set_field e (i+2) (Obj.repr (val_of_rel (k+i))) done; let cofix_body i = @@ -636,9 +628,7 @@ let mk_cofix_body apply_varray k ndef vcf = let c = Obj.field (Obj.repr vcfi) 0 in Obj.set_field e 0 c; let atom = Obj.new_block cofix_tag 1 in - let self = Obj.new_block accu_tag 2 in - set_bytecode_field self 0 accumulate; - Obj.set_field self 1 (Obj.repr atom); + let self = obj_of_atom (Obj.obj atom) in apply_varray (Obj.obj e) [|Obj.obj self|] in Array.init ndef cofix_body diff --git a/kernel/vmvalues.mli b/kernel/vmvalues.mli index f6efd49cfc..6632dc46b2 100644 --- a/kernel/vmvalues.mli +++ b/kernel/vmvalues.mli @@ -27,8 +27,6 @@ type to_update type tag = int -val accu_tag : tag - val type_atom_tag : tag val max_atom_tag : tag val proj_tag : tag @@ -181,7 +179,6 @@ val rec_args : vfix -> int array val first_fix : vfix -> vfix val fix_types : vfix -> tcode array val cofix_types : vcofix -> tcode array -external offset_closure_fix : vfix -> int -> vm_env = "coq_offset_closure" val mk_fix_body : int -> int -> vfix -> vfun array (** CoFix *) diff --git a/lib/acyclicGraph.ml b/lib/acyclicGraph.ml index dc5241b89e..8da09dc98a 100644 --- a/lib/acyclicGraph.ml +++ b/lib/acyclicGraph.ml @@ -356,39 +356,37 @@ module Make (Point:Point) = struct let get_new_edges g to_merge = (* Computing edge sets. *) - let to_merge_lvl = - List.fold_left (fun acc u -> PMap.add u.canon u acc) - PMap.empty to_merge - in let ltle = - let fold _ n acc = + let fold acc n = let fold u strict acc = - if strict then PMap.add u strict acc - else if PMap.mem u acc then acc - else PMap.add u false acc + match PMap.find u acc with + | true -> acc + | false -> if strict then PMap.add u true acc else acc + | exception Not_found -> PMap.add u strict acc in PMap.fold fold n.ltle acc in - PMap.fold fold to_merge_lvl PMap.empty + match to_merge with + | [] -> assert false + | hd :: tl -> List.fold_left fold hd.ltle tl in let ltle, _ = clean_ltle g ltle in - let ltle = - PMap.merge (fun _ a strict -> - match a, strict with - | Some _, Some true -> - (* There is a lt edge inside the new component. This is a - "bad cycle". *) - raise CycleDetected - | Some _, Some false -> None - | _, _ -> strict - ) to_merge_lvl ltle + let fold accu a = + match PMap.find a.canon ltle with + | true -> + (* There is a lt edge inside the new component. This is a + "bad cycle". *) + raise CycleDetected + | false -> PMap.remove a.canon accu + | exception Not_found -> accu in + let ltle = List.fold_left fold ltle to_merge in let gtge = - PMap.fold (fun _ n acc -> PSet.union acc n.gtge) - to_merge_lvl PSet.empty + List.fold_left (fun acc n -> PSet.union acc n.gtge) + PSet.empty to_merge in let gtge, _ = clean_gtge g gtge in - let gtge = PSet.diff gtge (PMap.domain to_merge_lvl) in + let gtge = List.fold_left (fun acc n -> PSet.remove n.canon acc) gtge to_merge in (ltle, gtge) diff --git a/lib/explore.ml b/lib/explore.ml index b3ffef6ac2..139de488e2 100644 --- a/lib/explore.ml +++ b/lib/explore.ml @@ -29,7 +29,7 @@ module Make = functor(S : SearchProblem) -> struct | [i] -> int i | i :: l -> pp_rec l ++ str "." ++ int i in - Feedback.msg_debug (h 0 (pp_rec p) ++ pp) + Feedback.msg_debug (h (pp_rec p) ++ pp) (*s Depth first search. *) @@ -22,7 +22,7 @@ type pp_tag = string type block_type = - | Pp_hbox of int + | Pp_hbox | Pp_vbox of int | Pp_hvbox of int | Pp_hovbox of int @@ -131,7 +131,7 @@ let strbrk s = let ismt = function | Ppcmd_empty -> true | _ -> false (* boxing commands *) -let h n s = Ppcmd_box(Pp_hbox n,s) +let h s = Ppcmd_box(Pp_hbox,s) let v n s = Ppcmd_box(Pp_vbox n,s) let hv n s = Ppcmd_box(Pp_hvbox n,s) let hov n s = Ppcmd_box(Pp_hovbox n,s) @@ -151,7 +151,7 @@ let escape_string s = let qstring s = str "\"" ++ str (escape_string s) ++ str "\"" let qs = qstring -let quote s = h 0 (str "\"" ++ s ++ str "\"") +let quote s = h (str "\"" ++ s ++ str "\"") let rec pr_com ft s = let (s1,os) = @@ -181,7 +181,7 @@ let split_tag tag = (* pretty printing functions *) let pp_with ft pp = let cpp_open_box = function - | Pp_hbox n -> Format.pp_open_hbox ft () + | Pp_hbox -> Format.pp_open_hbox ft () | Pp_vbox n -> Format.pp_open_vbox ft n | Pp_hvbox n -> Format.pp_open_hvbox ft n | Pp_hovbox n -> Format.pp_open_hovbox ft n @@ -309,12 +309,14 @@ let db_print_pp fmt pp = let block_type fmt btype = let (bt, v) = match btype with - | Pp_hbox v -> ("Pp_hbox", v) - | Pp_vbox v -> ("Pp_vbox", v) - | Pp_hvbox v -> ("Pp_hvbox", v) - | Pp_hovbox v -> ("Pp_hovbox", v) + | Pp_hbox -> ("Pp_hbox", None) + | Pp_vbox v -> ("Pp_vbox", Some v) + | Pp_hvbox v -> ("Pp_hvbox", Some v) + | Pp_hovbox v -> ("Pp_hovbox", Some v) in - fprintf fmt "%s %d" bt v + match v with + | None -> fprintf fmt "%s" bt + | Some v -> fprintf fmt "%s %d" bt v in let rec db_print_pp_r indent pp = let ind () = fprintf fmt "%s" (String.make (2 * indent) ' ') in diff --git a/lib/pp.mli b/lib/pp.mli index b265537728..12f1ba9bb2 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -43,7 +43,7 @@ type pp_tag = string type t type block_type = - | Pp_hbox of int + | Pp_hbox | Pp_vbox of int | Pp_hvbox of int | Pp_hovbox of int @@ -99,7 +99,7 @@ val strbrk : string -> t (** {6 Boxing commands} *) -val h : int -> t -> t +val h : t -> t val v : int -> t -> t val hv : int -> t -> t val hov : int -> t -> t 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..f485970eec 100644 --- a/parsing/cLexer.ml +++ b/parsing/cLexer.ml @@ -512,6 +512,12 @@ and progress_utf8 loc last nj n c tt cs = and progress_from_byte loc last nj tt cs c = progress_utf8 loc last nj (utf8_char_size loc cs c) c tt cs +let blank_or_eof cs = + match Stream.peek cs with + | None -> true + | Some (' ' | '\t' | '\n' |'\r') -> true + | _ -> false + type marker = Delimited of int * char list * char list | ImmediateAsciiIdent let peek_marker_len b e s = @@ -542,6 +548,11 @@ let parse_quotation loc bp s = in get_buff len, set_loc_pos loc bp (Stream.count s) | Delimited (lenmarker, bmarker, emarker) -> + let dot_gobbling = + (* only quotations starting with two curly braces can gobble sentences *) + match bmarker with + | '{' :: '{' :: _ -> true + | _ -> false in let b = Buffer.create 80 in let commit1 c = Buffer.add_char b c; Stream.junk s in let commit l = List.iter commit1 l in @@ -557,6 +568,10 @@ let parse_quotation loc bp s = commit1 '\n'; let loc = bump_loc_line_last loc (Stream.count s) in quotation loc depth + | '.' :: _ -> + commit1 '.'; + if not dot_gobbling && blank_or_eof s then raise Stream.Failure; + quotation loc depth | c :: cs -> commit1 c; quotation loc depth @@ -565,8 +580,26 @@ let parse_quotation loc bp s = let loc = quotation loc 0 in Buffer.contents b, set_loc_pos loc bp (Stream.count s) +let peek_string v s = + let l = String.length v in + let rec aux i = + if Int.equal i l then true + else + let l' = Stream.npeek (i + 1) s in + match List.nth l' i with + | c -> Char.equal c v.[i] && aux (i + 1) + | exception _ -> false (* EOF *) in + aux 0 let find_keyword loc id bp s = + if peek_string ":{{" s then + begin + (* "xxx:{{" always starts a sentence-gobbling quotation, whether registered or not *) + Stream.junk s; + let txt, loc = parse_quotation loc bp s in + QUOTATION (id ^ ":", txt), loc + end + else let tt = ttree_find !token_tree id in match progress_further loc tt.node 0 tt s with | None -> raise Not_found @@ -645,12 +678,6 @@ let parse_after_qmark ~diff_mode loc bp s = | AsciiChar | Utf8Token _ | EmptyStream -> fst (process_chars ~diff_mode loc bp '?' s) -let blank_or_eof cs = - match Stream.peek cs with - | None -> true - | Some (' ' | '\t' | '\n' |'\r') -> true - | _ -> false - (* Parse a token in a char stream *) let rec next_token ~diff_mode loc s = @@ -710,7 +737,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 +823,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 +918,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..723f08413e 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 = @@ -202,6 +202,7 @@ let parse_string f ?loc x = let strm = Stream.of_string x in Entry.parse f (Parsable.make ?loc strm) +(* universes not used by Coq build but still used by some plugins *) type gram_universe = string let utables : (string, unit) Hashtbl.t = @@ -211,21 +212,18 @@ let create_universe u = let () = Hashtbl.add utables u () in u -let uprim = create_universe "prim" -let uconstr = create_universe "constr" -let utactic = create_universe "tactic" +let uprim = create_universe "prim" [@@deprecated "Deprecated in 8.13"] +let uconstr = create_universe "constr" [@@deprecated "Deprecated in 8.13"] +let utactic = create_universe "tactic" [@@deprecated "Deprecated in 8.13"] let get_univ u = if Hashtbl.mem utables u then u else raise Not_found -let new_entry u s = - let ename = u ^ ":" ^ s in - let e = Entry.make ename in +let new_entry _ s = + let e = Entry.make s in e -let make_gen_entry u s = new_entry u s - module GrammarObj = struct type ('r, _, _) obj = 'r Entry.t @@ -251,52 +249,54 @@ let genarg_grammar x = check_compatibility x; Grammar.obj x -let create_generic_entry (type a) u s (etyp : a raw_abstract_argument_type) : a Entry.t = - let e = new_entry u s in +let create_generic_entry2 (type a) s (etyp : a raw_abstract_argument_type) : a Entry.t = + let e = Entry.create s in let Rawwit t = etyp in let () = Grammar.register0 t e in e +let create_generic_entry (type a) _ s (etyp : a raw_abstract_argument_type) : a Entry.t = + create_generic_entry2 s etyp + (* Initial grammar entries *) module Prim = struct - let gec_gen n = make_gen_entry uprim n (* Entries that can be referred via the string -> Entry.t table *) (* Typically for tactic or vernac extensions *) - let preident = gec_gen "preident" - let ident = gec_gen "ident" - let natural = gec_gen "natural" - let integer = gec_gen "integer" - let bignat = Entry.create "Prim.bignat" - let bigint = Entry.create "Prim.bigint" - let string = gec_gen "string" - let lstring = Entry.create "Prim.lstring" - let reference = make_gen_entry uprim "reference" + let preident = Entry.create "preident" + let ident = Entry.create "ident" + let natural = Entry.create "natural" + let integer = Entry.create "integer" + let bignat = Entry.create "bignat" + let bigint = Entry.create "bigint" + let string = Entry.create "string" + let lstring = Entry.create "lstring" + let reference = Entry.create "reference" let by_notation = Entry.create "by_notation" let smart_global = Entry.create "smart_global" - let strategy_level = gec_gen "strategy_level" + let strategy_level = Entry.create "strategy_level" (* parsed like ident but interpreted as a term *) - let var = gec_gen "var" + let var = Entry.create "var" - let name = Entry.create "Prim.name" - let identref = Entry.create "Prim.identref" - let univ_decl = Entry.create "Prim.univ_decl" - let ident_decl = Entry.create "Prim.ident_decl" + let name = Entry.create "name" + let identref = Entry.create "identref" + let univ_decl = Entry.create "univ_decl" + let ident_decl = Entry.create "ident_decl" let pattern_ident = Entry.create "pattern_ident" let pattern_identref = Entry.create "pattern_identref" (* A synonym of ident - maybe ident will be located one day *) - let base_ident = Entry.create "Prim.base_ident" + let base_ident = Entry.create "base_ident" - let qualid = Entry.create "Prim.qualid" - let fullyqualid = Entry.create "Prim.fullyqualid" - let dirpath = Entry.create "Prim.dirpath" + let qualid = Entry.create "qualid" + let fullyqualid = Entry.create "fullyqualid" + let dirpath = Entry.create "dirpath" - let ne_string = Entry.create "Prim.ne_string" - let ne_lstring = Entry.create "Prim.ne_lstring" + let ne_string = Entry.create "ne_string" + let ne_lstring = Entry.create "ne_lstring" let bar_cbrace = Entry.create "'|}'" @@ -304,32 +304,31 @@ module Prim = module Constr = struct - let gec_constr = make_gen_entry uconstr (* Entries that can be referred via the string -> Entry.t table *) - let constr = gec_constr "constr" - let operconstr = gec_constr "operconstr" + let constr = Entry.create "constr" + let operconstr = Entry.create "operconstr" let constr_eoi = eoi_entry constr - let lconstr = gec_constr "lconstr" - let binder_constr = gec_constr "binder_constr" - let ident = make_gen_entry uconstr "ident" - let global = make_gen_entry uconstr "global" - let universe_name = make_gen_entry uconstr "universe_name" - let universe_level = make_gen_entry uconstr "universe_level" - let sort = make_gen_entry uconstr "sort" - let sort_family = make_gen_entry uconstr "sort_family" - let pattern = Entry.create "constr:pattern" - let constr_pattern = gec_constr "constr_pattern" - let lconstr_pattern = gec_constr "lconstr_pattern" - let closed_binder = Entry.create "constr:closed_binder" - let binder = Entry.create "constr:binder" - let binders = Entry.create "constr:binders" - let open_binders = Entry.create "constr:open_binders" - let binders_fixannot = Entry.create "constr:binders_fixannot" - let typeclass_constraint = Entry.create "constr:typeclass_constraint" - let record_declaration = Entry.create "constr:record_declaration" - let appl_arg = Entry.create "constr:appl_arg" - let type_cstr = Entry.create "constr:type_cstr" + let lconstr = Entry.create "lconstr" + let binder_constr = Entry.create "binder_constr" + let ident = Entry.create "ident" + let global = Entry.create "global" + let universe_name = Entry.create "universe_name" + let universe_level = Entry.create "universe_level" + let sort = Entry.create "sort" + let sort_family = Entry.create "sort_family" + let pattern = Entry.create "pattern" + let constr_pattern = Entry.create "constr_pattern" + let lconstr_pattern = Entry.create "lconstr_pattern" + let closed_binder = Entry.create "closed_binder" + let binder = Entry.create "binder" + let binders = Entry.create "binders" + let open_binders = Entry.create "open_binders" + let binders_fixannot = Entry.create "binders_fixannot" + let typeclass_constraint = Entry.create "typeclass_constraint" + let record_declaration = Entry.create "record_declaration" + let appl_arg = Entry.create "appl_arg" + let type_cstr = Entry.create "type_cstr" end module Module = @@ -500,6 +499,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/pcoq.mli b/parsing/pcoq.mli index bd64d21518..ae9a7423c2 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -123,24 +123,29 @@ val parse_string : 'a Entry.t -> ?loc:Loc.t -> string -> 'a val eoi_entry : 'a Entry.t -> 'a Entry.t val map_entry : ('a -> 'b) -> 'a Entry.t -> 'b Entry.t -type gram_universe +type gram_universe [@@deprecated "Deprecated in 8.13"] +[@@@ocaml.warning "-3"] +val get_univ : string -> gram_universe [@@deprecated "Deprecated in 8.13"] +val create_universe : string -> gram_universe [@@deprecated "Deprecated in 8.13"] -val get_univ : string -> gram_universe -val create_universe : string -> gram_universe +val new_entry : gram_universe -> string -> 'a Entry.t [@@deprecated "Deprecated in 8.13"] -val new_entry : gram_universe -> string -> 'a Entry.t +val uprim : gram_universe [@@deprecated "Deprecated in 8.13"] +val uconstr : gram_universe [@@deprecated "Deprecated in 8.13"] +val utactic : gram_universe [@@deprecated "Deprecated in 8.13"] -val uprim : gram_universe -val uconstr : gram_universe -val utactic : gram_universe +val create_generic_entry : gram_universe -> string -> + ('a, rlevel) abstract_argument_type -> 'a Entry.t + [@@deprecated "Deprecated in 8.13. Use create_generic_entry2 instead."] +[@@@ocaml.warning "+3"] + +val create_generic_entry2 : string -> + ('a, rlevel) abstract_argument_type -> 'a Entry.t val register_grammar : ('raw, 'glb, 'top) genarg_type -> 'raw Entry.t -> unit val genarg_grammar : ('raw, 'glb, 'top) genarg_type -> 'raw Entry.t -val create_generic_entry : gram_universe -> string -> - ('a, rlevel) abstract_argument_type -> 'a Entry.t - module Prim : sig open Names diff --git a/parsing/ppextend.ml b/parsing/ppextend.ml index fe6e8360c1..aab385a707 100644 --- a/parsing/ppextend.ml +++ b/parsing/ppextend.ml @@ -17,7 +17,7 @@ open Constrexpr (*s Pretty-print. *) type ppbox = - | PpHB of int + | PpHB | PpHOVB of int | PpHVB of int | PpVB of int @@ -27,7 +27,7 @@ type ppcut = | PpFnl let ppcmd_of_box = function - | PpHB n -> h n + | PpHB -> h | PpHOVB n -> hov n | PpHVB n -> hv n | PpVB n -> v n diff --git a/parsing/ppextend.mli b/parsing/ppextend.mli index ee8180c7aa..56a3fc8e3c 100644 --- a/parsing/ppextend.mli +++ b/parsing/ppextend.mli @@ -13,7 +13,7 @@ open Constrexpr (** {6 Pretty-print. } *) type ppbox = - | PpHB of int + | PpHB | PpHOVB of int | PpHVB of int | PpVB of int 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/g_extraction.mlg b/plugins/extraction/g_extraction.mlg index 094f87f154..da7ed7be64 100644 --- a/plugins/extraction/g_extraction.mlg +++ b/plugins/extraction/g_extraction.mlg @@ -60,16 +60,10 @@ let pr_language = function | Scheme -> str "Scheme" | JSON -> str "JSON" -let warn_deprecated_ocaml_spelling = - CWarnings.create ~name:"deprecated-ocaml-spelling" ~category:"deprecated" - (fun () -> - strbrk ("The spelling \"OCaml\" should be used instead of \"Ocaml\".")) - } VERNAC ARGUMENT EXTEND language PRINTED BY { pr_language } -| [ "Ocaml" ] -> { let _ = warn_deprecated_ocaml_spelling () in Ocaml } | [ "OCaml" ] -> { Ocaml } | [ "Haskell" ] -> { Haskell } | [ "Scheme" ] -> { Scheme } 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/extraction/scheme.ml b/plugins/extraction/scheme.ml index ee50476b10..f671860bd5 100644 --- a/plugins/extraction/scheme.ml +++ b/plugins/extraction/scheme.ml @@ -28,7 +28,7 @@ let keywords = "error"; "delay"; "force"; "_"; "__"] Id.Set.empty -let pp_comment s = str";; "++h 0 s++fnl () +let pp_comment s = str ";; " ++ h s ++ fnl () let pp_header_comment = function | None -> mt () diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 743afe4177..e50c6087bb 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -1,3 +1,13 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + open Printer open CErrors open Util @@ -8,9 +18,7 @@ open Vars open Namegen open Names open Pp -open Tacmach open Termops -open Tacticals open Tactics open Indfun_common open Libnames @@ -27,7 +35,7 @@ let make_refl_eq constructor type_of_t t = mkApp (constructor, [|type_of_t; t|]) type pte_info = - {proving_tac : Id.t list -> Tacmach.tactic; is_valid : constr -> bool} + {proving_tac : Id.t list -> unit Proofview.tactic; is_valid : constr -> bool} type ptes_info = pte_info Id.Map.t @@ -36,16 +44,12 @@ type 'a dynamic_info = type body_info = constr dynamic_info -let observe_tac s = observe_tac (fun _ _ -> Pp.str s) - -let finish_proof dynamic_infos g = - observe_tac "finish" (Proofview.V82.of_tactic assumption) g +let observe_tac s = + New.observe_tac ~header:(str "observation") (fun _ _ -> Pp.str s) -let refine c = - Proofview.V82.of_tactic - (Logic.refiner ~check:true EConstr.Unsafe.(to_constr c)) - -let thin l = Proofview.V82.of_tactic (Tactics.clear l) +let finish_proof dynamic_infos = observe_tac "finish" assumption +let refine c = Logic.refiner ~check:true EConstr.Unsafe.(to_constr c) +let thin = clear let eq_constr sigma u v = EConstr.eq_constr_nounivs sigma u v let is_trivial_eq sigma t = @@ -83,37 +87,42 @@ let is_incompatible_eq env sigma t = if res then observe (str "is_incompatible_eq " ++ pr_leconstr_env env sigma t); res -let change_hyp_with_using msg hyp_id t tac : tactic = - fun g -> - let prov_id = pf_get_new_id hyp_id g in - tclTHENS - ((* observe_tac msg *) Proofview.V82.of_tactic - (assert_by (Name prov_id) t (Proofview.V82.tactic (tclCOMPLETE tac)))) - [ tclTHENLIST - [ (* observe_tac "change_hyp_with_using thin" *) - thin [hyp_id] - ; (* observe_tac "change_hyp_with_using rename " *) - Proofview.V82.of_tactic (rename_hyp [(prov_id, hyp_id)]) ] ] - g +let pf_get_new_id id env = + next_ident_away id (Id.Set.of_list (Termops.ids_of_named_context env)) + +let change_hyp_with_using msg hyp_id t tac = + Proofview.Goal.enter (fun gl -> + let prov_id = pf_get_new_id hyp_id (Proofview.Goal.hyps gl) in + Tacticals.New.tclTHENS + ((* observe_tac msg *) + assert_by (Name prov_id) t + (Tacticals.New.tclCOMPLETE tac)) + [ Tacticals.New.tclTHENLIST + [ (* observe_tac "change_hyp_with_using thin" *) + Tactics.clear [hyp_id] + ; (* observe_tac "change_hyp_with_using rename " *) + rename_hyp [(prov_id, hyp_id)] ] ]) exception TOREMOVE let prove_trivial_eq h_id context (constructor, type_of_term, term) = let nb_intros = List.length context in - tclTHENLIST - [ tclDO nb_intros (Proofview.V82.of_tactic intro) + Tacticals.New.tclTHENLIST + [ Tacticals.New.tclDO nb_intros intro ; (* introducing context *) - (fun g -> - let context_hyps = - fst - (list_chop ~msg:"prove_trivial_eq : " nb_intros (pf_ids_of_hyps g)) - in - let context_hyps' = - mkApp (constructor, [|type_of_term; term|]) - :: List.map mkVar context_hyps - in - let to_refine = applist (mkVar h_id, List.rev context_hyps') in - refine to_refine g) ] + Proofview.Goal.enter (fun g -> + let hyps = Proofview.Goal.hyps g in + let context_hyps = + fst + (list_chop ~msg:"prove_trivial_eq : " nb_intros + (ids_of_named_context hyps)) + in + let context_hyps' = + mkApp (constructor, [|type_of_term; term|]) + :: List.map mkVar context_hyps + in + let to_refine = applist (mkVar h_id, List.rev context_hyps') in + refine to_refine) ] let find_rectype env sigma c = let t, l = decompose_app sigma (Reductionops.whd_betaiotazeta env sigma c) in @@ -255,13 +264,11 @@ let change_eq env sigma hyp_id (context : rel_context) x t end_of_type = Typing.type_of (Proofview.Goal.env g) (Proofview.Goal.sigma g) to_refine in - tclTHEN - (Proofview.Unsafe.tclEVARS evm) - (Proofview.V82.tactic (refine to_refine)))) + tclTHEN (Proofview.Unsafe.tclEVARS evm) (refine to_refine))) in let simpl_eq_tac = change_hyp_with_using "prove_pattern_simplification" hyp_id new_type_of_hyp - (Proofview.V82.of_tactic prove_new_hyp) + prove_new_hyp in (* observe (str "In " ++ Ppconstr.pr_id hyp_id ++ *) (* str "removing an equation " ++ fnl ()++ *) @@ -294,30 +301,30 @@ let isLetIn sigma t = match EConstr.kind sigma t with LetIn _ -> true | _ -> false let h_reduce_with_zeta cl = - Proofview.V82.of_tactic - (reduce - (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false}) - cl) + reduce (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false}) cl -let rewrite_until_var arg_num eq_ids : tactic = +let rewrite_until_var arg_num eq_ids : unit Proofview.tactic = + let open Tacticals.New in (* tests if the declares recursive argument is neither a Constructor nor an applied Constructor since such a form for the recursive argument will break the Guard when trying to save the Lemma. *) let test_var g = - let sigma = project g in - let _, args = destApp sigma (pf_concl g) in + let sigma = Proofview.Goal.sigma g in + let _, args = destApp sigma (Proofview.Goal.concl g) in not (isConstruct sigma args.(arg_num) || isAppConstruct sigma args.(arg_num)) in - let rec do_rewrite eq_ids g = - if test_var g then tclIDTAC g - else - match eq_ids with - | [] -> anomaly (Pp.str "Cannot find a way to prove recursive property.") - | eq_id :: eq_ids -> - tclTHEN - (tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar eq_id)))) - (do_rewrite eq_ids) g + let rec do_rewrite eq_ids = + Proofview.Goal.enter (fun g -> + if test_var g then Proofview.tclUNIT () + else + match eq_ids with + | [] -> + anomaly (Pp.str "Cannot find a way to prove recursive property.") + | eq_id :: eq_ids -> + tclTHEN + (tclTRY (Equality.rewriteRL (mkVar eq_id))) + (do_rewrite eq_ids)) in do_rewrite eq_ids @@ -336,7 +343,8 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = EConstr.of_constr (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.True.I") in - let rec scan_type context type_of_hyp : tactic = + let open Tacticals.New in + let rec scan_type context type_of_hyp : unit Proofview.tactic = if isLetIn sigma type_of_hyp then let real_type_of_hyp = it_mkProd_or_LetIn type_of_hyp context in let reduced_type_of_hyp = @@ -362,28 +370,27 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = let prove_new_type_of_hyp = let context_length = List.length context in tclTHENLIST - [ tclDO context_length (Proofview.V82.of_tactic intro) - ; (fun g -> - let context_hyps_ids = - fst - (list_chop ~msg:"rec hyp : context_hyps" context_length - (pf_ids_of_hyps g)) - in - let rec_pte_id = pf_get_new_id rec_pte_id g in - let to_refine = - applist - ( mkVar hyp_id - , List.rev_map mkVar (rec_pte_id :: context_hyps_ids) ) - in - (* observe_tac "rec hyp " *) - (tclTHENS - (Proofview.V82.of_tactic - (assert_before (Name rec_pte_id) t_x)) - [ (* observe_tac "prove rec hyp" *) - prove_rec_hyp eq_hyps - ; (* observe_tac "prove rec hyp" *) - refine to_refine ]) - g) ] + [ tclDO context_length intro + ; Proofview.Goal.enter (fun g -> + let hyps = Proofview.Goal.hyps g in + let context_hyps_ids = + fst + (list_chop ~msg:"rec hyp : context_hyps" context_length + (ids_of_named_context hyps)) + in + let rec_pte_id = pf_get_new_id rec_pte_id hyps in + let to_refine = + applist + ( mkVar hyp_id + , List.rev_map mkVar (rec_pte_id :: context_hyps_ids) ) + in + (* observe_tac "rec hyp " *) + tclTHENS + (assert_before (Name rec_pte_id) t_x) + [ (* observe_tac "prove rec hyp" *) + prove_rec_hyp eq_hyps + ; (* observe_tac "prove rec hyp" *) + refine to_refine ]) ] in tclTHENLIST [ (* observe_tac "hyp rec" *) @@ -408,19 +415,20 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = let prove_trivial = let nb_intro = List.length context in tclTHENLIST - [ tclDO nb_intro (Proofview.V82.of_tactic intro) - ; (fun g -> - let context_hyps = - fst - (list_chop ~msg:"removing True : context_hyps " nb_intro - (pf_ids_of_hyps g)) - in - let to_refine = - applist - ( mkVar hyp_id - , List.rev (coq_I :: List.map mkVar context_hyps) ) - in - refine to_refine g) ] + [ tclDO nb_intro intro + ; Proofview.Goal.enter (fun g -> + let hyps = Proofview.Goal.hyps g in + let context_hyps = + fst + (list_chop ~msg:"removing True : context_hyps " nb_intro + (ids_of_named_context hyps)) + in + let to_refine = + applist + ( mkVar hyp_id + , List.rev (coq_I :: List.map mkVar context_hyps) ) + in + refine to_refine) ] in tclTHENLIST [ change_hyp_with_using "prove_trivial" hyp_id real_type_of_hyp @@ -455,100 +463,103 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = try (scan_type [] (Typing.type_of_variable env hyp_id), [hyp_id]) with TOREMOVE -> (thin [hyp_id], []) -let clean_goal_with_heq ptes_infos continue_tac (dyn_infos : body_info) g = - let env = pf_env g and sigma = project g in - let tac, new_hyps = - List.fold_left - (fun (hyps_tac, new_hyps) hyp_id -> - let hyp_tac, new_hyp = - clean_hyp_with_heq ptes_infos dyn_infos.eq_hyps hyp_id env sigma - in - (tclTHEN hyp_tac hyps_tac, new_hyp @ new_hyps)) - (tclIDTAC, []) dyn_infos.rec_hyps - in - let new_infos = - {dyn_infos with rec_hyps = new_hyps; nb_rec_hyps = List.length new_hyps} - in - tclTHENLIST - [tac; (* observe_tac "clean_hyp_with_heq continue" *) continue_tac new_infos] - g +let clean_goal_with_heq ptes_infos continue_tac (dyn_infos : body_info) = + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + let env = Proofview.Goal.env g in + let sigma = Proofview.Goal.sigma g in + let tac, new_hyps = + List.fold_left + (fun (hyps_tac, new_hyps) hyp_id -> + let hyp_tac, new_hyp = + clean_hyp_with_heq ptes_infos dyn_infos.eq_hyps hyp_id env sigma + in + (tclTHEN hyp_tac hyps_tac, new_hyp @ new_hyps)) + (tclIDTAC, []) dyn_infos.rec_hyps + in + let new_infos = + {dyn_infos with rec_hyps = new_hyps; nb_rec_hyps = List.length new_hyps} + in + tclTHENLIST + [ tac + ; (* observe_tac "clean_hyp_with_heq continue" *) + continue_tac new_infos ]) let heq_id = Id.of_string "Heq" -let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos g = - let nb_first_intro = nb_prod - 1 - dyn_infos.nb_rec_hyps in - tclTHENLIST - [ (* We first introduce the variables *) - tclDO nb_first_intro - (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) - ; onLastHypId (fun heq_id -> - tclTHENLIST - [ (* Then the new hypothesis *) - tclMAP - (fun id -> Proofview.V82.of_tactic (introduction id)) - dyn_infos.rec_hyps - ; observe_tac "after_introduction" (fun g' -> - (* We get infos on the equations introduced*) - let new_term_value_eq = pf_get_hyp_typ g' heq_id in - (* compute the new value of the body *) - let new_term_value = - match EConstr.kind (project g') new_term_value_eq with - | App (f, [|_; _; args2|]) -> args2 - | _ -> - observe - ( str "cannot compute new term value : " - ++ pr_gls g' ++ fnl () ++ str "last hyp is" - ++ pr_leconstr_env (pf_env g') (project g') - new_term_value_eq ); - anomaly (Pp.str "cannot compute new term value.") - in - let g', termtyp = tac_type_of g' term in - let fun_body = - mkLambda - ( make_annot Anonymous Sorts.Relevant - , termtyp - , Termops.replace_term (project g') term (mkRel 1) - dyn_infos.info ) - in - let new_body = - pf_nf_betaiota g' (mkApp (fun_body, [|new_term_value|])) - in - let new_infos = - { dyn_infos with - info = new_body - ; eq_hyps = heq_id :: dyn_infos.eq_hyps } - in - clean_goal_with_heq ptes_infos continue_tac new_infos g') ]) - ] - g - -let my_orelse tac1 tac2 g = - try tac1 g - with e when CErrors.noncritical e -> - (* observe (str "using snd tac since : " ++ CErrors.print e); *) - tac2 g +let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + let nb_first_intro = nb_prod - 1 - dyn_infos.nb_rec_hyps in + tclTHENLIST + [ (* We first introduce the variables *) + tclDO nb_first_intro + (intro_avoiding (Id.Set.of_list dyn_infos.rec_hyps)) + ; (* Then the equation itself *) + intro_using_then heq_id + (* we get the fresh name with onLastHypId *) + (fun _ -> Proofview.tclUNIT ()) + ; onLastHypId (fun heq_id -> + tclTHENLIST + [ (* Then the new hypothesis *) + tclMAP introduction dyn_infos.rec_hyps + ; observe_tac "after_introduction" + (Proofview.Goal.enter (fun g' -> + let env = Proofview.Goal.env g' in + let sigma = Proofview.Goal.sigma g' in + (* We get infos on the equations introduced*) + let new_term_value_eq = + Tacmach.New.pf_get_hyp_typ heq_id g' + in + (* compute the new value of the body *) + let new_term_value = + match EConstr.kind sigma new_term_value_eq with + | App (f, [|_; _; args2|]) -> args2 + | _ -> + observe + ( str "cannot compute new term value : " + ++ Tacmach.New.pr_gls g' ++ fnl () + ++ str "last hyp is" + ++ pr_leconstr_env env sigma new_term_value_eq ); + anomaly (Pp.str "cannot compute new term value.") + in + tclTYPEOFTHEN term (fun sigma termtyp -> + let fun_body = + mkLambda + ( make_annot Anonymous Sorts.Relevant + , termtyp + , Termops.replace_term sigma term (mkRel 1) + dyn_infos.info ) + in + let new_body = + Reductionops.nf_betaiota env sigma + (mkApp (fun_body, [|new_term_value|])) + in + let new_infos = + { dyn_infos with + info = new_body + ; eq_hyps = heq_id :: dyn_infos.eq_hyps } + in + clean_goal_with_heq ptes_infos continue_tac + new_infos))) ]) ]) -let instantiate_hyps_with_args (do_prove : Id.t list -> tactic) hyps args_id = +let instantiate_hyps_with_args (do_prove : Id.t list -> unit Proofview.tactic) + hyps args_id = let args = Array.of_list (List.map mkVar args_id) in + let open Tacticals.New in let instantiate_one_hyp hid = - my_orelse - (fun (* we instantiate the hyp if possible *) - g -> - let prov_hid = pf_get_new_id hid g in - let c = mkApp (mkVar hid, args) in - let evm, _ = pf_apply Typing.type_of g c in - let open Tacticals.New in - Proofview.V82.of_tactic - (tclTHENLIST - [ Proofview.Unsafe.tclEVARS evm - ; pose_proof (Name prov_hid) c - ; clear [hid] - ; rename_hyp [(prov_hid, hid)] ]) - g) - (fun (* + tclORELSE0 + (* we instantiate the hyp if possible *) + (Proofview.Goal.enter (fun g -> + let prov_hid = Tacmach.New.pf_get_new_id hid g in + let c = mkApp (mkVar hid, args) in + (* Check typing *) + tclTYPEOFTHEN c (fun _ _ -> + tclTHENLIST + [ pose_proof (Name prov_hid) c + ; thin [hid] + ; rename_hyp [(prov_hid, hid)] ]))) + (* if not then we are in a mutual function block and this hyp is a recursive hyp on an other function. @@ -556,9 +567,8 @@ let instantiate_hyps_with_args (do_prove : Id.t list -> tactic) hyps args_id = principle so that we can trash it *) - g -> - (* observe (str "Instantiation: removing hyp " ++ Ppconstr.pr_id hid); *) - thin [hid] g) + (* observe (str "Instantiation: removing hyp " ++ Ppconstr.pr_id hid); *) + (thin [hid]) in if List.is_empty args_id then tclTHENLIST @@ -568,172 +578,178 @@ let instantiate_hyps_with_args (do_prove : Id.t list -> tactic) hyps args_id = tclTHENLIST [ tclMAP (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) hyps ; tclMAP instantiate_one_hyp hyps - ; (fun g -> - let all_g_hyps_id = - List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty - in - let remaining_hyps = - List.filter (fun id -> Id.Set.mem id all_g_hyps_id) hyps - in - do_prove remaining_hyps g) ] + ; Proofview.Goal.enter (fun g -> + let all_g_hyps_id = + List.fold_right Id.Set.add + (Tacmach.New.pf_ids_of_hyps g) + Id.Set.empty + in + let remaining_hyps = + List.filter (fun id -> Id.Set.mem id all_g_hyps_id) hyps + in + do_prove remaining_hyps) ] let build_proof (interactive_proof : bool) (fnames : Constant.t list) ptes_infos - dyn_infos : tactic = - let rec build_proof_aux do_finalize dyn_infos : tactic = - fun g -> - let env = pf_env g in - let sigma = project g in - (* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*) - match EConstr.kind sigma dyn_infos.info with - | Case (ci, ct, iv, t, cb) -> - let do_finalize_t dyn_info' g = - let t = dyn_info'.info in - let dyn_infos = {dyn_info' with info = mkCase (ci, ct, iv, t, cb)} in - let g_nb_prod = nb_prod (project g) (pf_concl g) in - let g, type_of_term = tac_type_of g t in - let term_eq = make_refl_eq (Lazy.force refl_equal) type_of_term t in - tclTHENLIST - [ Proofview.V82.of_tactic - (generalize (term_eq :: List.map mkVar dyn_infos.rec_hyps)) - ; thin dyn_infos.rec_hyps - ; Proofview.V82.of_tactic - (pattern_option [(Locus.AllOccurrencesBut [1], t)] None) - ; (fun g -> - observe_tac "toto" - (tclTHENLIST - [ Proofview.V82.of_tactic (Simple.case t) - ; (fun g' -> - let g'_nb_prod = nb_prod (project g') (pf_concl g') in - let nb_instantiate_partial = g'_nb_prod - g_nb_prod in - observe_tac "treat_new_case" - (treat_new_case ptes_infos nb_instantiate_partial - (build_proof do_finalize) t dyn_infos) - g') ]) - g) ] - g - in - build_proof do_finalize_t {dyn_infos with info = t} g - | Lambda (n, t, b) -> ( - match EConstr.kind sigma (pf_concl g) with - | Prod _ -> - tclTHEN - (Proofview.V82.of_tactic intro) - (fun g' -> - let open Context.Named.Declaration in - let id = pf_last_hyp g' |> get_id in - let new_term = - pf_nf_betaiota g' (mkApp (dyn_infos.info, [|mkVar id|])) + dyn_infos : unit Proofview.tactic = + let open Tacticals.New in + let rec build_proof_aux do_finalize dyn_infos : unit Proofview.tactic = + Proofview.Goal.enter (fun g -> + let env = Proofview.Goal.env g in + let sigma = Proofview.Goal.sigma g in + (* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*) + match EConstr.kind sigma dyn_infos.info with + | Case (ci, ct, iv, t, cb) -> + let do_finalize_t dyn_info' = + Proofview.Goal.enter (fun g -> + let t = dyn_info'.info in + let dyn_infos = + {dyn_info' with info = mkCase (ci, ct, iv, t, cb)} + in + let g_nb_prod = + nb_prod (Proofview.Goal.sigma g) (Proofview.Goal.concl g) + in + tclTYPEOFTHEN t (fun _ type_of_term -> + let term_eq = + make_refl_eq (Lazy.force refl_equal) type_of_term t + in + tclTHENLIST + [ generalize (term_eq :: List.map mkVar dyn_infos.rec_hyps) + ; thin dyn_infos.rec_hyps + ; pattern_option [(Locus.AllOccurrencesBut [1], t)] None + ; observe_tac "toto" + (tclTHENLIST + [ Simple.case t + ; Proofview.Goal.enter (fun g' -> + let g'_nb_prod = + nb_prod (Proofview.Goal.sigma g') + (Proofview.Goal.concl g') + in + let nb_instantiate_partial = + g'_nb_prod - g_nb_prod + in + observe_tac "treat_new_case" + (treat_new_case ptes_infos + nb_instantiate_partial + (build_proof do_finalize) t dyn_infos)) + ]) ])) + in + build_proof do_finalize_t {dyn_infos with info = t} + | Lambda (n, t, b) -> ( + match EConstr.kind sigma (Proofview.Goal.concl g) with + | Prod _ -> + tclTHEN intro + (Proofview.Goal.enter (fun g' -> + let open Context.Named.Declaration in + let id = Tacmach.New.pf_last_hyp g' |> get_id in + let new_term = + Reductionops.nf_betaiota (Proofview.Goal.env g') + (Proofview.Goal.sigma g') + (mkApp (dyn_infos.info, [|mkVar id|])) + in + let new_infos = {dyn_infos with info = new_term} in + let do_prove new_hyps = + build_proof do_finalize + { new_infos with + rec_hyps = new_hyps + ; nb_rec_hyps = List.length new_hyps } + in + (* observe_tac "Lambda" *) + instantiate_hyps_with_args do_prove new_infos.rec_hyps [id] + (* build_proof do_finalize new_infos g' *))) + | _ -> do_finalize dyn_infos ) + | Cast (t, _, _) -> build_proof do_finalize {dyn_infos with info = t} + | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ + |Int _ | Float _ -> + do_finalize dyn_infos + | App (_, _) -> ( + let f, args = decompose_app sigma dyn_infos.info in + match EConstr.kind sigma f with + | Int _ -> user_err Pp.(str "integer cannot be applied") + | Float _ -> user_err Pp.(str "float cannot be applied") + | Array _ -> user_err Pp.(str "array cannot be applied") + | App _ -> + assert false (* we have collected all the app in decompose_app *) + | Proj _ -> assert false (*FIXME*) + | Var _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ + |Prod _ -> + let new_infos = {dyn_infos with info = (f, args)} in + build_proof_args env sigma do_finalize new_infos + | Const (c, _) when not (List.mem_f Constant.equal c fnames) -> + let new_infos = {dyn_infos with info = (f, args)} in + (* Pp.msgnl (str "proving in " ++ pr_lconstr_env (pf_env g) dyn_infos.info); *) + build_proof_args env sigma do_finalize new_infos + | Const _ -> do_finalize dyn_infos + | Lambda _ -> + let new_term = Reductionops.nf_beta env sigma dyn_infos.info in + build_proof do_finalize {dyn_infos with info = new_term} + | LetIn _ -> + let new_infos = + { dyn_infos with + info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info } in - let new_infos = {dyn_infos with info = new_term} in - let do_prove new_hyps = - build_proof do_finalize - { new_infos with - rec_hyps = new_hyps - ; nb_rec_hyps = List.length new_hyps } + tclTHENLIST + [ tclMAP + (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) + dyn_infos.rec_hyps + ; h_reduce_with_zeta Locusops.onConcl + ; build_proof do_finalize new_infos ] + | Cast (b, _, _) -> build_proof do_finalize {dyn_infos with info = b} + | Case _ | Fix _ | CoFix _ -> + let new_finalize dyn_infos = + let new_infos = {dyn_infos with info = (dyn_infos.info, args)} in + build_proof_args env sigma do_finalize new_infos in - (* observe_tac "Lambda" *) - (instantiate_hyps_with_args do_prove new_infos.rec_hyps [id]) g' - (* build_proof do_finalize new_infos g' *)) - g - | _ -> do_finalize dyn_infos g ) - | Cast (t, _, _) -> build_proof do_finalize {dyn_infos with info = t} g - | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ - |Float _ -> - do_finalize dyn_infos g - | App (_, _) -> ( - let f, args = decompose_app sigma dyn_infos.info in - match EConstr.kind sigma f with - | Int _ -> user_err Pp.(str "integer cannot be applied") - | Float _ -> user_err Pp.(str "float cannot be applied") - | Array _ -> user_err Pp.(str "array cannot be applied") - | App _ -> - assert false (* we have collected all the app in decompose_app *) - | Proj _ -> assert false (*FIXME*) - | Var _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ | Prod _ - -> - let new_infos = {dyn_infos with info = (f, args)} in - build_proof_args env sigma do_finalize new_infos g - | Const (c, _) when not (List.mem_f Constant.equal c fnames) -> - let new_infos = {dyn_infos with info = (f, args)} in - (* Pp.msgnl (str "proving in " ++ pr_lconstr_env (pf_env g) dyn_infos.info); *) - build_proof_args env sigma do_finalize new_infos g - | Const _ -> do_finalize dyn_infos g - | Lambda _ -> - let new_term = Reductionops.nf_beta env sigma dyn_infos.info in - build_proof do_finalize {dyn_infos with info = new_term} g - | LetIn _ -> - let new_infos = - { dyn_infos with - info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info } - in - tclTHENLIST - [ tclMAP - (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) - dyn_infos.rec_hyps - ; h_reduce_with_zeta Locusops.onConcl - ; build_proof do_finalize new_infos ] - g - | Cast (b, _, _) -> build_proof do_finalize {dyn_infos with info = b} g - | Case _ | Fix _ | CoFix _ -> - let new_finalize dyn_infos = - let new_infos = {dyn_infos with info = (dyn_infos.info, args)} in - build_proof_args env sigma do_finalize new_infos - in - build_proof new_finalize {dyn_infos with info = f} g ) - | Fix _ | CoFix _ -> - user_err Pp.(str "Anonymous local (co)fixpoints are not handled yet") - | Proj _ -> user_err Pp.(str "Prod") - | Prod _ -> do_finalize dyn_infos g - | LetIn _ -> - let new_infos = - { dyn_infos with - info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info } - in - tclTHENLIST - [ tclMAP - (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) - dyn_infos.rec_hyps - ; h_reduce_with_zeta Locusops.onConcl - ; build_proof do_finalize new_infos ] - g - | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") - | Array _ -> CErrors.user_err Pp.(str "Arrays not handled yet") - and build_proof do_finalize dyn_infos g = + build_proof new_finalize {dyn_infos with info = f} ) + | Fix _ | CoFix _ -> + user_err Pp.(str "Anonymous local (co)fixpoints are not handled yet") + | Proj _ -> user_err Pp.(str "Prod") + | Prod _ -> do_finalize dyn_infos + | LetIn _ -> + let new_infos = + { dyn_infos with + info = Reductionops.nf_betaiotazeta env sigma dyn_infos.info } + in + tclTHENLIST + [ tclMAP + (fun hyp_id -> h_reduce_with_zeta (Locusops.onHyp hyp_id)) + dyn_infos.rec_hyps + ; h_reduce_with_zeta Locusops.onConcl + ; build_proof do_finalize new_infos ] + | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") + | Array _ -> CErrors.user_err Pp.(str "Arrays not handled yet")) + and build_proof do_finalize dyn_infos = (* observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *) - Indfun_common.observe_tac + Indfun_common.New.observe_tac ~header:(str "observation") (fun env sigma -> str "build_proof with " ++ pr_leconstr_env env sigma dyn_infos.info) (build_proof_aux do_finalize dyn_infos) - g - and build_proof_args env sigma do_finalize dyn_infos : tactic = - (* f_args' args *) - fun g -> - let f_args', args = dyn_infos.info in - let tac : tactic = - fun g -> - match args with - | [] -> do_finalize {dyn_infos with info = f_args'} g - | arg :: args -> - (* observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *) - (* fnl () ++ *) - (* pr_goal (Tacmach.sig_it g) *) - (* ); *) - let do_finalize dyn_infos = - let new_arg = dyn_infos.info in - (* tclTRYD *) - build_proof_args env sigma do_finalize - {dyn_infos with info = (mkApp (f_args', [|new_arg|]), args)} + and build_proof_args env sigma do_finalize dyn_infos : unit Proofview.tactic = + (* f_args' args *) + Proofview.Goal.enter (fun g -> + let f_args', args = dyn_infos.info in + let tac = + match args with + | [] -> do_finalize {dyn_infos with info = f_args'} + | arg :: args -> + (* observe (str "build_proof_args with arg := "++ pr_lconstr_env (pf_env g) arg++ *) + (* fnl () ++ *) + (* pr_goal (Tacmach.sig_it g) *) + (* ); *) + let do_finalize dyn_infos = + let new_arg = dyn_infos.info in + (* tclTRYD *) + build_proof_args env sigma do_finalize + {dyn_infos with info = (mkApp (f_args', [|new_arg|]), args)} + in + build_proof do_finalize {dyn_infos with info = arg} in - build_proof do_finalize {dyn_infos with info = arg} g - in - (* observe_tac "build_proof_args" *) tac g + (* observe_tac "build_proof_args" *) tac) in let do_finish_proof dyn_infos = (* tclTRYD *) clean_goal_with_heq ptes_infos finish_proof dyn_infos in (* observe_tac "build_proof" *) - fun g -> - build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos g + build_proof (clean_goal_with_heq ptes_infos do_finish_proof) dyn_infos (* Proof of principles from structural functions *) @@ -747,52 +763,59 @@ type static_fix_info = ; num_in_block : int } let prove_rec_hyp_for_struct fix_info eq_hyps = - tclTHEN (rewrite_until_var fix_info.idx eq_hyps) (fun g -> - let _, pte_args = destApp (project g) (pf_concl g) in - let rec_hyp_proof = - mkApp (mkVar fix_info.name, array_get_start pte_args) - in - refine rec_hyp_proof g) + let open Tacticals.New in + tclTHEN + (rewrite_until_var fix_info.idx eq_hyps) + (Proofview.Goal.enter (fun g -> + let _, pte_args = + destApp (Proofview.Goal.sigma g) (Proofview.Goal.concl g) + in + let rec_hyp_proof = + mkApp (mkVar fix_info.name, array_get_start pte_args) + in + refine rec_hyp_proof)) let prove_rec_hyp fix_info = {proving_tac = prove_rec_hyp_for_struct fix_info; is_valid = (fun _ -> true)} -let generalize_non_dep hyp g = - (* observe (str "rec id := " ++ Ppconstr.pr_id hyp); *) - let hyps = [hyp] in - let env = Global.env () in - let hyp_typ = pf_get_hyp_typ g hyp in - let to_revert, _ = - let open Context.Named.Declaration in - Environ.fold_named_context_reverse - (fun (clear, keep) decl -> - let decl = map_named_decl EConstr.of_constr decl in - let hyp = get_id decl in - if - Id.List.mem hyp hyps - || List.exists (Termops.occur_var_in_decl env (project g) hyp) keep - || Termops.occur_var env (project g) hyp hyp_typ - || Termops.is_section_variable hyp - (* should be dangerous *) - then (clear, decl :: keep) - else (hyp :: clear, keep)) - ~init:([], []) (pf_env g) - in - (* observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *) - tclTHEN - ((* observe_tac "h_generalize" *) Proofview.V82.of_tactic - (generalize (List.map mkVar to_revert))) - ((* observe_tac "thin" *) thin to_revert) - g +let generalize_non_dep hyp = + Proofview.Goal.enter (fun g -> + (* observe (str "rec id := " ++ Ppconstr.pr_id hyp); *) + let hyps = [hyp] in + let env = Global.env () in + let sigma = Proofview.Goal.sigma g in + let hyp_typ = Tacmach.New.pf_get_hyp_typ hyp g in + let to_revert, _ = + let open Context.Named.Declaration in + Environ.fold_named_context_reverse + (fun (clear, keep) decl -> + let decl = map_named_decl EConstr.of_constr decl in + let hyp = get_id decl in + if + Id.List.mem hyp hyps + || List.exists (Termops.occur_var_in_decl env sigma hyp) keep + || Termops.occur_var env sigma hyp hyp_typ + || Termops.is_section_variable hyp + (* should be dangerous *) + then (clear, decl :: keep) + else (hyp :: clear, keep)) + ~init:([], []) (Proofview.Goal.env g) + in + (* observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *) + Tacticals.New.tclTHEN + ((* observe_tac "h_generalize" *) + generalize (List.map mkVar to_revert)) + ((* observe_tac "thin" *) clear to_revert)) let id_of_decl = RelDecl.get_name %> Nameops.Name.get_id let var_of_decl = id_of_decl %> mkVar let revert idl = - tclTHEN (Proofview.V82.of_tactic (generalize (List.map mkVar idl))) (thin idl) + Tacticals.New.tclTHEN (generalize (List.map mkVar idl)) (clear idl) let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num = + let open Tacticals.New in (* observe (str "nb_args := " ++ str (string_of_int nb_args)); *) (* observe (str "nb_params := " ++ str (string_of_int nb_params)); *) (* observe (str "rec_args_num := " ++ str (string_of_int (rec_args_num + 1) )); *) @@ -840,16 +863,14 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num let f_id = Label.to_id (Constant.label (fst (destConst evd f))) in let prove_replacement = tclTHENLIST - [ tclDO (nb_params + rec_args_num + 1) (Proofview.V82.of_tactic intro) - ; observe_tac "" (fun g -> - let rec_id = pf_nth_hyp_id g 1 in - tclTHENLIST - [ observe_tac "generalize_non_dep in generate_equation_lemma" - (generalize_non_dep rec_id) - ; observe_tac "h_case" - (Proofview.V82.of_tactic (simplest_case (mkVar rec_id))) - ; Proofview.V82.of_tactic intros_reflexivity ] - g) ] + [ tclDO (nb_params + rec_args_num + 1) intro + ; observe_tac "" + (onNthHypId 1 (fun rec_id -> + tclTHENLIST + [ observe_tac "generalize_non_dep in generate_equation_lemma" + (generalize_non_dep rec_id) + ; observe_tac "h_case" (simplest_case (mkVar rec_id)) + ; intros_reflexivity ])) ] in (* Pp.msgnl (str "lemma type (2) " ++ Printer.pr_lconstr_env (Global.env ()) evd lemma_type); *) @@ -860,9 +881,7 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num Declare.CInfo.make ~name:(mk_equation_id f_id) ~typ:lemma_type () in let lemma = Declare.Proof.start ~cinfo ~info evd in - let lemma, _ = - Declare.Proof.by (Proofview.V82.tactic prove_replacement) lemma - in + let lemma, _ = Declare.Proof.by prove_replacement lemma in let (_ : _ list) = Declare.Proof.save_regular ~proof:lemma ~opaque:Vernacexpr.Transparent ~idopt:None @@ -870,375 +889,398 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num evd let do_replace (evd : Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num - all_funs g = - let equation_lemma = - try - let finfos = - match find_Function_infos (fst (destConst !evd f)) (*FIXME*) with - | None -> raise Not_found - | Some finfos -> finfos - in - mkConst (Option.get finfos.equation_lemma) - with (Not_found | Option.IsNone) as e -> - let f_id = Label.to_id (Constant.label (fst (destConst !evd f))) in - (*i The next call to mk_equation_id is valid since we will construct the lemma - Ensures by: obvious - i*) - let equation_lemma_id = mk_equation_id f_id in - evd := - generate_equation_lemma !evd all_funs f fun_num (List.length params) - (List.length rev_args_id) rec_arg_num; - let _ = - match e with - | Option.IsNone -> + all_funs = + Proofview.Goal.enter (fun g -> + let equation_lemma = + try let finfos = - match find_Function_infos (fst (destConst !evd f)) with + match find_Function_infos (fst (destConst !evd f)) (*FIXME*) with | None -> raise Not_found | Some finfos -> finfos in - update_Function - { finfos with - equation_lemma = - Some - ( match Nametab.locate (qualid_of_ident equation_lemma_id) with - | GlobRef.ConstRef c -> c - | _ -> CErrors.anomaly (Pp.str "Not a constant.") ) } - | _ -> () + mkConst (Option.get finfos.equation_lemma) + with (Not_found | Option.IsNone) as e -> + let f_id = Label.to_id (Constant.label (fst (destConst !evd f))) in + (*i The next call to mk_equation_id is valid since we will construct the lemma + Ensures by: obvious + i*) + let equation_lemma_id = mk_equation_id f_id in + evd := + generate_equation_lemma !evd all_funs f fun_num (List.length params) + (List.length rev_args_id) rec_arg_num; + let _ = + match e with + | Option.IsNone -> + let finfos = + match find_Function_infos (fst (destConst !evd f)) with + | None -> raise Not_found + | Some finfos -> finfos + in + update_Function + { finfos with + equation_lemma = + Some + ( match + Nametab.locate (qualid_of_ident equation_lemma_id) + with + | GlobRef.ConstRef c -> c + | _ -> CErrors.anomaly (Pp.str "Not a constant.") ) } + | _ -> () + in + (* let res = Constrintern.construct_reference (pf_hyps g) equation_lemma_id in *) + let evd', res = + Evd.fresh_global (Global.env ()) !evd + (Constrintern.locate_reference + (qualid_of_ident equation_lemma_id)) + in + evd := evd'; + let sigma, _ = + Typing.type_of ~refresh:true (Global.env ()) !evd res + in + evd := sigma; + res in - (* let res = Constrintern.construct_reference (pf_hyps g) equation_lemma_id in *) - let evd', res = - Evd.fresh_global (Global.env ()) !evd - (Constrintern.locate_reference (qualid_of_ident equation_lemma_id)) + let nb_intro_to_do = + nb_prod (Proofview.Goal.sigma g) (Proofview.Goal.concl g) in - evd := evd'; - let sigma, _ = Typing.type_of ~refresh:true (Global.env ()) !evd res in - evd := sigma; - res - in - let nb_intro_to_do = nb_prod (project g) (pf_concl g) in - tclTHEN - (tclDO nb_intro_to_do (Proofview.V82.of_tactic intro)) - (fun g' -> - let just_introduced = nLastDecls nb_intro_to_do g' in - let open Context.Named.Declaration in - let just_introduced_id = List.map get_id just_introduced in + let open Tacticals.New in tclTHEN - (Proofview.V82.of_tactic (Equality.rewriteLR equation_lemma)) - (revert just_introduced_id) - g') - g + (tclDO nb_intro_to_do intro) + (Proofview.Goal.enter (fun g' -> + let just_introduced = Tacticals.New.nLastDecls g' nb_intro_to_do in + let open Context.Named.Declaration in + let just_introduced_id = List.map get_id just_introduced in + tclTHEN + (* Hack to synchronize the goal with the global env *) + (Proofview.V82.tactic + (Proofview.V82.of_tactic (Equality.rewriteLR equation_lemma))) + (revert just_introduced_id)))) let prove_princ_for_struct (evd : Evd.evar_map ref) interactive_proof fun_num - fnames all_funs _nparams : tactic = - fun g -> - let princ_type = pf_concl g in - (* Pp.msgnl (str "princ_type " ++ Printer.pr_lconstr princ_type); *) - (* Pp.msgnl (str "all_funs "); *) - (* Array.iter (fun c -> Pp.msgnl (Printer.pr_lconstr c)) all_funs; *) - let princ_info = compute_elim_sig (project g) princ_type in - let fresh_id = - let avoid = ref (pf_ids_of_hyps g) in - fun na -> - let new_id = - match na with - | Name id -> fresh_id !avoid (Id.to_string id) - | Anonymous -> fresh_id !avoid "H" + fnames all_funs _nparams : unit Proofview.tactic = + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + let princ_type = Proofview.Goal.concl g in + let env = Proofview.Goal.env g in + let sigma = Proofview.Goal.sigma g in + (* Pp.msgnl (str "princ_type " ++ Printer.pr_lconstr princ_type); *) + (* Pp.msgnl (str "all_funs "); *) + (* Array.iter (fun c -> Pp.msgnl (Printer.pr_lconstr c)) all_funs; *) + let princ_info = compute_elim_sig sigma princ_type in + let fresh_id = + let avoid = ref (Tacmach.New.pf_ids_of_hyps g) in + fun na -> + let new_id = + match na with + | Name id -> fresh_id !avoid (Id.to_string id) + | Anonymous -> fresh_id !avoid "H" + in + avoid := new_id :: !avoid; + Name new_id in - avoid := new_id :: !avoid; - Name new_id - in - let fresh_decl = RelDecl.map_name fresh_id in - let princ_info : elim_scheme = - { princ_info with - params = List.map fresh_decl princ_info.params - ; predicates = List.map fresh_decl princ_info.predicates - ; branches = List.map fresh_decl princ_info.branches - ; args = List.map fresh_decl princ_info.args } - in - let get_body const = - match Global.body_of_constant Library.indirect_accessor const with - | Some (body, _, _) -> - let env = Global.env () in - let sigma = Evd.from_env env in - Tacred.cbv_norm_flags - (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) - env sigma (EConstr.of_constr body) - | None -> user_err Pp.(str "Cannot define a principle over an axiom ") - in - let fbody = get_body fnames.(fun_num) in - let f_ctxt, f_body = decompose_lam (project g) fbody in - let f_ctxt_length = List.length f_ctxt in - let diff_params = princ_info.nparams - f_ctxt_length in - let full_params, princ_params, fbody_with_full_params = - if diff_params > 0 then - let princ_params, full_params = list_chop diff_params princ_info.params in - ( full_params - , (* real params *) - princ_params - , (* the params of the principle which are not params of the function *) - substl (* function instantiated with real params *) - (List.map var_of_decl full_params) - f_body ) - else - let f_ctxt_other, f_ctxt_params = list_chop (-diff_params) f_ctxt in - let f_body = compose_lam f_ctxt_other f_body in - ( princ_info.params - , (* real params *) - [] - , (* all params are full params *) - substl (* function instantiated with real params *) - (List.map var_of_decl princ_info.params) - f_body ) - in - observe - ( str "full_params := " - ++ prlist_with_sep spc - (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) - full_params ); - observe - ( str "princ_params := " - ++ prlist_with_sep spc - (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) - princ_params ); - observe - ( str "fbody_with_full_params := " - ++ pr_leconstr_env (Global.env ()) !evd fbody_with_full_params ); - let all_funs_with_full_params = - Array.map - (fun f -> applist (f, List.rev_map var_of_decl full_params)) - all_funs - in - let fix_offset = List.length princ_params in - let ptes_to_fix, infos = - match EConstr.kind (project g) fbody_with_full_params with - | Fix ((idxs, i), (names, typess, bodies)) -> - let bodies_with_all_params = - Array.map - (fun body -> - Reductionops.nf_betaiota (pf_env g) (project g) - (applist - ( substl - (List.rev (Array.to_list all_funs_with_full_params)) - body - , List.rev_map var_of_decl princ_params ))) - bodies + let fresh_decl = RelDecl.map_name fresh_id in + let princ_info : elim_scheme = + { princ_info with + params = List.map fresh_decl princ_info.params + ; predicates = List.map fresh_decl princ_info.predicates + ; branches = List.map fresh_decl princ_info.branches + ; args = List.map fresh_decl princ_info.args } in - let info_array = - Array.mapi - (fun i types -> - let types = - prod_applist (project g) types - (List.rev_map var_of_decl princ_params) - in - { idx = idxs.(i) - fix_offset - ; name = Nameops.Name.get_id (fresh_id names.(i).binder_name) - ; types - ; offset = fix_offset - ; nb_realargs = - List.length (fst (decompose_lam (project g) bodies.(i))) - - fix_offset - ; body_with_param = bodies_with_all_params.(i) - ; num_in_block = i }) - typess + let get_body const = + match Global.body_of_constant Library.indirect_accessor const with + | Some (body, _, _) -> + let env = Global.env () in + let sigma = Evd.from_env env in + Tacred.cbv_norm_flags + (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) + env sigma (EConstr.of_constr body) + | None -> user_err Pp.(str "Cannot define a principle over an axiom ") in - let pte_to_fix, rev_info = - List.fold_left_i - (fun i (acc_map, acc_info) decl -> - let pte = RelDecl.get_name decl in - let infos = info_array.(i) in - let type_args, _ = decompose_prod (project g) infos.types in - let nargs = List.length type_args in - let f = - applist - (mkConst fnames.(i), List.rev_map var_of_decl princ_info.params) - in - let first_args = Array.init nargs (fun i -> mkRel (nargs - i)) in - let app_f = mkApp (f, first_args) in - let pte_args = Array.to_list first_args @ [app_f] in - let app_pte = applist (mkVar (Nameops.Name.get_id pte), pte_args) in - let body_with_param, num = - let body = get_body fnames.(i) in - let body_with_full_params = - Reductionops.nf_betaiota (pf_env g) (project g) - (applist (body, List.rev_map var_of_decl full_params)) - in - match EConstr.kind (project g) body_with_full_params with - | Fix ((_, num), (_, _, bs)) -> - ( Reductionops.nf_betaiota (pf_env g) (project g) - (applist - ( substl - (List.rev (Array.to_list all_funs_with_full_params)) - bs.(num) - , List.rev_map var_of_decl princ_params )) - , num ) - | _ -> user_err Pp.(str "Not a mutual block") - in - let info = - { infos with - types = compose_prod type_args app_pte - ; body_with_param - ; num_in_block = num } - in - (* observe (str "binding " ++ Ppconstr.pr_id (Nameops.Name.get_id pte) ++ *) - (* str " to " ++ Ppconstr.pr_id info.name); *) - (Id.Map.add (Nameops.Name.get_id pte) info acc_map, info :: acc_info)) - 0 (Id.Map.empty, []) - (List.rev princ_info.predicates) + let fbody = get_body fnames.(fun_num) in + let f_ctxt, f_body = decompose_lam sigma fbody in + let f_ctxt_length = List.length f_ctxt in + let diff_params = princ_info.nparams - f_ctxt_length in + let full_params, princ_params, fbody_with_full_params = + if diff_params > 0 then + let princ_params, full_params = + list_chop diff_params princ_info.params + in + ( full_params + , (* real params *) + princ_params + , (* the params of the principle which are not params of the function *) + substl (* function instantiated with real params *) + (List.map var_of_decl full_params) + f_body ) + else + let f_ctxt_other, f_ctxt_params = list_chop (-diff_params) f_ctxt in + let f_body = compose_lam f_ctxt_other f_body in + ( princ_info.params + , (* real params *) + [] + , (* all params are full params *) + substl (* function instantiated with real params *) + (List.map var_of_decl princ_info.params) + f_body ) in - (pte_to_fix, List.rev rev_info) - | _ -> (Id.Map.empty, []) - in - let mk_fixes : tactic = - let pre_info, infos = list_chop fun_num infos in - match (pre_info, infos) with - | _, [] -> tclIDTAC - | _, this_fix_info :: others_infos -> - let other_fix_infos = - List.map - (fun fi -> (fi.name, fi.idx + 1, fi.types)) - (pre_info @ others_infos) + observe + ( str "full_params := " + ++ prlist_with_sep spc + (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) + full_params ); + observe + ( str "princ_params := " + ++ prlist_with_sep spc + (RelDecl.get_name %> Nameops.Name.get_id %> Ppconstr.pr_id) + princ_params ); + observe + ( str "fbody_with_full_params := " + ++ pr_leconstr_env (Global.env ()) !evd fbody_with_full_params ); + let all_funs_with_full_params = + Array.map + (fun f -> applist (f, List.rev_map var_of_decl full_params)) + all_funs in - if List.is_empty other_fix_infos then - if this_fix_info.idx + 1 = 0 then tclIDTAC - (* Someone tries to defined a principle on a fully parametric definition declared as a fixpoint (strange but ....) *) - else - Indfun_common.observe_tac - (fun _ _ -> str "h_fix " ++ int (this_fix_info.idx + 1)) - (Proofview.V82.of_tactic - (fix this_fix_info.name (this_fix_info.idx + 1))) - else - Proofview.V82.of_tactic - (Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1) - other_fix_infos 0) - in - let first_tac : tactic = - (* every operations until fix creations *) - tclTHENLIST - [ observe_tac "introducing params" - (Proofview.V82.of_tactic - (intros_using (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))) - ; observe_tac "introducing branches" - (Proofview.V82.of_tactic - (intros_using (List.rev_map id_of_decl princ_info.branches))) - ; observe_tac "building fixes" mk_fixes ] - in - let intros_after_fixes : tactic = - fun gl -> - let ctxt, pte_app = decompose_prod_assum (project gl) (pf_concl gl) in - let pte, pte_args = decompose_app (project gl) pte_app in - try - let pte = - try destVar (project gl) pte - with DestKO -> anomaly (Pp.str "Property is not a variable.") + let fix_offset = List.length princ_params in + let ptes_to_fix, infos = + match EConstr.kind sigma fbody_with_full_params with + | Fix ((idxs, i), (names, typess, bodies)) -> + let bodies_with_all_params = + Array.map + (fun body -> + Reductionops.nf_betaiota env sigma + (applist + ( substl + (List.rev (Array.to_list all_funs_with_full_params)) + body + , List.rev_map var_of_decl princ_params ))) + bodies + in + let info_array = + Array.mapi + (fun i types -> + let types = + prod_applist sigma types + (List.rev_map var_of_decl princ_params) + in + { idx = idxs.(i) - fix_offset + ; name = Nameops.Name.get_id (fresh_id names.(i).binder_name) + ; types + ; offset = fix_offset + ; nb_realargs = + List.length (fst (decompose_lam sigma bodies.(i))) + - fix_offset + ; body_with_param = bodies_with_all_params.(i) + ; num_in_block = i }) + typess + in + let pte_to_fix, rev_info = + List.fold_left_i + (fun i (acc_map, acc_info) decl -> + let pte = RelDecl.get_name decl in + let infos = info_array.(i) in + let type_args, _ = decompose_prod sigma infos.types in + let nargs = List.length type_args in + let f = + applist + ( mkConst fnames.(i) + , List.rev_map var_of_decl princ_info.params ) + in + let first_args = + Array.init nargs (fun i -> mkRel (nargs - i)) + in + let app_f = mkApp (f, first_args) in + let pte_args = Array.to_list first_args @ [app_f] in + let app_pte = + applist (mkVar (Nameops.Name.get_id pte), pte_args) + in + let body_with_param, num = + let body = get_body fnames.(i) in + let body_with_full_params = + Reductionops.nf_betaiota env sigma + (applist (body, List.rev_map var_of_decl full_params)) + in + match EConstr.kind sigma body_with_full_params with + | Fix ((_, num), (_, _, bs)) -> + ( Reductionops.nf_betaiota env sigma + (applist + ( substl + (List.rev + (Array.to_list all_funs_with_full_params)) + bs.(num) + , List.rev_map var_of_decl princ_params )) + , num ) + | _ -> user_err Pp.(str "Not a mutual block") + in + let info = + { infos with + types = compose_prod type_args app_pte + ; body_with_param + ; num_in_block = num } + in + (* observe (str "binding " ++ Ppconstr.pr_id (Nameops.Name.get_id pte) ++ *) + (* str " to " ++ Ppconstr.pr_id info.name); *) + ( Id.Map.add (Nameops.Name.get_id pte) info acc_map + , info :: acc_info )) + 0 (Id.Map.empty, []) + (List.rev princ_info.predicates) + in + (pte_to_fix, List.rev rev_info) + | _ -> (Id.Map.empty, []) in - let fix_info = Id.Map.find pte ptes_to_fix in - let nb_args = fix_info.nb_realargs in - tclTHENLIST - [ (* observe_tac ("introducing args") *) - tclDO nb_args (Proofview.V82.of_tactic intro) - ; (fun g -> - (* replacement of the function by its body *) - let args = nLastDecls nb_args g in - let fix_body = fix_info.body_with_param in - (* observe (str "fix_body := "++ pr_lconstr_env (pf_env gl) fix_body); *) - let open Context.Named.Declaration in - let args_id = List.map get_id args in - let dyn_infos = - { nb_rec_hyps = -100 - ; rec_hyps = [] - ; info = - Reductionops.nf_betaiota (pf_env g) (project g) - (applist (fix_body, List.rev_map mkVar args_id)) - ; eq_hyps = [] } - in - tclTHENLIST - [ observe_tac "do_replace" - (do_replace evd full_params - (fix_info.idx + List.length princ_params) - ( args_id - @ List.map - (RelDecl.get_name %> Nameops.Name.get_id) - princ_params ) - all_funs.(fix_info.num_in_block) - fix_info.num_in_block all_funs) - ; (let do_prove = - build_proof interactive_proof (Array.to_list fnames) - (Id.Map.map prove_rec_hyp ptes_to_fix) - in - let prove_tac branches = - let dyn_infos = - { dyn_infos with - rec_hyps = branches - ; nb_rec_hyps = List.length branches } - in - observe_tac "cleaning" - (clean_goal_with_heq - (Id.Map.map prove_rec_hyp ptes_to_fix) - do_prove dyn_infos) - in - (* observe (str "branches := " ++ *) - (* prlist_with_sep spc (fun decl -> Ppconstr.pr_id (id_of_decl decl)) princ_info.branches ++ fnl () ++ *) - (* str "args := " ++ prlist_with_sep spc Ppconstr.pr_id args_id *) + let mk_fixes : unit Proofview.tactic = + let pre_info, infos = list_chop fun_num infos in + match (pre_info, infos) with + | _, [] -> Proofview.tclUNIT () + | _, this_fix_info :: others_infos -> + let other_fix_infos = + List.map + (fun fi -> (fi.name, fi.idx + 1, fi.types)) + (pre_info @ others_infos) + in + if List.is_empty other_fix_infos then + if this_fix_info.idx + 1 = 0 then Proofview.tclUNIT () + (* Someone tries to defined a principle on a fully parametric definition declared as a fixpoint (strange but ....) *) + else + Indfun_common.New.observe_tac ~header:(str "observation") + (fun _ _ -> str "h_fix " ++ int (this_fix_info.idx + 1)) + (fix this_fix_info.name (this_fix_info.idx + 1)) + else + Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1) + other_fix_infos 0 + in + let first_tac : unit Proofview.tactic = + (* every operations until fix creations *) + (* names are already refreshed *) + tclTHENLIST + [ observe_tac "introducing params" + (intros_mustbe_force (List.rev_map id_of_decl princ_info.params)) + ; observe_tac "introducing predicates" + (intros_mustbe_force + (List.rev_map id_of_decl princ_info.predicates)) + ; observe_tac "introducing branches" + (intros_mustbe_force + (List.rev_map id_of_decl princ_info.branches)) + ; observe_tac "building fixes" mk_fixes ] + in + let intros_after_fixes : unit Proofview.tactic = + Proofview.Goal.enter (fun gl -> + let sigma = Proofview.Goal.sigma gl in + let ccl = Proofview.Goal.concl gl in + let ctxt, pte_app = decompose_prod_assum sigma ccl in + let pte, pte_args = decompose_app sigma pte_app in + try + let pte = + try destVar sigma pte + with DestKO -> anomaly (Pp.str "Property is not a variable.") + in + let fix_info = Id.Map.find pte ptes_to_fix in + let nb_args = fix_info.nb_realargs in + tclTHENLIST + [ (* observe_tac ("introducing args") *) + tclDO nb_args intro + ; Proofview.Goal.enter (fun g -> + (* replacement of the function by its body *) + let args = Tacticals.New.nLastDecls g nb_args in + let fix_body = fix_info.body_with_param in + (* observe (str "fix_body := "++ pr_lconstr_env (pf_env gl) fix_body); *) + let open Context.Named.Declaration in + let args_id = List.map get_id args in + let dyn_infos = + { nb_rec_hyps = -100 + ; rec_hyps = [] + ; info = + Reductionops.nf_betaiota (Proofview.Goal.env g) + (Proofview.Goal.sigma g) + (applist (fix_body, List.rev_map mkVar args_id)) + ; eq_hyps = [] } + in + tclTHENLIST + [ observe_tac "do_replace" + (do_replace evd full_params + (fix_info.idx + List.length princ_params) + ( args_id + @ List.map + (RelDecl.get_name %> Nameops.Name.get_id) + princ_params ) + all_funs.(fix_info.num_in_block) + fix_info.num_in_block all_funs) + ; (let do_prove = + build_proof interactive_proof + (Array.to_list fnames) + (Id.Map.map prove_rec_hyp ptes_to_fix) + in + let prove_tac branches = + let dyn_infos = + { dyn_infos with + rec_hyps = branches + ; nb_rec_hyps = List.length branches } + in + observe_tac "cleaning" + (clean_goal_with_heq + (Id.Map.map prove_rec_hyp ptes_to_fix) + do_prove dyn_infos) + in + (* observe (str "branches := " ++ *) + (* prlist_with_sep spc (fun decl -> Ppconstr.pr_id (id_of_decl decl)) princ_info.branches ++ fnl () ++ *) + (* str "args := " ++ prlist_with_sep spc Ppconstr.pr_id args_id *) - (* ); *) - (* observe_tac "instancing" *) - instantiate_hyps_with_args prove_tac - (List.rev_map id_of_decl princ_info.branches) - (List.rev args_id)) ] - g) ] - gl - with Not_found -> - let nb_args = min princ_info.nargs (List.length ctxt) in - tclTHENLIST - [ tclDO nb_args (Proofview.V82.of_tactic intro) - ; (fun g -> - (* replacement of the function by its body *) - let args = nLastDecls nb_args g in - let open Context.Named.Declaration in - let args_id = List.map get_id args in - let dyn_infos = - { nb_rec_hyps = -100 - ; rec_hyps = [] - ; info = - Reductionops.nf_betaiota (pf_env g) (project g) - (applist - ( fbody_with_full_params - , List.rev_map var_of_decl princ_params - @ List.rev_map mkVar args_id )) - ; eq_hyps = [] } - in - let fname = - destConst (project g) - (fst (decompose_app (project g) (List.hd (List.rev pte_args)))) - in - tclTHENLIST - [ Proofview.V82.of_tactic - (unfold_in_concl - [(Locus.AllOccurrences, Names.EvalConstRef (fst fname))]) - ; (let do_prove = - build_proof interactive_proof (Array.to_list fnames) - (Id.Map.map prove_rec_hyp ptes_to_fix) - in - let prove_tac branches = - let dyn_infos = - { dyn_infos with - rec_hyps = branches - ; nb_rec_hyps = List.length branches } - in - clean_goal_with_heq - (Id.Map.map prove_rec_hyp ptes_to_fix) - do_prove dyn_infos - in - instantiate_hyps_with_args prove_tac - (List.rev_map id_of_decl princ_info.branches) - (List.rev args_id)) ] - g) ] - gl - in - tclTHEN first_tac intros_after_fixes g + (* ); *) + (* observe_tac "instancing" *) + instantiate_hyps_with_args prove_tac + (List.rev_map id_of_decl princ_info.branches) + (List.rev args_id)) ]) ] + with Not_found -> + let nb_args = min princ_info.nargs (List.length ctxt) in + tclTHENLIST + [ tclDO nb_args intro + ; Proofview.Goal.enter (fun g -> + let env = Proofview.Goal.env g in + let sigma = Proofview.Goal.sigma g in + (* replacement of the function by its body *) + let args = Tacticals.New.nLastDecls g nb_args in + let open Context.Named.Declaration in + let args_id = List.map get_id args in + let dyn_infos = + { nb_rec_hyps = -100 + ; rec_hyps = [] + ; info = + Reductionops.nf_betaiota env sigma + (applist + ( fbody_with_full_params + , List.rev_map var_of_decl princ_params + @ List.rev_map mkVar args_id )) + ; eq_hyps = [] } + in + let fname = + destConst sigma + (fst + (decompose_app sigma (List.hd (List.rev pte_args)))) + in + tclTHENLIST + [ unfold_in_concl + [ ( Locus.AllOccurrences + , Names.EvalConstRef (fst fname) ) ] + ; (let do_prove = + build_proof interactive_proof + (Array.to_list fnames) + (Id.Map.map prove_rec_hyp ptes_to_fix) + in + let prove_tac branches = + let dyn_infos = + { dyn_infos with + rec_hyps = branches + ; nb_rec_hyps = List.length branches } + in + clean_goal_with_heq + (Id.Map.map prove_rec_hyp ptes_to_fix) + do_prove dyn_infos + in + instantiate_hyps_with_args prove_tac + (List.rev_map id_of_decl princ_info.branches) + (List.rev args_id)) ]) ]) + in + tclTHEN first_tac intros_after_fixes) (* Proof of principles of general functions *) (* let hrec_id = Recdef.hrec_id *) @@ -1249,97 +1291,95 @@ let prove_princ_for_struct (evd : Evd.evar_map ref) interactive_proof fun_num (* and list_rewrite = Recdef.list_rewrite *) (* and evaluable_of_global_reference = Recdef.evaluable_of_global_reference *) -let prove_with_tcc tcc_lemma_constr eqs : tactic = +let prove_with_tcc tcc_lemma_constr eqs : unit Proofview.tactic = + let open Tacticals.New in match !tcc_lemma_constr with | Undefined -> anomaly (Pp.str "No tcc proof !!") | Value lemma -> - fun gls -> - (* let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in *) - (* let ids = hid::pf_ids_of_hyps gls in *) - tclTHENLIST - [ (* generalize [lemma]; *) - (* h_intro hid; *) - (* Elim.h_decompose_and (mkVar hid); *) - tclTRY (list_rewrite true eqs) - ; (* (fun g -> *) - (* let ids' = pf_ids_of_hyps g in *) - (* let ids = List.filter (fun id -> not (List.mem id ids)) ids' in *) - (* rewrite *) - (* ) *) - Proofview.V82.of_tactic (Eauto.gen_eauto (false, 5) [] (Some [])) ] - gls - | Not_needed -> tclIDTAC + (* let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in *) + (* let ids = hid::pf_ids_of_hyps gls in *) + tclTHENLIST + [ (* generalize [lemma]; *) + (* h_intro hid; *) + (* Elim.h_decompose_and (mkVar hid); *) + tclTRY (list_rewrite true eqs) + ; (* (fun g -> *) + (* let ids' = pf_ids_of_hyps g in *) + (* let ids = List.filter (fun id -> not (List.mem id ids)) ids' in *) + (* rewrite *) + (* ) *) + Eauto.gen_eauto (false, 5) [] (Some []) ] + | Not_needed -> Proofview.tclUNIT () -let backtrack_eqs_until_hrec hrec eqs : tactic = - fun gls -> - let eqs = List.map mkVar eqs in - let rewrite = - tclFIRST - (List.map (fun x -> Proofview.V82.of_tactic (Equality.rewriteRL x)) eqs) - in - let _, hrec_concl = decompose_prod (project gls) (pf_get_hyp_typ gls hrec) in - let f_app = Array.last (snd (destApp (project gls) hrec_concl)) in - let f = fst (destApp (project gls) f_app) in - let rec backtrack : tactic = - fun g -> - let f_app = Array.last (snd (destApp (project g) (pf_concl g))) in - match EConstr.kind (project g) f_app with - | App (f', _) when eq_constr (project g) f' f -> tclIDTAC g - | _ -> tclTHEN rewrite backtrack g - in - backtrack gls +let backtrack_eqs_until_hrec hrec eqs : unit Proofview.tactic = + let open Tacticals.New in + Proofview.Goal.enter (fun gls -> + let sigma = Proofview.Goal.sigma gls in + let eqs = List.map mkVar eqs in + let rewrite = tclFIRST (List.map Equality.rewriteRL eqs) in + let _, hrec_concl = + decompose_prod sigma (Tacmach.New.pf_get_hyp_typ hrec gls) + in + let f_app = Array.last (snd (destApp sigma hrec_concl)) in + let f = fst (destApp sigma f_app) in + let rec backtrack () : unit Proofview.tactic = + Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma gls in + let f_app = + Array.last (snd (destApp sigma (Proofview.Goal.concl g))) + in + match EConstr.kind sigma f_app with + | App (f', _) when eq_constr sigma f' f -> Proofview.tclUNIT () + | _ -> tclTHEN rewrite (backtrack ())) + in + backtrack ()) let rec rewrite_eqs_in_eqs eqs = + let open Tacticals.New in match eqs with - | [] -> tclIDTAC + | [] -> Proofview.tclUNIT () | eq :: eqs -> tclTHEN (tclMAP - (fun id gl -> + (fun id -> observe_tac (Format.sprintf "rewrite %s in %s " (Id.to_string eq) (Id.to_string id)) (tclTRY - (Proofview.V82.of_tactic - (Equality.general_rewrite_in true Locus.AllOccurrences true - (* dep proofs also: *) true id (mkVar eq) false))) - gl) + (Equality.general_rewrite_in true Locus.AllOccurrences true + (* dep proofs also: *) true id (mkVar eq) false))) eqs) (rewrite_eqs_in_eqs eqs) -let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = - fun gls -> - (tclTHENLIST - [ backtrack_eqs_until_hrec hrec eqs - ; (* observe_tac ("new_prove_with_tcc ( applying "^(Id.to_string hrec)^" )" ) *) - tclTHENS (* We must have exactly ONE subgoal !*) - (Proofview.V82.of_tactic (apply (mkVar hrec))) - [ tclTHENLIST - [ Proofview.V82.of_tactic (keep (tcc_hyps @ eqs)) - ; Proofview.V82.of_tactic (apply (Lazy.force acc_inv)) - ; (fun g -> - if is_mes then - Proofview.V82.of_tactic - (unfold_in_concl - [ ( Locus.AllOccurrences - , evaluable_of_global_reference - (delayed_force ltof_ref) ) ]) - g - else tclIDTAC g) - ; observe_tac "rew_and_finish" - (tclTHENLIST - [ tclTRY - (list_rewrite false - (List.map (fun v -> (mkVar v, true)) eqs)) - ; observe_tac "rewrite_eqs_in_eqs" (rewrite_eqs_in_eqs eqs) - ; observe_tac "finishing using" - (tclCOMPLETE - ( Proofview.V82.of_tactic - @@ Eauto.eauto_with_bases (true, 5) - [(fun _ sigma -> (sigma, Lazy.force refl_equal))] - [ Hints.Hint_db.empty TransparentState.empty - false ] )) ]) ] ] ]) - gls +let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : unit Proofview.tactic + = + let open Tacticals.New in + tclTHENLIST + [ backtrack_eqs_until_hrec hrec eqs + ; (* observe_tac ("new_prove_with_tcc ( applying "^(Id.to_string hrec)^" )" ) *) + tclTHENS (* We must have exactly ONE subgoal !*) + (apply (mkVar hrec)) + [ tclTHENLIST + [ keep (tcc_hyps @ eqs) + ; apply (Lazy.force acc_inv) + ; ( if is_mes then + unfold_in_concl + [ ( Locus.AllOccurrences + , evaluable_of_global_reference (delayed_force ltof_ref) ) + ] + else Proofview.tclUNIT () ) + ; observe_tac "rew_and_finish" + (tclTHENLIST + [ tclTRY + (list_rewrite false + (List.map (fun v -> (mkVar v, true)) eqs)) + ; observe_tac "rewrite_eqs_in_eqs" (rewrite_eqs_in_eqs eqs) + ; observe_tac "finishing using" + (tclCOMPLETE + (Eauto.eauto_with_bases (true, 5) + [(fun _ sigma -> (sigma, Lazy.force refl_equal))] + [Hints.Hint_db.empty TransparentState.empty false])) + ]) ] ] ] let is_valid_hypothesis sigma predicates_name = let predicates_name = @@ -1362,199 +1402,204 @@ let is_valid_hypothesis sigma predicates_name = is_valid_hypothesis let prove_principle_for_gen (f_ref, functional_ref, eq_ref) tcc_lemma_ref is_mes - rec_arg_num rec_arg_type relation gl = - let princ_type = pf_concl gl in - let princ_info = compute_elim_sig (project gl) princ_type in - let fresh_id = - let avoid = ref (pf_ids_of_hyps gl) in - fun na -> - let new_id = - match na with - | Name id -> fresh_id !avoid (Id.to_string id) - | Anonymous -> fresh_id !avoid "H" + rec_arg_num rec_arg_type relation = + Proofview.Goal.enter (fun gl -> + let sigma = Proofview.Goal.sigma gl in + let princ_type = Proofview.Goal.concl gl in + let princ_info = compute_elim_sig sigma princ_type in + let fresh_id = + let avoid = ref (Tacmach.New.pf_ids_of_hyps gl) in + fun na -> + let new_id = + match na with + | Name id -> fresh_id !avoid (Id.to_string id) + | Anonymous -> fresh_id !avoid "H" + in + avoid := new_id :: !avoid; + Name new_id in - avoid := new_id :: !avoid; - Name new_id - in - let fresh_decl = map_name fresh_id in - let princ_info : elim_scheme = - { princ_info with - params = List.map fresh_decl princ_info.params - ; predicates = List.map fresh_decl princ_info.predicates - ; branches = List.map fresh_decl princ_info.branches - ; args = List.map fresh_decl princ_info.args } - in - let wf_tac = - if is_mes then fun b -> - Proofview.V82.of_tactic - @@ Recdef.tclUSER_if_not_mes Tacticals.New.tclIDTAC b None - else fun _ -> prove_with_tcc tcc_lemma_ref [] - in - let real_rec_arg_num = rec_arg_num - princ_info.nparams in - let npost_rec_arg = princ_info.nargs - real_rec_arg_num + 1 in - (* observe ( *) - (* str "princ_type := " ++ pr_lconstr princ_type ++ fnl () ++ *) - (* str "princ_info.nparams := " ++ int princ_info.nparams ++ fnl () ++ *) + let fresh_decl = map_name fresh_id in + let princ_info : elim_scheme = + { princ_info with + params = List.map fresh_decl princ_info.params + ; predicates = List.map fresh_decl princ_info.predicates + ; branches = List.map fresh_decl princ_info.branches + ; args = List.map fresh_decl princ_info.args } + in + let wf_tac = + if is_mes then fun b -> + Recdef.tclUSER_if_not_mes Tacticals.New.tclIDTAC b None + else fun _ -> prove_with_tcc tcc_lemma_ref [] + in + let real_rec_arg_num = rec_arg_num - princ_info.nparams in + let npost_rec_arg = princ_info.nargs - real_rec_arg_num + 1 in + (* observe ( *) + (* str "princ_type := " ++ pr_lconstr princ_type ++ fnl () ++ *) + (* str "princ_info.nparams := " ++ int princ_info.nparams ++ fnl () ++ *) - (* str "princ_info.nargs := " ++ int princ_info.nargs ++ fnl () ++ *) - (* str "rec_arg_num := " ++ int rec_arg_num ++ fnl() ++ *) - (* str "real_rec_arg_num := " ++ int real_rec_arg_num ++ fnl () ++ *) - (* str "npost_rec_arg := " ++ int npost_rec_arg ); *) - let post_rec_arg, pre_rec_arg = - Util.List.chop npost_rec_arg princ_info.args - in - let rec_arg_id = - match List.rev post_rec_arg with - | ( LocalAssum ({binder_name = Name id}, _) - | LocalDef ({binder_name = Name id}, _, _) ) - :: _ -> - id - | _ -> assert false - in - (* observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *) - let subst_constrs = - List.map - (get_name %> Nameops.Name.get_id %> mkVar) - (pre_rec_arg @ princ_info.params) - in - let relation = substl subst_constrs relation in - let input_type = substl subst_constrs rec_arg_type in - let wf_thm_id = Nameops.Name.get_id (fresh_id (Name (Id.of_string "wf_R"))) in - let acc_rec_arg_id = - Nameops.Name.get_id - (fresh_id (Name (Id.of_string ("Acc_" ^ Id.to_string rec_arg_id)))) - in - let revert l = - tclTHEN - (Proofview.V82.of_tactic (Tactics.generalize (List.map mkVar l))) - (Proofview.V82.of_tactic (clear l)) - in - let fix_id = Nameops.Name.get_id (fresh_id (Name hrec_id)) in - let prove_rec_arg_acc g = - ((* observe_tac "prove_rec_arg_acc" *) - tclCOMPLETE - (tclTHEN - (Proofview.V82.of_tactic + (* str "princ_info.nargs := " ++ int princ_info.nargs ++ fnl () ++ *) + (* str "rec_arg_num := " ++ int rec_arg_num ++ fnl() ++ *) + (* str "real_rec_arg_num := " ++ int real_rec_arg_num ++ fnl () ++ *) + (* str "npost_rec_arg := " ++ int npost_rec_arg ); *) + let post_rec_arg, pre_rec_arg = + Util.List.chop npost_rec_arg princ_info.args + in + let rec_arg_id = + match List.rev post_rec_arg with + | ( LocalAssum ({binder_name = Name id}, _) + | LocalDef ({binder_name = Name id}, _, _) ) + :: _ -> + id + | _ -> assert false + in + (* observe (str "rec_arg_id := " ++ pr_lconstr (mkVar rec_arg_id)); *) + let subst_constrs = + List.map + (get_name %> Nameops.Name.get_id %> mkVar) + (pre_rec_arg @ princ_info.params) + in + let relation = substl subst_constrs relation in + let input_type = substl subst_constrs rec_arg_type in + let wf_thm_id = + Nameops.Name.get_id (fresh_id (Name (Id.of_string "wf_R"))) + in + let acc_rec_arg_id = + Nameops.Name.get_id + (fresh_id (Name (Id.of_string ("Acc_" ^ Id.to_string rec_arg_id)))) + in + let open Tacticals.New in + let revert l = + tclTHEN (Tactics.generalize (List.map mkVar l)) (clear l) + in + let fix_id = Nameops.Name.get_id (fresh_id (Name hrec_id)) in + let prove_rec_arg_acc = + (* observe_tac "prove_rec_arg_acc" *) + tclCOMPLETE + (tclTHEN (assert_by (Name wf_thm_id) (mkApp (delayed_force well_founded, [|input_type; relation|])) - (Proofview.V82.tactic (fun g -> - (* observe_tac "prove wf" *) - (tclCOMPLETE (wf_tac is_mes)) g)))) - ((* observe_tac *) - (* "apply wf_thm" *) - Proofview.V82.of_tactic - (Tactics.Simple.apply - (mkApp (mkVar wf_thm_id, [|mkVar rec_arg_id|])))))) - g - in - let args_ids = List.map (get_name %> Nameops.Name.get_id) princ_info.args in - let lemma = - match !tcc_lemma_ref with - | Undefined -> user_err Pp.(str "No tcc proof !!") - | Value lemma -> EConstr.of_constr lemma - | Not_needed -> - EConstr.of_constr - (UnivGen.constr_of_monomorphic_global @@ Coqlib.lib_ref "core.True.I") - in - (* let rec list_diff del_list check_list = *) - (* match del_list with *) - (* [] -> *) - (* [] *) - (* | f::r -> *) - (* if List.mem f check_list then *) - (* list_diff r check_list *) - (* else *) - (* f::(list_diff r check_list) *) - (* in *) - let tcc_list = ref [] in - let start_tac gls = - let hyps = pf_ids_of_hyps gls in - let hid = - next_ident_away_in_goal (Id.of_string "prov") (Id.Set.of_list hyps) - in - tclTHENLIST - [ Proofview.V82.of_tactic (generalize [lemma]) - ; Proofview.V82.of_tactic (Simple.intro hid) - ; Proofview.V82.of_tactic (Elim.h_decompose_and (mkVar hid)) - ; (fun g -> - let new_hyps = pf_ids_of_hyps g in - tcc_list := List.rev (List.subtract Id.equal new_hyps (hid :: hyps)); - if List.is_empty !tcc_list then begin - tcc_list := [hid]; - tclIDTAC g - end - else thin [hid] g) ] - gls - in - tclTHENLIST - [ observe_tac "start_tac" start_tac - ; h_intros - (List.rev_map - (get_name %> Nameops.Name.get_id) - ( princ_info.args @ princ_info.branches @ princ_info.predicates - @ princ_info.params )) - ; Proofview.V82.of_tactic - (assert_by (Name acc_rec_arg_id) - (mkApp - (delayed_force acc_rel, [|input_type; relation; mkVar rec_arg_id|])) - (Proofview.V82.tactic prove_rec_arg_acc)) - ; revert (List.rev (acc_rec_arg_id :: args_ids)) - ; Proofview.V82.of_tactic (fix fix_id (List.length args_ids + 1)) - ; h_intros (List.rev (acc_rec_arg_id :: args_ids)) - ; Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_ref)) - ; (fun gl' -> - let body = - let _, args = destApp (project gl') (pf_concl gl') in - Array.last args - in - let body_info rec_hyps = - { nb_rec_hyps = List.length rec_hyps - ; rec_hyps - ; eq_hyps = [] - ; info = body } - in - let acc_inv = - lazy + (* observe_tac "prove wf" *) + (tclCOMPLETE (wf_tac is_mes))) + ((* observe_tac *) + (* "apply wf_thm" *) + Tactics.Simple.apply + (mkApp (mkVar wf_thm_id, [|mkVar rec_arg_id|])))) + in + let args_ids = + List.map (get_name %> Nameops.Name.get_id) princ_info.args + in + let lemma = + match !tcc_lemma_ref with + | Undefined -> user_err Pp.(str "No tcc proof !!") + | Value lemma -> EConstr.of_constr lemma + | Not_needed -> + EConstr.of_constr + ( UnivGen.constr_of_monomorphic_global + @@ Coqlib.lib_ref "core.True.I" ) + in + (* let rec list_diff del_list check_list = *) + (* match del_list with *) + (* [] -> *) + (* [] *) + (* | f::r -> *) + (* if List.mem f check_list then *) + (* list_diff r check_list *) + (* else *) + (* f::(list_diff r check_list) *) + (* in *) + let tcc_list = ref [] in + let start_tac = + Proofview.Goal.enter (fun gls -> + let hyps = Tacmach.New.pf_ids_of_hyps gls in + let hid = + next_ident_away_in_goal (Id.of_string "prov") + (Id.Set.of_list hyps) + in + tclTHENLIST + [ generalize [lemma] + ; Simple.intro hid + ; Elim.h_decompose_and (mkVar hid) + ; Proofview.Goal.enter (fun g -> + let new_hyps = Tacmach.New.pf_ids_of_hyps g in + tcc_list := + List.rev (List.subtract Id.equal new_hyps (hid :: hyps)); + if List.is_empty !tcc_list then begin + tcc_list := [hid]; + Proofview.tclUNIT () + end + else clear [hid]) ]) + in + tclTHENLIST + [ observe_tac "start_tac" start_tac + ; h_intros + (List.rev_map + (get_name %> Nameops.Name.get_id) + ( princ_info.args @ princ_info.branches @ princ_info.predicates + @ princ_info.params )) + ; assert_by (Name acc_rec_arg_id) (mkApp - ( delayed_force acc_inv_id + ( delayed_force acc_rel , [|input_type; relation; mkVar rec_arg_id|] )) - in - let acc_inv = - lazy (mkApp (Lazy.force acc_inv, [|mkVar acc_rec_arg_id|])) - in - let predicates_names = - List.map (get_name %> Nameops.Name.get_id) princ_info.predicates - in - let pte_info = - { proving_tac = - (fun eqs -> - (* msgnl (str "tcc_list := "++ prlist_with_sep spc Ppconstr.pr_id !tcc_list); *) - (* msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.args)); *) - (* msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.params)); *) - (* msgnl (str "acc_rec_arg_id := "++ Ppconstr.pr_id acc_rec_arg_id); *) - (* msgnl (str "eqs := "++ prlist_with_sep spc Ppconstr.pr_id eqs); *) + prove_rec_arg_acc + ; revert (List.rev (acc_rec_arg_id :: args_ids)) + ; fix fix_id (List.length args_ids + 1) + ; h_intros (List.rev (acc_rec_arg_id :: args_ids)) + ; Equality.rewriteLR (mkConst eq_ref) + ; Proofview.Goal.enter (fun gl' -> + let body = + let _, args = + destApp (Proofview.Goal.sigma gl') (Proofview.Goal.concl gl') + in + Array.last args + in + let body_info rec_hyps = + { nb_rec_hyps = List.length rec_hyps + ; rec_hyps + ; eq_hyps = [] + ; info = body } + in + let acc_inv = + lazy + (mkApp + ( delayed_force acc_inv_id + , [|input_type; relation; mkVar rec_arg_id|] )) + in + let acc_inv = + lazy (mkApp (Lazy.force acc_inv, [|mkVar acc_rec_arg_id|])) + in + let predicates_names = + List.map (get_name %> Nameops.Name.get_id) princ_info.predicates + in + let pte_info = + { proving_tac = + (fun eqs -> + (* msgnl (str "tcc_list := "++ prlist_with_sep spc Ppconstr.pr_id !tcc_list); *) + (* msgnl (str "princ_info.args := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.args)); *) + (* msgnl (str "princ_info.params := "++ prlist_with_sep spc Ppconstr.pr_id (List.map (fun (na,_,_) -> (Nameops.Name.get_id na)) princ_info.params)); *) + (* msgnl (str "acc_rec_arg_id := "++ Ppconstr.pr_id acc_rec_arg_id); *) + (* msgnl (str "eqs := "++ prlist_with_sep spc Ppconstr.pr_id eqs); *) - (* observe_tac "new_prove_with_tcc" *) - new_prove_with_tcc is_mes acc_inv fix_id - ( !tcc_list - @ List.map - (get_name %> Nameops.Name.get_id) - (princ_info.args @ princ_info.params) - @ [acc_rec_arg_id] ) - eqs) - ; is_valid = is_valid_hypothesis (project gl') predicates_names } - in - let ptes_info : pte_info Id.Map.t = - List.fold_left - (fun map pte_id -> Id.Map.add pte_id pte_info map) - Id.Map.empty predicates_names - in - let make_proof rec_hyps = - build_proof false [f_ref] ptes_info (body_info rec_hyps) - in - (* observe_tac "instantiate_hyps_with_args" *) - (instantiate_hyps_with_args make_proof - (List.map (get_name %> Nameops.Name.get_id) princ_info.branches) - (List.rev args_ids)) - gl') ] - gl + (* observe_tac "new_prove_with_tcc" *) + new_prove_with_tcc is_mes acc_inv fix_id + ( !tcc_list + @ List.map + (get_name %> Nameops.Name.get_id) + (princ_info.args @ princ_info.params) + @ [acc_rec_arg_id] ) + eqs) + ; is_valid = + is_valid_hypothesis (Proofview.Goal.sigma gl') + predicates_names } + in + let ptes_info : pte_info Id.Map.t = + List.fold_left + (fun map pte_id -> Id.Map.add pte_id pte_info map) + Id.Map.empty predicates_names + in + let make_proof rec_hyps = + build_proof false [f_ref] ptes_info (body_info rec_hyps) + in + (* observe_tac "instantiate_hyps_with_args" *) + instantiate_hyps_with_args make_proof + (List.map (get_name %> Nameops.Name.get_id) princ_info.branches) + (List.rev args_ids)) ]) diff --git a/plugins/funind/functional_principles_proofs.mli b/plugins/funind/functional_principles_proofs.mli index 52089ca7fb..096ea5fed5 100644 --- a/plugins/funind/functional_principles_proofs.mli +++ b/plugins/funind/functional_principles_proofs.mli @@ -1,3 +1,13 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + open Names val prove_princ_for_struct : @@ -7,7 +17,7 @@ val prove_princ_for_struct : -> Constant.t array -> EConstr.constr array -> int - -> Tacmach.tactic + -> unit Proofview.tactic val prove_principle_for_gen : Constant.t * Constant.t * Constant.t @@ -22,6 +32,6 @@ val prove_principle_for_gen : -> (* the type of the recursive argument *) EConstr.constr -> (* the wf relation used to prove the function *) - Tacmach.tactic + unit Proofview.tactic (* val is_pte : rel_declaration -> bool *) diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index a1094e39a4..bbc4df7dde 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -151,7 +151,7 @@ let (wit_function_rec_definition_loc : Vernacexpr.fixpoint_expr Loc.located Gena Genarg.create_arg "function_rec_definition_loc" let function_rec_definition_loc = - Pcoq.create_generic_entry Pcoq.utactic "function_rec_definition_loc" (Genarg.rawwit wit_function_rec_definition_loc) + Pcoq.create_generic_entry2 "function_rec_definition_loc" (Genarg.rawwit wit_function_rec_definition_loc) } diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml index 45b1713441..012fcee486 100644 --- a/plugins/funind/gen_principle.ml +++ b/plugins/funind/gen_principle.ml @@ -13,7 +13,8 @@ open Names open Indfun_common module RelDecl = Context.Rel.Declaration -let observe_tac s = observe_tac (fun _ _ -> Pp.str s) +let observe_tac s = + New.observe_tac ~header:(Pp.str "observation") (fun _ _ -> Pp.str s) (* Construct a fixpoint as a Glob_term @@ -210,9 +211,7 @@ let build_functional_principle (sigma : Evd.evar_map) old_princ_type sorts funs (EConstr.of_constr new_principle_type) in let map (c, u) = EConstr.mkConstU (c, EConstr.EInstance.make u) in - let ftac = - Proofview.V82.tactic (proof_tac (Array.map map funs) mutr_nparams) - in + let ftac = proof_tac (Array.map map funs) mutr_nparams in let env = Global.env () in let uctx = Evd.evar_universe_context sigma in let typ = EConstr.of_constr new_principle_type in @@ -335,7 +334,7 @@ let generate_principle (evd : Evd.evar_map ref) pconstants on_error is_general -> Names.Constant.t array -> EConstr.constr array -> int - -> Tacmach.tactic) : unit = + -> unit Proofview.tactic) : unit = let names = List.map (function {Vernacexpr.fname = {CAst.v = name}} -> name) fix_rec_l in @@ -442,7 +441,7 @@ let register_struct is_rec fixpoint_exprl = let generate_correction_proof_wf f_ref tcc_lemma_ref is_mes functional_ref eq_ref rec_arg_num rec_arg_type relation (_ : int) (_ : Names.Constant.t array) (_ : EConstr.constr array) (_ : int) : - Tacmach.tactic = + unit Proofview.tactic = Functional_principles_proofs.prove_principle_for_gen (f_ref, functional_ref, eq_ref) tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation @@ -593,250 +592,241 @@ let rec generate_fresh_id x avoid i = id :: generate_fresh_id x (id :: avoid) (pred i) let prove_fun_correct evd graphs_constr schemes lemmas_types_infos i : - Tacmach.tactic = + unit Proofview.tactic = let open Constr in let open EConstr in let open Context.Rel.Declaration in - let open Tacmach in + let open Tacmach.New in let open Tactics in - let open Tacticals in - fun g -> - (* first of all we recreate the lemmas types to be used as predicates of the induction principle - that is~: - \[fun (x_1:t_1)\ldots(x_n:t_n)=> fun fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\] - *) - (* we the get the definition of the graphs block *) - let graph_ind, u = destInd evd graphs_constr.(i) in - let kn = fst graph_ind in - let mib, _ = Global.lookup_inductive graph_ind in - (* and the principle to use in this lemma in $\zeta$ normal form *) - let f_principle, princ_type = schemes.(i) in - let princ_type = Reductionops.nf_zeta (Global.env ()) evd princ_type in - let princ_infos = Tactics.compute_elim_sig evd princ_type in - (* The number of args of the function is then easily computable *) - let nb_fun_args = Termops.nb_prod (project g) (pf_concl g) - 2 in - let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in - let ids = args_names @ pf_ids_of_hyps g in - (* Since we cannot ensure that the functional principle is defined in the - environment and due to the bug #1174, we will need to pose the principle - using a name - *) - let principle_id = - Namegen.next_ident_away_in_goal (Id.of_string "princ") - (Id.Set.of_list ids) - in - let ids = principle_id :: ids in - (* We get the branches of the principle *) - let branches = List.rev princ_infos.Tactics.branches in - (* and built the intro pattern for each of them *) - let intro_pats = - List.map - (fun decl -> - List.map - (fun id -> - CAst.make @@ Tactypes.IntroNaming (Namegen.IntroIdentifier id)) - (generate_fresh_id (Id.of_string "y") ids - (List.length - (fst (decompose_prod_assum evd (RelDecl.get_type decl)))))) - branches - in - (* before building the full intro pattern for the principle *) - let eq_ind = make_eq () in - let eq_construct = mkConstructUi (destInd evd eq_ind, 1) in - (* The next to referencies will be used to find out which constructor to apply in each branch *) - let ind_number = ref 0 and min_constr_number = ref 0 in - (* The tactic to prove the ith branch of the principle *) - let prove_branche i g = - (* We get the identifiers of this branch *) - let pre_args = - List.fold_right - (fun {CAst.v = pat} acc -> - match pat with - | Tactypes.IntroNaming (Namegen.IntroIdentifier id) -> id :: acc - | _ -> CErrors.anomaly (Pp.str "Not an identifier.")) - (List.nth intro_pats (pred i)) - [] + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + (* first of all we recreate the lemmas types to be used as predicates of the induction principle + that is~: + \[fun (x_1:t_1)\ldots(x_n:t_n)=> fun fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\] + *) + (* we the get the definition of the graphs block *) + let graph_ind, u = destInd evd graphs_constr.(i) in + let kn = fst graph_ind in + let mib, _ = Global.lookup_inductive graph_ind in + (* and the principle to use in this lemma in $\zeta$ normal form *) + let f_principle, princ_type = schemes.(i) in + let princ_type = Reductionops.nf_zeta (Global.env ()) evd princ_type in + let princ_infos = Tactics.compute_elim_sig evd princ_type in + (* The number of args of the function is then easily computable *) + let nb_fun_args = + Termops.nb_prod (Proofview.Goal.sigma g) (Proofview.Goal.concl g) - 2 + in + let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in + let ids = args_names @ pf_ids_of_hyps g in + (* Since we cannot ensure that the functional principle is defined in the + environment and due to the bug #1174, we will need to pose the principle + using a name + *) + let principle_id = + Namegen.next_ident_away_in_goal (Id.of_string "princ") + (Id.Set.of_list ids) + in + let ids = principle_id :: ids in + (* We get the branches of the principle *) + let branches = List.rev princ_infos.Tactics.branches in + (* and built the intro pattern for each of them *) + let intro_pats = + List.map + (fun decl -> + List.map + (fun id -> + CAst.make @@ Tactypes.IntroNaming (Namegen.IntroIdentifier id)) + (generate_fresh_id (Id.of_string "y") ids + (List.length + (fst (decompose_prod_assum evd (RelDecl.get_type decl)))))) + branches in - (* and get the real args of the branch by unfolding the defined constant *) - (* + (* before building the full intro pattern for the principle *) + let eq_ind = make_eq () in + let eq_construct = mkConstructUi (destInd evd eq_ind, 1) in + (* The next to referencies will be used to find out which constructor to apply in each branch *) + let ind_number = ref 0 and min_constr_number = ref 0 in + (* The tactic to prove the ith branch of the principle *) + let prove_branch i pat = + (* We get the identifiers of this branch *) + let pre_args = + List.fold_right + (fun {CAst.v = pat} acc -> + match pat with + | Tactypes.IntroNaming (Namegen.IntroIdentifier id) -> id :: acc + | _ -> CErrors.anomaly (Pp.str "Not an identifier.")) + pat [] + in + (* and get the real args of the branch by unfolding the defined constant *) + (* We can then recompute the arguments of the constructor. For each [hid] introduced by this branch, if [hid] has type $forall res, res=fv -> graph.(j)\ x_1\ x_n res$ the corresponding arguments of the constructor are [ fv (hid fv (refl_equal fv)) ]. If [hid] has another type the corresponding argument of the constructor is [hid] *) - let constructor_args g = - List.fold_right - (fun hid acc -> - let type_of_hid = pf_get_hyp_typ g hid in - let sigma = project g in - match EConstr.kind sigma type_of_hid with - | Prod (_, _, t') -> ( - match EConstr.kind sigma t' with - | Prod (_, t'', t''') -> ( - match (EConstr.kind sigma t'', EConstr.kind sigma t''') with - | App (eq, args), App (graph', _) - when EConstr.eq_constr sigma eq eq_ind - && Array.exists - (EConstr.eq_constr_nounivs sigma graph') - graphs_constr -> - args.(2) - :: mkApp - ( mkVar hid - , [| args.(2) - ; mkApp (eq_construct, [|args.(0); args.(2)|]) |] ) - :: acc + let constructor_args g = + List.fold_right + (fun hid acc -> + let type_of_hid = pf_get_hyp_typ hid g in + let sigma = Proofview.Goal.sigma g in + match EConstr.kind sigma type_of_hid with + | Prod (_, _, t') -> ( + match EConstr.kind sigma t' with + | Prod (_, t'', t''') -> ( + match (EConstr.kind sigma t'', EConstr.kind sigma t''') with + | App (eq, args), App (graph', _) + when EConstr.eq_constr sigma eq eq_ind + && Array.exists + (EConstr.eq_constr_nounivs sigma graph') + graphs_constr -> + args.(2) + :: mkApp + ( mkVar hid + , [| args.(2) + ; mkApp (eq_construct, [|args.(0); args.(2)|]) |] ) + :: acc + | _ -> mkVar hid :: acc ) | _ -> mkVar hid :: acc ) - | _ -> mkVar hid :: acc ) - | _ -> mkVar hid :: acc) - pre_args [] - in - (* in fact we must also add the parameters to the constructor args *) - let constructor_args g = - let params_id = - fst (List.chop princ_infos.Tactics.nparams args_names) + | _ -> mkVar hid :: acc) + pre_args [] in - List.map mkVar params_id @ constructor_args g - in - (* We then get the constructor corresponding to this branch and - modifies the references has needed i.e. - if the constructor is the last one of the current inductive then - add one the number of the inductive to take and add the number of constructor of the previous - graph to the minimal constructor number - *) - let constructor = - let constructor_num = i - !min_constr_number in - let length = - Array.length - mib.Declarations.mind_packets.(!ind_number) - .Declarations.mind_consnames + (* in fact we must also add the parameters to the constructor args *) + let constructor_args g = + let params_id = + fst (List.chop princ_infos.Tactics.nparams args_names) + in + List.map mkVar params_id @ constructor_args g in - if constructor_num <= length then ((kn, !ind_number), constructor_num) - else begin - incr ind_number; - min_constr_number := !min_constr_number + length; - ((kn, !ind_number), 1) - end - in - (* we can then build the final proof term *) - let app_constructor g = - applist (mkConstructU (constructor, u), constructor_args g) + (* We then get the constructor corresponding to this branch and + modifies the references has needed i.e. + if the constructor is the last one of the current inductive then + add one the number of the inductive to take and add the number of constructor of the previous + graph to the minimal constructor number + *) + let constructor = + let constructor_num = i - !min_constr_number in + let length = + Array.length + mib.Declarations.mind_packets.(!ind_number) + .Declarations.mind_consnames + in + if constructor_num <= length then ((kn, !ind_number), constructor_num) + else begin + incr ind_number; + min_constr_number := !min_constr_number + length; + ((kn, !ind_number), 1) + end + in + (* we can then build the final proof term *) + let app_constructor g = + applist (mkConstructU (constructor, u), constructor_args g) + in + (* an apply the tactic *) + let res, hres = + match + generate_fresh_id (Id.of_string "z") ids (* @this_branche_ids *) 2 + with + | [res; hres] -> (res, hres) + | _ -> assert false + in + (* observe (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor); *) + tclTHENLIST + [ observe_tac "h_intro_patterns " + (match pat with [] -> tclIDTAC | _ -> intro_patterns false pat) + ; (* unfolding of all the defined variables introduced by this branch *) + (* observe_tac "unfolding" pre_tac; *) + (* $zeta$ normalizing of the conclusion *) + reduce + (Genredexpr.Cbv + { Redops.all_flags with + Genredexpr.rDelta = false + ; Genredexpr.rConst = [] }) + Locusops.onConcl + ; observe_tac "toto " (Proofview.tclUNIT ()) + ; (* introducing the result of the graph and the equality hypothesis *) + observe_tac "introducing" (tclMAP Simple.intro [res; hres]) + ; (* replacing [res] with its value *) + observe_tac "rewriting res value" (Equality.rewriteLR (mkVar hres)) + ; (* Conclusion *) + observe_tac "exact" + (Proofview.Goal.enter (fun g -> exact_check (app_constructor g))) + ] in - (* an apply the tactic *) - let res, hres = - match - generate_fresh_id (Id.of_string "z") ids (* @this_branche_ids *) 2 - with - | [res; hres] -> (res, hres) - | _ -> assert false + (* end of branche proof *) + let lemmas = + Array.map + (fun (_, (ctxt, concl)) -> + match ctxt with + | [] | [_] | [_; _] -> CErrors.anomaly (Pp.str "bad context.") + | hres :: res :: decl :: ctxt -> + let res = + EConstr.it_mkLambda_or_LetIn + (EConstr.it_mkProd_or_LetIn concl [hres; res]) + ( LocalAssum (RelDecl.get_annot decl, RelDecl.get_type decl) + :: ctxt ) + in + res) + lemmas_types_infos in - (* observe (str "constructor := " ++ Printer.pr_lconstr_env (pf_env g) app_constructor); *) - (tclTHENLIST - [ observe_tac "h_intro_patterns " - (let l = List.nth intro_pats (pred i) in - match l with - | [] -> tclIDTAC - | _ -> Proofview.V82.of_tactic (intro_patterns false l)) - ; (* unfolding of all the defined variables introduced by this branch *) - (* observe_tac "unfolding" pre_tac; *) - (* $zeta$ normalizing of the conclusion *) - Proofview.V82.of_tactic - (reduce - (Genredexpr.Cbv - { Redops.all_flags with - Genredexpr.rDelta = false - ; Genredexpr.rConst = [] }) - Locusops.onConcl) - ; observe_tac "toto " tclIDTAC - ; (* introducing the result of the graph and the equality hypothesis *) - observe_tac "introducing" - (tclMAP - (fun x -> Proofview.V82.of_tactic (Simple.intro x)) - [res; hres]) - ; (* replacing [res] with its value *) - observe_tac "rewriting res value" - (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar hres))) - ; (* Conclusion *) - observe_tac "exact" (fun g -> - Proofview.V82.of_tactic (exact_check (app_constructor g)) g) ]) - g - in - (* end of branche proof *) - let lemmas = - Array.map - (fun (_, (ctxt, concl)) -> - match ctxt with - | [] | [_] | [_; _] -> CErrors.anomaly (Pp.str "bad context.") - | hres :: res :: decl :: ctxt -> - let res = - EConstr.it_mkLambda_or_LetIn - (EConstr.it_mkProd_or_LetIn concl [hres; res]) - ( LocalAssum (RelDecl.get_annot decl, RelDecl.get_type decl) - :: ctxt ) - in - res) - lemmas_types_infos - in - let param_names = fst (List.chop princ_infos.nparams args_names) in - let params = List.map mkVar param_names in - let lemmas = - Array.to_list (Array.map (fun c -> applist (c, params)) lemmas) - in - (* The bindings of the principle - that is the params of the principle and the different lemma types - *) - let bindings = - let params_bindings, avoid = - List.fold_left2 - (fun (bindings, avoid) decl p -> - let id = - Namegen.next_ident_away - (Nameops.Name.get_id (RelDecl.get_name decl)) - (Id.Set.of_list avoid) - in - (p :: bindings, id :: avoid)) - ([], pf_ids_of_hyps g) - princ_infos.params (List.rev params) + let param_names = fst (List.chop princ_infos.nparams args_names) in + let params = List.map mkVar param_names in + let lemmas = + Array.to_list (Array.map (fun c -> applist (c, params)) lemmas) in - let lemmas_bindings = - List.rev - (fst - (List.fold_left2 - (fun (bindings, avoid) decl p -> - let id = - Namegen.next_ident_away - (Nameops.Name.get_id (RelDecl.get_name decl)) - (Id.Set.of_list avoid) - in - ( Reductionops.nf_zeta (pf_env g) (project g) p :: bindings - , id :: avoid )) - ([], avoid) princ_infos.predicates lemmas)) + (* The bindings of the principle + that is the params of the principle and the different lemma types + *) + let bindings = + let params_bindings, avoid = + List.fold_left2 + (fun (bindings, avoid) decl p -> + let id = + Namegen.next_ident_away + (Nameops.Name.get_id (RelDecl.get_name decl)) + (Id.Set.of_list avoid) + in + (p :: bindings, id :: avoid)) + ([], pf_ids_of_hyps g) + princ_infos.params (List.rev params) + in + let lemmas_bindings = + List.rev + (fst + (List.fold_left2 + (fun (bindings, avoid) decl p -> + let id = + Namegen.next_ident_away + (Nameops.Name.get_id (RelDecl.get_name decl)) + (Id.Set.of_list avoid) + in + ( Reductionops.nf_zeta (Proofview.Goal.env g) + (Proofview.Goal.sigma g) p + :: bindings + , id :: avoid )) + ([], avoid) princ_infos.predicates lemmas)) + in + params_bindings @ lemmas_bindings in - params_bindings @ lemmas_bindings - in - tclTHENLIST - [ observe_tac "principle" - (Proofview.V82.of_tactic - (assert_by (Name principle_id) princ_type - (exact_check f_principle))) - ; observe_tac "intro args_names" - (tclMAP - (fun id -> Proofview.V82.of_tactic (Simple.intro id)) - args_names) - ; (* observe_tac "titi" (pose_proof (Name (Id.of_string "__")) (Reductionops.nf_beta Evd.empty ((mkApp (mkVar principle_id,Array.of_list bindings))))); *) - observe_tac "idtac" tclIDTAC - ; tclTHEN_i - (observe_tac "functional_induction" (fun gl -> - let term = mkApp (mkVar principle_id, Array.of_list bindings) in - let gl', _ty = - pf_eapply (Typing.type_of ~refresh:true) gl term - in - Proofview.V82.of_tactic (apply term) gl')) - (fun i g -> - observe_tac - ("proving branche " ^ string_of_int i) - (prove_branche i) g) ] - g + tclTHENLIST + [ observe_tac "principle" + (assert_by (Name principle_id) princ_type (exact_check f_principle)) + ; observe_tac "intro args_names" (tclMAP Simple.intro args_names) + ; (* observe_tac "titi" (pose_proof (Name (Id.of_string "__")) (Reductionops.nf_beta Evd.empty ((mkApp (mkVar principle_id,Array.of_list bindings))))); *) + observe_tac "idtac" tclIDTAC + ; tclTHENS + (observe_tac "functional_induction" + (Proofview.Goal.enter (fun gl -> + let term = + mkApp (mkVar principle_id, Array.of_list bindings) + in + tclTYPEOFTHEN ~refresh:true term (fun _ _ -> apply term)))) + (List.map_i + (fun i pat -> + observe_tac + ("proving branch " ^ string_of_int i) + (prove_branch i pat)) + 1 intro_pats) ]) (* [prove_fun_complete funs graphs schemes lemmas_types_infos i] is the tactic used to prove completeness lemma. @@ -865,7 +855,7 @@ let prove_fun_correct evd graphs_constr schemes lemmas_types_infos i : *) -let thin ids gl = Proofview.V82.of_tactic (Tactics.clear ids) gl +let thin = Tactics.clear (* [intros_with_rewrite] do the intros in each branch and treat each new hypothesis (unfolding, substituting, destructing cases \ldots) @@ -882,347 +872,343 @@ let tauto = (* [generalize_dependent_of x hyp g] generalize every hypothesis which depends of [x] but [hyp] *) -let generalize_dependent_of x hyp g = +let generalize_dependent_of x hyp = let open Context.Named.Declaration in - let open Tacmach in - let open Tacticals in - tclMAP - (function - | LocalAssum ({Context.binder_name = id}, t) - when (not (Id.equal id hyp)) - && Termops.occur_var (pf_env g) (project g) x t -> - tclTHEN - (Proofview.V82.of_tactic (Tactics.generalize [EConstr.mkVar id])) - (thin [id]) - | _ -> tclIDTAC) - (pf_hyps g) g - -let rec intros_with_rewrite g = - observe_tac "intros_with_rewrite" intros_with_rewrite_aux g - -and intros_with_rewrite_aux : Tacmach.tactic = + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + tclMAP + (function + | LocalAssum ({Context.binder_name = id}, t) + when (not (Id.equal id hyp)) + && Termops.occur_var (Proofview.Goal.env g) + (Proofview.Goal.sigma g) x t -> + tclTHEN (Tactics.generalize [EConstr.mkVar id]) (thin [id]) + | _ -> Proofview.tclUNIT ()) + (Proofview.Goal.hyps g)) + +let rec intros_with_rewrite () = + observe_tac "intros_with_rewrite" (intros_with_rewrite_aux ()) + +and intros_with_rewrite_aux () : unit Proofview.tactic = let open Constr in let open EConstr in - let open Tacmach in + let open Tacmach.New in let open Tactics in - let open Tacticals in - fun g -> - let eq_ind = make_eq () in - let sigma = project g in - match EConstr.kind sigma (pf_concl g) with - | Prod (_, t, t') -> ( - match EConstr.kind sigma t with - | App (eq, args) when EConstr.eq_constr sigma eq eq_ind -> - if Reductionops.is_conv (pf_env g) (project g) args.(1) args.(2) then - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST - [ Proofview.V82.of_tactic (Simple.intro id) - ; thin [id] - ; intros_with_rewrite ] - g - else if - isVar sigma args.(1) - && Environ.evaluable_named (destVar sigma args.(1)) (pf_env g) - then - tclTHENLIST - [ Proofview.V82.of_tactic - (unfold_in_concl - [ ( Locus.AllOccurrences - , Names.EvalVarRef (destVar sigma args.(1)) ) ]) - ; tclMAP - (fun id -> - tclTRY - (Proofview.V82.of_tactic - (unfold_in_hyp - [ ( Locus.AllOccurrences - , Names.EvalVarRef (destVar sigma args.(1)) ) ] - (destVar sigma args.(1), Locus.InHyp)))) - (pf_ids_of_hyps g) - ; intros_with_rewrite ] - g - else if - isVar sigma args.(2) - && Environ.evaluable_named (destVar sigma args.(2)) (pf_env g) - then - tclTHENLIST - [ Proofview.V82.of_tactic - (unfold_in_concl - [ ( Locus.AllOccurrences - , Names.EvalVarRef (destVar sigma args.(2)) ) ]) - ; tclMAP - (fun id -> - tclTRY - (Proofview.V82.of_tactic - (unfold_in_hyp - [ ( Locus.AllOccurrences - , Names.EvalVarRef (destVar sigma args.(2)) ) ] - (destVar sigma args.(2), Locus.InHyp)))) - (pf_ids_of_hyps g) - ; intros_with_rewrite ] - g - else if isVar sigma args.(1) then - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST - [ Proofview.V82.of_tactic (Simple.intro id) - ; generalize_dependent_of (destVar sigma args.(1)) id - ; tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))) - ; intros_with_rewrite ] - g - else if isVar sigma args.(2) then - let id = pf_get_new_id (Id.of_string "y") g in + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + let eq_ind = make_eq () in + let sigma = Proofview.Goal.sigma g in + match EConstr.kind sigma (Proofview.Goal.concl g) with + | Prod (_, t, t') -> ( + match EConstr.kind sigma t with + | App (eq, args) when EConstr.eq_constr sigma eq eq_ind -> + if + Reductionops.is_conv (Proofview.Goal.env g) (Proofview.Goal.sigma g) + args.(1) args.(2) + then + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST [Simple.intro id; thin [id]; intros_with_rewrite ()] + else if + isVar sigma args.(1) + && Environ.evaluable_named + (destVar sigma args.(1)) + (Proofview.Goal.env g) + then + tclTHENLIST + [ unfold_in_concl + [ ( Locus.AllOccurrences + , Names.EvalVarRef (destVar sigma args.(1)) ) ] + ; tclMAP + (fun id -> + tclTRY + (unfold_in_hyp + [ ( Locus.AllOccurrences + , Names.EvalVarRef (destVar sigma args.(1)) ) ] + (destVar sigma args.(1), Locus.InHyp))) + (pf_ids_of_hyps g) + ; intros_with_rewrite () ] + else if + isVar sigma args.(2) + && Environ.evaluable_named + (destVar sigma args.(2)) + (Proofview.Goal.env g) + then + tclTHENLIST + [ unfold_in_concl + [ ( Locus.AllOccurrences + , Names.EvalVarRef (destVar sigma args.(2)) ) ] + ; tclMAP + (fun id -> + tclTRY + (unfold_in_hyp + [ ( Locus.AllOccurrences + , Names.EvalVarRef (destVar sigma args.(2)) ) ] + (destVar sigma args.(2), Locus.InHyp))) + (pf_ids_of_hyps g) + ; intros_with_rewrite () ] + else if isVar sigma args.(1) then + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST + [ Simple.intro id + ; generalize_dependent_of (destVar sigma args.(1)) id + ; tclTRY (Equality.rewriteLR (mkVar id)) + ; intros_with_rewrite () ] + else if isVar sigma args.(2) then + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST + [ Simple.intro id + ; generalize_dependent_of (destVar sigma args.(2)) id + ; tclTRY (Equality.rewriteRL (mkVar id)) + ; intros_with_rewrite () ] + else + let id = pf_get_new_id (Id.of_string "y") g in + tclTHENLIST + [ Simple.intro id + ; tclTRY (Equality.rewriteLR (mkVar id)) + ; intros_with_rewrite () ] + | Ind _ + when EConstr.eq_constr sigma t + (EConstr.of_constr + ( UnivGen.constr_of_monomorphic_global + @@ Coqlib.lib_ref "core.False.type" )) -> + tauto + | Case (_, _, _, v, _) -> + tclTHENLIST [simplest_case v; intros_with_rewrite ()] + | LetIn _ -> tclTHENLIST - [ Proofview.V82.of_tactic (Simple.intro id) - ; generalize_dependent_of (destVar sigma args.(2)) id - ; tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar id))) - ; intros_with_rewrite ] - g - else + [ reduce + (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false}) + Locusops.onConcl + ; intros_with_rewrite () ] + | _ -> let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST - [ Proofview.V82.of_tactic (Simple.intro id) - ; tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))) - ; intros_with_rewrite ] - g - | Ind _ - when EConstr.eq_constr sigma t - (EConstr.of_constr - ( UnivGen.constr_of_monomorphic_global - @@ Coqlib.lib_ref "core.False.type" )) -> - Proofview.V82.of_tactic tauto g - | Case (_, _, _, v, _) -> - tclTHENLIST - [Proofview.V82.of_tactic (simplest_case v); intros_with_rewrite] - g + tclTHENLIST [Simple.intro id; intros_with_rewrite ()] ) | LetIn _ -> tclTHENLIST - [ Proofview.V82.of_tactic - (reduce - (Genredexpr.Cbv - {Redops.all_flags with Genredexpr.rDelta = false}) - Locusops.onConcl) - ; intros_with_rewrite ] - g - | _ -> - let id = pf_get_new_id (Id.of_string "y") g in - tclTHENLIST - [Proofview.V82.of_tactic (Simple.intro id); intros_with_rewrite] - g ) - | LetIn _ -> - tclTHENLIST - [ Proofview.V82.of_tactic - (reduce - (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false}) - Locusops.onConcl) - ; intros_with_rewrite ] - g - | _ -> tclIDTAC g - -let rec reflexivity_with_destruct_cases g = + [ reduce + (Genredexpr.Cbv {Redops.all_flags with Genredexpr.rDelta = false}) + Locusops.onConcl + ; intros_with_rewrite () ] + | _ -> Proofview.tclUNIT ()) + +let rec reflexivity_with_destruct_cases () = let open Constr in let open EConstr in - let open Tacmach in + let open Tacmach.New in let open Tactics in - let open Tacticals in - let destruct_case () = - try - match - EConstr.kind (project g) (snd (destApp (project g) (pf_concl g))).(2) - with - | Case (_, _, _, v, _) -> - tclTHENLIST - [ Proofview.V82.of_tactic (simplest_case v) - ; Proofview.V82.of_tactic intros - ; observe_tac "reflexivity_with_destruct_cases" - reflexivity_with_destruct_cases ] - | _ -> Proofview.V82.of_tactic reflexivity - with e when CErrors.noncritical e -> Proofview.V82.of_tactic reflexivity - in - let eq_ind = make_eq () in - let my_inj_flags = - Some - { Equality.keep_proof_equalities = false - ; injection_in_context = false - ; (* for compatibility, necessary *) - injection_pattern_l2r_order = - false (* probably does not matter; except maybe with dependent hyps *) - } - in - let discr_inject = - Tacticals.onAllHypsAndConcl (fun sc g -> - match sc with - | None -> tclIDTAC g - | Some id -> ( - match EConstr.kind (project g) (pf_get_hyp_typ g id) with - | App (eq, [|_; t1; t2|]) when EConstr.eq_constr (project g) eq eq_ind - -> - if Equality.discriminable (pf_env g) (project g) t1 t2 then - Proofview.V82.of_tactic (Equality.discrHyp id) g - else if - Equality.injectable (pf_env g) (project g) ~keep_proofs:None t1 t2 - then - tclTHENLIST - [ Proofview.V82.of_tactic (Equality.injHyp my_inj_flags None id) - ; thin [id] - ; intros_with_rewrite ] - g - else tclIDTAC g - | _ -> tclIDTAC g )) - in - (tclFIRST - [ observe_tac "reflexivity_with_destruct_cases : reflexivity" - (Proofview.V82.of_tactic reflexivity) - ; observe_tac "reflexivity_with_destruct_cases : destruct_case" - (destruct_case ()) - ; (* We reach this point ONLY if - the same value is matched (at least) two times - along binding path. - In this case, either we have a discriminable hypothesis and we are done, - either at least an injectable one and we do the injection before continuing - *) - observe_tac "reflexivity_with_destruct_cases : others" - (tclTHEN (tclPROGRESS discr_inject) reflexivity_with_destruct_cases) ]) - g + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + let destruct_case () = + try + match + EConstr.kind (Proofview.Goal.sigma g) + (snd (destApp (Proofview.Goal.sigma g) (Proofview.Goal.concl g))).( + 2) + with + | Case (_, _, _, v, _) -> + tclTHENLIST + [ simplest_case v + ; intros + ; observe_tac "reflexivity_with_destruct_cases" + (reflexivity_with_destruct_cases ()) ] + | _ -> reflexivity + with e when CErrors.noncritical e -> reflexivity + in + let eq_ind = make_eq () in + let my_inj_flags = + Some + { Equality.keep_proof_equalities = false + ; injection_in_context = false + ; (* for compatibility, necessary *) + injection_pattern_l2r_order = + false + (* probably does not matter; except maybe with dependent hyps *) + } + in + let discr_inject = + onAllHypsAndConcl (fun sc -> + match sc with + | None -> Proofview.tclUNIT () + | Some id -> + Proofview.Goal.enter (fun g -> + match + EConstr.kind (Proofview.Goal.sigma g) (pf_get_hyp_typ id g) + with + | App (eq, [|_; t1; t2|]) + when EConstr.eq_constr (Proofview.Goal.sigma g) eq eq_ind -> + if + Equality.discriminable (Proofview.Goal.env g) + (Proofview.Goal.sigma g) t1 t2 + then Equality.discrHyp id + else if + Equality.injectable (Proofview.Goal.env g) + (Proofview.Goal.sigma g) ~keep_proofs:None t1 t2 + then + tclTHENLIST + [ Equality.injHyp my_inj_flags None id + ; thin [id] + ; intros_with_rewrite () ] + else Proofview.tclUNIT () + | _ -> Proofview.tclUNIT ())) + in + tclFIRST + [ observe_tac "reflexivity_with_destruct_cases : reflexivity" reflexivity + ; observe_tac "reflexivity_with_destruct_cases : destruct_case" + (destruct_case ()) + ; (* We reach this point ONLY if + the same value is matched (at least) two times + along binding path. + In this case, either we have a discriminable hypothesis and we are done, + either at least an injectable one and we do the injection before continuing + *) + observe_tac "reflexivity_with_destruct_cases : others" + (tclTHEN (tclPROGRESS discr_inject) + (reflexivity_with_destruct_cases ())) ]) let prove_fun_complete funcs graphs schemes lemmas_types_infos i : - Tacmach.tactic = + unit Proofview.tactic = let open EConstr in - let open Tacmach in + let open Tacmach.New in let open Tactics in - let open Tacticals in - fun g -> - (* We compute the types of the different mutually recursive lemmas - in $\zeta$ normal form - *) - let lemmas = - Array.map - (fun (_, (ctxt, concl)) -> - Reductionops.nf_zeta (pf_env g) (project g) - (EConstr.it_mkLambda_or_LetIn concl ctxt)) - lemmas_types_infos - in - (* We get the constant and the principle corresponding to this lemma *) - let f = funcs.(i) in - let graph_principle = - Reductionops.nf_zeta (pf_env g) (project g) - (EConstr.of_constr schemes.(i)) - in - let g, princ_type = tac_type_of g graph_principle in - let princ_infos = Tactics.compute_elim_sig (project g) princ_type in - (* Then we get the number of argument of the function - and compute a fresh name for each of them - *) - let nb_fun_args = Termops.nb_prod (project g) (pf_concl g) - 2 in - let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in - let ids = args_names @ pf_ids_of_hyps g in - (* and fresh names for res H and the principle (cf bug bug #1174) *) - let res, hres, graph_principle_id = - match generate_fresh_id (Id.of_string "z") ids 3 with - | [res; hres; graph_principle_id] -> (res, hres, graph_principle_id) - | _ -> assert false - in - let ids = res :: hres :: graph_principle_id :: ids in - (* we also compute fresh names for each hyptohesis of each branch - of the principle *) - let branches = List.rev princ_infos.branches in - let intro_pats = - List.map - (fun decl -> - List.map - (fun id -> id) - (generate_fresh_id (Id.of_string "y") ids - (Termops.nb_prod (project g) (RelDecl.get_type decl)))) - branches - in - (* We will need to change the function by its body - using [f_equation] if it is recursive (that is the graph is infinite - or unfold if the graph is finite - *) - let rewrite_tac j ids : Tacmach.tactic = - let graph_def = graphs.(j) in - let infos = - match find_Function_infos (fst (destConst (project g) funcs.(j))) with - | None -> CErrors.user_err Pp.(str "No graph found") - | Some infos -> infos + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + (* We compute the types of the different mutually recursive lemmas + in $\zeta$ normal form + *) + let lemmas = + Array.map + (fun (_, (ctxt, concl)) -> + Reductionops.nf_zeta (Proofview.Goal.env g) (Proofview.Goal.sigma g) + (EConstr.it_mkLambda_or_LetIn concl ctxt)) + lemmas_types_infos in - if - infos.is_general - || Rtree.is_infinite Declareops.eq_recarg - graph_def.Declarations.mind_recargs - then - let eq_lemma = - try Option.get infos.equation_lemma - with Option.IsNone -> - CErrors.anomaly (Pp.str "Cannot find equation lemma.") - in - tclTHENLIST - [ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) ids - ; Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_lemma)) - ; (* Don't forget to $\zeta$ normlize the term since the principles - have been $\zeta$-normalized *) - Proofview.V82.of_tactic - (reduce - (Genredexpr.Cbv - {Redops.all_flags with Genredexpr.rDelta = false}) - Locusops.onConcl) - ; Proofview.V82.of_tactic (generalize (List.map mkVar ids)) - ; thin ids ] - else - Proofview.V82.of_tactic - (unfold_in_concl - [ ( Locus.AllOccurrences - , Names.EvalConstRef (fst (destConst (project g) f)) ) ]) - in - (* The proof of each branche itself *) - let ind_number = ref 0 in - let min_constr_number = ref 0 in - let prove_branche i g = - (* we fist compute the inductive corresponding to the branch *) - let this_ind_number = - let constructor_num = i - !min_constr_number in - let length = - Array.length graphs.(!ind_number).Declarations.mind_consnames - in - if constructor_num <= length then !ind_number - else begin - incr ind_number; - min_constr_number := !min_constr_number + length; - !ind_number - end + (* We get the constant and the principle corresponding to this lemma *) + let f = funcs.(i) in + let graph_principle = + Reductionops.nf_zeta (Proofview.Goal.env g) (Proofview.Goal.sigma g) + (EConstr.of_constr schemes.(i)) in - let this_branche_ids = List.nth intro_pats (pred i) in - tclTHENLIST - [ (* we expand the definition of the function *) - observe_tac "rewrite_tac" - (rewrite_tac this_ind_number this_branche_ids) - ; (* introduce hypothesis with some rewrite *) - observe_tac "intros_with_rewrite (all)" intros_with_rewrite - ; (* The proof is (almost) complete *) - observe_tac "reflexivity" reflexivity_with_destruct_cases ] - g - in - let params_names = fst (List.chop princ_infos.nparams args_names) in - let open EConstr in - let params = List.map mkVar params_names in - tclTHENLIST - [ tclMAP - (fun id -> Proofview.V82.of_tactic (Simple.intro id)) - (args_names @ [res; hres]) - ; observe_tac "h_generalize" - (Proofview.V82.of_tactic - (generalize - [ mkApp - ( applist (graph_principle, params) - , Array.map (fun c -> applist (c, params)) lemmas ) ])) - ; Proofview.V82.of_tactic (Simple.intro graph_principle_id) - ; observe_tac "" - (tclTHEN_i - (observe_tac "elim" - (Proofview.V82.of_tactic - (elim false None - (mkVar hres, Tactypes.NoBindings) - (Some (mkVar graph_principle_id, Tactypes.NoBindings))))) - (fun i g -> observe_tac "prove_branche" (prove_branche i) g)) ] - g + tclTYPEOFTHEN graph_principle (fun sigma princ_type -> + let princ_infos = Tactics.compute_elim_sig sigma princ_type in + (* Then we get the number of argument of the function + and compute a fresh name for each of them + *) + let nb_fun_args = + Termops.nb_prod sigma (Proofview.Goal.concl g) - 2 + in + let args_names = + generate_fresh_id (Id.of_string "x") [] nb_fun_args + in + let ids = args_names @ pf_ids_of_hyps g in + (* and fresh names for res H and the principle (cf bug bug #1174) *) + let res, hres, graph_principle_id = + match generate_fresh_id (Id.of_string "z") ids 3 with + | [res; hres; graph_principle_id] -> (res, hres, graph_principle_id) + | _ -> assert false + in + let ids = res :: hres :: graph_principle_id :: ids in + (* we also compute fresh names for each hyptohesis of each branch + of the principle *) + let branches = List.rev princ_infos.branches in + let intro_pats = + List.map + (fun decl -> + List.map + (fun id -> id) + (generate_fresh_id (Id.of_string "y") ids + (Termops.nb_prod (Proofview.Goal.sigma g) + (RelDecl.get_type decl)))) + branches + in + (* We will need to change the function by its body + using [f_equation] if it is recursive (that is the graph is infinite + or unfold if the graph is finite + *) + let rewrite_tac j ids : unit Proofview.tactic = + let graph_def = graphs.(j) in + let infos = + match + find_Function_infos + (fst (destConst (Proofview.Goal.sigma g) funcs.(j))) + with + | None -> CErrors.user_err Pp.(str "No graph found") + | Some infos -> infos + in + if + infos.is_general + || Rtree.is_infinite Declareops.eq_recarg + graph_def.Declarations.mind_recargs + then + let eq_lemma = + try Option.get infos.equation_lemma + with Option.IsNone -> + CErrors.anomaly (Pp.str "Cannot find equation lemma.") + in + tclTHENLIST + [ tclMAP Simple.intro ids + ; Equality.rewriteLR (mkConst eq_lemma) + ; (* Don't forget to $\zeta$ normlize the term since the principles + have been $\zeta$-normalized *) + reduce + (Genredexpr.Cbv + {Redops.all_flags with Genredexpr.rDelta = false}) + Locusops.onConcl + ; generalize (List.map mkVar ids) + ; thin ids ] + else + unfold_in_concl + [ ( Locus.AllOccurrences + , Names.EvalConstRef + (fst (destConst (Proofview.Goal.sigma g) f)) ) ] + in + (* The proof of each branche itself *) + let ind_number = ref 0 in + let min_constr_number = ref 0 in + let prove_branch i this_branche_ids = + (* we fist compute the inductive corresponding to the branch *) + let this_ind_number = + let constructor_num = i - !min_constr_number in + let length = + Array.length graphs.(!ind_number).Declarations.mind_consnames + in + if constructor_num <= length then !ind_number + else begin + incr ind_number; + min_constr_number := !min_constr_number + length; + !ind_number + end + in + tclTHENLIST + [ (* we expand the definition of the function *) + observe_tac "rewrite_tac" + (rewrite_tac this_ind_number this_branche_ids) + ; (* introduce hypothesis with some rewrite *) + observe_tac "intros_with_rewrite (all)" (intros_with_rewrite ()) + ; (* The proof is (almost) complete *) + observe_tac "reflexivity" (reflexivity_with_destruct_cases ()) + ] + in + let params_names = fst (List.chop princ_infos.nparams args_names) in + let open EConstr in + let params = List.map mkVar params_names in + tclTHENLIST + [ tclMAP Simple.intro (args_names @ [res; hres]) + ; observe_tac "h_generalize" + (generalize + [ mkApp + ( applist (graph_principle, params) + , Array.map (fun c -> applist (c, params)) lemmas ) ]) + ; Simple.intro graph_principle_id + ; observe_tac "" + (tclTHENS + (observe_tac "elim" + (elim false None + (mkVar hres, Tactypes.NoBindings) + (Some (mkVar graph_principle_id, Tactypes.NoBindings)))) + (List.map_i + (fun i pat -> + observe_tac "prove_branch" (prove_branch i pat)) + 1 intro_pats)) ])) exception No_graph_found @@ -1523,9 +1509,7 @@ let derive_correctness (funs : Constr.pconstant list) (graphs : inductive list) let info = Declare.Info.make () in let cinfo = Declare.CInfo.make ~name:lem_id ~typ () in let lemma = Declare.Proof.start ~cinfo ~info !evd in - let lemma = - fst @@ Declare.Proof.by (Proofview.V82.tactic (proving_tac i)) lemma - in + let lemma = fst @@ Declare.Proof.by (proving_tac i) lemma in let (_ : _ list) = Declare.Proof.save_regular ~proof:lemma ~opaque:Vernacexpr.Transparent ~idopt:None @@ -1592,10 +1576,9 @@ let derive_correctness (funs : Constr.pconstant list) (graphs : inductive list) let lemma = fst (Declare.Proof.by - (Proofview.V82.tactic - (observe_tac - ("prove completeness (" ^ Id.to_string f_id ^ ")") - (proving_tac i))) + (observe_tac + ("prove completeness (" ^ Id.to_string f_id ^ ")") + (proving_tac i)) lemma) in let (_ : _ list) = @@ -1877,13 +1860,13 @@ let do_generate_principle_aux pconstants on_error register_built let warn_cannot_define_graph = CWarnings.create ~name:"funind-cannot-define-graph" ~category:"funind" (fun (names, error) -> - Pp.(strbrk "Cannot define graph(s) for " ++ h 1 names ++ error)) + Pp.(strbrk "Cannot define graph(s) for " ++ hv 1 names ++ error)) let warn_cannot_define_principle = CWarnings.create ~name:"funind-cannot-define-principle" ~category:"funind" (fun (names, error) -> Pp.( - strbrk "Cannot define induction principle(s) for " ++ h 1 names ++ error)) + strbrk "Cannot define induction principle(s) for " ++ hv 1 names ++ error)) let warning_error names e = let e_explain e = @@ -1915,7 +1898,7 @@ let error_error names e = CErrors.user_err Pp.( str "Cannot define graph(s) for " - ++ h 1 + ++ hv 1 (prlist_with_sep (fun _ -> str "," ++ spc ()) Ppconstr.pr_id names) ++ e_explain e) | _ -> raise e diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index af53f16e1f..0179215d6a 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -394,10 +394,7 @@ let jmeq_refl () = @@ Coqlib.lib_ref "core.JMeq.refl" with e when CErrors.noncritical e -> raise (ToShow e) -let h_intros l = - Proofview.V82.of_tactic - (Tacticals.New.tclMAP (fun x -> Tactics.Simple.intro x) l) - +let h_intros l = Tacticals.New.tclMAP (fun x -> Tactics.Simple.intro x) l let h_id = Id.of_string "h" let hrec_id = Id.of_string "hrec" @@ -428,13 +425,12 @@ let evaluable_of_global_reference r = | _ -> assert false let list_rewrite (rev : bool) (eqs : (EConstr.constr * bool) list) = - let open Tacticals in + let open Tacticals.New in (tclREPEAT (List.fold_right (fun (eq, b) i -> tclORELSE - (Proofview.V82.of_tactic - ((if b then Equality.rewriteLR else Equality.rewriteRL) eq)) + ((if b then Equality.rewriteLR else Equality.rewriteRL) eq) i) (if rev then List.rev eqs else eqs) (tclFAIL 0 (mt ()))) [@ocaml.warning "-3"]) diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 396db55458..7b7044fdaf 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -90,7 +90,7 @@ exception Defining_principle of exn exception ToShow of exn val is_strict_tcc : unit -> bool -val h_intros : Names.Id.t list -> Tacmach.tactic +val h_intros : Names.Id.t list -> unit Proofview.tactic val h_id : Names.Id.t val hrec_id : Names.Id.t val acc_inv_id : EConstr.constr Util.delayed @@ -102,7 +102,7 @@ val well_founded : EConstr.constr Util.delayed val evaluable_of_global_reference : GlobRef.t -> Names.evaluable_global_reference -val list_rewrite : bool -> (EConstr.constr * bool) list -> Tacmach.tactic +val list_rewrite : bool -> (EConstr.constr * bool) list -> unit Proofview.tactic val decompose_lam_n : Evd.evar_map diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 253c95fa67..33076a876b 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -23,8 +23,7 @@ open Nameops open CErrors open Util open UnivGen -open Tacticals -open Tacmach +open Tacticals.New open Tactics open Nametab open Tacred @@ -94,7 +93,7 @@ let const_of_ref = function (* Generic values *) let pf_get_new_ids idl g = - let ids = pf_ids_of_hyps g in + let ids = Tacmach.New.pf_ids_of_hyps g in let ids = Id.Set.of_list ids in List.fold_right (fun id acc -> @@ -105,8 +104,9 @@ let next_ident_away_in_goal ids avoid = next_ident_away_in_goal ids (Id.Set.of_list avoid) let compute_renamed_type gls id = - rename_bound_vars_as_displayed (project gls) (*no avoid*) Id.Set.empty - (*no rels*) [] (pf_get_hyp_typ gls id) + rename_bound_vars_as_displayed (Proofview.Goal.sigma gls) + (*no avoid*) Id.Set.empty (*no rels*) [] + (Tacmach.New.pf_get_hyp_typ id gls) let h'_id = Id.of_string "h'" let teq_id = Id.of_string "teq" @@ -218,20 +218,6 @@ let (declare_f : fun f_id kind input_type fterm_ref -> declare_fun f_id kind (value_f input_type fterm_ref) -let observe_tclTHENLIST s tacl = - if do_observe () then - let rec aux n = function - | [] -> tclIDTAC - | [tac] -> - observe_tac (fun env sigma -> s env sigma ++ spc () ++ int n) tac - | tac :: tacl -> - observe_tac - (fun env sigma -> s env sigma ++ spc () ++ int n) - (tclTHEN tac (aux (succ n) tacl)) - in - aux 0 tacl - else tclTHENLIST tacl - module New = struct open Tacticals.New @@ -364,11 +350,11 @@ type ('a, 'b) journey_info_tac = -> (* the arguments of the constructor *) 'b infos -> (* infos of the caller *) - ('b infos -> tactic) + ('b infos -> unit Proofview.tactic) -> (* the continuation tactic of the caller *) 'b infos -> (* argument of the tactic *) - tactic + unit Proofview.tactic (* journey_info : specifies the actions to do on the different term constructors during the traveling of the term *) @@ -376,7 +362,9 @@ type journey_info = { letiN : (Name.t * constr * types * constr, constr) journey_info_tac ; lambdA : (Name.t * types * constr, constr) journey_info_tac ; casE : - ((constr infos -> tactic) -> constr infos -> tactic) + ( (constr infos -> unit Proofview.tactic) + -> constr infos + -> unit Proofview.tactic) -> ( case_info * constr * (constr, EInstance.t) case_invert @@ -397,132 +385,131 @@ let add_vars sigma forbidden e = in aux forbidden e -let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = - fun g -> - let rev_context, b = decompose_lam_n (project g) nb_lam e in - let ids = - List.fold_left - (fun acc (na, _) -> - let pre_id = - match na.binder_name with Name x -> x | Anonymous -> ano_id - in - pre_id :: acc) - [] rev_context - in - let rev_ids = pf_get_new_ids (List.rev ids) g in - let new_b = substl (List.map mkVar rev_ids) b in - observe_tclTHENLIST - (fun _ _ -> str "treat_case1") - [ h_intros (List.rev rev_ids) - ; Proofview.V82.of_tactic (intro_using teq_id) - ; onLastHypId (fun heq -> - observe_tclTHENLIST - (fun _ _ -> str "treat_case2") - [ Proofview.V82.of_tactic (clear to_intros) - ; h_intros to_intros - ; (fun g' -> - let ty_teq = pf_get_hyp_typ g' heq in - let teq_lhs, teq_rhs = - let _, args = - try destApp (project g') ty_teq - with DestKO -> assert false - in - (args.(1), args.(2)) - in - let new_b' = - Termops.replace_term (project g') teq_lhs teq_rhs new_b - in - let new_infos = - { infos with - info = new_b' - ; eqs = heq :: infos.eqs - ; forbidden_ids = - ( if forbid_new_ids then - add_vars (project g') infos.forbidden_ids new_b' - else infos.forbidden_ids ) } - in - finalize_tac new_infos g') ]) ] - g - -let rec travel_aux jinfo continuation_tac (expr_info : constr infos) g = - let sigma = project g in - let env = pf_env g in - match EConstr.kind sigma expr_info.info with - | CoFix _ | Fix _ -> - user_err Pp.(str "Function cannot treat local fixpoint or cofixpoint") - | Array _ -> user_err Pp.(str "Function cannot treat arrays") - | Proj _ -> user_err Pp.(str "Function cannot treat projections") - | LetIn (na, b, t, e) -> - let new_continuation_tac = - jinfo.letiN (na.binder_name, b, t, e) expr_info continuation_tac - in - travel jinfo new_continuation_tac - {expr_info with info = b; is_final = false} - g - | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") - | Prod _ -> ( - try - check_not_nested env sigma - (expr_info.f_id :: expr_info.forbidden_ids) - expr_info.info; - jinfo.otherS () expr_info continuation_tac expr_info g - with e when CErrors.noncritical e -> - user_err ~hdr:"Recdef.travel" - ( str "the term " - ++ Printer.pr_leconstr_env env sigma expr_info.info - ++ str " can not contain a recursive call to " - ++ Id.print expr_info.f_id ) ) - | Lambda (n, t, b) -> ( - try - check_not_nested env sigma - (expr_info.f_id :: expr_info.forbidden_ids) - expr_info.info; - jinfo.otherS () expr_info continuation_tac expr_info g - with e when CErrors.noncritical e -> - user_err ~hdr:"Recdef.travel" - ( str "the term " - ++ Printer.pr_leconstr_env env sigma expr_info.info - ++ str " can not contain a recursive call to " - ++ Id.print expr_info.f_id ) ) - | Case (ci, t, iv, a, l) -> - let continuation_tac_a = - jinfo.casE (travel jinfo) (ci, t, iv, a, l) expr_info continuation_tac - in - travel jinfo continuation_tac_a - {expr_info with info = a; is_main_branch = false; is_final = false} - g - | App _ -> ( - let f, args = decompose_app sigma expr_info.info in - if EConstr.eq_constr sigma f expr_info.f_constr then - jinfo.app_reC (f, args) expr_info continuation_tac expr_info g - else - match EConstr.kind sigma f with - | App _ -> assert false (* f is coming from a decompose_app *) - | Const _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ - |Prod _ | Var _ -> - let new_infos = {expr_info with info = (f, args)} in +let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : + unit Proofview.tactic = + Proofview.Goal.enter (fun g -> + let rev_context, b = decompose_lam_n (Proofview.Goal.sigma g) nb_lam e in + let ids = + List.fold_left + (fun acc (na, _) -> + let pre_id = + match na.binder_name with Name x -> x | Anonymous -> ano_id + in + pre_id :: acc) + [] rev_context + in + let rev_ids = pf_get_new_ids (List.rev ids) g in + let new_b = substl (List.map mkVar rev_ids) b in + New.observe_tclTHENLIST + (fun _ _ -> str "treat_case1") + [ h_intros (List.rev rev_ids) + ; intro_using_then teq_id (fun _ -> Proofview.tclUNIT ()) + ; Tacticals.New.onLastHypId (fun heq -> + New.observe_tclTHENLIST + (fun _ _ -> str "treat_case2") + [ clear to_intros + ; h_intros to_intros + ; Proofview.Goal.enter (fun g' -> + let sigma = Proofview.Goal.sigma g' in + let ty_teq = Tacmach.New.pf_get_hyp_typ heq g' in + let teq_lhs, teq_rhs = + let _, args = + try destApp sigma ty_teq with DestKO -> assert false + in + (args.(1), args.(2)) + in + let new_b' = + Termops.replace_term sigma teq_lhs teq_rhs new_b + in + let new_infos = + { infos with + info = new_b' + ; eqs = heq :: infos.eqs + ; forbidden_ids = + ( if forbid_new_ids then + add_vars sigma infos.forbidden_ids new_b' + else infos.forbidden_ids ) } + in + finalize_tac new_infos) ]) ]) + +let rec travel_aux jinfo continuation_tac (expr_info : constr infos) = + Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma g in + let env = Proofview.Goal.env g in + match EConstr.kind sigma expr_info.info with + | CoFix _ | Fix _ -> + user_err Pp.(str "Function cannot treat local fixpoint or cofixpoint") + | Array _ -> user_err Pp.(str "Function cannot treat arrays") + | Proj _ -> user_err Pp.(str "Function cannot treat projections") + | LetIn (na, b, t, e) -> let new_continuation_tac = - jinfo.apP (f, args) expr_info continuation_tac + jinfo.letiN (na.binder_name, b, t, e) expr_info continuation_tac + in + travel jinfo new_continuation_tac + {expr_info with info = b; is_final = false} + | Rel _ -> anomaly (Pp.str "Free var in goal conclusion!") + | Prod _ -> ( + try + check_not_nested env sigma + (expr_info.f_id :: expr_info.forbidden_ids) + expr_info.info; + jinfo.otherS () expr_info continuation_tac expr_info + with e when CErrors.noncritical e -> + user_err ~hdr:"Recdef.travel" + ( str "the term " + ++ Printer.pr_leconstr_env env sigma expr_info.info + ++ str " can not contain a recursive call to " + ++ Id.print expr_info.f_id ) ) + | Lambda (n, t, b) -> ( + try + check_not_nested env sigma + (expr_info.f_id :: expr_info.forbidden_ids) + expr_info.info; + jinfo.otherS () expr_info continuation_tac expr_info + with e when CErrors.noncritical e -> + user_err ~hdr:"Recdef.travel" + ( str "the term " + ++ Printer.pr_leconstr_env env sigma expr_info.info + ++ str " can not contain a recursive call to " + ++ Id.print expr_info.f_id ) ) + | Case (ci, t, iv, a, l) -> + let continuation_tac_a = + jinfo.casE (travel jinfo) (ci, t, iv, a, l) expr_info continuation_tac in - travel_args jinfo expr_info.is_main_branch new_continuation_tac - new_infos g - | Case _ -> - user_err ~hdr:"Recdef.travel" - ( str "the term " - ++ Printer.pr_leconstr_env env sigma expr_info.info - ++ str - " can not contain an applied match (See Limitation in Section \ - 2.3 of refman)" ) - | _ -> - anomaly - ( Pp.str "travel_aux : unexpected " - ++ Printer.pr_leconstr_env env sigma expr_info.info - ++ Pp.str "." ) ) - | Cast (t, _, _) -> travel jinfo continuation_tac {expr_info with info = t} g - | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ | Int _ - |Float _ -> - let new_continuation_tac = jinfo.otherS () expr_info continuation_tac in - new_continuation_tac expr_info g + travel jinfo continuation_tac_a + {expr_info with info = a; is_main_branch = false; is_final = false} + | App _ -> ( + let f, args = decompose_app sigma expr_info.info in + if EConstr.eq_constr sigma f expr_info.f_constr then + jinfo.app_reC (f, args) expr_info continuation_tac expr_info + else + match EConstr.kind sigma f with + | App _ -> assert false (* f is coming from a decompose_app *) + | Const _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ + |Prod _ | Var _ -> + let new_infos = {expr_info with info = (f, args)} in + let new_continuation_tac = + jinfo.apP (f, args) expr_info continuation_tac + in + travel_args jinfo expr_info.is_main_branch new_continuation_tac + new_infos + | Case _ -> + user_err ~hdr:"Recdef.travel" + ( str "the term " + ++ Printer.pr_leconstr_env env sigma expr_info.info + ++ str + " can not contain an applied match (See Limitation in \ + Section 2.3 of refman)" ) + | _ -> + anomaly + ( Pp.str "travel_aux : unexpected " + ++ Printer.pr_leconstr_env env sigma expr_info.info + ++ Pp.str "." ) ) + | Cast (t, _, _) -> travel jinfo continuation_tac {expr_info with info = t} + | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ + |Int _ | Float _ -> + let new_continuation_tac = jinfo.otherS () expr_info continuation_tac in + new_continuation_tac expr_info) and travel_args jinfo is_final continuation_tac infos = let f_args', args = infos.info in @@ -537,135 +524,131 @@ and travel_args jinfo is_final continuation_tac infos = travel jinfo new_continuation_tac {infos with info = arg; is_final = false} and travel jinfo continuation_tac expr_info = - observe_tac + New.observe_tac (fun env sigma -> str jinfo.message ++ Printer.pr_leconstr_env env sigma expr_info.info) (travel_aux jinfo continuation_tac expr_info) (* Termination proof *) -let rec prove_lt hyple g = - let sigma = project g in - begin - try - let varx, varz = - match decompose_app sigma (pf_concl g) with - | _, x :: z :: _ when isVar sigma x && isVar sigma z -> (x, z) - | _ -> assert false - in - let h = - List.find - (fun id -> - match decompose_app sigma (pf_get_hyp_typ g id) with - | _, t :: _ -> EConstr.eq_constr sigma t varx - | _ -> false) - hyple - in - let y = - List.hd (List.tl (snd (decompose_app sigma (pf_get_hyp_typ g h)))) - in - observe_tclTHENLIST - (fun _ _ -> str "prove_lt1") - [ Proofview.V82.of_tactic - (apply (mkApp (le_lt_trans (), [|varx; y; varz; mkVar h|]))) - ; observe_tac (fun _ _ -> str "prove_lt") (prove_lt hyple) ] - with Not_found -> - observe_tclTHENLIST - (fun _ _ -> str "prove_lt2") - [ Proofview.V82.of_tactic (apply (delayed_force lt_S_n)) - ; observe_tac - (fun _ _ -> str "assumption: " ++ Printer.pr_goal g) - (Proofview.V82.of_tactic assumption) ] - end - g - -let rec destruct_bounds_aux infos (bound, hyple, rechyps) lbounds g = - match lbounds with - | [] -> - let ids = pf_ids_of_hyps g in - let s_max = mkApp (delayed_force coq_S, [|bound|]) in - let k = next_ident_away_in_goal k_id ids in - let ids = k :: ids in - let h' = next_ident_away_in_goal h'_id ids in - let ids = h' :: ids in - let def = next_ident_away_in_goal def_id ids in - observe_tclTHENLIST - (fun _ _ -> str "destruct_bounds_aux1") - [ Proofview.V82.of_tactic (split (ImplicitBindings [s_max])) - ; Proofview.V82.of_tactic - (intro_then (fun id -> - Proofview.V82.tactic - (observe_tac - (fun _ _ -> str "destruct_bounds_aux") - (tclTHENS - (Proofview.V82.of_tactic (simplest_case (mkVar id))) - [ observe_tclTHENLIST - (fun _ _ -> str "") - [ Proofview.V82.of_tactic (intro_using h_id) - ; Proofview.V82.of_tactic - (simplest_elim - (mkApp (delayed_force lt_n_O, [|s_max|]))) - ; Proofview.V82.of_tactic default_full_auto ] - ; observe_tclTHENLIST - (fun _ _ -> str "destruct_bounds_aux2") - [ observe_tac - (fun _ _ -> str "clearing k ") - (Proofview.V82.of_tactic (clear [id])) - ; h_intros [k; h'; def] - ; observe_tac - (fun _ _ -> str "simple_iter") - (Proofview.V82.of_tactic - (simpl_iter Locusops.onConcl)) - ; observe_tac - (fun _ _ -> str "unfold functional") - (Proofview.V82.of_tactic - (unfold_in_concl - [ ( Locus.OnlyOccurrences [1] - , evaluable_of_global_reference - infos.func ) ])) - ; observe_tclTHENLIST - (fun _ _ -> str "test") - [ list_rewrite true - (List.fold_right - (fun e acc -> (mkVar e, true) :: acc) - infos.eqs - (List.map (fun e -> (e, true)) rechyps)) - ; (* list_rewrite true *) - (* (List.map (fun e -> (mkVar e,true)) infos.eqs) *) - (* ; *) - observe_tac - (fun _ _ -> str "finishing") - (tclORELSE - (Proofview.V82.of_tactic - intros_reflexivity) - (observe_tac - (fun _ _ -> str "calling prove_lt") - (prove_lt hyple))) ] ] ])))) ] - g - | (_, v_bound) :: l -> - observe_tclTHENLIST - (fun _ _ -> str "destruct_bounds_aux3") - [ Proofview.V82.of_tactic (simplest_elim (mkVar v_bound)) - ; Proofview.V82.of_tactic (clear [v_bound]) - ; tclDO 2 (Proofview.V82.of_tactic intro) - ; onNthHypId 1 (fun p_hyp -> - onNthHypId 2 (fun p -> - observe_tclTHENLIST - (fun _ _ -> str "destruct_bounds_aux4") - [ Proofview.V82.of_tactic - (simplest_elim - (mkApp (delayed_force max_constr, [|bound; mkVar p|]))) - ; tclDO 3 (Proofview.V82.of_tactic intro) - ; onNLastHypsId 3 (fun lids -> - match lids with - | [hle2; hle1; pmax] -> - destruct_bounds_aux infos - ( mkVar pmax - , hle1 :: hle2 :: hyple - , mkVar p_hyp :: rechyps ) - l - | _ -> assert false) ])) ] - g +let rec prove_lt hyple = + Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma g in + try + let varx, varz = + match decompose_app sigma (Proofview.Goal.concl g) with + | _, x :: z :: _ when isVar sigma x && isVar sigma z -> (x, z) + | _ -> assert false + in + let h = + List.find + (fun id -> + match decompose_app sigma (Tacmach.New.pf_get_hyp_typ id g) with + | _, t :: _ -> EConstr.eq_constr sigma t varx + | _ -> false) + hyple + in + let y = + List.hd + (List.tl + (snd (decompose_app sigma (Tacmach.New.pf_get_hyp_typ h g)))) + in + New.observe_tclTHENLIST + (fun _ _ -> str "prove_lt1") + [ apply (mkApp (le_lt_trans (), [|varx; y; varz; mkVar h|])) + ; New.observe_tac (fun _ _ -> str "prove_lt") (prove_lt hyple) ] + with Not_found -> + New.observe_tclTHENLIST + (fun _ _ -> str "prove_lt2") + [ apply (delayed_force lt_S_n) + ; New.observe_tac + (fun _ _ -> + str "assumption: " + ++ Printer.pr_goal Evd.{it = Proofview.Goal.goal g; sigma}) + assumption ]) + +let rec destruct_bounds_aux infos (bound, hyple, rechyps) lbounds = + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + match lbounds with + | [] -> + let ids = Tacmach.New.pf_ids_of_hyps g in + let s_max = mkApp (delayed_force coq_S, [|bound|]) in + let k = next_ident_away_in_goal k_id ids in + let ids = k :: ids in + let h' = next_ident_away_in_goal h'_id ids in + let ids = h' :: ids in + let def = next_ident_away_in_goal def_id ids in + New.observe_tclTHENLIST + (fun _ _ -> str "destruct_bounds_aux1") + [ split (ImplicitBindings [s_max]) + ; intro_then (fun id -> + New.observe_tac + (fun _ _ -> str "destruct_bounds_aux") + (tclTHENS + (simplest_case (mkVar id)) + [ New.observe_tclTHENLIST + (fun _ _ -> str "") + [ intro_using_then h_id + (* We don't care about the refreshed name, + accessed only through auto? *) + (fun _ -> Proofview.tclUNIT ()) + ; simplest_elim + (mkApp (delayed_force lt_n_O, [|s_max|])) + ; default_full_auto ] + ; New.observe_tclTHENLIST + (fun _ _ -> str "destruct_bounds_aux2") + [ New.observe_tac + (fun _ _ -> str "clearing k ") + (clear [id]) + ; h_intros [k; h'; def] + ; New.observe_tac + (fun _ _ -> str "simple_iter") + (simpl_iter Locusops.onConcl) + ; New.observe_tac + (fun _ _ -> str "unfold functional") + (unfold_in_concl + [ ( Locus.OnlyOccurrences [1] + , evaluable_of_global_reference infos.func ) + ]) + ; New.observe_tclTHENLIST + (fun _ _ -> str "test") + [ list_rewrite true + (List.fold_right + (fun e acc -> (mkVar e, true) :: acc) + infos.eqs + (List.map (fun e -> (e, true)) rechyps)) + ; (* list_rewrite true *) + (* (List.map (fun e -> (mkVar e,true)) infos.eqs) *) + (* ; *) + New.observe_tac + (fun _ _ -> str "finishing") + (tclORELSE intros_reflexivity + (New.observe_tac + (fun _ _ -> str "calling prove_lt") + (prove_lt hyple))) ] ] ])) ] + | (_, v_bound) :: l -> + New.observe_tclTHENLIST + (fun _ _ -> str "destruct_bounds_aux3") + [ simplest_elim (mkVar v_bound) + ; clear [v_bound] + ; tclDO 2 intro + ; onNthHypId 1 (fun p_hyp -> + onNthHypId 2 (fun p -> + New.observe_tclTHENLIST + (fun _ _ -> str "destruct_bounds_aux4") + [ simplest_elim + (mkApp (delayed_force max_constr, [|bound; mkVar p|])) + ; tclDO 3 intro + ; onNLastHypsId 3 (fun lids -> + match lids with + | [hle2; hle1; pmax] -> + destruct_bounds_aux infos + ( mkVar pmax + , hle1 :: hle2 :: hyple + , mkVar p_hyp :: rechyps ) + l + | _ -> assert false) ])) ]) let destruct_bounds infos = destruct_bounds_aux infos @@ -674,47 +657,51 @@ let destruct_bounds infos = let terminate_app f_and_args expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch then - observe_tclTHENLIST + New.observe_tclTHENLIST (fun _ _ -> str "terminate_app1") [ continuation_tac infos - ; observe_tac + ; New.observe_tac (fun _ _ -> str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))) - ; observe_tac + (split (ImplicitBindings [infos.info])) + ; New.observe_tac (fun _ _ -> str "destruct_bounds (1)") (destruct_bounds infos) ] else continuation_tac infos let terminate_others _ expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch then - observe_tclTHENLIST + New.observe_tclTHENLIST (fun _ _ -> str "terminate_others") [ continuation_tac infos - ; observe_tac + ; New.observe_tac (fun _ _ -> str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))) - ; observe_tac (fun _ _ -> str "destruct_bounds") (destruct_bounds infos) - ] + (split (ImplicitBindings [infos.info])) + ; New.observe_tac + (fun _ _ -> str "destruct_bounds") + (destruct_bounds infos) ] else continuation_tac infos -let terminate_letin (na, b, t, e) expr_info continuation_tac info g = - let sigma = project g in - let env = pf_env g in - let new_e = subst1 info.info e in - let new_forbidden = - let forbid = - try - check_not_nested env sigma (expr_info.f_id :: expr_info.forbidden_ids) b; - true - with e when CErrors.noncritical e -> false - in - if forbid then - match na with - | Anonymous -> info.forbidden_ids - | Name id -> id :: info.forbidden_ids - else info.forbidden_ids - in - continuation_tac {info with info = new_e; forbidden_ids = new_forbidden} g +let terminate_letin (na, b, t, e) expr_info continuation_tac info = + Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma g in + let env = Proofview.Goal.env g in + let new_e = subst1 info.info e in + let new_forbidden = + let forbid = + try + check_not_nested env sigma + (expr_info.f_id :: expr_info.forbidden_ids) + b; + true + with e when CErrors.noncritical e -> false + in + if forbid then + match na with + | Anonymous -> info.forbidden_ids + | Name id -> id :: info.forbidden_ids + else info.forbidden_ids + in + continuation_tac {info with info = new_e; forbidden_ids = new_forbidden}) let pf_type c tac = let open Tacticals.New in @@ -724,9 +711,6 @@ let pf_type c tac = let evars, ty = Typing.type_of env sigma c in tclTHEN (Proofview.Unsafe.tclEVARS evars) (tac ty)) -let pf_type c tac = - Proofview.V82.of_tactic (pf_type c (fun ty -> Proofview.V82.tactic (tac ty))) - let pf_typel l tac = let rec aux tys l = match l with @@ -740,8 +724,8 @@ let pf_typel l tac = modified hypotheses are generalized in the process and should be introduced back later; the result is the pair of the tactic and the list of hypotheses that have been generalized and cleared. *) -let mkDestructEq not_on_hyp expr g = - let hyps = pf_hyps g in +let mkDestructEq not_on_hyp env sigma expr = + let hyps = EConstr.named_context env in let to_revert = Util.List.map_filter (fun decl -> @@ -749,170 +733,169 @@ let mkDestructEq not_on_hyp expr g = let id = get_id decl in if Id.List.mem id not_on_hyp - || not (Termops.dependent (project g) expr (get_type decl)) + || not (Termops.dependent sigma expr (get_type decl)) then None else Some id) hyps in let to_revert_constr = List.rev_map mkVar to_revert in - let g, type_of_expr = tac_type_of g expr in + let sigma, type_of_expr = Typing.type_of env sigma expr in let new_hyps = mkApp (Lazy.force refl_equal, [|type_of_expr; expr|]) :: to_revert_constr in let tac = pf_typel new_hyps (fun _ -> - observe_tclTHENLIST + New.observe_tclTHENLIST (fun _ _ -> str "mkDestructEq") - [ Proofview.V82.of_tactic (generalize new_hyps) - ; (fun g2 -> - let changefun patvars env sigma = - pattern_occs - [(Locus.AllOccurrencesBut [1], expr)] - (pf_env g2) sigma (pf_concl g2) - in - Proofview.V82.of_tactic - (change_in_concl ~check:true None changefun) - g2) - ; Proofview.V82.of_tactic (simplest_case expr) ]) + [ generalize new_hyps + ; Proofview.Goal.enter (fun g2 -> + let changefun patvars env sigma = + pattern_occs + [(Locus.AllOccurrencesBut [1], expr)] + (Proofview.Goal.env g2) sigma (Proofview.Goal.concl g2) + in + change_in_concl ~check:true None changefun) + ; simplest_case expr ]) in - (g, tac, to_revert) + (sigma, tac, to_revert) let terminate_case next_step (ci, a, iv, t, l) expr_info continuation_tac infos - g = - let sigma = project g in - let env = pf_env g in - let f_is_present = - try - check_not_nested env sigma (expr_info.f_id :: expr_info.forbidden_ids) a; - false - with e when CErrors.noncritical e -> true - in - let a' = infos.info in - let new_info = - { infos with - info = mkCase (ci, t, iv, a', l) - ; is_main_branch = expr_info.is_main_branch - ; is_final = expr_info.is_final } - in - let g, destruct_tac, rev_to_thin_intro = - mkDestructEq [expr_info.rec_arg_id] a' g - in - let to_thin_intro = List.rev rev_to_thin_intro in - observe_tac - (fun _ _ -> - str "treating cases (" - ++ int (Array.length l) - ++ str ")" ++ spc () - ++ Printer.pr_leconstr_env (pf_env g) sigma a') - ( try - tclTHENS destruct_tac - (List.map_i - (fun i e -> - observe_tac - (fun _ _ -> str "do treat case") - (treat_case f_is_present to_thin_intro - (next_step continuation_tac) - ci.ci_cstr_ndecls.(i) e new_info)) - 0 (Array.to_list l)) - with - | UserError (Some "Refiner.thensn_tac3", _) - |UserError (Some "Refiner.tclFAIL_s", _) - -> - observe_tac - (fun _ _ -> - str "is computable " - ++ Printer.pr_leconstr_env env sigma new_info.info) - (next_step continuation_tac - { new_info with - info = - Reductionops.nf_betaiotazeta (pf_env g) sigma new_info.info }) - ) - g - -let terminate_app_rec (f, args) expr_info continuation_tac _ g = - let sigma = project g in - let env = pf_env g in - List.iter - (check_not_nested env sigma (expr_info.f_id :: expr_info.forbidden_ids)) - args; - try - let v = - List.assoc_f - (List.equal (EConstr.eq_constr sigma)) - args expr_info.args_assoc - in - let new_infos = {expr_info with info = v} in - observe_tclTHENLIST - (fun _ _ -> str "terminate_app_rec") - [ continuation_tac new_infos - ; ( if expr_info.is_final && expr_info.is_main_branch then - observe_tclTHENLIST - (fun _ _ -> str "terminate_app_rec1") - [ observe_tac - (fun _ _ -> str "first split") - (Proofview.V82.of_tactic - (split (ImplicitBindings [new_infos.info]))) - ; observe_tac - (fun _ _ -> str "destruct_bounds (3)") - (destruct_bounds new_infos) ] - else tclIDTAC ) ] - g - with Not_found -> - observe_tac - (fun _ _ -> str "terminate_app_rec not found") - (tclTHENS - (Proofview.V82.of_tactic - (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 - ; onNthHypId 1 (fun v_bound -> - onNthHypId 2 (fun v -> - let new_infos = - { expr_info with - info = mkVar v - ; values_and_bounds = - (v, v_bound) :: expr_info.values_and_bounds - ; args_assoc = (args, mkVar v) :: expr_info.args_assoc - } - in - observe_tclTHENLIST - (fun _ _ -> str "terminate_app_rec3") - [ continuation_tac new_infos - ; ( if expr_info.is_final && expr_info.is_main_branch - then - observe_tclTHENLIST - (fun _ _ -> str "terminate_app_rec4") - [ observe_tac - (fun _ _ -> str "first split") - (Proofview.V82.of_tactic - (split - (ImplicitBindings [new_infos.info]))) - ; observe_tac - (fun _ _ -> str "destruct_bounds (2)") - (destruct_bounds new_infos) ] - else tclIDTAC ) ])) ] - ; observe_tac - (fun _ _ -> str "proving decreasing") - (tclTHENS (* proof of args < formal args *) - (Proofview.V82.of_tactic (apply (Lazy.force expr_info.acc_inv))) - [ observe_tac - (fun _ _ -> str "assumption") - (Proofview.V82.of_tactic assumption) - ; observe_tclTHENLIST - (fun _ _ -> str "terminate_app_rec5") - [ tclTRY - (list_rewrite true - (List.map (fun e -> (mkVar e, true)) expr_info.eqs)) - ; Proofview.V82.of_tactic - @@ tclUSER expr_info.concl_tac true - (Some - ( expr_info.ih :: expr_info.acc_id - :: (fun (x, y) -> y) - (List.split expr_info.values_and_bounds) )) - ] ]) ]) - g + = + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma g in + let env = Proofview.Goal.env g in + let f_is_present = + try + check_not_nested env sigma + (expr_info.f_id :: expr_info.forbidden_ids) + a; + false + with e when CErrors.noncritical e -> true + in + let a' = infos.info in + let new_info = + { infos with + info = mkCase (ci, t, iv, a', l) + ; is_main_branch = expr_info.is_main_branch + ; is_final = expr_info.is_final } + in + let sigma, destruct_tac, rev_to_thin_intro = + mkDestructEq [expr_info.rec_arg_id] env sigma a' + in + let to_thin_intro = List.rev rev_to_thin_intro in + New.observe_tac + (fun _ _ -> + str "treating cases (" + ++ int (Array.length l) + ++ str ")" ++ spc () + ++ Printer.pr_leconstr_env env sigma a') + ( try + tclTHENS destruct_tac + (List.map_i + (fun i e -> + New.observe_tac + (fun _ _ -> str "do treat case") + (treat_case f_is_present to_thin_intro + (next_step continuation_tac) + ci.ci_cstr_ndecls.(i) e new_info)) + 0 (Array.to_list l)) + with + | UserError (Some "Refiner.thensn_tac3", _) + |UserError (Some "Refiner.tclFAIL_s", _) + -> + New.observe_tac + (fun _ _ -> + str "is computable " + ++ Printer.pr_leconstr_env env sigma new_info.info) + (next_step continuation_tac + { new_info with + info = Reductionops.nf_betaiotazeta env sigma new_info.info + }) )) + +let terminate_app_rec (f, args) expr_info continuation_tac _ = + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma g in + let env = Proofview.Goal.env g in + List.iter + (check_not_nested env sigma (expr_info.f_id :: expr_info.forbidden_ids)) + args; + try + let v = + List.assoc_f + (List.equal (EConstr.eq_constr sigma)) + args expr_info.args_assoc + in + let new_infos = {expr_info with info = v} in + New.observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec") + [ continuation_tac new_infos + ; ( if expr_info.is_final && expr_info.is_main_branch then + New.observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec1") + [ New.observe_tac + (fun _ _ -> str "first split") + (split (ImplicitBindings [new_infos.info])) + ; New.observe_tac + (fun _ _ -> str "destruct_bounds (3)") + (destruct_bounds new_infos) ] + else Proofview.tclUNIT () ) ] + with Not_found -> + New.observe_tac + (fun _ _ -> str "terminate_app_rec not found") + (tclTHENS + (simplest_elim (mkApp (mkVar expr_info.ih, Array.of_list args))) + [ New.observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec2") + [ intro_using_then rec_res_id + (* refreshed name gotten from onNthHypId *) + (fun _ -> Proofview.tclUNIT ()) + ; intro + ; onNthHypId 1 (fun v_bound -> + onNthHypId 2 (fun v -> + let new_infos = + { expr_info with + info = mkVar v + ; values_and_bounds = + (v, v_bound) :: expr_info.values_and_bounds + ; args_assoc = + (args, mkVar v) :: expr_info.args_assoc } + in + New.observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec3") + [ continuation_tac new_infos + ; ( if + expr_info.is_final && expr_info.is_main_branch + then + New.observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec4") + [ New.observe_tac + (fun _ _ -> str "first split") + (split + (ImplicitBindings [new_infos.info])) + ; New.observe_tac + (fun _ _ -> str "destruct_bounds (2)") + (destruct_bounds new_infos) ] + else Proofview.tclUNIT () ) ])) ] + ; New.observe_tac + (fun _ _ -> str "proving decreasing") + (tclTHENS (* proof of args < formal args *) + (apply (Lazy.force expr_info.acc_inv)) + [ New.observe_tac (fun _ _ -> str "assumption") assumption + ; New.observe_tclTHENLIST + (fun _ _ -> str "terminate_app_rec5") + [ tclTRY + (list_rewrite true + (List.map + (fun e -> (mkVar e, true)) + expr_info.eqs)) + ; tclUSER expr_info.concl_tac true + (Some + ( expr_info.ih :: expr_info.acc_id + :: (fun (x, y) -> y) + (List.split expr_info.values_and_bounds) )) + ] ]) ])) let terminate_info = { message = "prove_terminate with term " @@ -928,194 +911,197 @@ let prove_terminate = travel terminate_info (* Equation proof *) let equation_case next_step case expr_info continuation_tac infos = - observe_tac + New.observe_tac (fun _ _ -> str "equation case") (terminate_case next_step case expr_info continuation_tac infos) -let rec prove_le g = - let sigma = project g in - let x, z = - let _, args = decompose_app sigma (pf_concl g) in - (List.hd args, List.hd (List.tl args)) - in - tclFIRST - [ Proofview.V82.of_tactic assumption - ; Proofview.V82.of_tactic (apply (delayed_force le_n)) - ; begin - try - let matching_fun c = - match EConstr.kind sigma c with - | App (c, [|x0; _|]) -> - EConstr.isVar sigma x0 - && Id.equal (destVar sigma x0) (destVar sigma x) - && EConstr.isRefX sigma (le ()) c - | _ -> false - in - let h, t = - List.find (fun (_, t) -> matching_fun t) (pf_hyps_types g) - in - let h = h.binder_name in - let y = - let _, args = decompose_app sigma t in - List.hd (List.tl args) - in - observe_tclTHENLIST - (fun _ _ -> str "prove_le") - [ Proofview.V82.of_tactic - (apply (mkApp (le_trans (), [|x; y; z; mkVar h|]))) - ; observe_tac (fun _ _ -> str "prove_le (rec)") prove_le ] - with Not_found -> tclFAIL 0 (mt ()) - end ] - g +let rec prove_le () = + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma g in + let x, z = + let _, args = decompose_app sigma (Proofview.Goal.concl g) in + (List.hd args, List.hd (List.tl args)) + in + tclFIRST + [ assumption + ; apply (delayed_force le_n) + ; begin + try + let matching_fun c = + match EConstr.kind sigma c with + | App (c, [|x0; _|]) -> + EConstr.isVar sigma x0 + && Id.equal (destVar sigma x0) (destVar sigma x) + && EConstr.isRefX sigma (le ()) c + | _ -> false + in + let h, t = + List.find + (fun (_, t) -> matching_fun t) + (Tacmach.New.pf_hyps_types g) + in + let y = + let _, args = decompose_app sigma t in + List.hd (List.tl args) + in + New.observe_tclTHENLIST + (fun _ _ -> str "prove_le") + [ apply (mkApp (le_trans (), [|x; y; z; mkVar h|])) + ; New.observe_tac + (fun _ _ -> str "prove_le (rec)") + (prove_le ()) ] + with Not_found -> Tacticals.New.tclFAIL 0 (mt ()) + end ]) let rec make_rewrite_list expr_info max = function - | [] -> tclIDTAC + | [] -> Proofview.tclUNIT () | (_, p, hp) :: l -> - observe_tac + let open Tacticals.New in + New.observe_tac (fun _ _ -> str "make_rewrite_list") (tclTHENS - (observe_tac + (New.observe_tac (fun _ _ -> str "rewrite heq on " ++ Id.print p) - (fun g -> - let sigma = project g in - let t_eq = compute_renamed_type g hp in - let k, def = - let k_na, _, t = destProd sigma t_eq in - let _, _, t = destProd sigma t in - let def_na, _, _ = destProd sigma t in - ( Nameops.Name.get_id k_na.binder_name - , Nameops.Name.get_id def_na.binder_name ) - in - Proofview.V82.of_tactic - (general_rewrite_bindings false Locus.AllOccurrences true + (Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma g in + let t_eq = compute_renamed_type g hp in + let k, def = + let k_na, _, t = destProd sigma t_eq in + let _, _, t = destProd sigma t in + let def_na, _, _ = destProd sigma t in + ( Nameops.Name.get_id k_na.binder_name + , Nameops.Name.get_id def_na.binder_name ) + in + general_rewrite_bindings false Locus.AllOccurrences true (* dep proofs also: *) true ( mkVar hp , ExplicitBindings [ CAst.make @@ (NamedHyp def, expr_info.f_constr) ; CAst.make @@ (NamedHyp k, f_S max) ] ) - false) - g)) + false))) [ make_rewrite_list expr_info max l - ; observe_tclTHENLIST + ; New.observe_tclTHENLIST (fun _ _ -> str "make_rewrite_list") [ (* x < S max proof *) - Proofview.V82.of_tactic (apply (delayed_force le_lt_n_Sm)) - ; observe_tac (fun _ _ -> str "prove_le(2)") prove_le ] ]) + apply (delayed_force le_lt_n_Sm) + ; New.observe_tac (fun _ _ -> str "prove_le(2)") (prove_le ()) ] ]) let make_rewrite expr_info l hp max = + let open Tacticals.New in tclTHENFIRST - (observe_tac + (New.observe_tac (fun _ _ -> str "make_rewrite") (make_rewrite_list expr_info max l)) - (observe_tac + (New.observe_tac (fun _ _ -> str "make_rewrite") (tclTHENS - (fun g -> - let sigma = project g in - let t_eq = compute_renamed_type g hp in - let k, def = - let k_na, _, t = destProd sigma t_eq in - let _, _, t = destProd sigma t in - let def_na, _, _ = destProd sigma t in - ( Nameops.Name.get_id k_na.binder_name - , Nameops.Name.get_id def_na.binder_name ) - in - observe_tac - (fun _ _ -> str "general_rewrite_bindings") - (Proofview.V82.of_tactic + (Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma g in + let t_eq = compute_renamed_type g hp in + let k, def = + let k_na, _, t = destProd sigma t_eq in + let _, _, t = destProd sigma t in + let def_na, _, _ = destProd sigma t in + ( Nameops.Name.get_id k_na.binder_name + , Nameops.Name.get_id def_na.binder_name ) + in + New.observe_tac + (fun _ _ -> str "general_rewrite_bindings") (general_rewrite_bindings false Locus.AllOccurrences true (* dep proofs also: *) true ( mkVar hp , ExplicitBindings [ CAst.make @@ (NamedHyp def, expr_info.f_constr) ; CAst.make @@ (NamedHyp k, f_S (f_S max)) ] ) - false)) - g) - [ observe_tac + false))) + [ New.observe_tac (fun _ _ -> str "make_rewrite finalize") ((* tclORELSE( h_reflexivity) *) - observe_tclTHENLIST + New.observe_tclTHENLIST (fun _ _ -> str "make_rewrite") - [ Proofview.V82.of_tactic (simpl_iter Locusops.onConcl) - ; observe_tac + [ simpl_iter Locusops.onConcl + ; New.observe_tac (fun _ _ -> str "unfold functional") - (Proofview.V82.of_tactic - (unfold_in_concl - [ ( Locus.OnlyOccurrences [1] - , evaluable_of_global_reference expr_info.func ) ])) + (unfold_in_concl + [ ( Locus.OnlyOccurrences [1] + , evaluable_of_global_reference expr_info.func ) ]) ; list_rewrite true (List.map (fun e -> (mkVar e, true)) expr_info.eqs) - ; observe_tac + ; New.observe_tac (fun _ _ -> str "h_reflexivity") - (Proofview.V82.of_tactic intros_reflexivity) ]) - ; observe_tclTHENLIST + intros_reflexivity ]) + ; New.observe_tclTHENLIST (fun _ _ -> str "make_rewrite1") [ (* x < S (S max) proof *) - Proofview.V82.of_tactic - (apply (EConstr.of_constr (delayed_force le_lt_SS))) - ; observe_tac (fun _ _ -> str "prove_le (3)") prove_le ] ])) + apply (EConstr.of_constr (delayed_force le_lt_SS)) + ; New.observe_tac (fun _ _ -> str "prove_le (3)") (prove_le ()) ] + ])) let rec compute_max rew_tac max l = match l with | [] -> rew_tac max | (_, p, _) :: l -> - observe_tclTHENLIST + let open Tacticals.New in + New.observe_tclTHENLIST (fun _ _ -> str "compute_max") - [ Proofview.V82.of_tactic - (simplest_elim (mkApp (delayed_force max_constr, [|max; mkVar p|]))) - ; tclDO 3 (Proofview.V82.of_tactic intro) + [ simplest_elim (mkApp (delayed_force max_constr, [|max; mkVar p|])) + ; tclDO 3 intro ; onNLastHypsId 3 (fun lids -> match lids with | [hle2; hle1; pmax] -> compute_max rew_tac (mkVar pmax) l | _ -> assert false) ] let rec destruct_hex expr_info acc l = + let open Tacticals.New in match l with | [] -> ( match List.rev acc with - | [] -> tclIDTAC + | [] -> Proofview.tclUNIT () | (_, p, hp) :: tl -> - observe_tac + New.observe_tac (fun _ _ -> str "compute max ") (compute_max (make_rewrite expr_info tl hp) (mkVar p) tl) ) | (v, hex) :: l -> - observe_tclTHENLIST + New.observe_tclTHENLIST (fun _ _ -> str "destruct_hex") - [ Proofview.V82.of_tactic (simplest_case (mkVar hex)) - ; Proofview.V82.of_tactic (clear [hex]) - ; tclDO 2 (Proofview.V82.of_tactic intro) + [ simplest_case (mkVar hex) + ; clear [hex] + ; tclDO 2 intro ; onNthHypId 1 (fun hp -> onNthHypId 2 (fun p -> - observe_tac + New.observe_tac (fun _ _ -> str "destruct_hex after " ++ Id.print hp ++ spc () ++ Id.print p) (destruct_hex expr_info ((v, p, hp) :: acc) l))) ] let rec intros_values_eq expr_info acc = + let open Tacticals.New in tclORELSE - (observe_tclTHENLIST + (New.observe_tclTHENLIST (fun _ _ -> str "intros_values_eq") - [ tclDO 2 (Proofview.V82.of_tactic intro) + [ tclDO 2 intro ; onNthHypId 1 (fun hex -> onNthHypId 2 (fun v -> intros_values_eq expr_info ((v, hex) :: acc))) ]) (tclCOMPLETE (destruct_hex expr_info [] acc)) let equation_others _ expr_info continuation_tac infos = + let open Tacticals.New in if expr_info.is_final && expr_info.is_main_branch then - observe_tac + New.observe_tac (fun env sigma -> str "equation_others (cont_tac +intros) " ++ Printer.pr_leconstr_env env sigma expr_info.info) (tclTHEN (continuation_tac infos) - (observe_tac + (New.observe_tac (fun env sigma -> str "intros_values_eq equation_others " ++ Printer.pr_leconstr_env env sigma expr_info.info) (intros_values_eq expr_info []))) else - observe_tac + New.observe_tac (fun env sigma -> str "equation_others (cont_tac) " ++ Printer.pr_leconstr_env env sigma expr_info.info) @@ -1123,47 +1109,46 @@ let equation_others _ expr_info continuation_tac infos = let equation_app f_and_args expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch then - observe_tac + New.observe_tac (fun _ _ -> str "intros_values_eq equation_app") (intros_values_eq expr_info []) else continuation_tac infos -let equation_app_rec (f, args) expr_info continuation_tac info g = - let sigma = project g in - try - let v = - List.assoc_f - (List.equal (EConstr.eq_constr sigma)) - args expr_info.args_assoc - in - let new_infos = {expr_info with info = v} in - observe_tac (fun _ _ -> str "app_rec found") (continuation_tac new_infos) g - with Not_found -> - if expr_info.is_final && expr_info.is_main_branch then - observe_tclTHENLIST - (fun _ _ -> str "equation_app_rec") - [ Proofview.V82.of_tactic - (simplest_case (mkApp (expr_info.f_terminate, Array.of_list args))) - ; continuation_tac - { expr_info with - args_assoc = (args, delayed_force coq_O) :: expr_info.args_assoc - } - ; observe_tac - (fun _ _ -> str "app_rec intros_values_eq") - (intros_values_eq expr_info []) ] - g - else - observe_tclTHENLIST - (fun _ _ -> str "equation_app_rec1") - [ Proofview.V82.of_tactic - (simplest_case (mkApp (expr_info.f_terminate, Array.of_list args))) - ; observe_tac - (fun _ _ -> str "app_rec not_found") - (continuation_tac - { expr_info with - args_assoc = - (args, delayed_force coq_O) :: expr_info.args_assoc }) ] - g +let equation_app_rec (f, args) expr_info continuation_tac info = + Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma g in + try + let v = + List.assoc_f + (List.equal (EConstr.eq_constr sigma)) + args expr_info.args_assoc + in + let new_infos = {expr_info with info = v} in + New.observe_tac + (fun _ _ -> str "app_rec found") + (continuation_tac new_infos) + with Not_found -> + if expr_info.is_final && expr_info.is_main_branch then + New.observe_tclTHENLIST + (fun _ _ -> str "equation_app_rec") + [ simplest_case (mkApp (expr_info.f_terminate, Array.of_list args)) + ; continuation_tac + { expr_info with + args_assoc = + (args, delayed_force coq_O) :: expr_info.args_assoc } + ; New.observe_tac + (fun _ _ -> str "app_rec intros_values_eq") + (intros_values_eq expr_info []) ] + else + New.observe_tclTHENLIST + (fun _ _ -> str "equation_app_rec1") + [ simplest_case (mkApp (expr_info.f_terminate, Array.of_list args)) + ; New.observe_tac + (fun _ _ -> str "app_rec not_found") + (continuation_tac + { expr_info with + args_assoc = + (args, delayed_force coq_O) :: expr_info.args_assoc }) ]) let equation_info = { message = "prove_equation with term " @@ -1223,73 +1208,68 @@ let compute_terminate_type nb_args func = compose_prod rev_args value let termination_proof_header is_mes input_type ids args_id relation rec_arg_num - rec_arg_id tac wf_tac : tactic = - fun g -> - let nargs = List.length args_id in - let pre_rec_args = - List.rev_map mkVar (fst (List.chop (rec_arg_num - 1) args_id)) - in - let relation = substl pre_rec_args relation in - let input_type = substl pre_rec_args input_type in - let wf_thm = next_ident_away_in_goal (Id.of_string "wf_R") ids in - let wf_rec_arg = - next_ident_away_in_goal - (Id.of_string ("Acc_" ^ Id.to_string rec_arg_id)) - (wf_thm :: ids) - in - let hrec = next_ident_away_in_goal hrec_id (wf_rec_arg :: wf_thm :: ids) in - let acc_inv = - lazy - (mkApp - (delayed_force acc_inv_id, [|input_type; relation; mkVar rec_arg_id|])) - in - tclTHEN (h_intros args_id) - (tclTHENS - (observe_tac - (fun _ _ -> str "first assert") - (Proofview.V82.of_tactic - (assert_before (Name wf_rec_arg) - (mkApp - ( delayed_force acc_rel - , [|input_type; relation; mkVar rec_arg_id|] ))))) - [ (* accesibility proof *) - tclTHENS - (observe_tac - (fun _ _ -> str "second assert") - (Proofview.V82.of_tactic - (assert_before (Name wf_thm) - (mkApp - (delayed_force well_founded, [|input_type; relation|]))))) - [ (* interactive proof that the relation is well_founded *) - observe_tac - (fun _ _ -> str "wf_tac") - (wf_tac is_mes (Some args_id)) - ; (* this gives the accessibility argument *) - observe_tac - (fun _ _ -> str "apply wf_thm") - (Proofview.V82.of_tactic - (Simple.apply (mkApp (mkVar wf_thm, [|mkVar rec_arg_id|])))) - ] - ; (* rest of the proof *) - observe_tclTHENLIST - (fun _ _ -> str "rest of proof") - [ observe_tac - (fun _ _ -> str "generalize") - (onNLastHypsId (nargs + 1) - (tclMAP (fun id -> - tclTHEN - (Proofview.V82.of_tactic - (Tactics.generalize [mkVar id])) - (Proofview.V82.of_tactic (clear [id]))))) - ; observe_tac - (fun _ _ -> str "fix") - (Proofview.V82.of_tactic (fix hrec (nargs + 1))) - ; h_intros args_id - ; Proofview.V82.of_tactic (Simple.intro wf_rec_arg) - ; observe_tac - (fun _ _ -> str "tac") - (tac wf_rec_arg hrec wf_rec_arg acc_inv) ] ]) - g + rec_arg_id tac wf_tac : unit Proofview.tactic = + let open Tacticals.New in + Proofview.Goal.enter (fun g -> + let nargs = List.length args_id in + let pre_rec_args = + List.rev_map mkVar (fst (List.chop (rec_arg_num - 1) args_id)) + in + let relation = substl pre_rec_args relation in + let input_type = substl pre_rec_args input_type in + let wf_thm = next_ident_away_in_goal (Id.of_string "wf_R") ids in + let wf_rec_arg = + next_ident_away_in_goal + (Id.of_string ("Acc_" ^ Id.to_string rec_arg_id)) + (wf_thm :: ids) + in + let hrec = + next_ident_away_in_goal hrec_id (wf_rec_arg :: wf_thm :: ids) + in + let acc_inv = + lazy + (mkApp + ( delayed_force acc_inv_id + , [|input_type; relation; mkVar rec_arg_id|] )) + in + tclTHEN (h_intros args_id) + (tclTHENS + (New.observe_tac + (fun _ _ -> str "first assert") + (assert_before (Name wf_rec_arg) + (mkApp + ( delayed_force acc_rel + , [|input_type; relation; mkVar rec_arg_id|] )))) + [ (* accesibility proof *) + tclTHENS + (New.observe_tac + (fun _ _ -> str "second assert") + (assert_before (Name wf_thm) + (mkApp + (delayed_force well_founded, [|input_type; relation|])))) + [ (* interactive proof that the relation is well_founded *) + New.observe_tac + (fun _ _ -> str "wf_tac") + (wf_tac is_mes (Some args_id)) + ; (* this gives the accessibility argument *) + New.observe_tac + (fun _ _ -> str "apply wf_thm") + (Simple.apply (mkApp (mkVar wf_thm, [|mkVar rec_arg_id|]))) + ] + ; (* rest of the proof *) + New.observe_tclTHENLIST + (fun _ _ -> str "rest of proof") + [ New.observe_tac + (fun _ _ -> str "generalize") + (onNLastHypsId (nargs + 1) + (tclMAP (fun id -> + tclTHEN (Tactics.generalize [mkVar id]) (clear [id])))) + ; New.observe_tac (fun _ _ -> str "fix") (fix hrec (nargs + 1)) + ; h_intros args_id + ; Simple.intro wf_rec_arg + ; New.observe_tac + (fun _ _ -> str "tac") + (tac wf_rec_arg hrec wf_rec_arg acc_inv) ] ])) let rec instantiate_lambda sigma t l = match l with @@ -1299,62 +1279,61 @@ let rec instantiate_lambda sigma t l = instantiate_lambda sigma (subst1 a body) l let whole_start concl_tac nb_args is_mes func input_type relation rec_arg_num : - tactic = - fun g -> - let sigma = project g in - let ids = Termops.ids_of_named_context (pf_hyps g) in - let func_body = def_of_const (constr_of_monomorphic_global func) in - let func_body = EConstr.of_constr func_body in - let f_name, _, body1 = destLambda sigma func_body in - let f_id = - match f_name.binder_name with - | Name f_id -> next_ident_away_in_goal f_id ids - | Anonymous -> anomaly (Pp.str "Anonymous function.") - in - let n_names_types, _ = decompose_lam_n sigma nb_args body1 in - let n_ids, ids = - List.fold_left - (fun (n_ids, ids) (n_name, _) -> - match n_name.binder_name with - | Name id -> - let n_id = next_ident_away_in_goal id ids in - (n_id :: n_ids, n_id :: ids) - | _ -> anomaly (Pp.str "anonymous argument.")) - ([], f_id :: ids) - n_names_types - in - let rec_arg_id = List.nth n_ids (rec_arg_num - 1) in - let expr = - instantiate_lambda sigma func_body (mkVar f_id :: List.map mkVar n_ids) - in - termination_proof_header is_mes input_type ids n_ids relation rec_arg_num - rec_arg_id - (fun rec_arg_id hrec acc_id acc_inv g -> - (prove_terminate - (fun infos -> tclIDTAC) - { is_main_branch = true - ; (* we are on the main branche (i.e. still on a match ... with .... end *) - is_final = true - ; (* and on leaf (more or less) *) - f_terminate = delayed_force coq_O - ; nb_arg = nb_args - ; concl_tac - ; rec_arg_id - ; is_mes - ; ih = hrec - ; f_id - ; f_constr = mkVar f_id - ; func - ; info = expr - ; acc_inv - ; acc_id - ; values_and_bounds = [] - ; eqs = [] - ; forbidden_ids = [] - ; args_assoc = [] }) - g) - (fun b ids -> Proofview.V82.of_tactic (tclUSER_if_not_mes concl_tac b ids)) - g + unit Proofview.tactic = + Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma g in + let hyps = Proofview.Goal.hyps g in + let ids = Termops.ids_of_named_context hyps in + let func_body = def_of_const (constr_of_monomorphic_global func) in + let func_body = EConstr.of_constr func_body in + let f_name, _, body1 = destLambda sigma func_body in + let f_id = + match f_name.binder_name with + | Name f_id -> next_ident_away_in_goal f_id ids + | Anonymous -> anomaly (Pp.str "Anonymous function.") + in + let n_names_types, _ = decompose_lam_n sigma nb_args body1 in + let n_ids, ids = + List.fold_left + (fun (n_ids, ids) (n_name, _) -> + match n_name.binder_name with + | Name id -> + let n_id = next_ident_away_in_goal id ids in + (n_id :: n_ids, n_id :: ids) + | _ -> anomaly (Pp.str "anonymous argument.")) + ([], f_id :: ids) + n_names_types + in + let rec_arg_id = List.nth n_ids (rec_arg_num - 1) in + let expr = + instantiate_lambda sigma func_body (mkVar f_id :: List.map mkVar n_ids) + in + termination_proof_header is_mes input_type ids n_ids relation rec_arg_num + rec_arg_id + (fun rec_arg_id hrec acc_id acc_inv -> + prove_terminate + (fun infos -> Proofview.tclUNIT ()) + { is_main_branch = true + ; (* we are on the main branche (i.e. still on a match ... with .... end *) + is_final = true + ; (* and on leaf (more or less) *) + f_terminate = delayed_force coq_O + ; nb_arg = nb_args + ; concl_tac + ; rec_arg_id + ; is_mes + ; ih = hrec + ; f_id + ; f_constr = mkVar f_id + ; func + ; info = expr + ; acc_inv + ; acc_id + ; values_and_bounds = [] + ; eqs = [] + ; forbidden_ids = [] + ; args_assoc = [] }) + (fun b ids -> tclUSER_if_not_mes concl_tac b ids)) let get_current_subgoals_types pstate = let p = Declare.Proof.get pstate in @@ -1389,9 +1368,7 @@ let build_and_l sigma l = let c, tac, nb = f pl in ( mk_and p1 c , tclTHENS - (Proofview.V82.of_tactic - (apply - (EConstr.of_constr (constr_of_monomorphic_global conj_constr)))) + (apply (EConstr.of_constr (constr_of_monomorphic_global conj_constr))) [tclIDTAC; tac] , nb + 1 ) in @@ -1513,29 +1490,23 @@ let open_new_goal ~lemma build_proof sigma using_lemmas ref_ goal_name let lemma = Declare.Proof.start ~cinfo ~info sigma in let lemma = if Indfun_common.is_strict_tcc () then - fst @@ Declare.Proof.by (Proofview.V82.tactic tclIDTAC) lemma + fst @@ Declare.Proof.by tclIDTAC lemma else fst @@ Declare.Proof.by - (Proofview.V82.tactic (fun g -> - tclTHEN decompose_and_tac - (tclORELSE - (tclFIRST - (List.map - (fun c -> - Proofview.V82.of_tactic - (Tacticals.New.tclTHENLIST - [ intros - ; Simple.apply - (fst - (interp_constr (Global.env ()) - Evd.empty c)) - (*FIXME*) - ; Tacticals.New.tclCOMPLETE Auto.default_auto - ])) - using_lemmas)) - tclIDTAC) - g)) + (tclTHEN decompose_and_tac + (tclORELSE + (tclFIRST + (List.map + (fun c -> + Tacticals.New.tclTHENLIST + [ intros + ; Simple.apply + (fst (interp_constr (Global.env ()) Evd.empty c)) + (*FIXME*) + ; Tacticals.New.tclCOMPLETE Auto.default_auto ]) + using_lemmas)) + tclIDTAC)) lemma in if Declare.Proof.get_open_goals lemma = 0 then (defined lemma; None) @@ -1560,11 +1531,10 @@ let com_terminate interactive_proof tcc_lemma_name tcc_lemma_ref is_mes in fst @@ Declare.Proof.by - (Proofview.V82.tactic - (observe_tac - (fun _ _ -> str "whole_start") - (whole_start tac_end nb_args is_mes fonctional_ref input_type - relation rec_arg_num))) + (New.observe_tac + (fun _ _ -> str "whole_start") + (whole_start tac_end nb_args is_mes fonctional_ref input_type + relation rec_arg_num)) lemma in let lemma = @@ -1583,31 +1553,28 @@ let com_terminate interactive_proof tcc_lemma_name tcc_lemma_ref is_mes if interactive_proof then Some lemma else (defined lemma; None) let start_equation (f : GlobRef.t) (term_f : GlobRef.t) - (cont_tactic : Id.t list -> tactic) g = - let sigma = project g in - let ids = pf_ids_of_hyps g in - let terminate_constr = constr_of_monomorphic_global term_f in - let terminate_constr = EConstr.of_constr terminate_constr in - let nargs = - nb_prod (project g) - (EConstr.of_constr (type_of_const sigma terminate_constr)) - in - let x = n_x_id ids nargs in - observe_tac - (fun _ _ -> str "start_equation") - (observe_tclTHENLIST - (fun _ _ -> str "start_equation") - [ h_intros x - ; Proofview.V82.of_tactic - (unfold_in_concl - [(Locus.AllOccurrences, evaluable_of_global_reference f)]) - ; observe_tac - (fun _ _ -> str "simplest_case") - (Proofview.V82.of_tactic - (simplest_case - (mkApp (terminate_constr, Array.of_list (List.map mkVar x))))) - ; observe_tac (fun _ _ -> str "prove_eq") (cont_tactic x) ]) - g + (cont_tactic : Id.t list -> unit Proofview.tactic) = + Proofview.Goal.enter (fun g -> + let sigma = Proofview.Goal.sigma g in + let ids = Tacmach.New.pf_ids_of_hyps g in + let terminate_constr = constr_of_monomorphic_global term_f in + let terminate_constr = EConstr.of_constr terminate_constr in + let nargs = + nb_prod sigma (EConstr.of_constr (type_of_const sigma terminate_constr)) + in + let x = n_x_id ids nargs in + New.observe_tac + (fun _ _ -> str "start_equation") + (New.observe_tclTHENLIST + (fun _ _ -> str "start_equation") + [ h_intros x + ; unfold_in_concl + [(Locus.AllOccurrences, evaluable_of_global_reference f)] + ; New.observe_tac + (fun _ _ -> str "simplest_case") + (simplest_case + (mkApp (terminate_constr, Array.of_list (List.map mkVar x)))) + ; New.observe_tac (fun _ _ -> str "prove_eq") (cont_tactic x) ])) let com_eqn uctx nb_arg eq_name functional_ref f_ref terminate_ref equation_lemma_type = @@ -1630,35 +1597,34 @@ let com_eqn uctx nb_arg eq_name functional_ref f_ref terminate_ref let lemma = fst @@ Declare.Proof.by - (Proofview.V82.tactic - (start_equation f_ref terminate_ref (fun x -> - prove_eq - (fun _ -> tclIDTAC) - { nb_arg - ; f_terminate = - EConstr.of_constr - (constr_of_monomorphic_global terminate_ref) - ; f_constr = EConstr.of_constr f_constr - ; concl_tac = Tacticals.New.tclIDTAC - ; func = functional_ref - ; info = - instantiate_lambda Evd.empty - (EConstr.of_constr - (def_of_const - (constr_of_monomorphic_global functional_ref))) - (EConstr.of_constr f_constr :: List.map mkVar x) - ; is_main_branch = true - ; is_final = true - ; values_and_bounds = [] - ; eqs = [] - ; forbidden_ids = [] - ; acc_inv = lazy (assert false) - ; acc_id = Id.of_string "____" - ; args_assoc = [] - ; f_id = Id.of_string "______" - ; rec_arg_id = Id.of_string "______" - ; is_mes = false - ; ih = Id.of_string "______" }))) + (start_equation f_ref terminate_ref (fun x -> + prove_eq + (fun _ -> Proofview.tclUNIT ()) + { nb_arg + ; f_terminate = + EConstr.of_constr + (constr_of_monomorphic_global terminate_ref) + ; f_constr = EConstr.of_constr f_constr + ; concl_tac = Tacticals.New.tclIDTAC + ; func = functional_ref + ; info = + instantiate_lambda Evd.empty + (EConstr.of_constr + (def_of_const + (constr_of_monomorphic_global functional_ref))) + (EConstr.of_constr f_constr :: List.map mkVar x) + ; is_main_branch = true + ; is_final = true + ; values_and_bounds = [] + ; eqs = [] + ; forbidden_ids = [] + ; acc_inv = lazy (assert false) + ; acc_id = Id.of_string "____" + ; args_assoc = [] + ; f_id = Id.of_string "______" + ; rec_arg_id = Id.of_string "______" + ; is_mes = false + ; ih = Id.of_string "______" })) lemma in let _ = diff --git a/plugins/ltac/coretactics.mlg b/plugins/ltac/coretactics.mlg index cb226de586..f1f538ab39 100644 --- a/plugins/ltac/coretactics.mlg +++ b/plugins/ltac/coretactics.mlg @@ -263,7 +263,7 @@ END (** Double induction *) -TACTIC EXTEND double_induction +TACTIC EXTEND double_induction DEPRECATED { Deprecation.make () } | [ "double" "induction" quantified_hypothesis(h1) quantified_hypothesis(h2) ] -> { Elim.h_double_induction h1 h2 } END diff --git a/plugins/ltac/extraargs.mlg b/plugins/ltac/extraargs.mlg index eb53fd45d0..863c4d37d8 100644 --- a/plugins/ltac/extraargs.mlg +++ b/plugins/ltac/extraargs.mlg @@ -25,7 +25,7 @@ open Locus (** Adding scopes for generic arguments not defined through ARGUMENT EXTEND *) let create_generic_quotation name e wit = - let inject (loc, v) = Tacexpr.TacGeneric (Genarg.in_gen (Genarg.rawwit wit) v) in + let inject (loc, v) = Tacexpr.TacGeneric (Some name, Genarg.in_gen (Genarg.rawwit wit) v) in Tacentries.create_ltac_quotation name inject (e, None) let () = create_generic_quotation "integer" Pcoq.Prim.integer Stdarg.wit_int 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..6cf5d30a95 100644 --- a/plugins/ltac/g_ltac.mlg +++ b/plugins/ltac/g_ltac.mlg @@ -48,14 +48,14 @@ let reference_to_id qid = CErrors.user_err ?loc:qid.CAst.loc (str "This expression should be a simple identifier.") -let tactic_mode = Entry.create "vernac:tactic_command" +let tactic_mode = Entry.create "tactic_command" let new_entry name = let e = Entry.create name in e -let toplevel_selector = new_entry "vernac:toplevel_selector" -let tacdef_body = new_entry "tactic:tacdef_body" +let toplevel_selector = new_entry "toplevel_selector" +let tacdef_body = new_entry "tacdef_body" (* Registers [tactic_mode] as a parser for proof editing *) let classic_proof_mode = Pvernac.register_proof_mode "Classic" tactic_mode @@ -180,7 +180,7 @@ GRAMMAR EXTEND Gram [ [ a = tactic_arg -> { a } | c = Constr.constr -> { (match c with { CAst.v = CRef (r,None) } -> Reference r | c -> ConstrMayEval (ConstrTerm c)) } (* Unambiguous entries: tolerated w/o "ltac:" modifier *) - | "()" -> { TacGeneric (genarg_of_unit ()) } ] ] + | "()" -> { TacGeneric (None, genarg_of_unit ()) } ] ] ; (* Can be used as argument and at toplevel in tactic expressions. *) tactic_arg: @@ -209,9 +209,9 @@ GRAMMAR EXTEND Gram | c = Constr.constr -> { ConstrTerm c } ] ] ; tactic_atom: - [ [ n = integer -> { TacGeneric (genarg_of_int n) } + [ [ n = integer -> { TacGeneric (None, genarg_of_int n) } | r = reference -> { TacCall (CAst.make ~loc (r,[])) } - | "()" -> { TacGeneric (genarg_of_unit ()) } ] ] + | "()" -> { TacGeneric (None, genarg_of_unit ()) } ] ] ; match_key: [ [ "match" -> { Once } @@ -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: @@ -355,28 +355,8 @@ GRAMMAR EXTEND Gram open Stdarg open Tacarg open Vernacextend -open Goptions open Libnames -let print_info_trace = - declare_intopt_option_and_ref ~depr:false ~key:["Info" ; "Level"] - -let vernac_solve ~pstate n info tcom b = - let open Goal_select in - let pstate, status = Declare.Proof.map_fold_endline ~f:(fun etac p -> - let with_end_tac = if b then Some etac else None in - let global = match n with SelectAll | SelectList _ -> true | _ -> false in - let info = Option.append info (print_info_trace ()) in - let (p,status) = - Proof.solve n info (Tacinterp.hide_interp global tcom None) ?with_end_tac p - in - (* in case a strict subtree was completed, - go back to the top of the prooftree *) - let p = Proof.maximal_unfocus Vernacentries.command_focus p in - p,status) pstate in - if not status then Feedback.feedback Feedback.AddedAxiom; - pstate - let pr_ltac_selector s = Pptactic.pr_goal_selector ~toplevel:true s } @@ -409,34 +389,34 @@ END { -let is_anonymous_abstract = function - | TacAbstract (_,None) -> true - | TacSolve [TacAbstract (_,None)] -> true - | _ -> false let rm_abstract = function - | TacAbstract (t,_) -> t - | TacSolve [TacAbstract (t,_)] -> TacSolve [t] - | x -> x + | TacAbstract (t,_) -> t, true + | TacSolve [TacAbstract (t,_)] -> TacSolve [t], true + | x -> x, false let is_explicit_terminator = function TacSolve _ -> true | _ -> false } VERNAC { tactic_mode } EXTEND VernacSolve STATE proof -| [ ltac_selector_opt(g) ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => +| [ ltac_selector_opt(g) ltac_info_opt(info) tactic(t) ltac_use_default(with_end_tac) ] => { classify_as_proofstep } -> { let g = Option.default (Goal_select.get_default_goal_selector ()) g in - vernac_solve g n t def + let global = match g with Goal_select.SelectAll | Goal_select.SelectList _ -> true | _ -> false in + let t = ComTactic.I (Tacinterp.hide_interp, { Tacinterp.global; ast = t; }) in + ComTactic.solve g ~info t ~with_end_tac } -| [ "par" ":" ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => +END + +VERNAC { tactic_mode } EXTEND VernacSolveParallel STATE proof +| [ "par" ":" ltac_info_opt(info) tactic(t) ltac_use_default(with_end_tac) ] => { - let anon_abstracting_tac = is_anonymous_abstract t in let solving_tac = is_explicit_terminator t in - let parallel = `Yes (solving_tac,anon_abstracting_tac) in let pbr = if solving_tac then Some "par" else None in - VtProofStep{ parallel = parallel; proof_block_detection = pbr } + VtProofStep{ proof_block_detection = pbr } } -> { - let t = rm_abstract t in - vernac_solve Goal_select.SelectAll n t def + let t, abstract = rm_abstract t in + let t = ComTactic.I (Tacinterp.hide_interp, { Tacinterp.global = true; ast = t; }) in + ComTactic.solve_parallel ~info t ~abstract ~with_end_tac } END diff --git a/plugins/ltac/g_obligations.mlg b/plugins/ltac/g_obligations.mlg index fa176482bf..fc24475a62 100644 --- a/plugins/ltac/g_obligations.mlg +++ b/plugins/ltac/g_obligations.mlg @@ -56,7 +56,7 @@ type 'a withtac_argtype = (Tacexpr.raw_tactic_expr option, 'a) Genarg.abstract_a let wit_withtac : Tacexpr.raw_tactic_expr option Genarg.uniform_genarg_type = Genarg.create_arg "withtac" -let withtac = Pcoq.create_generic_entry Pcoq.utactic "withtac" (Genarg.rawwit wit_withtac) +let withtac = Pcoq.create_generic_entry2 "withtac" (Genarg.rawwit wit_withtac) } @@ -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/g_rewrite.mlg b/plugins/ltac/g_rewrite.mlg index 09cdc997ab..8331927cda 100644 --- a/plugins/ltac/g_rewrite.mlg +++ b/plugins/ltac/g_rewrite.mlg @@ -219,7 +219,7 @@ type binders_argtype = local_binder_expr list let wit_binders = (Genarg.create_arg "binders" : binders_argtype Genarg.uniform_genarg_type) -let binders = Pcoq.create_generic_entry Pcoq.utactic "binders" (Genarg.rawwit wit_binders) +let binders = Pcoq.create_generic_entry2 "binders" (Genarg.rawwit wit_binders) let () = let raw_printer env sigma _ _ _ l = Pp.pr_non_empty_arg (Ppconstr.pr_binders env sigma) l in diff --git a/plugins/ltac/leminv.ml b/plugins/ltac/leminv.ml index 0024d1a4ba..f42c1f73a3 100644 --- a/plugins/ltac/leminv.ml +++ b/plugins/ltac/leminv.ml @@ -228,14 +228,15 @@ let inversion_scheme ~name ~poly env sigma t sort dep_option inv_op = let c = fill_holes pfterm in (* warning: side-effect on ownSign *) let invProof = it_mkNamedLambda_or_LetIn c !ownSign in - let p = EConstr.to_constr sigma invProof in - p, sigma + invProof, sigma let add_inversion_lemma ~poly name env sigma t sort dep inv_op = let invProof, sigma = inversion_scheme ~name ~poly env sigma t sort dep inv_op in - let univs = Evd.univ_entry ~poly sigma in - let entry = Declare.definition_entry ~univs invProof in - let _ : Names.Constant.t = Declare.declare_constant ~name ~kind:Decls.(IsProof Lemma) (Declare.DefinitionEntry entry) in + let cinfo = Declare.CInfo.make ~name ~typ:None () in + let info = Declare.Info.make ~poly ~kind:Decls.(IsProof Lemma) () in + let _ : Names.GlobRef.t = + Declare.declare_definition ~cinfo ~info ~opaque:false ~body:invProof sigma + in () (* inv_op = Inv (derives de complete inv. lemma) @@ -244,13 +245,10 @@ let add_inversion_lemma ~poly name env sigma t sort dep inv_op = let add_inversion_lemma_exn ~poly na com comsort bool tac = let env = Global.env () in let sigma = Evd.from_env env in - let sigma, c = Constrintern.interp_type_evars ~program_mode:false env sigma com in + let c, uctx = Constrintern.interp_type env sigma com in + let sigma = Evd.from_ctx uctx in let sigma, sort = Evd.fresh_sort_in_family ~rigid:univ_rigid sigma comsort in - try - add_inversion_lemma ~poly na env sigma c sort bool tac - with - | UserError (Some "Case analysis",s) -> (* Reference to Indrec *) - user_err ~hdr:"Inv needs Nodep Prop Set" s + add_inversion_lemma ~poly na env sigma c sort bool tac (* ================================= *) (* Applying a given inversion lemma *) diff --git a/plugins/ltac/pltac.ml b/plugins/ltac/pltac.ml index 5b5ee64a56..b7b54143df 100644 --- a/plugins/ltac/pltac.ml +++ b/plugins/ltac/pltac.ml @@ -11,39 +11,37 @@ open Pcoq (* Main entry for extensions *) -let simple_tactic = Entry.create "tactic:simple_tactic" - -let make_gen_entry _ name = Entry.create ("tactic:" ^ name) +let simple_tactic = Entry.create "simple_tactic" (* Typically for tactic user extensions *) let open_constr = - make_gen_entry utactic "open_constr" + Entry.create "open_constr" let constr_with_bindings = - make_gen_entry utactic "constr_with_bindings" + Entry.create "constr_with_bindings" let bindings = - make_gen_entry utactic "bindings" + Entry.create "bindings" let hypident = Entry.create "hypident" -let constr_may_eval = make_gen_entry utactic "constr_may_eval" -let constr_eval = make_gen_entry utactic "constr_eval" +let constr_may_eval = Entry.create "constr_may_eval" +let constr_eval = Entry.create "constr_eval" let uconstr = - make_gen_entry utactic "uconstr" + Entry.create "uconstr" let quantified_hypothesis = - make_gen_entry utactic "quantified_hypothesis" -let destruction_arg = make_gen_entry utactic "destruction_arg" -let int_or_var = make_gen_entry utactic "int_or_var" + Entry.create "quantified_hypothesis" +let destruction_arg = Entry.create "destruction_arg" +let int_or_var = Entry.create "int_or_var" let simple_intropattern = - make_gen_entry utactic "simple_intropattern" -let in_clause = make_gen_entry utactic "in_clause" + Entry.create "simple_intropattern" +let in_clause = Entry.create "in_clause" let clause_dft_concl = - make_gen_entry utactic "clause" + Entry.create "clause" (* Main entries for ltac *) -let tactic_arg = Entry.create "tactic:tactic_arg" -let tactic_expr = make_gen_entry utactic "tactic_expr" -let binder_tactic = make_gen_entry utactic "binder_tactic" +let tactic_arg = Entry.create "tactic_arg" +let tactic_expr = Entry.create "tactic_expr" +let binder_tactic = Entry.create "binder_tactic" -let tactic = make_gen_entry utactic "tactic" +let tactic = Entry.create "tactic" (* Main entry for quotations *) let tactic_eoi = eoi_entry tactic diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml index 6233807016..cbb53497d3 100644 --- a/plugins/ltac/pptactic.ml +++ b/plugins/ltac/pptactic.ml @@ -179,7 +179,7 @@ let string_of_genarg_arg (ArgumentType arg) = | ConstrTypeOf c -> hov 1 (keyword "type of" ++ spc() ++ prc env sigma c) | ConstrTerm c when test c -> - h 0 (str "(" ++ prc env sigma c ++ str ")") + h (str "(" ++ prc env sigma c ++ str ")") | ConstrTerm c -> prc env sigma c @@ -338,8 +338,8 @@ let string_of_genarg_arg (ArgumentType arg) = | Extend.Uentryl (_, l) -> prtac LevelSome arg | _ -> match arg with - | TacGeneric arg -> - let pr l arg = prtac l (TacGeneric arg) in + | TacGeneric (isquot,arg) -> + let pr l arg = prtac l (TacGeneric (isquot,arg)) in pr_any_arg pr symb arg | _ -> str "ltac:(" ++ prtac LevelSome arg ++ str ")" @@ -571,7 +571,7 @@ let pr_goal_selector ~toplevel s = let pr_let_clause k pr_gen pr_arg (na,(bl,t)) = let pr = function - | TacGeneric arg -> + | TacGeneric (_,arg) -> let name = string_of_genarg_arg (genarg_tag arg) in if name = "unit" || name = "int" then (* Hard-wired parsing rules *) @@ -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) ++ ( @@ -1049,8 +1049,9 @@ let pr_goal_selector ~toplevel s = pr_may_eval env sigma pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c, leval | TacArg { CAst.v=TacFreshId l } -> primitive "fresh" ++ pr_fresh_ids l, latom - | TacArg { CAst.v=TacGeneric arg } -> - pr.pr_generic env sigma arg, latom + | TacArg { CAst.v=TacGeneric (isquot,arg) } -> + let p = pr.pr_generic env sigma arg in + (match isquot with Some name -> str name ++ str ":(" ++ p ++ str ")" | None -> p), latom | TacArg { CAst.v=TacCall {CAst.v=(f,[])} } -> pr.pr_reference f, latom | TacArg { CAst.v=TacCall {CAst.loc; v=(f,l)} } -> diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml index 0dbf16a821..9c15d24dd3 100644 --- a/plugins/ltac/profile_ltac.ml +++ b/plugins/ltac/profile_ltac.ml @@ -146,7 +146,7 @@ let header = fnl () let rec print_node ~filter all_total indent prefix (s, e) = - h 0 ( + h ( padr_with '-' 40 (prefix ^ s ^ " ") ++ padl 7 (format_ratio (e.local /. all_total)) ++ padl 7 (format_ratio (e.total /. all_total)) @@ -212,7 +212,7 @@ let to_string ~filter ?(cutoff=0.0) node = in let filter s n = filter s && (all_total <= 0.0 || n /. all_total >= cutoff /. 100.0) in let msg = - h 0 (str "total time: " ++ padl 11 (format_sec (all_total))) ++ + h (str "total time: " ++ padl 11 (format_sec (all_total))) ++ fnl () ++ fnl () ++ header ++ 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..5ef76dbdc1 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -181,7 +181,7 @@ end) = struct fun env sigma -> class_info env sigma (Lazy.force r) let proper_proj env sigma = - mkConst (Option.get (pi3 (List.hd (proper_class env sigma).cl_projs))) + mkConst (Option.get (List.hd (proper_class env sigma).cl_projs).meth_const) let proper_type env (sigma,cstrs) = let l = (proper_class env sigma).cl_impl in @@ -498,7 +498,7 @@ let rec decompose_app_rel env evd t = let decompose_app_rel env evd t = let (rel, t1, t2) = decompose_app_rel env evd t in - let ty = Retyping.get_type_of env evd rel in + let ty = try Retyping.get_type_of ~lax:true env evd rel with Retyping.RetypeError _ -> error_no_relation () in let () = if not (Reductionops.is_arity env evd ty) then error_no_relation () in (rel, t1, t2) @@ -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; @@ -2144,7 +2144,7 @@ let setoid_proof ty fn fallback = let car = snd (List.hd (fst (Reductionops.splay_prod env sigma t))) in (try init_relation_classes () with _ -> raise Not_found); fn env sigma car rel - with e -> + with e when CErrors.noncritical e -> (* XXX what is the right test here as to whether e can be converted ? *) let e, info = Exninfo.capture e in Proofview.tclZERO ~info e diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index 91d26519b8..f7037176d2 100644 --- a/plugins/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -394,7 +394,7 @@ type appl = (* Values for interpretation *) type tacvalue = - | VFun of appl*Tacexpr.ltac_trace * Val.t Id.Map.t * + | VFun of appl * Tacexpr.ltac_trace * Loc.t option * Val.t Id.Map.t * Name.t list * Tacexpr.glob_tactic_expr | VRec of Val.t Id.Map.t ref * Tacexpr.glob_tactic_expr diff --git a/plugins/ltac/taccoerce.mli b/plugins/ltac/taccoerce.mli index 3afbb56b23..b8592c5c76 100644 --- a/plugins/ltac/taccoerce.mli +++ b/plugins/ltac/taccoerce.mli @@ -104,7 +104,7 @@ type appl = (** For calls to global constants, some may alias other. *) type tacvalue = - | VFun of appl*Tacexpr.ltac_trace * Val.t Id.Map.t * + | VFun of appl *Tacexpr.ltac_trace * Loc.t option * Val.t Id.Map.t * Name.t list * Tacexpr.glob_tactic_expr | VRec of Val.t Id.Map.t ref * Tacexpr.glob_tactic_expr diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml index f8c25d5dd0..f0ca813b08 100644 --- a/plugins/ltac/tacentries.ml +++ b/plugins/ltac/tacentries.ml @@ -174,7 +174,7 @@ let add_tactic_entry (kn, ml, tg) state = if Genarg.has_type arg wit && not ml then Tacexp (Genarg.out_gen wit arg) else - TacGeneric arg + TacGeneric (None, arg) in let l = List.map map l in (TacAlias (CAst.make ~loc (kn,l)):raw_tactic_expr) @@ -349,7 +349,7 @@ let extend_atomic_tactic name entries = | TacNonTerm (_, (symb, _)) -> let EntryName (typ, e) = prod_item_of_symbol 0 symb in let Genarg.Rawwit wit = typ in - let inj x = TacArg (CAst.make @@ TacGeneric (Genarg.in_gen typ x)) in + let inj x = TacArg (CAst.make @@ TacGeneric (None, Genarg.in_gen typ x)) in let default = epsilon_value inj e in match default with | None -> raise NonEmptyArgument @@ -780,7 +780,7 @@ let ml_val_tactic_extend ~plugin ~name ~local ?deprecation sign tac = let ml_tactic_name = { mltac_tactic = name; mltac_plugin = plugin } in let len = ml_sig_len sign in let vars = List.init len (fun i -> Id.of_string (Printf.sprintf "arg%i" i)) in - let body = TacGeneric (in_tacval { tacval_tac = ml_tactic_name; tacval_var = vars }) in + let body = TacGeneric (None, in_tacval { tacval_tac = ml_tactic_name; tacval_var = vars }) in let vars = List.map (fun id -> Name id) vars in let body = Tacexpr.TacFun (vars, Tacexpr.TacArg (CAst.make body)) in let id = Names.Id.of_string name in @@ -869,14 +869,14 @@ let argument_extend (type a b c) ~name (arg : (a, b, c) tactic_argument) = let () = Pcoq.register_grammar wit e in e | Vernacextend.Arg_rules rules -> - let e = Pcoq.create_generic_entry Pcoq.utactic name (Genarg.rawwit wit) in + let e = Pcoq.create_generic_entry2 name (Genarg.rawwit wit) in let () = Pcoq.grammar_extend e {pos=None; data=[(None, None, rules)]} in e in let (rpr, gpr, tpr) = arg.arg_printer in let () = Pptactic.declare_extra_genarg_pprule wit rpr gpr tpr in let () = create_ltac_quotation name - (fun (loc, v) -> Tacexpr.TacGeneric (Genarg.in_gen (Genarg.rawwit wit) v)) + (fun (loc, v) -> Tacexpr.TacGeneric (Some name,Genarg.in_gen (Genarg.rawwit wit) v)) (entry, None) in (wit, entry) diff --git a/plugins/ltac/tacexpr.ml b/plugins/ltac/tacexpr.ml index b261096b63..eaedf8d9c1 100644 --- a/plugins/ltac/tacexpr.ml +++ b/plugins/ltac/tacexpr.ml @@ -154,7 +154,7 @@ constraint 'a = < (** Possible arguments of a tactic definition *) type 'a gen_tactic_arg = - | TacGeneric of 'lev generic_argument + | TacGeneric of string option * 'lev generic_argument | ConstrMayEval of ('trm,'cst,'pat) may_eval | Reference of 'ref | TacCall of ('ref * 'a gen_tactic_arg list) CAst.t diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli index 650349b586..50767821e4 100644 --- a/plugins/ltac/tacexpr.mli +++ b/plugins/ltac/tacexpr.mli @@ -153,7 +153,7 @@ constraint 'a = < (** Possible arguments of a tactic definition *) type 'a gen_tactic_arg = - | TacGeneric of 'lev generic_argument + | TacGeneric of string option * 'lev generic_argument | ConstrMayEval of ('trm,'cst,'pat) may_eval | Reference of 'ref | TacCall of ('ref * 'a gen_tactic_arg list) CAst.t diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml index afa79a88db..dea216045e 100644 --- a/plugins/ltac/tacintern.ml +++ b/plugins/ltac/tacintern.ml @@ -195,7 +195,7 @@ let intern_non_tactic_reference strict ist qid = if qualid_is_ident qid && not strict then let id = qualid_basename qid in let ipat = in_gen (glbwit wit_intro_pattern) (make ?loc:qid.CAst.loc @@ IntroNaming (IntroIdentifier id)) in - TacGeneric ipat + TacGeneric (None,ipat) else (* Reference not found *) let _, info = Exninfo.capture exn in @@ -713,9 +713,9 @@ and intern_tacarg strict onlytac ist = function | TacPretype c -> TacPretype (intern_constr ist c) | TacNumgoals -> TacNumgoals | Tacexp t -> Tacexp (intern_tactic onlytac ist t) - | TacGeneric arg -> + | TacGeneric (isquot,arg) -> let arg = intern_genarg ist arg in - TacGeneric arg + TacGeneric (isquot,arg) (* Reads the rules of a Match Context or a Match *) and intern_match_rule onlytac ist ?(as_type=false) = function diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index fdebe14a23..eaeae50254 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -124,7 +124,7 @@ let is_traced () = let name_vfun appl vle = if is_traced () && has_type vle (topwit wit_tacvalue) then match to_tacvalue vle with - | VFun (appl0,trace,lfun,vars,t) -> of_tacvalue (VFun (combine_appl appl0 appl,trace,lfun,vars,t)) + | VFun (appl0,trace,loc,lfun,vars,t) -> of_tacvalue (VFun (combine_appl appl0 appl,trace,loc,lfun,vars,t)) | _ -> vle else vle @@ -134,6 +134,7 @@ let f_avoid_ids : Id.Set.t TacStore.field = TacStore.field () (* ids inherited from the call context (needed to get fresh ids) *) let f_debug : debug_info TacStore.field = TacStore.field () let f_trace : ltac_trace TacStore.field = TacStore.field () +let f_loc : Loc.t TacStore.field = TacStore.field () (* Signature for interpretation: val_interp and interpretation functions *) type interp_sign = Geninterp.interp_sign = @@ -141,12 +142,23 @@ type interp_sign = Geninterp.interp_sign = ; poly : bool ; extra : TacStore.t } +let add_extra_trace trace extra = TacStore.set extra f_trace trace let extract_trace ist = if is_traced () then match TacStore.get ist.extra f_trace with | None -> [] | Some l -> l else [] +let add_extra_loc loc extra = + match loc with + | None -> extra + | Some loc -> TacStore.set extra f_loc loc +let add_loc loc ist = + match loc with + | None -> ist + | Some loc -> { ist with extra = TacStore.set ist.extra f_loc loc } +let extract_loc ist = TacStore.get ist.extra f_loc + let print_top_val env v = Pptactic.pr_value Pptactic.ltop v let catching_error call_trace fail (e, info) = @@ -161,27 +173,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 call_trace tac = + wrap_error + tac + (catching_error call_trace (fun (e, info) -> Proofview.tclZERO ~info e)) -let catch_error_tac ?loc call_trace tac = - wrap_error ?loc +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)) @@ -204,7 +234,7 @@ let pr_inspect env expr result = let pp_result = if has_type result (topwit wit_tacvalue) then match to_tacvalue result with - | VFun (_,_, ist, ul, b) -> + | VFun (_, _, _, ist, ul, b) -> let body = if List.is_empty ul then b else (TacFun (ul, b)) in str "a closure with body " ++ fnl() ++ pr_closure env ist body | VRec (ist, body) -> @@ -231,10 +261,10 @@ let propagate_trace ist loc id v = if has_type v (topwit wit_tacvalue) then let tacv = to_tacvalue v in match tacv with - | VFun (appl,_,lfun,it,b) -> + | VFun (appl,_,_,lfun,it,b) -> let t = if List.is_empty it then b else TacFun (it,b) in let trace = push_trace(loc,LtacVarCall (id,t)) ist in - let ans = VFun (appl,trace,lfun,it,b) in + let ans = VFun (appl,trace,loc,lfun,it,b) in Proofview.tclUNIT (of_tacvalue ans) | _ -> Proofview.tclUNIT v else Proofview.tclUNIT v @@ -242,7 +272,7 @@ let propagate_trace ist loc id v = let append_trace trace v = if has_type v (topwit wit_tacvalue) then match to_tacvalue v with - | VFun (appl,trace',lfun,it,b) -> of_tacvalue (VFun (appl,trace'@trace,lfun,it,b)) + | VFun (appl,trace',loc,lfun,it,b) -> of_tacvalue (VFun (appl,trace'@trace,loc,lfun,it,b)) | _ -> v else v @@ -254,7 +284,7 @@ let coerce_to_tactic loc id v = if has_type v (topwit wit_tacvalue) then let tacv = to_tacvalue v in match tacv with - | VFun _ -> v + | VFun (appl,trace,_,lfun,it,b) -> of_tacvalue (VFun (appl,trace,loc,lfun,it,b)) | _ -> fail () else fail () @@ -553,7 +583,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 @@ -1044,7 +1074,7 @@ let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : Val.t Ftacti function. *) let value_interp ist = match tac with | TacFun (it, body) -> - Ftactic.return (of_tacvalue (VFun (UnnamedAppl,extract_trace ist, ist.lfun, it, body))) + Ftactic.return (of_tacvalue (VFun (UnnamedAppl, extract_trace ist, extract_loc ist, ist.lfun, it, body))) | TacLetIn (true,l,u) -> interp_letrec ist l u | TacLetIn (false,l,u) -> interp_letin ist l u | TacMatchGoal (lz,lr,lmr) -> interp_match_goal ist lz lr lmr @@ -1052,7 +1082,7 @@ let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : Val.t Ftacti | TacArg {loc;v} -> interp_tacarg ist v | t -> (* Delayed evaluation *) - Ftactic.return (of_tacvalue (VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], t))) + Ftactic.return (of_tacvalue (VFun (UnnamedAppl, extract_trace ist, extract_loc ist, ist.lfun, [], t))) in let open Ftactic in Control.check_for_interrupt (); @@ -1066,12 +1096,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 +1175,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 {CAst.loc} -> Ftactic.run (val_interp (add_loc loc ist) tac) (fun v -> tactic_of_value ist v) | TacSelect (sel, tac) -> Tacticals.New.tclSELECT sel (interp_tactic ist tac) (* For extensions *) | TacAlias {loc; v=(s,l)} -> @@ -1160,9 +1190,9 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with let ist = { lfun ; poly - ; extra = TacStore.set ist.extra f_trace trace } in + ; extra = add_extra_loc loc (add_extra_trace trace ist.extra) } in val_interp ist alias.Tacenv.alias_body >>= fun v -> - Ftactic.lift (catch_error_loc ?loc (tactic_of_value ist v)) + Ftactic.lift (tactic_of_value ist v) in let tac = Ftactic.with_env interp_vars >>= fun (env, lr) -> @@ -1191,7 +1221,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,11 +1255,12 @@ 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 (* interp *) loc false trace + (val_interp ~appl (add_loc (* exec *) loc ist) (Tacenv.interp_ltac r))) and interp_tacarg ist arg : Val.t Ftactic.t = match arg with - | TacGeneric arg -> interp_genarg ist arg + | TacGeneric (_,arg) -> interp_genarg ist arg | Reference r -> interp_ltac_reference false ist r | ConstrMayEval c -> Ftactic.enter begin fun gl -> @@ -1279,8 +1310,8 @@ and interp_app loc ist fv largs : Val.t Ftactic.t = is not a tactic that expects arguments. Otherwise Ltac goes into an infinite loop (val_interp puts a VFun back on body, and then interp_app is called again...) *) - | (VFun(appl,trace,olfun,(_::_ as var),body) - |VFun(appl,trace,olfun,([] as var), + | (VFun(appl,trace,_,olfun,(_::_ as var),body) + |VFun(appl,trace,_,olfun,([] as var), (TacFun _|TacLetIn _|TacMatchGoal _|TacMatch _| TacArg _ as body))) -> let (extfun,lvar,lval)=head_with_value (var,largs) in let fold accu (id, v) = Id.Map.add id v accu in @@ -1294,7 +1325,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 (add_loc loc ist) body)) >>= fun v -> Ftactic.return (name_vfun (push_appl appl largs) v) end begin fun (e, info) -> @@ -1315,8 +1346,8 @@ and interp_app loc ist fv largs : Val.t Ftactic.t = end <*> if List.is_empty lval then Ftactic.return v else interp_app loc ist v lval else - Ftactic.return (of_tacvalue (VFun(push_appl appl largs,trace,newlfun,lvar,body))) - | (VFun(appl,trace,olfun,[],body)) -> + Ftactic.return (of_tacvalue (VFun(push_appl appl largs,trace,loc,newlfun,lvar,body))) + | (VFun(appl,trace,_,olfun,[],body)) -> let extra_args = List.length largs in let info = Exninfo.reify () in Tacticals.New.tclZEROMSG ~info @@ -1335,15 +1366,15 @@ and interp_app loc ist fv largs : Val.t Ftactic.t = and tactic_of_value ist vle = if has_type vle (topwit wit_tacvalue) then match to_tacvalue vle with - | VFun (appl,trace,lfun,[],t) -> + | VFun (appl,trace,loc,lfun,[],t) -> Proofview.tclProofInfo [@ocaml.warning "-3"] >>= fun (_name, poly) -> let ist = { lfun = lfun; poly; extra = TacStore.set ist.extra f_trace []; } in - let tac = name_if_glob appl (eval_tactic ist t) in - Profile_ltac.do_profile "tactic_of_value" trace (catch_error_tac trace tac) - | VFun (appl,_,vmap,vars,_) -> + let tac = name_if_glob appl (eval_tactic_ist ist t) in + Profile_ltac.do_profile "tactic_of_value" trace (catch_error_tac_loc loc false trace tac) + | VFun (appl,_,loc,vmap,vars,_) -> let tactic_nm = match appl with UnnamedAppl -> "An unnamed user-defined tactic" @@ -1422,14 +1453,14 @@ and interp_match_success ist { Tactic_matching.subst ; context ; terms ; lhs } = let ist = { ist with lfun } in val_interp ist lhs >>= fun v -> if has_type v (topwit wit_tacvalue) then match to_tacvalue v with - | VFun (appl,trace,lfun,[],t) -> + | VFun (appl,trace,loc,lfun,[],t) -> let ist = { lfun = lfun ; poly ; extra = TacStore.set ist.extra f_trace trace } in - let tac = eval_tactic ist t in - let dummy = VFun (appl,extract_trace ist, Id.Map.empty, [], TacId []) in + let tac = eval_tactic_ist ist t in + let dummy = VFun (appl, extract_trace ist, loc, Id.Map.empty, [], TacId []) in catch_error_tac trace (tac <*> Ftactic.return (of_tacvalue dummy)) | _ -> Ftactic.return v else Ftactic.return v @@ -1909,11 +1940,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 *) @@ -1922,7 +1953,7 @@ module Value = struct include Taccoerce.Value let of_closure ist tac = - let closure = VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], tac) in + let closure = VFun (UnnamedAppl, extract_trace ist, None, ist.lfun, [], tac) in of_tacvalue closure let apply_expr f args = @@ -1959,22 +1990,26 @@ 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 let interp t = interp_tac_gen Id.Map.empty Id.Set.empty (get_debug()) t +(* MUST be marshallable! *) +type tactic_expr = { + global: bool; + ast: Tacexpr.raw_tactic_expr; +} + (* Used to hide interpretation for pretty-print, now just launch tactics *) (* [global] means that [t] should be internalized outside of goals. *) -let hide_interp global t ot = +let hide_interp {global;ast} = let hide_interp env = let ist = Genintern.empty_glob_sign env in - let te = intern_pure_tactic ist t in + let te = intern_pure_tactic ist ast in let t = eval_tactic te in - match ot with - | None -> t - | Some t' -> Tacticals.New.tclTHEN t t' + t in if global then Proofview.tclENV >>= fun env -> @@ -1984,6 +2019,8 @@ let hide_interp global t ot = hide_interp (Proofview.Goal.env gl) end +let hide_interp = ComTactic.register_tactic_interpreter "ltac1" hide_interp + (***************************************************************************) (** Register standard arguments *) @@ -2010,6 +2047,9 @@ let () = declare_uniform wit_int let () = + declare_uniform wit_nat + +let () = declare_uniform wit_bool let () = @@ -2076,7 +2116,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 +2143,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/ltac/tacinterp.mli b/plugins/ltac/tacinterp.mli index cbb17bf0fa..01d7306c9d 100644 --- a/plugins/ltac/tacinterp.mli +++ b/plugins/ltac/tacinterp.mli @@ -126,8 +126,12 @@ val interp_tac_gen : value Id.Map.t -> Id.Set.t -> val interp : raw_tactic_expr -> unit Proofview.tactic (** Hides interpretation for pretty-print *) +type tactic_expr = { + global: bool; + ast: Tacexpr.raw_tactic_expr; +} -val hide_interp : bool -> raw_tactic_expr -> unit Proofview.tactic option -> unit Proofview.tactic +val hide_interp : tactic_expr ComTactic.tactic_interpreter (** Internals that can be useful for syntax extensions. *) diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index c2f1589b74..fd869b225f 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -237,7 +237,7 @@ and subst_tacarg subst = function | TacPretype c -> TacPretype (subst_glob_constr subst c) | TacNumgoals -> TacNumgoals | Tacexp t -> Tacexp (subst_tactic subst t) - | TacGeneric arg -> TacGeneric (subst_genarg subst arg) + | TacGeneric (isquot,arg) -> TacGeneric (isquot,subst_genarg subst arg) (* Reads the rules of a Match Context or a Match *) and subst_match_rule subst = function diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index 9eeba614c7..9008691bca 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -354,7 +354,7 @@ let is_linear_for v pc = *) let is_linear_substitution sys ((p, o), prf) = - let pred v = v =/ Q.one || v =/ Q.neg_one in + let pred v = v =/ Q.one || v =/ Q.minus_one in match o with | Eq -> ( match @@ -761,7 +761,7 @@ let reduce_unary psys = let is_unary_equation (cstr, prf) = if cstr.op == Eq then Vect.find - (fun v n -> if n =/ Q.one || n =/ Q.neg_one then Some v else None) + (fun v n -> if n =/ Q.one || n =/ Q.minus_one then Some v else None) cstr.coeffs else None in @@ -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/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 44bc20e55f..d2c49c4432 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -2141,6 +2141,7 @@ let really_call_csdpcert : List.fold_left Filename.concat (Envars.coqlib ()) ["plugins"; "micromega"; "csdpcert" ^ Coq_config.exec_extension] in + let cmdname = if Sys.file_exists cmdname then cmdname else "csdpcert" in match (command cmdname [|cmdname|] (provername, poly) : csdp_certificate) with | F str -> if debug then Printf.fprintf stdout "really_call_csdpcert : %s\n" str; diff --git a/plugins/micromega/dune b/plugins/micromega/dune index 33ad3a0138..204125ab56 100644 --- a/plugins/micromega/dune +++ b/plugins/micromega/dune @@ -4,7 +4,7 @@ ; be careful not to link the executable to the plugin! (modules (:standard \ csdpcert g_zify zify)) (synopsis "Coq's micromega plugin") - (libraries num coq.plugins.ltac)) + (libraries coq.plugins.ltac)) (executable (name csdpcert) diff --git a/plugins/micromega/mfourier.ml b/plugins/micromega/mfourier.ml index 3d1770a541..f4d17b8940 100644 --- a/plugins/micromega/mfourier.ml +++ b/plugins/micromega/mfourier.ml @@ -190,6 +190,7 @@ let system_list sys = let add (v1, c1) (v2, c2) = assert (c1 <>/ Q.zero && c2 <>/ Q.zero); + (* XXX Can use Q.inv now *) let res = mul_add (Q.one // c1) v1 (Q.one // c2) v2 in (res, count res) @@ -569,7 +570,7 @@ module Fourier = struct (* We add a dummy (fresh) variable for vector *) let fresh = List.fold_left (fun fr c -> max fr (Vect.fresh c.coeffs)) 0 l in let cstr = - {coeffs = Vect.set fresh Q.neg_one vect; op = Eq; cst = Q.zero} + {coeffs = Vect.set fresh Q.minus_one vect; op = Eq; cst = Q.zero} in match solve fresh choose_equality_var choose_variable (cstr :: l) with | Inr prf -> None (* This is an unsatisfiability proof *) diff --git a/plugins/micromega/numCompat.ml b/plugins/micromega/numCompat.ml index 4cb91ea520..02c4bab497 100644 --- a/plugins/micromega/numCompat.ml +++ b/plugins/micromega/numCompat.ml @@ -31,37 +31,24 @@ module type ZArith = sig end module Z = struct - type t = Big_int.big_int - - open Big_int - - let zero = zero_big_int - let one = unit_big_int - let two = big_int_of_int 2 - let add = Big_int.add_big_int - let sub = Big_int.sub_big_int - let mul = Big_int.mult_big_int - let div = Big_int.div_big_int - let neg = Big_int.minus_big_int - let sign = Big_int.sign_big_int - let equal = eq_big_int - let compare = compare_big_int - let power_int = power_big_int_positive_int - let quomod = quomod_big_int + (* Beware this only works fine in ZArith >= 1.10 due to + https://github.com/ocaml/Zarith/issues/58 *) + include Z - let ppcm x y = - let g = gcd_big_int x y in - let x' = div_big_int x g in - let y' = div_big_int y g in - mult_big_int g (mult_big_int x' y') - - let gcd = gcd_big_int + (* Constants *) + let two = Z.of_int 2 + let ten = Z.of_int 10 + let power_int = Big_int_Z.power_big_int_positive_int + let quomod = Big_int_Z.quomod_big_int - let lcm x y = - if eq_big_int x zero && eq_big_int y zero then zero - else abs_big_int (div_big_int (mult_big_int x y) (gcd x y)) + (* zarith fails with division by zero if x == 0 && y == 0 *) + let lcm x y = if Z.equal x zero && Z.equal y zero then zero else Z.lcm x y - let to_string = string_of_big_int + let ppcm x y = + let g = gcd x y in + let x' = Z.div x g in + let y' = Z.div y g in + Z.mul g (Z.mul x' y') end module type QArith = sig @@ -74,7 +61,7 @@ module type QArith = sig val one : t val two : t val ten : t - val neg_one : t + val minus_one : t module Notations : sig val ( // ) : t -> t -> t @@ -119,56 +106,64 @@ end module Q : QArith with module Z = Z = struct module Z = Z - type t = Num.num + let pow_check_exp x y = + let z_res = + if y = 0 then Z.one + else if y > 0 then Z.pow x y + else (* s < 0 *) + Z.pow x (abs y) + in + let z_res = Q.of_bigint z_res in + if 0 <= y then z_res else Q.inv z_res - open Num + include Q - let of_int x = Int x - let zero = Int 0 - let one = Int 1 - let two = Int 2 - let ten = Int 10 - let neg_one = Int (-1) + let two = Q.(of_int 2) + let ten = Q.(of_int 10) module Notations = struct - let ( // ) = div_num - let ( +/ ) = add_num - let ( -/ ) = sub_num - let ( */ ) = mult_num - let ( =/ ) = eq_num - let ( <>/ ) = ( <>/ ) - let ( >/ ) = ( >/ ) - let ( >=/ ) = ( >=/ ) - let ( </ ) = ( </ ) - let ( <=/ ) = ( <=/ ) + let ( // ) = Q.div + let ( +/ ) = Q.add + let ( -/ ) = Q.sub + let ( */ ) = Q.mul + let ( =/ ) = Q.equal + let ( <>/ ) x y = not (Q.equal x y) + let ( >/ ) = Q.gt + let ( >=/ ) = Q.geq + let ( </ ) = Q.lt + let ( <=/ ) = Q.leq end - let compare = compare_num - let make x y = Big_int x // Big_int y - - let numdom r = - let r' = Ratio.normalize_ratio (ratio_of_num r) in - (Ratio.numerator_ratio r', Ratio.denominator_ratio r') - - let num x = numdom x |> fst - let den x = numdom x |> snd - let of_bigint x = Big_int x - let to_bigint = big_int_of_num - let neg = minus_num - - (* let inv = *) - let max = max_num - let min = min_num - let sign = sign_num - let abs = abs_num - let mod_ = mod_num - let floor = floor_num - let ceiling = ceiling_num - let round = round_num - let pow2 n = power_num two (Int n) - let pow10 n = power_num ten (Int n) - let power x = power_num (Int x) - let to_string = string_of_num - let of_string = num_of_string - let to_float = float_of_num + (* XXX: review / improve *) + let floorZ q : Z.t = Z.fdiv (num q) (den q) + let floor q : t = floorZ q |> Q.of_bigint + let ceiling q : t = Z.cdiv (Q.num q) (Q.den q) |> Q.of_bigint + let half = Q.make Z.one Z.two + + (* We imitate Num's round which is to the nearest *) + let round q = floor (Q.add half q) + + (* XXX: review / improve *) + let quo x y = + let s = sign y in + let res = floor (x / abs y) in + if Int.equal s (-1) then neg res else res + + let mod_ x y = x - (y * quo x y) + + (* XXX: review / improve *) + (* Note that Z.pow doesn't support negative exponents *) + + let pow2 y = pow_check_exp Z.two y + let pow10 y = pow_check_exp Z.ten y + + let power (x : int) (y : t) : t = + let y = + try Q.to_int y + with Z.Overflow -> + (* XXX: make doesn't link Pp / CErrors for csdpcert, that could be fixed *) + raise (Invalid_argument "[micromega] overflow in exponentiation") + (* CErrors.user_err (Pp.str "[micromega] overflow in exponentiation") *) + in + pow_check_exp (Z.of_int x) y end diff --git a/plugins/micromega/numCompat.mli b/plugins/micromega/numCompat.mli index acc6be6ce0..0b4d52708f 100644 --- a/plugins/micromega/numCompat.mli +++ b/plugins/micromega/numCompat.mli @@ -25,8 +25,15 @@ module type ZArith = sig val power_int : t -> int -> t val quomod : t -> t -> t * t val ppcm : t -> t -> t + + (** [gcd x y] Greatest Common Divisor. Must always return a + positive number *) val gcd : t -> t -> t + + (** [lcm x y] Least Common Multiplier. Must always return a + positive number *) val lcm : t -> t -> t + val to_string : t -> string end @@ -40,7 +47,9 @@ module type QArith = sig val one : t val two : t val ten : t - val neg_one : t + + (** -1 constant *) + val minus_one : t module Notations : sig val ( // ) : t -> t -> t diff --git a/plugins/micromega/polynomial.ml b/plugins/micromega/polynomial.ml index afef41d67e..5c0aa9ef0d 100644 --- a/plugins/micromega/polynomial.ml +++ b/plugins/micromega/polynomial.ml @@ -156,7 +156,7 @@ let pp_mon o (m, i) = if Monomial.is_const m then if Q.zero =/ i then () else Printf.fprintf o "%s" (Q.to_string i) else if Q.one =/ i then Monomial.pp o m - else if Q.neg_one =/ i then Printf.fprintf o "-%a" Monomial.pp m + else if Q.minus_one =/ i then Printf.fprintf o "-%a" Monomial.pp m else if Q.zero =/ i then () else Printf.fprintf o "%s*%a" (Q.to_string i) Monomial.pp m @@ -912,7 +912,7 @@ module WithProof = struct else match o with | Eq -> - Some ((Vect.set 0 Q.neg_one Vect.null, Eq), ProofFormat.Gcd (g, prf)) + Some ((Vect.set 0 Q.minus_one Vect.null, Eq), ProofFormat.Gcd (g, prf)) | Gt -> failwith "cutting_plane ignore strict constraints" | Ge -> (* This is a non-trivial common divisor *) @@ -999,7 +999,7 @@ module WithProof = struct | Some (c, p) -> Some (c, ProofFormat.simplify_prf_rule p) let is_substitution strict ((p, o), prf) = - let pred v = if strict then v =/ Q.one || v =/ Q.neg_one else true in + let pred v = if strict then v =/ Q.one || v =/ Q.minus_one else true in match o with Eq -> LinPoly.search_linear pred p | _ -> None let subst1 sys0 = diff --git a/plugins/micromega/simplex.ml b/plugins/micromega/simplex.ml index eaa26ded62..f59d65085a 100644 --- a/plugins/micromega/simplex.ml +++ b/plugins/micromega/simplex.ml @@ -247,8 +247,8 @@ let solve_column (c : var) (r : var) (e : Vect.t) : Vect.t = let a = Vect.get c e in if a =/ Q.zero then failwith "Cannot solve column" else - let a' = Q.neg_one // a in - Vect.mul a' (Vect.set r Q.neg_one (Vect.set c Q.zero e)) + let a' = Q.minus_one // a in + Vect.mul a' (Vect.set r Q.minus_one (Vect.set c Q.zero e)) (** [pivot_row r c e] @param c is such that c = e @@ -364,7 +364,8 @@ let push_real (opt : bool) (nw : var) (v : Vect.t) (rst : Restricted.t) if n >=/ Q.zero then Sat (t', None) else let v' = safe_find "push_real" nw t' in - Unsat (Vect.set nw Q.one (Vect.set 0 Q.zero (Vect.mul Q.neg_one v'))) ) + Unsat (Vect.set nw Q.one (Vect.set 0 Q.zero (Vect.mul Q.minus_one v'))) + ) (** One complication is that equalities needs some pre-processing. *) @@ -399,7 +400,7 @@ let eliminate_equalities (vr0 : var) (l : Polynomial.cstr list) = elim (idx + 1) (vr + 1) (IMap.add vr (idx, true) vm) l ((vr, v) :: acc) | Eq -> let v1 = Vect.set 0 (Q.neg c.cst) c.coeffs in - let v2 = Vect.mul Q.neg_one v1 in + let v2 = Vect.mul Q.minus_one v1 in let vm = IMap.add vr (idx, true) (IMap.add (vr + 1) (idx, false) vm) in elim (idx + 1) (vr + 2) vm l ((vr, v1) :: (vr + 1, v2) :: acc) | Gt -> raise Strict ) diff --git a/plugins/micromega/sos.ml b/plugins/micromega/sos.ml index 2b04bb80e2..aeb9d14555 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) @@ -576,7 +576,7 @@ let eliminate_all_equations one = else let v = choose_variable eq in let a = apply eq v in - let eq' = equation_cmul (Q.neg_one // a) (undefine v eq) in + let eq' = equation_cmul (Q.minus_one // a) (undefine v eq) in let elim e = let b = tryapplyd e v Q.zero in if b =/ Q.zero then e @@ -814,7 +814,7 @@ let bmatrix_add = combine ( +/ ) (fun x -> x =/ Q.zero) let bmatrix_cmul c bm = if c =/ Q.zero then undefined else mapf (fun x -> c */ x) bm -let bmatrix_neg = bmatrix_cmul Q.neg_one +let bmatrix_neg = bmatrix_cmul Q.minus_one (* ------------------------------------------------------------------------- *) (* Smash a block matrix into components. *) @@ -943,7 +943,7 @@ let real_positivnullstellensatz_general linf d eqs leqs pol = List.fold_right (fun k -> List.nth pvs (k - 1) |-> element vec k) (1 -- dim vec) - ((0, 0, 0) |=> Q.neg_one) + ((0, 0, 0) |=> Q.minus_one) in let finalassigs = foldl (fun a v e -> (v |-> equation_eval newassigs e) a) newassigs allassig @@ -1166,7 +1166,7 @@ let sumofsquares_general_symmetry tool pol = match cls with | [] -> raise Sanity | [h] -> acc - | h :: t -> List.map (fun k -> (k |-> Q.neg_one) (h |=> Q.one)) t @ acc + | h :: t -> List.map (fun k -> (k |-> Q.minus_one) (h |=> Q.one)) t @ acc in List.fold_right mk_eq eqvcls [] in @@ -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/vect.ml b/plugins/micromega/vect.ml index 3e0b1f2cd9..4df32f2ba4 100644 --- a/plugins/micromega/vect.ml +++ b/plugins/micromega/vect.ml @@ -52,7 +52,7 @@ let pp_var_num pp_var o {var = v; coe = n} = if Int.equal v 0 then if Q.zero =/ n then () else Printf.fprintf o "%s" (Q.to_string n) else if Q.one =/ n then pp_var o v - else if Q.neg_one =/ n then Printf.fprintf o "-%a" pp_var v + else if Q.minus_one =/ n then Printf.fprintf o "-%a" pp_var v else if Q.zero =/ n then () else Printf.fprintf o "%s*%a" (Q.to_string n) pp_var v @@ -60,7 +60,7 @@ let pp_var_num_smt pp_var o {var = v; coe = n} = if Int.equal v 0 then if Q.zero =/ n then () else Printf.fprintf o "%s" (Q.to_string n) else if Q.one =/ n then pp_var o v - else if Q.neg_one =/ n then Printf.fprintf o "(- %a)" pp_var v + else if Q.minus_one =/ n then Printf.fprintf o "(- %a)" pp_var v else if Q.zero =/ n then () else Printf.fprintf o "(* %s %a)" (Q.to_string n) pp_var v 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..c24bafc761 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,20 +121,20 @@ 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)) -let tpexpr = gen_constant "plugins.setoid_ring.pexpr" -let ttconst = gen_constant "plugins.setoid_ring.const" -let ttvar = gen_constant "plugins.setoid_ring.var" -let ttadd = gen_constant "plugins.setoid_ring.add" -let ttsub = gen_constant "plugins.setoid_ring.sub" -let ttmul = gen_constant "plugins.setoid_ring.mul" -let ttopp = gen_constant "plugins.setoid_ring.opp" -let ttpow = gen_constant "plugins.setoid_ring.pow" +let tpexpr = gen_constant "plugins.ring.pexpr" +let ttconst = gen_constant "plugins.ring.const" +let ttvar = gen_constant "plugins.ring.var" +let ttadd = gen_constant "plugins.ring.add" +let ttsub = gen_constant "plugins.ring.sub" +let ttmul = gen_constant "plugins.ring.mul" +let ttopp = gen_constant "plugins.ring.opp" +let ttpow = gen_constant "plugins.ring.pow" let tlist = gen_constant "core.list.type" let lnil = gen_constant "core.list.nil" @@ -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/ring/dune b/plugins/ring/dune new file mode 100644 index 0000000000..080d8c672e --- /dev/null +++ b/plugins/ring/dune @@ -0,0 +1,7 @@ +(library + (name ring_plugin) + (public_name coq.plugins.ring) + (synopsis "Coq's ring plugin") + (libraries coq.plugins.ltac)) + +(coq.pp (modules g_ring)) diff --git a/plugins/setoid_ring/g_newring.mlg b/plugins/ring/g_ring.mlg index eb7710bbc2..3c800987ac 100644 --- a/plugins/setoid_ring/g_newring.mlg +++ b/plugins/ring/g_ring.mlg @@ -13,8 +13,8 @@ open Ltac_plugin open Pp open Util -open Newring_ast -open Newring +open Ring_ast +open Ring open Stdarg open Tacarg open Pcoq.Constr @@ -22,7 +22,7 @@ open Pltac } -DECLARE PLUGIN "newring_plugin" +DECLARE PLUGIN "ring_plugin" TACTIC EXTEND protect_fv | [ "protect_fv" string(map) "in" ident(id) ] -> diff --git a/plugins/setoid_ring/newring.ml b/plugins/ring/ring.ml index 95faede7d0..9c75175889 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/ring/ring.ml @@ -28,7 +28,7 @@ open Libobject open Printer open Declare open Entries -open Newring_ast +open Ring_ast open Proofview.Notations let error msg = CErrors.user_err Pp.(str msg) @@ -115,7 +115,7 @@ let closed_term args _ = match args with let closed_term_ast = let tacname = { - mltac_plugin = "newring_plugin"; + mltac_plugin = "ring_plugin"; mltac_tactic = "closed_term"; } in let () = Tacenv.register_ml_tactic tacname [|closed_term|] in @@ -127,8 +127,8 @@ let closed_term_ast = let l = List.map (fun gr -> ArgArg(Loc.tag gr)) l in TacFun([Name(Id.of_string"t")], TacML(CAst.make (tacname, - [TacGeneric (Genarg.in_gen (Genarg.glbwit Stdarg.wit_constr) (DAst.make @@ GVar(Id.of_string"t"),None)); - TacGeneric (Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Stdarg.wit_ref)) l)]))) + [TacGeneric (None, Genarg.in_gen (Genarg.glbwit Stdarg.wit_constr) (DAst.make @@ GVar(Id.of_string"t"),None)); + TacGeneric (None, Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Stdarg.wit_ref)) l)]))) (* let _ = add_tacdef false ((Loc.ghost,Id.of_string"ring_closed_term" *) @@ -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))) @@ -174,7 +178,7 @@ let tactic_res = ref [||] let get_res = let open Tacexpr in - let name = { mltac_plugin = "newring_plugin"; mltac_tactic = "get_res"; } in + let name = { mltac_plugin = "ring_plugin"; mltac_tactic = "get_res"; } in let entry = { mltac_name = name; mltac_index = 0 } in let tac args ist = let n = Tacinterp.Value.cast (Genarg.topwit Stdarg.wit_int) (List.hd args) in @@ -196,7 +200,7 @@ let exec_tactic env evd n f args = (* Build the getter *) let lid = List.init n (fun i -> Id.of_string("x"^string_of_int i)) in let n = Genarg.in_gen (Genarg.glbwit Stdarg.wit_int) n in - let get_res = TacML (CAst.make (get_res, [TacGeneric n])) in + let get_res = TacML (CAst.make (get_res, [TacGeneric (None, n)])) in let getter = Tacexp (TacFun (List.map (fun n -> Name n) lid, get_res)) in (* Evaluate the whole result *) let gl = dummy_goal env evd in @@ -208,7 +212,7 @@ let exec_tactic env evd n f args = let gen_constant n = lazy (EConstr.of_constr (UnivGen.constr_of_monomorphic_global (Coqlib.lib_ref n))) let gen_reference n = lazy (Coqlib.lib_ref n) -let coq_mk_Setoid = gen_constant "plugins.setoid_ring.Build_Setoid_Theory" +let coq_mk_Setoid = gen_constant "plugins.ring.Build_Setoid_Theory" let coq_None = gen_reference "core.option.None" let coq_Some = gen_reference "core.option.Some" let coq_eq = gen_constant "core.eq.type" @@ -261,7 +265,7 @@ let znew_ring_path = let zltac s = lazy(KerName.make (ModPath.MPfile znew_ring_path) (Label.make s)) -let mk_cst l s = lazy (Coqlib.coq_reference "newring" l s) [@@ocaml.warning "-3"] +let mk_cst l s = lazy (Coqlib.coq_reference "ring" l s) [@@ocaml.warning "-3"] let pol_cst s = mk_cst [plugin_dir;"Ring_polynom"] s (* Ring theory *) @@ -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/setoid_ring/newring.mli b/plugins/ring/ring.mli index 73d6d91434..6d24ae84d7 100644 --- a/plugins/setoid_ring/newring.mli +++ b/plugins/ring/ring.mli @@ -11,7 +11,7 @@ open Names open EConstr open Constrexpr -open Newring_ast +open Ring_ast val protect_tac_in : string -> Id.t -> unit Proofview.tactic diff --git a/plugins/setoid_ring/newring_ast.ml b/plugins/ring/ring_ast.ml index 8b82783db9..8b82783db9 100644 --- a/plugins/setoid_ring/newring_ast.ml +++ b/plugins/ring/ring_ast.ml diff --git a/plugins/setoid_ring/newring_ast.mli b/plugins/ring/ring_ast.mli index 8b82783db9..8b82783db9 100644 --- a/plugins/setoid_ring/newring_ast.mli +++ b/plugins/ring/ring_ast.mli diff --git a/plugins/ring/ring_plugin.mlpack b/plugins/ring/ring_plugin.mlpack new file mode 100644 index 0000000000..91d7199f9b --- /dev/null +++ b/plugins/ring/ring_plugin.mlpack @@ -0,0 +1,3 @@ +Ring_ast +Ring +G_ring diff --git a/plugins/setoid_ring/dune b/plugins/setoid_ring/dune deleted file mode 100644 index 60522cd3f5..0000000000 --- a/plugins/setoid_ring/dune +++ /dev/null @@ -1,7 +0,0 @@ -(library - (name newring_plugin) - (public_name coq.plugins.setoid_ring) - (synopsis "Coq's setoid ring plugin") - (libraries coq.plugins.ltac)) - -(coq.pp (modules g_newring)) diff --git a/plugins/setoid_ring/newring_plugin.mlpack b/plugins/setoid_ring/newring_plugin.mlpack deleted file mode 100644 index 5aa79b5868..0000000000 --- a/plugins/setoid_ring/newring_plugin.mlpack +++ /dev/null @@ -1,3 +0,0 @@ -Newring_ast -Newring -G_newring 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..89e0c9fcbe 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) @@ -403,7 +403,7 @@ END let pr_mmod = function May -> str "?" | Must -> str "!" | Once -> mt () let wit_ssrmmod = add_genarg "ssrmmod" (fun env sigma -> pr_mmod) -let ssrmmod = Pcoq.create_generic_entry Pcoq.utactic "ssrmmod" (Genarg.rawwit wit_ssrmmod);; +let ssrmmod = Pcoq.create_generic_entry2 "ssrmmod" (Genarg.rawwit wit_ssrmmod);; } @@ -1682,7 +1682,7 @@ let set_pr_ssrtac name prec afmt = (* FIXME *) () (* let ssrtac_expr ?loc name args = TacML (CAst.make ?loc (ssrtac_entry name, args)) let tclintros_expr ?loc tac ipats = - let args = [Tacexpr.TacGeneric (in_gen (rawwit wit_ssrintrosarg) (tac, ipats))] in + let args = [Tacexpr.TacGeneric (None, in_gen (rawwit wit_ssrintrosarg) (tac, ipats))] in ssrtac_expr ?loc "tclintros" args } @@ -1777,7 +1777,7 @@ let _ = set_pr_ssrtac "tcldo" 3 [ArgSep "do "; ArgSsr "doarg"] let ssrdotac_expr ?loc n m tac clauses = let arg = ((n, m), tac), clauses in - ssrtac_expr ?loc "tcldo" [Tacexpr.TacGeneric (in_gen (rawwit wit_ssrdoarg) arg)] + ssrtac_expr ?loc "tcldo" [Tacexpr.TacGeneric (None, in_gen (rawwit wit_ssrdoarg) arg)] } @@ -1828,7 +1828,7 @@ let tclseq_expr ?loc tac dir arg = let arg1 = in_gen (rawwit wit_ssrtclarg) tac in let arg2 = in_gen (rawwit wit_ssrseqdir) dir in let arg3 = in_gen (rawwit wit_ssrseqarg) (check_seqtacarg dir arg) in - ssrtac_expr ?loc "tclseq" (List.map (fun x -> Tacexpr.TacGeneric x) [arg1; arg2; arg3]) + ssrtac_expr ?loc "tclseq" (List.map (fun x -> Tacexpr.TacGeneric (None, x)) [arg1; arg2; arg3]) } @@ -2451,7 +2451,7 @@ GRAMMAR EXTEND Gram tactic_expr: LEVEL "3" [ RIGHTA [ IDENT "abstract"; gens = ssrdgens -> { ssrtac_expr ~loc "abstract" - [Tacexpr.TacGeneric (Genarg.in_gen (Genarg.rawwit wit_ssrdgens) gens)] } ]]; + [Tacexpr.TacGeneric (None, Genarg.in_gen (Genarg.rawwit wit_ssrdgens) gens)] } ]]; END TACTIC EXTEND ssrabstract | [ "abstract" ssrdgens(gens) ] -> { 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/detyping.ml b/pretyping/detyping.ml index 7fcb0795bd..91c155fcce 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -883,7 +883,12 @@ and detype_binder d flags bk avoid env sigma decl c = | BLetIn -> let c = detype d { flags with flg_isgoal = false } avoid env sigma (Option.get body) in (* Heuristic: we display the type if in Prop *) - let s = try Retyping.get_sort_family_of (snd env) sigma ty with _ when !Flags.in_debugger || !Flags.in_toplevel -> InType (* Can fail because of sigma missing in debugger *) in + let s = + (* It can fail if ty is an evar, or if run inside ocamldebug or the + OCaml toplevel since their printers don't have access to the proper sigma/env *) + try Retyping.get_sort_family_of (snd env) sigma ty + with Retyping.RetypeError _ -> InType + in let t = if s != InProp && not !Flags.raw_print then None else Some (detype d { flags with flg_isgoal = false } avoid env sigma ty) in GLetIn (na', c, t, r) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 2feae8cc25..a5311e162d 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,22 +1203,32 @@ 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 = +let occur_evars sigma evs c = + if Evar.Set.is_empty evs then false + else + let rec occur_rec c = match EConstr.kind sigma c with + | Evar (sp,_) when Evar.Set.mem sp evs -> raise Occur + | _ -> EConstr.iter sigma occur_rec c + in + try occur_rec c; false with Occur -> true + +let apply_on_subterm env evd fixed f test c t = let test = test env evd c in let prc env evd = Termops.Internal.print_constr_env env evd in let evdref = ref evd in + let fixedref = ref fixed in let rec applyrec (env,(k,c) as acc) t = - if Evar.Set.exists (fun fixed -> occur_evar !evdref fixed t) !fixedref then + if occur_evars !evdref !fixedref t then match EConstr.kind !evdref t with | Evar (ev, args) when Evar.Set.mem ev !fixedref -> t | _ -> map_constr_with_binders_left_to_right !evdref @@ -1234,7 +1241,8 @@ let apply_on_subterm env evd fixedref f test c t = try test env !evdref k c t with e when CErrors.noncritical e -> assert false in if b then (if debug_ho_unification () then Feedback.msg_debug (Pp.str "succeeded"); - let evd', t' = f !evdref k t in + let evd', fixed, t' = f !evdref !fixedref k t in + fixedref := fixed; evdref := evd'; t') else ( if debug_ho_unification () then Feedback.msg_debug (Pp.str "failed"); @@ -1243,7 +1251,7 @@ let apply_on_subterm env evd fixedref f test c t = applyrec acc t)) in let t' = applyrec (env,(0,c)) t in - !evdref, t' + !evdref, !fixedref, t' let filter_possible_projections evd c ty ctxt args = (* Since args in the types will be replaced by holes, we count the @@ -1352,9 +1360,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 @@ -1381,8 +1388,7 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = | _, _, [] -> [] | _ -> anomaly (Pp.str "Signature or instance are shorter than the occurrences list.") in - let fixed = ref Evar.Set.empty in - let rec set_holes env_rhs evd rhs = function + let rec set_holes env_rhs evd fixed rhs = function | (id,idty,c,cty,evsref,filter,occs)::subst -> let c = nf_evar evd c in if debug_ho_unification () then @@ -1391,7 +1397,7 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = prc env_rhs evd c ++ str" in " ++ prc env_rhs evd rhs); let occ = ref 1 in - let set_var evd k inst = + let set_var evd fixed k inst = let oc = !occ in if debug_ho_unification () then (Feedback.msg_debug Pp.(str"Found one occurrence"); @@ -1399,10 +1405,10 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = incr occ; match occs with | AtOccurrences occs -> - if Locusops.is_selected oc occs then evd, mkVar id.binder_name - else evd, inst + if Locusops.is_selected oc occs then evd, fixed, mkVar id.binder_name + else evd, fixed, inst | Unspecified prefer_abstraction -> - let evd, evty = set_holes env_rhs evd cty subst in + let evd, fixed, evty = set_holes env_rhs evd fixed cty subst in let evty = nf_evar evd evty in if debug_ho_unification () then Feedback.msg_debug Pp.(str"abstracting one occurrence " ++ prc env_rhs evd inst ++ @@ -1418,21 +1424,21 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = env_evar_unf evd evty else evd, evty in let (evd, evk) = new_pure_evar sign evd evty ~filter in + let fixed = Evar.Set.add evk fixed in evsref := (evk,evty,inst,prefer_abstraction)::!evsref; - fixed := Evar.Set.add evk !fixed; - evd, mkEvar (evk, instance) + evd, fixed, mkEvar (evk, instance) in - let evd, rhs' = apply_on_subterm env_rhs evd fixed set_var test c rhs in + let evd, fixed, rhs' = apply_on_subterm env_rhs evd fixed set_var test c rhs in if debug_ho_unification () then Feedback.msg_debug Pp.(str"abstracted: " ++ prc env_rhs evd rhs'); let () = check_selected_occs env_rhs evd c !occ occs in let env_rhs' = push_named (NamedDecl.LocalAssum (id,idty)) env_rhs in - set_holes env_rhs' evd rhs' subst - | [] -> evd, rhs in + set_holes env_rhs' evd fixed rhs' subst + | [] -> evd, fixed, rhs in let subst = make_subst (ctxt,args,argoccs) in - let evd, rhs' = set_holes env_rhs evd rhs subst in + let evd, _, rhs' = set_holes env_rhs evd Evar.Set.empty rhs subst in let rhs' = nf_evar evd rhs' in (* Thin evars making the term typable in env_evar *) let evd, rhs' = thin_evars env_evar evd ctxt rhs' in @@ -1555,7 +1561,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 +1589,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 +1600,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 +1627,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/evardefine.ml b/pretyping/evardefine.ml index f33030d6a4..eaf8c65811 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -175,10 +175,7 @@ let define_evar_as_sort env evd (ev,args) = let evd' = Evd.define ev (mkSort s) evd in Evd.set_leq_sort env evd' (Sorts.super s) (ESorts.kind evd' sort), s -(* Propagation of constraints through application and abstraction: - Given a type constraint on a functional term, returns the type - constraint on its domain and codomain. If the input constraint is - an evar instantiate it with the product of 2 new evars. *) +(* Unify with unknown array *) let rec presplit env sigma c = let c = Reductionops.whd_all env sigma c in @@ -189,25 +186,6 @@ let rec presplit env sigma c = presplit env sigma (mkApp (lam, args)) | _ -> sigma, c -let split_tycon ?loc env evd tycon = - match tycon with - | None -> evd,(make_annot Anonymous Relevant,None,None) - | Some c -> - let evd, c = presplit env evd c in - let evd, na, dom, rng = match EConstr.kind evd c with - | Prod (na,dom,rng) -> evd, na, dom, rng - | Evar ev -> - let (evd,prod) = define_evar_as_product env evd ev in - let (na,dom,rng) = destProd evd prod in - let anon = {na with binder_name = Anonymous} in - evd, anon, dom, rng - | _ -> - (* XXX no error to allow later coercion? Not sure if possible with funclass *) - error_not_product ?loc env evd c - in - evd, (na, mk_tycon dom, mk_tycon rng) - - let define_pure_evar_as_array env sigma evk = let evi = Evd.find_undefined sigma evk in let evenv = evar_env env evi in diff --git a/pretyping/evardefine.mli b/pretyping/evardefine.mli index e5c3f8baa1..5702e169c8 100644 --- a/pretyping/evardefine.mli +++ b/pretyping/evardefine.mli @@ -8,7 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Names open EConstr open Evd open Environ @@ -31,10 +30,6 @@ val mk_valcon : constr -> val_constraint val evar_absorb_arguments : env -> evar_map -> existential -> constr list -> evar_map * existential -val split_tycon : - ?loc:Loc.t -> env -> evar_map -> type_constraint -> - evar_map * (Name.t Context.binder_annot * type_constraint * type_constraint) - val split_as_array : env -> evar_map -> type_constraint -> evar_map * type_constraint (** If the constraint can be made to look like [array A] return [A], @@ -51,3 +46,6 @@ val define_evar_as_sort : env -> evar_map -> existential -> evar_map * Sorts.t val pr_tycon : env -> evar_map -> type_constraint -> Pp.t +(** Used for bidi heuristic when typing lambdas. Transforms an applied + evar to an evar with bigger context (ie ?X e to ?X'@{y=e}). *) +val presplit : env -> evar_map -> EConstr.t -> evar_map * EConstr.t diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 79839099f7..715b80f428 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) -> @@ -1172,8 +1196,8 @@ let postpone_non_unique_projection env evd pbty (evk,argsv as ev) sols rhs = let filter_compatible_candidates unify flags env evd evi args rhs c = let c' = instantiate_evar_array evi c args in match unify flags TermUnification env evd Reduction.CONV rhs c' with - | Success evd -> Some (c,evd) - | UnifFailure _ -> None + | Success evd -> Inl (c,evd) + | UnifFailure _ -> Inr c' (* [restrict_candidates ... filter ev1 ev2] restricts the candidates of ev1, removing those not compatible with the filter, as well as @@ -1194,8 +1218,8 @@ let restrict_candidates unify flags env evd filter1 (evk1,argsv1) (evk2,argsv2) let filter c2 = let compatibility = filter_compatible_candidates unify flags env evd evi2 argsv2 c1' c2 in match compatibility with - | None -> false - | Some _ -> true + | Inl _ -> true + | Inr _ -> false in let filtered = List.filter filter l2 in match filtered with [] -> false | _ -> true) l1 in @@ -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 @@ -1416,29 +1440,33 @@ let solve_refl ?(can_drop=false) unify flags env evd pbty evk argsv1 argsv2 = in advance, we check which of them apply *) exception NoCandidates -exception IncompatibleCandidates +exception IncompatibleCandidates of EConstr.t let solve_candidates unify flags env evd (evk,argsv) rhs = let evi = Evd.find evd evk in match evi.evar_candidates with | None -> raise NoCandidates | Some l -> - let l' = - List.map_filter - (fun c -> filter_compatible_candidates unify flags env evd evi argsv rhs c) l in - match l' with - | [] -> raise IncompatibleCandidates - | [c,evd] -> + let rec aux = function + | [] -> [], [] + | c::l -> + let compatl, disjointl = aux l in + match filter_compatible_candidates unify flags env evd evi argsv rhs c with + | Inl c -> c::compatl, disjointl + | Inr c -> compatl, c::disjointl in + match aux l with + | [], c::_ -> raise (IncompatibleCandidates c) + | [c,evd], _ -> (* solve_candidates might have been called recursively in the mean *) (* time and the evar been solved by the filtering process *) if Evd.is_undefined evd evk then let evd' = Evd.define evk c evd in check_evar_instance unify flags env evd' evk c else evd - | l when List.length l < List.length l' -> + | l, _::_ (* At least one discarded candidate *) -> let candidates = List.map fst l in restrict_evar evd evk None (UpdateWith candidates) - | l -> evd + | l, [] -> evd let occur_evar_upto_types sigma n c = let c = EConstr.Unsafe.to_constr c in @@ -1460,7 +1488,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' @@ -1769,6 +1798,6 @@ let solve_simple_eqn unify flags ?(choose=false) ?(imitate_defs=true) UnifFailure (evd,MetaOccurInBody evk1) | IllTypedInstance (env,t,u) -> UnifFailure (evd,InstanceNotSameType (evk1,env,t,u)) - | IncompatibleCandidates -> - UnifFailure (evd,ConversionFailed (env,mkEvar ev1,t2)) + | IncompatibleCandidates t -> + UnifFailure (evd,IncompatibleInstances (env,ev1,t,t2)) 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/pretype_errors.ml b/pretyping/pretype_errors.ml index 207ffc7b86..1e8441dd8a 100644 --- a/pretyping/pretype_errors.ml +++ b/pretyping/pretype_errors.ml @@ -20,6 +20,7 @@ type unification_error = | NotSameHead | NoCanonicalStructure | ConversionFailed of env * constr * constr (* Non convertible closed terms *) + | IncompatibleInstances of env * existential * constr * constr | MetaOccurInBody of Evar.t | InstanceNotSameType of Evar.t * env * types * types | UnifUnivInconsistency of Univ.univ_inconsistency diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli index 70f218d617..45997e9a66 100644 --- a/pretyping/pretype_errors.mli +++ b/pretyping/pretype_errors.mli @@ -23,6 +23,7 @@ type unification_error = | NotSameHead | NoCanonicalStructure | ConversionFailed of env * constr * constr + | IncompatibleInstances of env * existential * constr * constr | MetaOccurInBody of Evar.t | InstanceNotSameType of Evar.t * env * types * types | UnifUnivInconsistency of Univ.univ_inconsistency diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index b9825b6a92..7597661ca8 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -925,7 +925,32 @@ struct let sigma, ty' = Coercion.inh_coerce_to_prod ?loc ~program_mode !!env sigma ty in sigma, Some ty' in - let sigma, (name',dom,rng) = split_tycon ?loc !!env sigma tycon' in + let sigma,name',dom,rng = + match tycon' with + | None -> sigma,Anonymous, None, None + | Some ty -> + let sigma, ty = Evardefine.presplit !!env sigma ty in + match EConstr.kind sigma ty with + | Prod (na,dom,rng) -> + sigma, na.binder_name, Some dom, Some rng + | Evar ev -> + (* define_evar_as_product works badly when impredicativity + is possible but not known (#12623). OTOH if we know we + are impredicative (typically Prop) we want to keep the + information when typing the body. *) + let s = Retyping.get_sort_of !!env sigma ty in + if Environ.is_impredicative_sort !!env s + || Evd.check_leq sigma (Univ.Universe.type1) (Sorts.univ_of_sort s) + then + let sigma, prod = define_evar_as_product !!env sigma ev in + let na,dom,rng = destProd sigma prod in + sigma, na.binder_name, Some dom, Some rng + else + sigma, Anonymous, None, None + | _ -> + (* XXX no error to allow later coercion? Not sure if possible with funclass *) + error_not_product ?loc !!env sigma ty + in let dom_valcon = valcon_of_tycon dom in let sigma, j = eval_type_pretyper self ~program_mode ~poly resolve_tc dom_valcon env sigma c1 in let name = {binder_name=name; binder_relevance=Sorts.relevance_of_sort j.utj_type} in @@ -934,7 +959,7 @@ struct let var',env' = push_rel ~hypnaming sigma var env in let sigma, j' = eval_pretyper self ~program_mode ~poly resolve_tc rng env' sigma c2 in let name = get_name var' in - let resj = judge_of_abstraction !!env (orelse_name name name'.binder_name) j j' in + let resj = judge_of_abstraction !!env (orelse_name name name') j j' in discard_trace @@ inh_conv_coerce_to_tycon ?loc ~program_mode resolve_tc env sigma resj tycon let pretype_prod self (name, bk, c1, c2) = diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index fdc770dba6..08a6db5639 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -445,7 +445,7 @@ type state_reduction_function = let pr_state env sigma (tm,sk) = let open Pp in let pr c = Termops.Internal.print_constr_env env sigma c in - h 0 (pr tm ++ str "|" ++ cut () ++ Stack.pr pr sk) + h (pr tm ++ str "|" ++ cut () ++ Stack.pr pr sk) (*************************************) (*** Reduction Functions Operators ***) @@ -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) @@ -730,7 +705,7 @@ let rec whd_state_gen flags env sigma = let open Pp in let pr c = Termops.Internal.print_constr_env env sigma c in Feedback.msg_debug - (h 0 (str "<<" ++ pr x ++ + (h (str "<<" ++ pr x ++ str "|" ++ cut () ++ Stack.pr pr stack ++ str ">>")) in @@ -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..fc71254a46 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -11,7 +11,6 @@ (*i*) open Names open Globnames -open Term open Constr open Vars open Evd @@ -42,7 +41,11 @@ let get_solve_one_instance, solve_one_instance_hook = Hook.make () let resolve_one_typeclass ?(unique=get_typeclasses_unique_solutions ()) env evm t = Hook.get get_solve_one_instance env evm t unique -type direction = Forward | Backward +type class_method = { + meth_name : Name.t; + meth_info : hint_info option; + meth_const : Constant.t option; +} (* This module defines type-classes *) type typeclass = { @@ -59,8 +62,7 @@ type typeclass = { cl_props : Constr.rel_context; (* The method implementations as projections. *) - cl_projs : (Name.t * (direction * hint_info) option - * Constant.t option) list; + cl_projs : class_method list; cl_strict : bool; @@ -68,6 +70,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; @@ -155,66 +158,6 @@ let load_class cl = (** Build the subinstances hints. *) -let check_instance env sigma c = - try - let (evd, c) = resolve_one_typeclass env sigma - (Retyping.get_type_of env sigma c) in - not (Evd.has_undefined evd) - with e when CErrors.noncritical e -> false - -let build_subclasses ~check env sigma glob { hint_priority = pri } = - let _id = Nametab.basename_of_global glob in - let _next_id = - let i = ref (-1) in - (fun () -> incr i; - Nameops.add_suffix _id ("_subinstance_" ^ string_of_int !i)) - in - let ty, ctx = Typeops.type_of_global_in_context env glob in - let inst, ctx = UnivGen.fresh_instance_from ctx None in - let ty = Vars.subst_instance_constr inst ty in - let ty = EConstr.of_constr ty in - let sigma = Evd.merge_context_set Evd.univ_rigid sigma ctx in - let rec aux pri c ty path = - match class_of_constr env sigma ty with - | None -> [] - | Some (rels, ((tc,u), args)) -> - let instapp = - Reductionops.whd_beta env sigma (EConstr.of_constr (appvectc c (Context.Rel.to_extended_vect mkRel 0 rels))) - in - let instapp = EConstr.Unsafe.to_constr instapp in - let projargs = Array.of_list (args @ [instapp]) in - let projs = List.map_filter - (fun (n, b, proj) -> - match b with - | None -> None - | Some (Backward, _) -> None - | Some (Forward, info) -> - let proj = Option.get proj in - let rels = List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) rels in - let u = EConstr.EInstance.kind sigma u in - let body = it_mkLambda_or_LetIn (mkApp (mkConstU (proj,u), projargs)) rels in - if check && check_instance env sigma (EConstr.of_constr body) then None - else - let newpri = - match pri, info.hint_priority with - | Some p, Some p' -> Some (p + p') - | Some p, None -> Some (p + 1) - | _, _ -> None - in - Some (GlobRef.ConstRef proj, { info with hint_priority = newpri }, body)) tc.cl_projs - in - let declare_proj hints (cref, info, body) = - let path' = cref :: path in - let ty = Retyping.get_type_of env sigma (EConstr.of_constr body) in - let rest = aux pri body ty path' in - hints @ (path', info, body) :: rest - in List.fold_left declare_proj [] projs - in - let term = Constr.mkRef (glob, inst) in - (*FIXME subclasses should now get substituted for each particular instance of - the polymorphic superclass *) - aux pri term ty [glob] - (* * interface functions *) @@ -268,7 +211,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/typeclasses.mli b/pretyping/typeclasses.mli index 9de8083276..3f84d08a7e 100644 --- a/pretyping/typeclasses.mli +++ b/pretyping/typeclasses.mli @@ -13,8 +13,6 @@ open Constr open Evd open Environ -type direction = Forward | Backward - (* Core typeclasses hints *) type 'a hint_info_gen = { hint_priority : int option; @@ -22,6 +20,12 @@ type 'a hint_info_gen = type hint_info = (Pattern.patvar list * Pattern.constr_pattern) hint_info_gen +type class_method = { + meth_name : Name.t; + meth_info : hint_info option; + meth_const : Constant.t option; +} + (** This module defines type-classes *) type typeclass = { cl_univs : Univ.AUContext.t; @@ -39,7 +43,7 @@ type typeclass = { cl_props : Constr.rel_context; (** Context of definitions and properties on defs, will not be shared *) - cl_projs : (Name.t * (direction * hint_info) option * Constant.t option) list; + cl_projs : class_method list; (** The methods implementations of the typeclass as projections. Some may be undefinable due to sorting restrictions or simply undefined if no name is provided. The [int option option] indicates subclasses whose hint has @@ -127,11 +131,3 @@ val classes_transparent_state : unit -> TransparentState.t val solve_all_instances_hook : (env -> evar_map -> evar_filter -> bool -> bool -> bool -> evar_map) Hook.t val solve_one_instance_hook : (env -> evar_map -> EConstr.types -> bool -> evar_map * EConstr.constr) Hook.t - -(** Build the subinstances hints for a given typeclass object. - check tells if we should check for existence of the - subinstances and add only the missing ones. *) - -val build_subclasses : check:bool -> env -> evar_map -> GlobRef.t -> - hint_info -> - (GlobRef.t list * hint_info * constr) list 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/ppconstr.ml b/printing/ppconstr.ml index af105f4d63..267f5e0b5f 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -467,7 +467,7 @@ let tag_var = tag Tag.variable let pr_record_body_gen pr l = spc () ++ prlist_with_sep pr_semicolon - (fun (id, c) -> h 1 (pr_reference id ++ spc () ++ str":=" ++ pr ltop c)) l + (fun (id, c) -> pr_reference id ++ str" :=" ++ pr ltop c) l let pr_forall n = keyword "forall" ++ pr_com_at n ++ spc () 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..387f0f6f5f 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 @@ -739,7 +720,7 @@ let make_clenv_binding env sigma = make_clenv_binding_gen false None env sigma (* Pretty-print *) let pr_clenv clenv = - h 0 + h (str"TEMPL: " ++ Termops.Internal.print_constr_env clenv.env clenv.evd clenv.templval.rebus ++ str" : " ++ Termops.Internal.print_constr_env clenv.env clenv.evd clenv.templtyp.rebus ++ fnl () ++ pr_evar_map (Some 2) clenv.env clenv.evd) 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/proofs/tacmach.ml b/proofs/tacmach.ml index ecdbfa5118..1207e0e599 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -99,7 +99,7 @@ let db_pr_goal sigma g = str" " ++ pc) ++ fnl () let pr_gls gls = - hov 0 (pr_evar_map (Some 2) (pf_env gls) (sig_sig gls) ++ fnl () ++ db_pr_goal (project gls) (sig_it gls)) + hov 0 (pr_evar_map (Some 2) (pf_env gls) (project gls) ++ fnl () ++ db_pr_goal (project gls) (sig_it gls)) (* Variants of [Tacmach] functions built with the new proof engine *) module New = struct @@ -183,6 +183,9 @@ module New = struct let pf_unsafe_type_of gl t = pf_apply (unsafe_type_of[@warning "-3"]) gl t + let pr_gls gl = + hov 0 (pr_evar_map (Some 2) (pf_env gl) (project gl) ++ fnl () ++ db_pr_goal (project gl) (Proofview.Goal.goal gl)) + end (* deprecated *) diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index d8f7b7eed8..08f88d46c1 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -126,4 +126,5 @@ module New : sig val pf_nf_evar : Proofview.Goal.t -> constr -> constr + val pr_gls : Proofview.Goal.t -> Pp.t end diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index a8088dae36..4f04b9fe1c 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -386,3 +386,8 @@ end module MakeQueue(T : Task) () = struct include Make(T) () end module MakeWorker(T : Task) () = struct include Make(T) () end + +exception RemoteException of Pp.t +let _ = CErrors.register_handler (function + | RemoteException ppcmd -> Some ppcmd + | _ -> None) diff --git a/stm/asyncTaskQueue.mli b/stm/asyncTaskQueue.mli index cf174d0c93..a1fa6f7268 100644 --- a/stm/asyncTaskQueue.mli +++ b/stm/asyncTaskQueue.mli @@ -220,3 +220,6 @@ module MakeWorker(T : Task) () : sig val main_loop : unit -> unit end + +(** convenience exception to marshall to master *) +exception RemoteException of Pp.t diff --git a/stm/partac.ml b/stm/partac.ml new file mode 100644 index 0000000000..8232b017f9 --- /dev/null +++ b/stm/partac.ml @@ -0,0 +1,178 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Pp + +let stm_pr_err s = Format.eprintf "%s] %s\n%!" (Spawned.process_id ()) s + +module TacTask : sig + + type output = (Constr.constr * UState.t) option + type task = { + t_state : Vernacstate.t; + t_assign : output Future.assignment -> unit; + t_ast : ComTactic.interpretable; + t_goalno : int; + t_goal : Goal.goal; + t_kill : unit -> unit; + t_name : string } + + include AsyncTaskQueue.Task with type task := task + +end = struct (* {{{ *) + + let forward_feedback { Feedback.doc_id = did; span_id = id; route; contents } = + Feedback.feedback ~did ~id ~route contents + + type output = (Constr.constr * UState.t) option + + type task = { + t_state : Vernacstate.t; + t_assign : output Future.assignment -> unit; + t_ast : ComTactic.interpretable; + t_goalno : int; + t_goal : Goal.goal; + t_kill : unit -> unit; + t_name : string } + + type request = { + r_state : Vernacstate.t option; + r_ast : ComTactic.interpretable; + r_goalno : int; + r_goal : Goal.goal; + r_name : string } + + type response = + | RespBuiltSubProof of (Constr.constr * UState.t) + | RespError of Pp.t + | RespNoProgress + + let name = ref "tacticworker" + let extra_env () = [||] + type competence = unit + type worker_status = Fresh | Old of competence + + let task_match _ _ = true + + (* run by the master, on a thread *) + let request_of_task age { t_state; t_ast; t_goalno; t_goal; t_name } = + Some { + r_state = if age <> Fresh then None else Some t_state; + r_ast = t_ast; + r_goalno = t_goalno; + r_goal = t_goal; + r_name = t_name } + + let use_response _ { t_assign; t_kill } resp = + match resp with + | RespBuiltSubProof o -> t_assign (`Val (Some o)); `Stay ((),[]) + | RespNoProgress -> + t_assign (`Val None); + t_kill (); + `Stay ((),[]) + | RespError msg -> + let e = (AsyncTaskQueue.RemoteException msg, Exninfo.null) in + t_assign (`Exn e); + t_kill (); + `Stay ((),[]) + + let on_marshal_error err { t_name } = + stm_pr_err ("Fatal marshal error: " ^ t_name ); + flush_all (); exit 1 + + let on_task_cancellation_or_expiration_or_slave_death = function + | Some { t_kill } -> t_kill () + | _ -> () + + let command_focus = Proof.new_focus_kind () + let focus_cond = Proof.no_cond command_focus + + let state = ref None + let receive_state = function + | None -> () + | Some st -> state := Some st + + let perform { r_state = st; r_ast = tactic; r_goal; r_goalno } = + receive_state st; + Vernacstate.unfreeze_interp_state (Option.get !state); + try + Vernacstate.LemmaStack.with_top (Option.get (Option.get !state).Vernacstate.lemmas) ~f:(fun pstate -> + let pstate = + Declare.Proof.map pstate ~f:(Proof.focus focus_cond () r_goalno) in + let pstate = + ComTactic.solve ~pstate + Goal_select.SelectAll ~info:None tactic ~with_end_tac:false in + let { Proof.sigma } = Declare.Proof.fold pstate ~f:Proof.data in + match Evd.(evar_body (find sigma r_goal)) with + | Evd.Evar_empty -> RespNoProgress + | Evd.Evar_defined t -> + let t = Evarutil.nf_evar sigma t in + let evars = Evarutil.undefined_evars_of_term sigma t in + if Evar.Set.is_empty evars then + let t = EConstr.Unsafe.to_constr t in + RespBuiltSubProof (t, Evd.evar_universe_context sigma) + else + CErrors.user_err ~hdr:"STM" + Pp.(str"The par: selector requires a tactic that makes no progress or fully" ++ + 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)) + ) + with e when CErrors.noncritical e -> + RespError (CErrors.print e ++ spc() ++ str "(for subgoal "++int r_goalno ++ str ")") + + let name_of_task { t_name } = t_name + let name_of_request { r_name } = r_name + +end (* }}} *) + +module TaskQueue = AsyncTaskQueue.MakeQueue(TacTask) () + +let assign_tac ~abstract res : unit Proofview.tactic = + Proofview.(Goal.enter begin fun g -> + let gid = Goal.goal g in + let g_solution = + try List.assoc gid res + with Not_found -> CErrors.anomaly(str"Partac: wrong focus.") in + if not (Future.is_over g_solution) then + tclUNIT () + else + let open Notations in + match Future.join g_solution with + | Some (pt, uc) -> + let push_state ctx = + Proofview.tclEVARMAP >>= fun sigma -> + Proofview.Unsafe.tclEVARS (Evd.merge_universe_context sigma ctx) + in + (if abstract then Abstract.tclABSTRACT None else (fun x -> x)) + (push_state uc <*> Tactics.exact_no_check (EConstr.of_constr pt)) + | None -> tclUNIT () + end) + +let enable_par ~nworkers = ComTactic.set_par_implementation + (fun ~pstate ~info t_ast ~abstract ~with_end_tac -> + let t_state = Vernacstate.freeze_interp_state ~marshallable:true in + TaskQueue.with_n_workers nworkers CoqworkmgrApi.High (fun queue -> + Declare.Proof.map pstate ~f:(fun p -> + let open TacTask in + let results = (Proof.data p).Proof.goals |> CList.map_i (fun i g -> + let g_solution, t_assign = + Future.create_delegate ~name:(Printf.sprintf "subgoal %d" i) + (fun x -> x) in + TaskQueue.enqueue_task queue + ~cancel_switch:(ref false) + { t_state; t_assign; t_ast; + t_goalno = i; t_goal = g; t_name = Goal.uid g; + t_kill = (fun () -> TaskQueue.cancel_all queue) }; + g, g_solution) 1 in + TaskQueue.join queue; + let p,_,() = + Proof.run_tactic (Global.env()) + (assign_tac ~abstract results) p in + p))) diff --git a/stm/partac.mli b/stm/partac.mli new file mode 100644 index 0000000000..a206b2e5d8 --- /dev/null +++ b/stm/partac.mli @@ -0,0 +1,13 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +val enable_par : nworkers:int -> unit + +module TacTask : AsyncTaskQueue.Task 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..85f889c879 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 @@ -163,9 +159,9 @@ type cmd_t = { cids : Names.Id.t list; cblock : proof_block_name option; cqueue : [ `MainQueue - | `TacQueue of solving_tac * anon_abstracting_tac * AsyncTaskQueue.cancel_switch - | `QueryQueue of AsyncTaskQueue.cancel_switch - | `SkipQueue ] } + | `QueryQueue + | `SkipQueue ]; + cancel_switch : AsyncTaskQueue.cancel_switch; } type fork_t = aast * Vcs_.Branch.t * opacity_guarantee * Names.Id.t list type qed_t = { qast : aast; @@ -194,10 +190,10 @@ type step = type visit = { step : step; next : Stateid.t } let mkTransTac cast cblock cqueue = - Cmd { ctac = true; cast; cblock; cqueue; cids = []; ceff = false } + Cmd { ctac = true; cast; cblock; cqueue; cids = []; ceff = false; cancel_switch = ref false } let mkTransCmd cast cids ceff cqueue = - Cmd { ctac = false; cast; cblock = None; cqueue; cids; ceff } + Cmd { ctac = false; cast; cblock = None; cqueue; cids; ceff; cancel_switch = ref false } type cached_state = | EmptyState @@ -746,8 +742,7 @@ end = struct (* {{{ *) Stateid.Set.iter (fun id -> match (Vcs_aux.visit old_vcs id).step with | `Qed ({ fproof = Some (_, cancel_switch) }, _) - | `Cmd { cqueue = `TacQueue (_,_,cancel_switch) } - | `Cmd { cqueue = `QueryQueue cancel_switch } -> + | `Cmd { cancel_switch } -> cancel_switch := true | _ -> ()) erased_nodes; @@ -834,15 +829,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 +856,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 +911,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 +918,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 +941,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) @@ -1235,11 +1221,6 @@ let record_pb_time ?loc proof_name time = hints := Aux_file.set !hints proof_name proof_build_time end -exception RemoteException of Pp.t -let _ = CErrors.register_handler (function - | RemoteException ppcmd -> Some ppcmd - | _ -> None) - (****************** proof structure for error recovery ************************) (******************************************************************************) @@ -1442,7 +1423,7 @@ end = struct (* {{{ *) RespError { e_error_at; e_safe_id = valid; e_msg; e_safe_states } -> feedback (InProgress ~-1); let info = Stateid.add ~valid Exninfo.null e_error_at in - let e = (RemoteException e_msg, info) in + let e = (AsyncTaskQueue.RemoteException e_msg, info) in t_assign (`Exn e); `Stay(t_states,[States e_safe_states]) | _ -> assert false @@ -1453,7 +1434,7 @@ end = struct (* {{{ *) | Some (BuildProof { t_start = start; t_assign }) -> let s = "Worker dies or task expired" in let info = Stateid.add ~valid:start Exninfo.null start in - let e = (RemoteException (Pp.strbrk s), info) in + let e = (AsyncTaskQueue.RemoteException (Pp.strbrk s), info) in t_assign (`Exn e); execution_error start (Pp.strbrk s); feedback (InProgress ~-1) @@ -1549,8 +1530,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) @@ -1805,224 +1786,6 @@ end = struct (* {{{ *) end (* }}} *) -and TacTask : sig - - type output = (Constr.constr * UState.t) option - type task = { - t_state : Stateid.t; - t_state_fb : Stateid.t; - t_assign : output Future.assignment -> unit; - t_ast : int * aast; - t_goal : Goal.goal; - t_kill : unit -> unit; - t_name : string } - - include AsyncTaskQueue.Task with type task := task - -end = struct (* {{{ *) - - type output = (Constr.constr * UState.t) option - - let forward_feedback msg = Hooks.(call forward_feedback msg) - - type task = { - t_state : Stateid.t; - t_state_fb : Stateid.t; - t_assign : output Future.assignment -> unit; - t_ast : int * aast; - t_goal : Goal.goal; - t_kill : unit -> unit; - t_name : string } - - type request = { - r_state : Stateid.t; - r_state_fb : Stateid.t; - r_document : VCS.vcs option; - r_ast : int * aast; - r_goal : Goal.goal; - r_name : string } - - type response = - | RespBuiltSubProof of (Constr.constr * UState.t) - | RespError of Pp.t - | RespNoProgress - - let name = ref "tacticworker" - let extra_env () = [||] - type competence = unit - type worker_status = Fresh | Old of competence - - let task_match _ _ = true - - (* run by the master, on a thread *) - let request_of_task age { t_state; t_state_fb; t_ast; t_goal; t_name } = - try Some { - r_state = t_state; - r_state_fb = t_state_fb; - r_document = - if age <> Fresh then None - else Some (VCS.slice ~block_start:t_state ~block_stop:t_state); - r_ast = t_ast; - r_goal = t_goal; - r_name = t_name } - with VCS.Expired -> None - - let use_response _ { t_assign; t_state; t_state_fb; t_kill } resp = - match resp with - | RespBuiltSubProof o -> t_assign (`Val (Some o)); `Stay ((),[]) - | RespNoProgress -> - t_assign (`Val None); - t_kill (); - `Stay ((),[]) - | RespError msg -> - let e = (RemoteException msg, Exninfo.null) in - t_assign (`Exn e); - t_kill (); - `Stay ((),[]) - - let on_marshal_error err { t_name } = - stm_pr_err ("Fatal marshal error: " ^ t_name ); - flush_all (); exit 1 - - let on_task_cancellation_or_expiration_or_slave_death = function - | Some { t_kill } -> t_kill () - | _ -> () - - let command_focus = Proof.new_focus_kind () - let focus_cond = Proof.no_cond command_focus - - let perform { r_state = id; r_state_fb; r_document = vcs; r_ast; r_goal } = - Option.iter VCS.restore vcs; - try - Reach.known_state ~doc:dummy_doc (* XXX should be vcs *) ~cache:false id; - State.purify (fun () -> - let Proof.{sigma=sigma0} = Proof.data (PG_compat.give_me_the_proof ()) in - let g = Evd.find sigma0 r_goal in - let is_ground c = Evarutil.is_ground_term sigma0 c in - if not ( - is_ground Evd.(evar_concl g) && - List.for_all (Context.Named.Declaration.for_all is_ground) - Evd.(evar_context g)) - then - CErrors.user_err ~hdr:"STM" Pp.(strbrk("The par: goal selector does not support goals with existential variables")) - else begin - let (i, ast) = r_ast in - PG_compat.map_proof (fun p -> Proof.focus focus_cond () i p); - (* STATE SPEC: - * - start : id - * - return: id - * => captures state id in a future closure, which will - discard execution state but for the proof + univs. - *) - let st = Vernacstate.freeze_interp_state ~marshallable:false in - ignore(stm_vernac_interp r_state_fb st ast); - let Proof.{sigma} = Proof.data (PG_compat.give_me_the_proof ()) in - match Evd.(evar_body (find sigma r_goal)) with - | Evd.Evar_empty -> RespNoProgress - | Evd.Evar_defined t -> - let t = Evarutil.nf_evar sigma t in - let evars = Evarutil.undefined_evars_of_term sigma t in - if Evar.Set.is_empty evars then - let t = EConstr.Unsafe.to_constr t in - RespBuiltSubProof (t, Evd.evar_universe_context sigma) - else - CErrors.user_err ~hdr:"STM" - Pp.(str"The par: selector requires a tactic that makes no progress or fully" ++ - 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) - - let name_of_task { t_name } = t_name - let name_of_request { r_name } = r_name - -end (* }}} *) - -and Partac : sig - - val vernac_interp : - solve:bool -> abstract:bool -> cancel_switch:AsyncTaskQueue.cancel_switch -> - int -> CoqworkmgrApi.priority -> Stateid.t -> Stateid.t -> aast -> unit - -end = struct (* {{{ *) - - module TaskQueue = AsyncTaskQueue.MakeQueue(TacTask) () - - let stm_fail ~st fail f = - if fail then - Vernacinterp.with_fail ~st f - else - f () - - let vernac_interp ~solve ~abstract ~cancel_switch nworkers priority safe_id id - { indentation; verbose; expr = e; strlen } : unit - = - let cl, time, batch, fail = - let rec find ~time ~batch ~fail cl = match cl with - | ControlTime batch :: cl -> find ~time:true ~batch ~fail cl - | ControlRedirect _ :: cl -> find ~time ~batch ~fail cl - | ControlFail :: cl -> find ~time ~batch ~fail:true cl - | cl -> cl, time, batch, fail in - find ~time:false ~batch:false ~fail:false e.CAst.v.control in - let e = CAst.map (fun cmd -> { cmd with control = cl }) e in - let st = Vernacstate.freeze_interp_state ~marshallable:false in - stm_fail ~st fail (fun () -> - (if time then System.with_time ~batch ~header:(Pp.mt ()) else (fun x -> x)) (fun () -> - TaskQueue.with_n_workers nworkers priority (fun queue -> - PG_compat.map_proof (fun p -> - let Proof.{goals} = Proof.data p in - let open TacTask in - let res = CList.map_i (fun i g -> - let f, assign = - Future.create_delegate - ~name:(Printf.sprintf "subgoal %d" i) - (State.exn_on id ~valid:safe_id) in - let t_ast = (i, { indentation; verbose; expr = e; strlen }) in - let t_name = Goal.uid g in - TaskQueue.enqueue_task queue - { t_state = safe_id; t_state_fb = id; - t_assign = assign; t_ast; t_goal = g; t_name; - t_kill = (fun () -> if solve then TaskQueue.cancel_all queue) } - ~cancel_switch; - g,f) - 1 goals in - TaskQueue.join queue; - let assign_tac : unit Proofview.tactic = - Proofview.(Goal.enter begin fun g -> - let gid = Goal.goal g in - let f = - try List.assoc gid res - with Not_found -> CErrors.anomaly(str"Partac: wrong focus.") in - if not (Future.is_over f) then - (* One has failed and cancelled the others, but not this one *) - if solve then Tacticals.New.tclZEROMSG - (str"Interrupted by the failure of another goal") - else tclUNIT () - else - let open Notations in - match Future.join f with - | Some (pt, uc) -> - let sigma, env = PG_compat.get_current_context () in - let push_state ctx = - Proofview.tclEVARMAP >>= fun sigma -> - Proofview.Unsafe.tclEVARS (Evd.merge_universe_context sigma ctx) - in - stm_pperr_endline (fun () -> hov 0 ( - str"g=" ++ int (Evar.repr gid) ++ spc () ++ - str"t=" ++ (Printer.pr_constr_env env sigma pt) ++ spc () ++ - str"uc=" ++ Termops.pr_evar_universe_context uc)); - (if abstract then Abstract.tclABSTRACT None else (fun x -> x)) - (push_state uc <*> - Tactics.exact_no_check (EConstr.of_constr pt)) - | None -> - if solve then Tacticals.New.tclSOLVE [] else tclUNIT () - end) - in - let p,_,() = Proof.run_tactic (Global.env()) assign_tac p in - p))) ()) - -end (* }}} *) - and QueryTask : sig type task = { t_where : Stateid.t; t_for : Stateid.t ; t_what : aast } @@ -2344,7 +2107,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 = @@ -2371,15 +2136,7 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = ), cache, true | `Cmd { cast = x; cqueue = `SkipQueue } -> (fun () -> reach view.next), cache, true - | `Cmd { cast = x; cqueue = `TacQueue (solve,abstract,cancel_switch); cblock } -> - (fun () -> - resilient_tactic id cblock (fun () -> - reach ~cache:true view.next; - Partac.vernac_interp ~solve ~abstract ~cancel_switch - !cur_opt.async_proofs_n_tacworkers - !cur_opt.async_proofs_worker_priority view.next id x) - ), cache, true - | `Cmd { cast = x; cqueue = `QueryQueue cancel_switch } + | `Cmd { cast = x; cqueue = `QueryQueue; cancel_switch } when async_proofs_is_master !cur_opt -> (fun () -> reach view.next; Query.vernac_interp ~cancel_switch view.next id x @@ -2387,7 +2144,6 @@ let known_state ~doc ?(redefine_qed=false) ~cache id = | `Cmd { cast = x; ceff = eff; ctac = true; cblock } -> (fun () -> resilient_tactic id cblock (fun () -> reach view.next; - (* State resulting from reach *) let st = Vernacstate.freeze_interp_state ~marshallable:false in ignore(stm_vernac_interp id st x) ) @@ -2598,6 +2354,7 @@ let doc_type_module_name (std : stm_doc_type) = let init_core () = if !cur_opt.async_proofs_mode = APon then Control.enable_thread_delay := true; + if !Flags.async_proofs_worker_id = "master" then Partac.enable_par ~nworkers:!cur_opt.async_proofs_n_tacworkers; State.register_root_state () let dirpath_of_file f = @@ -2948,12 +2705,9 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) VCS.set_parsing_state id head_parsing; Backtrack.record (); `Ok - | VtProofStep { parallel; proof_block_detection = cblock } -> + | VtProofStep { proof_block_detection = cblock } -> let id = VCS.new_node ~id:newtip proof_mode () in - let queue = - match parallel with - | `Yes(solve,abstract) -> `TacQueue (solve, abstract, ref false) - | `No -> `MainQueue in + let queue = `MainQueue in VCS.commit id (mkTransTac x cblock queue); (* Static proof block detection delayed until an error really occurs. If/when and UI will make something useful with this piece of info, diff --git a/stm/stm.mli b/stm/stm.mli index 9780c96512..097bcbe0ca 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -195,7 +195,6 @@ val set_perspective : doc:doc -> Stateid.t list -> unit (** workers **************************************************************** **) module ProofTask : AsyncTaskQueue.Task -module TacTask : AsyncTaskQueue.Task module QueryTask : AsyncTaskQueue.Task (** document structure customization *************************************** **) diff --git a/stm/stm.mllib b/stm/stm.mllib index 4b254e8113..831369625f 100644 --- a/stm/stm.mllib +++ b/stm/stm.mllib @@ -6,6 +6,7 @@ WorkerPool Vernac_classifier CoqworkmgrApi AsyncTaskQueue +Partac Stm ProofBlockDelimiter Vio_checking diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index f89fb9f52d..3996c64b67 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -15,11 +15,6 @@ open CAst open Vernacextend open Vernacexpr -let string_of_parallel = function - | `Yes (solve,abs) -> - "par" ^ if solve then "solve" else "" ^ if abs then "abs" else "" - | `No -> "" - let string_of_vernac_when = function | VtLater -> "Later" | VtNow -> "Now" @@ -30,9 +25,8 @@ let string_of_vernac_classification = function | VtQed (VtKeep VtKeepAxiom) -> "Qed(admitted)" | VtQed (VtKeep (VtKeepOpaque | VtKeepDefined)) -> "Qed(keep)" | VtQed VtDrop -> "Qed(drop)" - | VtProofStep { parallel; proof_block_detection } -> - "ProofStep " ^ string_of_parallel parallel ^ - Option.default "" proof_block_detection + | VtProofStep { proof_block_detection } -> + "ProofStep " ^ Option.default "" proof_block_detection | VtQuery -> "Query" | VtMeta -> "Meta " | VtProofMode _ -> "Proof Mode" @@ -80,12 +74,11 @@ let classify_vernac e = | VernacCheckGuard | VernacUnfocused | VernacSolveExistential _ -> - VtProofStep { parallel = `No; proof_block_detection = None } + VtProofStep { proof_block_detection = None } | VernacBullet _ -> - VtProofStep { parallel = `No; proof_block_detection = Some "bullet" } + VtProofStep { proof_block_detection = Some "bullet" } | VernacEndSubproof -> - VtProofStep { parallel = `No; - proof_block_detection = Some "curly" } + VtProofStep { proof_block_detection = Some "curly" } (* StartProof *) | VernacDefinition ((DoDischarge,_),({v=i},_),ProveBody _) -> VtStartProof(Doesn'tGuaranteeOpacity, idents_of_name i) @@ -213,7 +206,7 @@ let classify_vernac e = (match static_classifier ~atts:v.attrs v.expr with | VtQuery | VtProofStep _ | VtSideff _ | VtMeta as x -> x - | VtQed _ -> VtProofStep { parallel = `No; proof_block_detection = None } + | VtQed _ -> VtProofStep { proof_block_detection = None } | VtStartProof _ | VtProofMode _ -> VtQuery) else static_classifier ~atts:v.attrs v.expr 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..f721e9956b 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,33 +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)) - - let app f dn = Dn.app f dn + Dn.lookup dn (bounded_constr_val_discr_st env sigma st) (t,!dnet_depth)) end diff --git a/tactics/btermdn.mli b/tactics/btermdn.mli index 4358e5a8d9..01d68a8045 100644 --- a/tactics/btermdn.mli +++ b/tactics/btermdn.mli @@ -28,13 +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 app : (Z.t -> unit) -> t -> unit + val lookup : Environ.env -> Evd.evar_map -> TransparentState.t option -> t -> EConstr.constr -> Z.t list end val dnet_depth : int ref diff --git a/tactics/cbn.ml b/tactics/cbn.ml index dfbcc9fbce..0b13f4763a 100644 --- a/tactics/cbn.ml +++ b/tactics/cbn.ml @@ -543,7 +543,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = let open Pp in let pr c = Termops.Internal.print_constr_env env sigma c in Feedback.msg_debug - (h 0 (str "<<" ++ pr x ++ + (h (str "<<" ++ pr x ++ str "|" ++ cut () ++ Cst_stack.pr env sigma cst_l ++ str "|" ++ cut () ++ Stack.pr pr stack ++ str ">>")) @@ -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..ed92a85a12 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 (Option.is_empty h.hint_uctx) 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,20 @@ 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 + if Option.has_some h.hint_uctx || 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 h.hint_term 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 +256,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 +306,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 +321,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 +347,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 +372,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) @@ -509,17 +483,7 @@ let make_resolve_hyp env sigma st only_classes pri decl = if keep then let id = GlobRef.VarRef id in let name = PathHints [id] in - let hints = - if is_class then - let hints = build_subclasses ~check:false env sigma id empty_hint_info in - (List.map_append - (fun (path,info,c) -> - let h = IsConstr (EConstr.of_constr c,Univ.ContextSet.empty) [@ocaml.warning "-3"] in - make_resolves env sigma ~name:(PathHints path) info ~check:true ~poly:false h) - hints) - else [] - in - (hints @ make_resolves env sigma pri ~name ~check:false ~poly:false (IsGlobRef id)) + (make_resolves env sigma pri ~name ~check:false (IsGlobRef id)) else [] let make_hints g (modes,st) only_classes sign = @@ -740,8 +704,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 +920,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 +938,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 +1200,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..c587f91e54 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 @@ -60,10 +62,10 @@ prefix ordering, [dna] is the function returning the main node of a pattern *) pathrec [] let tm_of tm lbl = - try [Trie.next tm lbl, true] with Not_found -> [] + try [Trie.next tm lbl] with Not_found -> [] let rec skip_arg n tm = - if Int.equal n 0 then [tm, true] + if Int.equal n 0 then [tm] else let labels = Trie.labels tm in let map lbl = match lbl with @@ -71,31 +73,27 @@ prefix ordering, [dna] is the function returning the main node of a pattern *) | Some (_, m) -> skip_arg (pred n + m) (Trie.next tm lbl) in - List.flatten (List.map map labels) + List.map_append map labels let lookup tm dna t = let rec lookrec t tm = match dna t with | Nothing -> tm_of tm None | Label(lbl,v) -> - tm_of tm None@ - (List.fold_left - (fun l c -> - List.flatten(List.map (fun (tm, b) -> - if b then lookrec c tm - else [tm,b]) l)) - (tm_of tm (Some(lbl,List.length v))) v) + let fold accu c = List.map_append (fun tm -> lookrec c tm) accu in + tm_of tm None @ + (List.fold_left fold (tm_of tm (Some (lbl, List.length v))) v) | Everything -> skip_arg 1 tm in - List.flatten (List.map (fun (tm,b) -> ZSet.elements (Trie.get tm)) (lookrec t tm)) + List.map_append (fun tm -> 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 rmv tm dna (pat,inf) = - let p = path_of dna pat in Trie.remove p (ZSet.singleton inf) tm + let add tm p inf = + Trie.add p (ZSet.singleton inf) tm - let app f tm = Trie.iter (fun _ p -> ZSet.iter f p) tm + let rmv tm p inf = + Trie.remove p (ZSet.singleton inf) tm end diff --git a/tactics/dn.mli b/tactics/dn.mli index 2a60c3eb82..85f9ef6dfb 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 @@ -34,6 +38,4 @@ sig val lookup : t -> 'term lookup_fun -> 'term -> Z.t list - val app : (Z.t -> unit) -> t -> unit - end 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/eqschemes.ml b/tactics/eqschemes.ml index 955a7957bf..f90c143a1a 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -68,7 +68,9 @@ module RelDecl = Context.Rel.Declaration let hid = Id.of_string "H" let xid = Id.of_string "X" let default_id_of_sort = function InSProp | InProp | InSet -> hid | InType -> xid -let fresh env id = next_global_ident_away id Id.Set.empty +let fresh env id avoid = + let freshid = next_global_ident_away id avoid in + freshid, Id.Set.add freshid avoid let with_context_set ctx (b, ctx') = (b, Univ.ContextSet.union ctx ctx') @@ -204,7 +206,7 @@ let build_sym_scheme env ind = let cstr n = mkApp (mkConstructUi(indu,1),Context.Rel.to_extended_vect mkRel n mib.mind_params_ctxt) in let inds = snd (mind_arity mip) in - let varH = fresh env (default_id_of_sort inds) in + let varH,_ = fresh env (default_id_of_sort inds) Id.Set.empty in let applied_ind = build_dependent_inductive indu specif in let indr = Sorts.relevance_of_sort_family inds in let realsign_ind = @@ -263,7 +265,7 @@ let build_sym_involutive_scheme env ind = let cstr n = mkApp (mkConstructUi (indu,1),Context.Rel.to_extended_vect mkRel n paramsctxt) in let inds = snd (mind_arity mip) in let indr = Sorts.relevance_of_sort_family inds in - let varH = fresh env (default_id_of_sort inds) in + let varH,_ = fresh env (default_id_of_sort inds) Id.Set.empty in let applied_ind = build_dependent_inductive indu specif in let applied_ind_C = mkApp @@ -380,9 +382,9 @@ let build_l2r_rew_scheme dep env ind kind = rel_vect p nrealargs]) in let inds = snd (mind_arity mip) in let indr = Sorts.relevance_of_sort_family inds in - let varH = fresh env (default_id_of_sort inds) in - let varHC = fresh env (Id.of_string "HC") in - let varP = fresh env (Id.of_string "P") in + let varH,avoid = fresh env (default_id_of_sort inds) Id.Set.empty in + let varHC,avoid = fresh env (Id.of_string "HC") avoid in + let varP,_ = fresh env (Id.of_string "P") avoid in let applied_ind = build_dependent_inductive indu specif in let applied_ind_P = mkApp (mkIndU indu, Array.concat @@ -498,9 +500,9 @@ let build_l2r_forward_rew_scheme dep env ind kind = rel_vect p nrealargs]) in let inds = snd (mind_arity mip) in let indr = Sorts.relevance_of_sort_family inds in - let varH = fresh env (default_id_of_sort inds) in - let varHC = fresh env (Id.of_string "HC") in - let varP = fresh env (Id.of_string "P") in + let varH,avoid = fresh env (default_id_of_sort inds) Id.Set.empty in + let varHC,avoid = fresh env (Id.of_string "HC") avoid in + let varP,_ = fresh env (Id.of_string "P") avoid in let applied_ind = build_dependent_inductive indu specif in let applied_ind_P = mkApp (mkIndU indu, Array.concat @@ -593,9 +595,9 @@ let build_r2l_forward_rew_scheme dep env ind kind = let constrargs_cstr = constrargs@[cstr 0] in let inds = snd (mind_arity mip) in let indr = Sorts.relevance_of_sort_family inds in - let varH = fresh env (default_id_of_sort inds) in - let varHC = fresh env (Id.of_string "HC") in - let varP = fresh env (Id.of_string "P") in + let varH,avoid = fresh env (default_id_of_sort inds) Id.Set.empty in + let varHC,avoid = fresh env (Id.of_string "HC") avoid in + let varP,_ = fresh env (Id.of_string "P") avoid in let applied_ind = build_dependent_inductive indu specif in let realsign_ind = name_context env ((LocalAssum (make_annot (Name varH) indr,applied_ind))::realsign) in @@ -806,9 +808,9 @@ let build_congr env (eq,refl,ctx) ind = if not (Int.equal (Context.Rel.length constrsign) (Context.Rel.length mib.mind_params_ctxt)) then error "Constructor must have no arguments"; let b = List.nth constrargs (i + mib.mind_nparams - 1) in - let varB = fresh env (Id.of_string "B") in - let varH = fresh env (Id.of_string "H") in - let varf = fresh env (Id.of_string "f") in + let varB,avoid = fresh env (Id.of_string "B") Id.Set.empty in + let varH,avoid = fresh env (Id.of_string "H") avoid in + let varf,avoid = fresh env (Id.of_string "f") avoid in let rci = Sorts.Relevant in (* TODO relevance *) let ci = make_case_info (Global.env()) ind rci RegularStyle in let uni, ctx = Univ.extend_in_context_set (UnivGen.new_global_univ ()) ctx in diff --git a/tactics/equality.ml b/tactics/equality.ml index a2325b69cc..60e2db4dce 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; @@ -659,8 +659,12 @@ let replace_using_leibniz clause c1 c2 l2r unsafe try_prove_eq_opt = | None -> tclFAIL 0 (str"Terms do not have convertible types") | Some evd -> - let e = lib_ref "core.eq.type" in - let sym = lib_ref "core.eq.sym" in + let e,sym = + try lib_ref "core.eq.type", lib_ref "core.eq.sym" + with UserError _ -> + try lib_ref "core.identity.type", lib_ref "core.identity.sym" + with UserError _ -> + user_err (strbrk "Need a registration for either core.eq.type and core.eq.sym or core.identity.type and core.identity.sym.") in Tacticals.New.pf_constr_of_global sym >>= fun sym -> Tacticals.New.pf_constr_of_global e >>= fun e -> let eq = applist (e, [t1;c1;c2]) in @@ -1013,19 +1017,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 +1044,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 +1059,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 +1072,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 +1136,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 +1387,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 +1398,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 +1421,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 +1440,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 +1496,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 +1519,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 +1655,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..fe3efef7c5 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 = @@ -128,22 +129,20 @@ type hints_path = GlobRef.t hints_path_gen type hint_term = | IsGlobRef of GlobRef.t - | IsConstr of constr * Univ.ContextSet.t + | IsConstr of constr * Univ.ContextSet.t option (* None if monomorphic *) type 'a with_uid = { obj : 'a; uid : KerName.t; } -type raw_hint = constr * types * Univ.ContextSet.t * bool (* poly *) +type raw_hint = constr * types * Univ.ContextSet.t option type hint = { hint_term : constr; hint_type : types; - hint_uctx : Univ.ContextSet.t; + hint_uctx : Univ.ContextSet.t option; (* None if monomorphic *) hint_clnv : clausenv; - hint_poly : bool; - (** Is the hint polymorpic and hence should be refreshed at each application *) } type 'a with_metadata = @@ -237,10 +236,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 +285,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' @@ -304,15 +332,19 @@ let strip_params env sigma c = | _ -> c) | _ -> c +let merge_context_set_opt sigma ctx = match ctx with +| None -> sigma +| Some ctx -> Evd.merge_context_set Evd.univ_flexible sigma ctx + let instantiate_hint env sigma p = - let mk_clenv (c, cty, ctx, poly) = - let sigma = Evd.merge_context_set univ_flexible sigma ctx in + let mk_clenv (c, cty, ctx) = + let sigma = merge_context_set_opt sigma ctx in let cl = mk_clenv_from_env env sigma None (c,cty) in let cl = {cl with templval = { cl.templval with rebus = strip_params env sigma cl.templval.rebus }; env = empty_env} in - { hint_term = c; hint_type = cty; hint_uctx = ctx; hint_clnv = cl; hint_poly = poly } + { hint_term = c; hint_type = cty; hint_uctx = ctx; hint_clnv = cl; } in let code = match p.code.obj with | Res_pf c -> Res_pf (mk_clenv c) @@ -320,8 +352,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 +531,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 +631,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 +644,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 +667,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 +675,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 +722,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 +804,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 = @@ -789,118 +818,89 @@ let secvars_of_constr env sigma c = let secvars_of_global env gr = secvars_of_idset (vars_of_global env gr) -let make_exact_entry env sigma info ~poly ?(name=PathAny) (c, cty, ctx) = +let make_exact_entry env sigma info ?(name=PathAny) (c, cty, ctx) = let secvars = secvars_of_constr env sigma c in let cty = strip_outer_cast sigma cty in 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)); }) + code = with_uid (Give_exact (c, cty, ctx)); }) -let make_apply_entry env sigma (eapply,hnf,verbose) info ~poly ?(name=PathAny) (c, cty, ctx) = +let make_apply_entry env sigma hnf info ?(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 sigma' = merge_context_set_opt 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, { pri; pat = Some pat; name; 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; + code = with_uid (Res_pf(c,cty,ctx)); }) + else (Some hd, { pri; pat = Some pat; name; db = None; secvars; - code = with_uid (ERes_pf(c,cty,ctx,poly)); }) - end + code = with_uid (ERes_pf(c,cty,ctx)); }) | _ -> failwith "make_apply_entry" (* flags is (e,h,v) with e=true if eapply and h=true if hnf and v=true if verbose c is a constr cty is the type of constr *) -let pr_hint_term env sigma ctx = function - | IsGlobRef gr -> pr_global gr - | IsConstr (c, ctx) -> - let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in - pr_econstr_env env sigma c - -let warn_polymorphic_hint = - CWarnings.create ~name:"polymorphic-hint" ~category:"automation" - (fun hint -> strbrk"Using polymorphic hint " ++ hint ++ - str" monomorphically" ++ - strbrk" use Polymorphic Hint to use it polymorphically.") - -let fresh_global_or_constr env sigma poly cr = - let isgr, (c, ctx) = - match cr with - | IsGlobRef gr -> - let (c, ctx) = UnivGen.fresh_global_instance env gr in - true, (EConstr.of_constr c, ctx) - | IsConstr (c, ctx) -> false, (c, ctx) - in - if poly then (c, ctx) - else if Univ.ContextSet.is_empty ctx then (c, ctx) - else begin - if isgr then - warn_polymorphic_hint (pr_hint_term env sigma ctx cr); - DeclareUctx.declare_universe_context ~poly:false ctx; - (c, Univ.ContextSet.empty) - end - -let make_resolves env sigma flags info ~check ~poly ?name cr = - let c, ctx = fresh_global_or_constr env sigma poly cr in +let fresh_global_or_constr env sigma cr = match cr with +| IsGlobRef gr -> + let (c, ctx) = UnivGen.fresh_global_instance env gr in + let ctx = if Environ.is_polymorphic env gr then Some ctx else None in + (EConstr.of_constr c, ctx) +| IsConstr (c, ctx) -> (c, ctx) + +let make_resolves env sigma (eapply, hnf) info ~check ?name cr = + let c, ctx = fresh_global_or_constr env sigma 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_exact_entry env sigma info ?name; + make_apply_entry env sigma hnf info ?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,9 +909,9 @@ 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 ~name:(PathHints [GlobRef.VarRef hname]) - (c, NamedDecl.get_type decl, Univ.ContextSet.empty)] + (c, NamedDecl.get_type decl, None)] with | Failure _ -> [] | e when noncritical e -> anomaly (Pp.str "make_resolve_hyp.") @@ -929,14 +929,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 @@ -950,9 +957,9 @@ let make_mode ref m = str" arguments while the mode declares " ++ int (Array.length m')) else m' -let make_trivial env sigma poly ?(name=PathAny) r = - let c,ctx = fresh_global_or_constr env sigma poly r in - let sigma = Evd.merge_context_set univ_flexible sigma ctx in +let make_trivial env sigma ?(name=PathAny) r = + let c,ctx = fresh_global_or_constr env sigma r in + let sigma = merge_context_set_opt sigma ctx in let t = hnf_constr env sigma (Retyping.get_type_of env sigma c) in let hd = head_constr sigma t in let ce = mk_clenv_from_env env sigma None (c,t) in @@ -962,7 +969,7 @@ let make_trivial env sigma poly ?(name=PathAny) r = name = name; db = None; secvars = secvars_of_constr env sigma c; - code= with_uid (Res_pf_THEN_trivial_fail(c,t,ctx,poly)) }) + code= with_uid (Res_pf_THEN_trivial_fail(c,t,ctx)) }) @@ -1009,8 +1016,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,14 +1078,14 @@ 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 - let subst_aux ((c, t, ctx, poly) as h) = + let subst_aux ((c, t, ctx) as h) = let c' = subst_mps subst c in let t' = subst_mps subst t in - if c==c' && t'==t then h else (c', t', ctx, poly) + if c==c' && t'==t then h else (c', t', ctx) in let subst_hint (k,data as hint) = let k' = Option.Smart.map subst_key k in @@ -1100,9 +1108,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 @@ -1185,10 +1194,29 @@ let add_resolves env sigma clist ~local ~superglobal dbnames = List.iter (fun dbname -> let r = - List.flatten (List.map (fun (pri, poly, hnf, path, gr) -> - make_resolves env sigma (true,hnf,not !Flags.quiet) - pri ~check:true ~poly ~name:path gr) clist) + List.flatten (List.map (fun (pri, hnf, path, gr) -> + make_resolves env sigma (true, hnf) + pri ~check:true ~name:path gr) clist) in + let check (_, hint) = match hint.code.obj with + | ERes_pf (c, cty, ctx) -> + let sigma' = merge_context_set_opt 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 @@ -1240,7 +1268,7 @@ let add_externs info tacast ~local ~superglobal dbnames = let add_trivials env sigma l ~local ~superglobal dbnames = List.iter (fun dbname -> - let l = List.map (fun (name, poly, c) -> make_trivial env sigma poly ~name c) l in + let l = List.map (fun (name, c) -> make_trivial env sigma ~name c) l in let hint = make_hint ~local dbname (AddHints { superglobal; hints = l }) in Lib.add_anonymous_leaf (inAutoHint hint)) dbnames @@ -1250,8 +1278,8 @@ type hnf = bool type nonrec hint_info = hint_info type hints_entry = - | HintsResolveEntry of (hint_info * bool * hnf * hints_path_atom * hint_term) list - | HintsImmediateEntry of (hints_path_atom * bool * hint_term) list + | HintsResolveEntry of (hint_info * hnf * hints_path_atom * hint_term) list + | HintsImmediateEntry of (hints_path_atom * hint_term) list | HintsCutEntry of hints_path | HintsUnfoldEntry of evaluable_global_reference list | HintsTransparencyEntry of evaluable_global_reference hints_transparency_target * bool @@ -1324,24 +1352,21 @@ let expand_constructor_hints env sigma lems = match EConstr.kind sigma lem with | Ind (ind,u) -> List.init (nconstructors env ind) - (fun i -> - let ctx = Univ.ContextSet.diff (Evd.universe_context_set evd) - (Evd.universe_context_set sigma) in - not (Univ.ContextSet.is_empty ctx), - IsConstr (mkConstructU ((ind,i+1),u),ctx)) + (fun i -> IsGlobRef (GlobRef.ConstructRef ((ind,i+1)))) | _ -> let (c, ctx) = prepare_hint false env sigma (evd,lem) in - [not (Univ.ContextSet.is_empty ctx), IsConstr (c, ctx)]) lems + let ctx = if Univ.ContextSet.is_empty ctx then None else Some ctx in + [IsConstr (c, ctx)]) lems (* builds a hint database from a constr signature *) (* typically used with (lid, ltyp) = pf_hyps_types <some goal> *) 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 + List.map_append (fun lem -> + make_resolves env sigma (eapply, true) empty_hint_info ~check:true lem) lems -let make_resolves env sigma info ~check ~poly ?name hint = - make_resolves env sigma (true, false, false) info ~check ~poly ?name hint +let make_resolves env sigma info ~check ?name hint = + make_resolves env sigma (true, false) info ~check ?name hint let make_local_hint_db env sigma ts eapply lems = let map c = c env sigma in @@ -1382,7 +1407,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 +1452,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 +1618,44 @@ 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 *) + match h.hint_uctx with + | Some ctx -> + (* 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; + } + | None -> + { clenv with evd = evd ; env = Proofview.Goal.env gl } + +let fresh_hint env sigma h = + let { hint_term = c; hint_uctx = ctx } = h in + match h.hint_uctx with + | None -> sigma, c + | Some ctx -> + (* 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 + +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..dd22cff10b 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -37,14 +37,13 @@ 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; + hint_uctx : Univ.ContextSet.t option; hint_clnv : clausenv; - hint_poly : bool; } type 'a hints_path_atom_gen = @@ -134,18 +133,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 @@ -170,11 +169,11 @@ type hnf = bool type hint_term = | IsGlobRef of GlobRef.t - | IsConstr of constr * Univ.ContextSet.t [@ocaml.deprecated "Declare a hint constant instead"] + | IsConstr of constr * Univ.ContextSet.t option [@ocaml.deprecated "Declare a hint constant instead"] type hints_entry = - | HintsResolveEntry of (hint_info * bool * hnf * hints_path_atom * hint_term) list - | HintsImmediateEntry of (hints_path_atom * bool * hint_term) list + | HintsResolveEntry of (hint_info * hnf * hints_path_atom * hint_term) list + | HintsImmediateEntry of (hints_path_atom * hint_term) list | HintsCutEntry of hints_path | HintsUnfoldEntry of evaluable_global_reference list | HintsTransparencyEntry of evaluable_global_reference hints_transparency_target * bool @@ -211,7 +210,7 @@ val prepare_hint : bool (* Check no remaining evars *) -> has missing arguments. *) val make_resolves : - env -> evar_map -> hint_info -> check:bool -> poly:bool -> ?name:hints_path_atom -> + env -> evar_map -> hint_info -> check:bool -> ?name:hints_path_atom -> hint_term -> hint_entry list (** [make_resolve_hyp hname htyp]. @@ -239,6 +238,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..498a4cfc26 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -116,7 +116,11 @@ let make_inv_predicate env evd indf realargs id status concl = (* Now, we can recurse down this list, for each ai,(mkRel k) whether to push <Ai>(mkRel k)=ai (when Ai is closed). In any case, we carry along the rest of pairs *) - let eqdata = Coqlib.build_coq_eq_data () in + let eqdata = + try Coqlib.build_coq_eq_data () + with UserError _ -> + try Coqlib.build_coq_identity_data () + with UserError _ -> user_err (str "No registered equality.") in let rec build_concl eqns args n = function | [] -> it_mkProd concl eqns, Array.rev_of_list args | ai :: restlist -> @@ -351,8 +355,12 @@ let remember_first_eq id x = if !x == Logic.MoveLast then x := Logic.MoveAfter i let dest_nf_eq env sigma t = match EConstr.kind sigma t with | App (r, [| t; x; y |]) -> let open Reductionops in - let eq = Coqlib.lib_ref "core.eq.type" in - if isRefX sigma eq r then + let is_global_exists gr c = + Coqlib.has_ref gr && isRefX sigma (Coqlib.lib_ref gr) c + in + let is_eq = is_global_exists "core.eq.type" r in + let is_identity = is_global_exists "core.identity.type" r in + if is_eq || is_identity then (t, whd_all env sigma x, whd_all env sigma y) else user_err Pp.(str "Not an equality.") | _ -> @@ -409,7 +417,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 +471,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 +482,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 +495,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..24aa178ed2 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 @@ -806,6 +797,9 @@ module New = struct end let onLastDecl = onNthDecl 1 + let nLastHypsId gl n = List.map (NamedDecl.get_id) (nLastDecls gl n) + let nLastHyps gl n = List.map mkVar (nLastHypsId gl n) + let ifOnHyp pred tac1 tac2 id = Proofview.Goal.enter begin fun gl -> let typ = Tacmach.New.pf_get_hyp_typ id gl in @@ -817,6 +811,10 @@ module New = struct let onHyps find tac = Proofview.Goal.enter begin fun gl -> tac (find gl) end + let onNLastDecls n tac = onHyps (fun gl -> nLastDecls gl n) tac + let onNLastHypsId n tac = onHyps (fun gl -> nLastHypsId gl n) tac + let onNLastHyps n tac = onHyps (fun gl -> nLastHyps gl n) tac + let afterHyp id tac = Proofview.Goal.enter begin fun gl -> let hyps = Proofview.Goal.hyps gl in @@ -844,59 +842,15 @@ 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) = + let fullGoal gl = None :: List.map Option.make (Tacmach.New.pf_ids_of_hyps gl) + let onAllHyps tac = 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 + tclMAP tac (Tacmach.New.pf_ids_of_hyps gl) + end + let onAllHypsAndConcl tac = + Proofview.Goal.enter begin fun gl -> + tclMAP tac (fullGoal gl) + end let elimination_sort_of_goal gl = (* Retyping will expand evars anyway. *) @@ -912,72 +866,17 @@ 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 -> let (sigma, c) = Evd.fresh_global env sigma ref in Proofview.Unsafe.tclEVARS sigma <*> Proofview.tclUNIT c + let tclTYPEOFTHEN ?refresh c tac = + Proofview.Goal.enter (fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Proofview.Goal.sigma gl in + let (sigma, t) = Typing.type_of ?refresh env sigma c in + Proofview.Unsafe.tclEVARS sigma <*> tac sigma t) + end diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 48a06e6e1d..e97c5f3c1f 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 @@ -237,6 +224,10 @@ module New : sig val onLastHyp : (constr -> unit tactic) -> unit tactic val onLastDecl : (named_declaration -> unit tactic) -> unit tactic + val onNLastHypsId : int -> (Id.t list -> unit tactic) -> unit tactic + val onNLastHyps : int -> (constr list -> unit tactic) -> unit tactic + val onNLastDecls : int -> (named_context -> unit tactic) -> unit tactic + val onHyps : (Proofview.Goal.t -> named_context) -> (named_context -> unit tactic) -> unit tactic val afterHyp : Id.t -> (named_context -> unit tactic) -> unit tactic @@ -245,24 +236,14 @@ module New : sig val tryAllHypsAndConcl : (Id.t option -> unit tactic) -> unit tactic val onClause : (Id.t option -> unit tactic) -> clause -> unit tactic + val onAllHyps : (Id.t -> unit tactic) -> unit tactic + val onAllHypsAndConcl : (Id.t option -> unit tactic) -> unit tactic + val elimination_sort_of_goal : Proofview.Goal.t -> Sorts.family 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 + + val tclTYPEOFTHEN : ?refresh:bool -> constr -> (evar_map -> types -> unit Proofview.tactic) -> unit 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/.csdp.cache.test-suite b/test-suite/.csdp.cache.test-suite Binary files differindex 046cb067c5..36efdf469e 100644 --- a/test-suite/.csdp.cache.test-suite +++ b/test-suite/.csdp.cache.test-suite diff --git a/test-suite/Makefile b/test-suite/Makefile index f7447d6cec..6c373701cf 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -141,7 +141,7 @@ run: $(SUBSYSTEMS) bugs: $(BUGS) clean: - rm -f trace .nia.cache .lia.cache output/MExtraction.out + rm -f trace .csdp.cache .nia.cache .lia.cache output/MExtraction.out rm -f vos/Makefile vos/Makefile.conf $(SHOW) 'RM <**/*.stamp> <**/*.vo> <**/*.vio> <**/*.log> <**/*.glob>' $(HIDE)find . \( \ @@ -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_12414.v b/test-suite/bugs/closed/bug_12414.v new file mode 100644 index 0000000000..50b4b86eff --- /dev/null +++ b/test-suite/bugs/closed/bug_12414.v @@ -0,0 +1,13 @@ +Set Universe Polymorphism. +Set Printing Universes. +Inductive list {T} : Type := | cons (t : T) : list -> list. (* who needs nil anyway? *) +Arguments list : clear implicits. + +Fixpoint map {A B} (f: A -> B) (l : list A) : list B := + let '(cons t l) := l in cons (f t) (map f l). +About map@{_ _}. +(* Two universes, as expected. *) + +Definition map_Set@{} {A B : Set} := @map A B. + +Definition map_Prop@{} {A B : Prop} := @map A B. 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_12623.v b/test-suite/bugs/closed/bug_12623.v new file mode 100644 index 0000000000..9fdcb94e0c --- /dev/null +++ b/test-suite/bugs/closed/bug_12623.v @@ -0,0 +1,18 @@ +Set Universe Polymorphism. + +Axiom M : Type -> Prop. +Axiom raise : forall {T}, M T. + +Inductive goal : Type := +| AHyp : forall {A : Type}, goal. + +Definition gtactic@{u u0} := goal@{u} -> M@{u0} (False). + +Class Seq (C : Type) := + seq : C -> gtactic. +Arguments seq {C _} _. + +Instance seq_one : Seq@{Set _ _} (gtactic) := fun t2 => fun g => raise. + +Definition x1 : gtactic := @seq@{_ _ _} _ _ (fun g : goal => raise). +Definition x2 : gtactic := @seq@{_ _ _} _ seq_one (fun g : goal => raise). 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_12917.v b/test-suite/bugs/closed/bug_12917.v new file mode 100644 index 0000000000..cd6b0766c6 --- /dev/null +++ b/test-suite/bugs/closed/bug_12917.v @@ -0,0 +1 @@ +Fail Derive Inversion bla with (le _ _). 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_13003.v b/test-suite/bugs/closed/bug_13003.v new file mode 100644 index 0000000000..570baef2ef --- /dev/null +++ b/test-suite/bugs/closed/bug_13003.v @@ -0,0 +1,9 @@ +Set Mangle Names. +Import EqNotations. +Lemma eq_sigT_sig_eq X P (x1 x2:X) H1 H2 : + forall (E1 : x1=x2), rew E1 in H1 = H2 -> existT P x1 H1 = existT P x2 H2. +Proof. + intros ->. + intros <-. + reflexivity. +Defined. diff --git a/test-suite/bugs/closed/bug_13059.v b/test-suite/bugs/closed/bug_13059.v new file mode 100644 index 0000000000..2416e3ad13 --- /dev/null +++ b/test-suite/bugs/closed/bug_13059.v @@ -0,0 +1,31 @@ +Set Uniform Inductive Parameters. +Inductive test (X : Set) : Prop := +with test2 (X : Set) : X -> Prop := + | C (x : X) : test2 x. + +Require Import List. +Import ListNotations. + +Set Suggest Proof Using. +Set Primitive Projections. + + +Section Grammar. +Variable A : Type. + +Record grammar : Type := Grammar { + gm_nonterm :> Type ; + gm_rules :> list (gm_nonterm * list (A + gm_nonterm)) ; +}. + +Set Uniform Inductive Parameters. +Inductive lang (gm : grammar) : gm -> list A -> Prop := +| lang_rule S ps ws : In (S, ps) gm -> lmatch ps ws -> lang S (concat ws) +with lmatch (gm : grammar) : list (A + gm) -> list (list A) -> Prop := +| lmatch_nil : lmatch [] [] +| lmatch_consL ps ws a : lmatch ps ws -> lmatch (inl a :: ps) ([a] :: ws) +| lmatch_consR ps ws S w : + lang S w -> lmatch ps ws -> lmatch (inr S :: ps) (w :: ws) +. + +End Grammar. diff --git a/test-suite/bugs/closed/bug_13086.v b/test-suite/bugs/closed/bug_13086.v new file mode 100644 index 0000000000..75f842b1cf --- /dev/null +++ b/test-suite/bugs/closed/bug_13086.v @@ -0,0 +1,11 @@ +Unset Universe Checking. + +Definition bad1@{|Set < Set} := Prop. + +Set Universe Polymorphism. +Axiom ax : Type. +Inductive I@{u} : Prop := foo : ax@{u} -> I. + +Definition bad2@{v} (x:I@{v}) : I@{Set} := x. + +Definition vsdvds (f : (Prop -> Prop) -> Prop) (x : Set -> Prop) := f x. diff --git a/test-suite/bugs/closed/bug_13109.v b/test-suite/bugs/closed/bug_13109.v new file mode 100644 index 0000000000..76511a44c5 --- /dev/null +++ b/test-suite/bugs/closed/bug_13109.v @@ -0,0 +1,24 @@ +Require Import Coq.Program.Tactics. + +Set Universe Polymorphism. +Obligation Tactic := idtac. + +Program Definition foo : Type := _. +Program Definition bar : Type := _. +Admit Obligations. +(* Error: Anomaly "Uncaught exception AcyclicGraph.Make(Point).AlreadyDeclared." +Please report at http://coq.inria.fr/bugs/. + *) +Print foo. +Print foo_obligation_1. +Print bar. +Print bar_obligation_1. + +Program Definition baz : Type := _. +Admit Obligations of baz. +Print baz. +Print baz_obligation_1. + +Admit Obligations. + +Fail Admit Obligations of nobody. diff --git a/test-suite/bugs/closed/bug_2928.v b/test-suite/bugs/closed/bug_2928.v deleted file mode 100644 index 21e92ae20c..0000000000 --- a/test-suite/bugs/closed/bug_2928.v +++ /dev/null @@ -1,11 +0,0 @@ -Class Equiv A := equiv: A -> A -> Prop. -Infix "=" := equiv : type_scope. - -Class Associative {A} f `{Equiv A} := associativity x y z : f x (f y z) = f (f x y) z. - -Class SemiGroup A op `{Equiv A} := { sg_ass :>> Associative op }. - -Class SemiLattice A op `{Equiv A} := - { semilattice_sg :>> SemiGroup A op - ; redundant : Associative op - }. 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_5197.v b/test-suite/bugs/closed/bug_5197.v index 0c236e12ad..00b9e9bd9d 100644 --- a/test-suite/bugs/closed/bug_5197.v +++ b/test-suite/bugs/closed/bug_5197.v @@ -20,11 +20,11 @@ Definition Typeᶠ : TYPE := {| rel := fun _ A => (forall ω : Ω, A ω) -> Type; |}. Set Printing Universes. -Fail Definition Typeᵇ : El Typeᶠ := +Definition Typeᵇ : El Typeᶠ := mkPack _ _ (fun w => Type) (fun w A => (forall ω, A ω) -> Type). -Definition Typeᵇ : El Typeᶠ := - mkPack _ (fun _ (A : Ω -> Type) => (forall ω : Ω, A ω) -> _) (fun w => Type) (fun w A => (forall ω, A ω) -> Type). +(* Definition Typeᵇ : El Typeᶠ := *) +(* mkPack _ (fun _ (A : Ω -> Type) => (forall ω : Ω, A ω) -> _) (fun w => Type) (fun w A => (forall ω, A ω) -> Type). *) (** Bidirectional typechecking helps here *) Require Import Program.Tactics. 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/coq-makefile/timing/precomputed-time-tests/007-no-output-sync/run.sh b/test-suite/coq-makefile/timing/precomputed-time-tests/007-no-output-sync/run.sh new file mode 100755 index 0000000000..a5c48b3324 --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/007-no-output-sync/run.sh @@ -0,0 +1,11 @@ +#!/usr/bin/env bash + +set -x +set -e + +cd "$(dirname "${BASH_SOURCE[0]}")" + +"$COQLIB"/tools/make-one-time-file.py time-of-build.log.in time-of-build.log 2>time-of-build.err.log || exit $? + +diff -u time-of-build.log.expected time-of-build.log || exit $? +diff -u time-of-build.err.log.expected time-of-build.err.log || exit $? diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/007-no-output-sync/time-of-build.err.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/007-no-output-sync/time-of-build.err.log.expected new file mode 100644 index 0000000000..f2184407e7 --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/007-no-output-sync/time-of-build.err.log.expected @@ -0,0 +1 @@ +WARNING: Invalid time string: not the right number of dots (.); expected one: '0.240.05' diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/007-no-output-sync/time-of-build.log.expected b/test-suite/coq-makefile/timing/precomputed-time-tests/007-no-output-sync/time-of-build.log.expected new file mode 100644 index 0000000000..0fb57a1406 --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/007-no-output-sync/time-of-build.log.expected @@ -0,0 +1,398 @@ + Time | Peak Mem | File Name +------------------------------------------------------------- +29m02.87s | 1136588 ko | Total Time / Peak Mem +------------------------------------------------------------- + 2m19.40s | 1007764 ko | PCUICSafeConversion.vo + 1m59.92s | 1136588 ko | PCUICSafeReduce.vo + 1m34.58s | 849824 ko | PCUICParallelReductionConfluence.vo + 1m26.21s | 1038900 ko | erasure_live_test.vo + 1m20.36s | 975764 ko | PCUICSR.vo + 0m56.51s | 896928 ko | bugkncst.vo + 0m56.17s | 1113548 ko | ErasureCorrectness.vo + 0m56.09s | 958816 ko | PCUICSafeChecker.vo + 0m51.78s | 809012 ko | Typing.vo + 0m42.82s | 727688 ko | PCUICTyping.vo + 0m39.21s | 1012876 ko | ErasureFunction.vo + 0m39.04s | 790088 ko | PCUICEquality.vo + 0m38.12s | 657100 ko | PCUICSigmaCalculus.vo + 0m34.44s | 742788 ko | PCUICConfluence.vo + 0m29.65s | 750296 ko | PCUICConversion.vo + 0m28.26s | 779308 ko | PCUICParallelReduction.vo + 0m28.24s | 723216 ko | PCUICPosition.vo + 0m27.93s | 621392 ko | Substitution.vo + 0m26.28s | 597996 ko | PCUICLiftSubst.vo + 0m26.11s | 959132 ko | PCUICPrincipality.vo + 0m25.86s | 857128 ko | times_bool_fun.vo + 0m25.65s | 673140 ko | PCUICSubstitution.vo + 0m23.99s | 654592 ko | PCUICClosed.vo + 0m23.42s | 685852 ko | PCUICWeakening.vo + 0m23.34s | 854428 ko | SafeErasureFunction.vo + 0m22.85s | 706592 ko | PCUICSpine.vo + 0m21.55s | 603616 ko | Closed.vo + 0m19.93s | 581920 ko | tauto.vo + 0m19.08s | 683776 ko | PCUICInductives.vo + 0m17.91s | 741808 ko | param_original.vo + 0m15.64s | 579100 ko | Weakening.vo + 0m14.98s | 623196 ko | PCUICNameless.vo + 0m13.39s | 794032 ko | ESubstitution.vo + 0m13.16s | 641024 ko | TemplateToPCUICCorrectness.vo + 0m11.81s | 532016 ko | LiftSubst.vo + 0m11.54s | 589944 ko | PCUICWcbvEval.vo + 0m10.41s | 621644 ko | PCUICUnivSubstitution.vo + 0m10.39s | 661964 ko | PCUICInductiveInversion.vo + 0m10.08s | 521520 ko | ELiftSubst.vo + 0m09.58s | 684644 ko | PCUICAlpha.vo + 0m09.35s | 622488 ko | PCUICInversion.vo + 0m08.74s | 629108 ko | PCUICContextConversion.vo + 0m08.61s | 892080 ko | param_generous_packed.vo + 0m08.05s | 556676 ko | TypingWf.vo + 0m07.84s | 608576 ko | PCUICToTemplateCorrectness.vo + 0m07.75s | 625664 ko | PCUICArities.vo + 0m07.64s | 646256 ko | PCUICElimination.vo + 0m07.23s | 614752 ko | times_bool_fun2.vo + 0m06.54s | 667924 ko | PCUICSafeLemmata.vo + 0m06.33s | 615568 ko | PCUICContexts.vo + 0m06.30s | 733700 ko | PCUICSafeRetyping.vo + 0m06.16s | 583116 ko | PCUICReduction.vo + 0m06.04s | 529900 ko | utils/MCCompare.vo + 0m05.85s | 551516 ko | common/uGraph.vo + 0m05.66s | 643396 ko | EArities.vo + 0m04.94s | 533768 ko | WcbvEval.vo + 0m04.90s | 501352 ko | vs.vo + 0m04.72s | 498552 ko | utils/wGraph.vo + 0m04.53s | 552364 ko | Reflect.vo + 0m04.41s | 348856 ko | MiniHoTT.vo + 0m04.38s | 571076 ko | PCUICWeakeningEnv.vo + 0m04.23s | 531272 ko | Universes.vo + 0m04.11s | 543956 ko | PCUICReflect.vo + 0m04.00s | 555748 ko | Checker.vo + 0m03.99s | 624912 ko | PCUICValidity.vo + 0m03.99s | 806128 ko | SafeTemplateErasure.vo + 0m03.85s | 520080 ko | EWcbvEval.vo + 0m03.42s | 350716 ko | MiniHoTT_paths.vo + 0m03.39s | 741428 ko | Prelim.vo + 0m03.34s | 586388 ko | PCUICGeneration.vo + 0m03.33s | 533884 ko | PCUICUnivSubst.vo + 0m03.11s | 561316 ko | Extraction.vo + 0m03.11s | 490756 ko | UnivSubst.vo + 0m02.89s | 726228 ko | safechecker_test.vo + 0m02.80s | 512292 ko | WeakeningEnv.vo + 0m02.78s | 543424 ko | PCUICAstUtils.vo + 0m02.78s | 465984 ko | utils/All_Forall.vo + 0m02.67s | 729072 ko | EInversion.vo + 0m02.42s | 703592 ko | SafeTemplateChecker.vo + 0m02.27s | 558304 ko | TypingTests.vo + 0m02.12s | 630488 ko | PCUICSN.vo + 0m01.93s | 556444 ko | param_binary.vo + 0m01.85s | 561876 ko | PCUICCumulativity.vo + 0m01.82s | 554420 ko | translation_utils.vo + 0m01.77s | 491968 ko | EnvironmentTyping.vo + 0m01.75s | 598288 ko | PCUICCtxShape.vo + 0m01.69s | 514692 ko | Generation.vo + 0m01.62s | 512080 ko | bug5.vo + 0m01.58s | 589768 ko | PCUICRetyping.vo + 0m01.57s | 617808 ko | Extract.vo + 0m01.56s | 527740 ko | demo.vo + 0m01.55s | 562424 ko | PCUICCSubst.vo + 0m01.49s | 553352 ko | param_cheap_packed.vo + 0m01.47s | 527440 ko | PCUICUtils.vo + 0m01.47s | 452340 ko | utils/MCList.vo + 0m01.44s | 503484 ko | PCUICSize.vo + 0m01.42s | 619396 ko | EAll.vo + 0m01.37s | 551200 ko | PCUICNormal.vo + 0m01.35s | 526276 ko | modules_sections.vo + 0m01.34s | 549492 ko | standard_model.vo + 0m01.30s | 551364 ko | PCUICPretty.vo + 0m01.29s | 545736 ko | All.vo + 0m01.21s | 524028 ko | proj.vo + 0m01.21s | 513888 ko | test/test.vo + 0m01.18s | 486324 ko | Induction.vo + 0m01.13s | 524144 ko | add_constructor.vo + 0m01.11s | 549776 ko | PCUICChecker.vo + 0m01.10s | 487520 ko | EAstUtils.vo + 0m01.10s | 484172 ko | Environment.vo + 0m01.10s | 543584 ko | erasure_test.vo + 0m01.09s | 525128 ko | order_rec.vo + 0m01.05s | 512080 ko | ECSubst.vo + 0m01.05s | 489932 ko | WfInv.vo + 0m01.05s | 522968 ko | issue28.vo + 0m01.04s | 527408 ko | PCUICToTemplate.vo + 0m01.03s | 510284 ko | bug1.vo + 0m01.03s | 522996 ko | run_in_tactic.vo + 0m01.03s | 522248 ko | unfold.vo + 0m01.02s | 522688 ko | issue27.vo + 0m01.01s | 524932 ko | tmVariable.vo + 0m01.00s | 485664 ko | AstUtils.vo + 0m00.99s | 522992 ko | univ.vo + 0m00.98s | 522552 ko | tmInferInstance.vo + 0m00.96s | 546928 ko | PCUICMetaTheory.vo + 0m00.94s | 510368 ko | castprop.vo + 0m00.94s | 500016 ko | opaque.vo + 0m00.92s | 522724 ko | tmExistingInstance.vo + 0m00.91s | 513348 ko | MyPlugin.vo + 0m00.90s | 524140 ko | Retyping.vo + 0m00.90s | 500080 ko | letin.vo + 0m00.89s | 481312 ko | PCUICInduction.vo + 0m00.89s | 500252 ko | bug7.vo + 0m00.89s | 500068 ko | mutind.vo + 0m00.88s | 500120 ko | case.vo + 0m00.88s | 501748 ko | extractable.vo + 0m00.87s | 486460 ko | Pretty.vo + 0m00.86s | 500064 ko | sigma.vo + 0m00.85s | 500408 ko | bug6.vo + 0m00.84s | 497360 ko | Normal.vo + 0m00.84s | 500436 ko | bug8.vo + 0m00.82s | 498504 ko | Constants.vo + 0m00.81s | 500380 ko | bug2.vo + 0m00.81s | 500192 ko | cofix.vo + 0m00.80s | 502088 ko | hnf_ctor.vo + 0m00.79s | 479940 ko | Ast.vo + 0m00.79s | 500100 ko | evars.vo + 0m00.77s | 488076 ko | EPretty.vo + 0m00.75s | 450728 ko | BasicAst.vo + 0m00.75s | 477372 ko | PCUICAst.vo + 0m00.73s | 487644 ko | ETyping.vo + 0m00.73s | 481988 ko | TemplateMonad/Core.vo + 0m00.72s | 477800 ko | EAst.vo + 0m00.71s | 479012 ko | EInduction.vo + 0m00.70s | 485084 ko | EWndEval.vo + 0m00.70s | 481156 ko | TemplateMonad/Extractable.vo + 0m00.69s | 482472 ko | TemplateToPCUIC.vo + 0m00.60s | 433064 ko | PCUICCheckerCompleteness.vo + 0m00.60s | 437492 ko | TemplateMonad/Common.vo + 0m00.56s | 440168 ko | utils/MCOption.vo + 0m00.54s | 420452 ko | TemplateMonad.vo + 0m00.52s | 385340 ko | utils.vo + 0m00.48s | 404556 ko | utils/MCArith.vo + 0m00.42s | 339136 ko | utils/LibHypsNaming.vo + 0m00.41s | 39160 ko | gen-src/universes0.cmx + 0m00.33s | 45284 ko | pCUICSafeChecker.cmx + 0m00.30s | 270156 ko | utils/MCString.vo + 0m00.29s | 238116 ko | Loader.vo + 0m00.27s | 43056 ko | pCUICSafeConversion.cmx +0m00.240s | N/A | denoter.cmx + 0m00.19s | 34468 ko | gen-src/quoter.cmx + 0m00.17s | 33044 ko | constr_quoter.cmx + 0m00.15s | 25208 ko | gen-src/binPos.cmx + 0m00.15s | 38520 ko | run_template_monad.cmx + 0m00.14s | 31740 ko | constr_denoter.cmx + 0m00.14s | 25372 ko | gen-src/all_Forall.cmx + 0m00.14s | 149456 ko | monad_utils.vo + 0m00.14s | 31636 ko | wGraph.cmx + 0m00.13s | 23892 ko | gen-src/binPosDef.cmx + 0m00.13s | 20232 ko | metacoq_erasure_plugin.cmxs + 0m00.12s | 22784 ko | gen-src/binInt.cmx + 0m00.11s | 31208 ko | erasureFunction.cmx + 0m00.11s | 31632 ko | gen-src/metacoq_template_plugin.cmx + 0m00.11s | 20224 ko | metacoq_safechecker_plugin.cmxs + 0m00.11s | 30984 ko | uGraph0.cmx + 0m00.10s | 28644 ko | eAst.cmx + 0m00.10s | 33140 ko | g_template_coq.cmx + 0m00.10s | 27364 ko | gen-src/ast_quoter.cmx + 0m00.10s | 20796 ko | gen-src/binNat.cmx + 0m00.10s | 18416 ko | gen-src/metacoq_template_plugin.cmxs + 0m00.10s | 27228 ko | gen-src/myPlugin.cmx + 0m00.10s | 26404 ko | gen-src/quoter.cmo + 0m00.09s | 26992 ko | ePretty.cmx + 0m00.09s | 35368 ko | g_metacoq_safechecker.cmx + 0m00.09s | 24572 ko | gen-src/ast0.cmx + 0m00.09s | 20020 ko | gen-src/hexadecimal.cmx + 0m00.09s | 30504 ko | gen-src/run_extractable.cmx + 0m00.09s | 29148 ko | pCUICPretty.cmx + 0m00.09s | 29852 ko | safeErasureFunction.cmx + 0m00.09s | 88348 ko | utils/MCProd.vo + 0m00.08s | 27288 ko | gen-src/ast_denoter.cmx + 0m00.08s | 24324 ko | gen-src/denoter.cmx + 0m00.08s | 21352 ko | gen-src/mSetList.cmx + 0m00.08s | 22020 ko | gen-src/pretty.cmx + 0m00.08s | 32668 ko | metacoq_erasure_plugin.cmx + 0m00.08s | 26392 ko | pCUICAstUtils.cmx + 0m00.08s | 27752 ko | pCUICTyping.cmx + 0m00.07s | 19912 ko | gen-src/peanoNat.cmx + 0m00.07s | 27504 ko | gen-src/plugin_core.cmx + 0m00.07s | 27792 ko | pCUICSafeReduce.cmx + 0m00.07s | 30244 ko | safeTemplateErasure.cmx + 0m00.06s | 24684 ko | eTyping.cmx + 0m00.06s | 22652 ko | erasureFunction.cmi + 0m00.06s | 27844 ko | g_demo_plugin.cmx + 0m00.06s | 30052 ko | g_metacoq_erasure.cmx + 0m00.06s | 25216 ko | mSetWeakList.cmx + 0m00.06s | 30436 ko | metacoq_safechecker_plugin.cmx + 0m00.06s | 26256 ko | pCUICEquality.cmx + 0m00.06s | 26244 ko | pCUICLiftSubst.cmx + 0m00.06s | 26048 ko | pCUICPosition.cmx + 0m00.06s | 23232 ko | pCUICSafeConversion.cmi + 0m00.06s | 27380 ko | pCUICSafeRetyping.cmx + 0m00.06s | 25408 ko | safeTemplateChecker.cmx + 0m00.06s | 26384 ko | templateToPCUIC.cmx + 0m00.06s | 24780 ko | uGraph0.cmi + 0m00.05s | 64048 ko | Lens.vo + 0m00.05s | 24800 ko | eAstUtils.cmx + 0m00.05s | 25192 ko | eLiftSubst.cmx + 0m00.05s | 22440 ko | gen-src/ast_quoter.cmo + 0m00.05s | 20324 ko | gen-src/mSetInterface.cmx + 0m00.05s | 26032 ko | pCUICAst.cmx + 0m00.05s | 25140 ko | pCUICChecker.cmx + 0m00.05s | 24336 ko | pCUICReflect.cmx + 0m00.05s | 24300 ko | pCUICSafeChecker.cmi + 0m00.05s | 21556 ko | pCUICSafeReduce.cmi + 0m00.05s | 25180 ko | pCUICUnivSubst.cmx + 0m00.05s | 21660 ko | safeErasureFunction.cmi + 0m00.05s | 23148 ko | safeTemplateErasure.cmi + 0m00.05s | 21328 ko | templateToPCUIC.cmi + 0m00.05s | 16040 ko | template_coq.cmxs + 0m00.05s | 24076 ko | typing0.cmx + 0m00.05s | 63096 ko | utils/MCPrelude.vo + 0m00.05s | 68156 ko | utils/MCRelations.vo + 0m00.05s | 22824 ko | wGraph.cmi + 0m00.04s | 62716 ko | ExtractableLoader.vo + 0m00.04s | 61716 ko | config.vo + 0m00.04s | 22020 ko | constr_reification.cmx + 0m00.04s | 21964 ko | demo_plugin.cmx + 0m00.04s | 20540 ko | ePretty.cmi + 0m00.04s | 23032 ko | extract.cmx + 0m00.04s | 19608 ko | gen-src/astUtils.cmx + 0m00.04s | 18780 ko | gen-src/extractable.cmx + 0m00.04s | 22124 ko | gen-src/lens.cmx + 0m00.04s | 19008 ko | gen-src/liftSubst.cmx + 0m00.04s | 19600 ko | gen-src/mSetProperties.cmx + 0m00.04s | 20208 ko | gen-src/myPlugin.cmi + 0m00.04s | 18464 ko | gen-src/nat0.cmx + 0m00.04s | 22136 ko | gen-src/tm_util.cmx + 0m00.04s | 18504 ko | gen-src/universes0.cmi + 0m00.04s | 20108 ko | mSetWeakList.cmi + 0m00.04s | 22452 ko | monad_utils.cmx + 0m00.04s | 21244 ko | pCUICAst.cmi + 0m00.04s | 20412 ko | pCUICAstUtils.cmi + 0m00.04s | 21236 ko | pCUICChecker.cmi + 0m00.04s | 20560 ko | pCUICPretty.cmi + 0m00.04s | 21400 ko | pCUICTyping.cmi + 0m00.04s | 20348 ko | safeTemplateChecker.cmi + 0m00.04s | 19228 ko | utils.cmi + 0m00.04s | 22212 ko | utils.cmx + 0m00.04s | 62924 ko | utils/MCEquality.vo + 0m00.04s | 61384 ko | utils/MCSquash.vo + 0m00.03s | 19340 ko | classes0.cmi + 0m00.03s | 20908 ko | eAst.cmi + 0m00.03s | 19496 ko | eAstUtils.cmi + 0m00.03s | 20252 ko | eTyping.cmi + 0m00.03s | 19268 ko | eqDecInstances.cmi + 0m00.03s | 22196 ko | eqDecInstances.cmx + 0m00.03s | 19396 ko | eqdepFacts.cmi + 0m00.03s | 22072 ko | eqdepFacts.cmx + 0m00.03s | 21060 ko | extract.cmi + 0m00.03s | 18744 ko | gen-src/basicAst.cmx + 0m00.03s | 17936 ko | gen-src/decimal.cmx + 0m00.03s | 19716 ko | gen-src/environment.cmx + 0m00.03s | 19172 ko | gen-src/lens.cmi + 0m00.03s | 17796 ko | gen-src/list0.cmx + 0m00.03s | 18548 ko | gen-src/univSubst0.cmx + 0m00.03s | 19324 ko | init.cmi + 0m00.03s | 22188 ko | init.cmx + 0m00.03s | 19272 ko | monad_utils.cmi + 0m00.03s | 20372 ko | pCUICEquality.cmi + 0m00.03s | 20444 ko | pCUICLiftSubst.cmi + 0m00.03s | 22044 ko | pCUICNormal.cmx + 0m00.03s | 20488 ko | pCUICPosition.cmi + 0m00.03s | 20240 ko | pCUICReflect.cmi + 0m00.03s | 19348 ko | pCUICSafeLemmata.cmi + 0m00.03s | 21604 ko | pCUICSafeRetyping.cmi + 0m00.03s | 20308 ko | pCUICUnivSubst.cmi + 0m00.03s | 21812 ko | tm_util.cmx + 0m00.03s | 20300 ko | typing0.cmi + 0m00.02s | 21960 ko | classes0.cmx + 0m00.02s | 19300 ko | eLiftSubst.cmi + 0m00.02s | 16900 ko | gen-src/ascii.cmx + 0m00.02s | 16836 ko | gen-src/cRelationClasses.cmx + 0m00.02s | 16420 ko | gen-src/common0.cmx + 0m00.02s | 16472 ko | gen-src/mCString.cmx + 0m00.02s | 15244 ko | gen-src/mSetInterface.cmi + 0m00.02s | 15212 ko | gen-src/mSetProperties.cmi + 0m00.02s | 17196 ko | gen-src/plugin_core.cmi + 0m00.02s | 16332 ko | gen-src/specif.cmx + 0m00.02s | 16504 ko | gen-src/string0.cmx + 0m00.02s | 18448 ko | gen-src/tm_util.cmo + 0m00.02s | 19224 ko | pCUICCumulativity.cmi + 0m00.02s | 21940 ko | pCUICCumulativity.cmx + 0m00.02s | 19304 ko | pCUICNormal.cmi + 0m00.02s | 22084 ko | pCUICSafeLemmata.cmx + 0m00.02s | 19220 ko | ssrbool.cmi + 0m00.02s | 21912 ko | ssrbool.cmx + 0m00.02s | 19956 ko | template_coq.cmx + 0m00.01s | 14256 ko | demo_plugin.cmxs + 0m00.01s | 14992 ko | gen-src/all_Forall.cmi + 0m00.01s | 15204 ko | gen-src/ast0.cmi + 0m00.01s | 14404 ko | gen-src/basicAst.cmi + 0m00.01s | 13564 ko | gen-src/binInt.cmi + 0m00.01s | 14264 ko | gen-src/binPos.cmi + 0m00.01s | 15772 ko | gen-src/bool.cmx + 0m00.01s | 13388 ko | gen-src/cRelationClasses.cmi + 0m00.01s | 15536 ko | gen-src/compare_dec.cmx + 0m00.01s | 16200 ko | gen-src/datatypes.cmx + 0m00.01s | 14988 ko | gen-src/environment.cmi + 0m00.01s | 15840 ko | gen-src/equalities.cmx + 0m00.01s | 13404 ko | gen-src/list0.cmi + 0m00.01s | 15672 ko | gen-src/mCCompare.cmx + 0m00.01s | 16712 ko | gen-src/mCList.cmx + 0m00.01s | 15708 ko | gen-src/mCProd.cmx + 0m00.01s | 13748 ko | gen-src/mSetFacts.cmi + 0m00.01s | 17012 ko | gen-src/mSetFacts.cmx + 0m00.01s | 15760 ko | gen-src/mSetList.cmi + 0m00.01s | 14056 ko | gen-src/metacoq_template_plugin.cmxa + 0m00.01s | 15860 ko | gen-src/orderedType0.cmx + 0m00.01s | 13748 ko | gen-src/orders.cmi + 0m00.01s | 16768 ko | gen-src/orders.cmx + 0m00.01s | 16032 ko | gen-src/ordersFacts.cmx + 0m00.01s | 15844 ko | gen-src/ordersTac.cmx + 0m00.01s | 11760 ko | gen-src/reification.cmo + 0m00.01s | 14740 ko | gen-src/reification.cmx + 0m00.01s | 13824 ko | gen-src/run_extractable.cmi + 0m00.01s | 13460 ko | i + 0m00.01s | 17068 ko | plugin_core.cmi + 0m00.01s | 14796 ko | reification.cmx + 0m00.00s | 13200 ko | demo_plugin.cmxa + 0m00.00s | 12228 ko | gen-src/ascii.cmi + 0m00.00s | 14040 ko | gen-src/astUtils.cmi + 0m00.00s | 11244 ko | gen-src/basics.cmi + 0m00.00s | 13444 ko | gen-src/binNat.cmi + 0m00.00s | 11340 ko | gen-src/binNums.cmi + 0m00.00s | 13536 ko | gen-src/binPosDef.cmi + 0m00.00s | 11744 ko | gen-src/bool.cmi + 0m00.00s | 13492 ko | gen-src/common0.cmi + 0m00.00s | 11720 ko | gen-src/compare_dec.cmi + 0m00.00s | 11112 ko | gen-src/config0.cmi + 0m00.00s | 14648 ko | gen-src/config0.cmx + 0m00.00s | 12948 ko | gen-src/datatypes.cmi + 0m00.00s | 12404 ko | gen-src/decimal.cmi + 0m00.00s | 13240 ko | gen-src/equalities.cmi + 0m00.00s | 13580 ko | gen-src/extractable.cmi + 0m00.00s | 13064 ko | gen-src/hexadecimal.cmi + 0m00.00s | 13680 ko | gen-src/liftSubst.cmi + 0m00.00s | 11524 ko | gen-src/logic0.cmi + 0m00.00s | 15516 ko | gen-src/logic0.cmx + 0m00.00s | 11644 ko | gen-src/mCCompare.cmi + 0m00.00s | 13612 ko | gen-src/mCList.cmi + 0m00.00s | 12200 ko | gen-src/mCOption.cmi + 0m00.00s | 11228 ko | gen-src/mCPrelude.cmi + 0m00.00s | 14368 ko | gen-src/mCPrelude.cmx + 0m00.00s | 11620 ko | gen-src/mCProd.cmi + 0m00.00s | 11080 ko | gen-src/mCRelations.cmi + 0m00.00s | 14184 ko | gen-src/mCRelations.cmx + 0m00.00s | 11712 ko | gen-src/mCString.cmi + 0m00.00s | 13776 ko | gen-src/mSetDecide.cmi + 0m00.00s | 11900 ko | gen-src/numeral.cmi + 0m00.00s | 15820 ko | gen-src/numeral.cmx + 0m00.00s | 12108 ko | gen-src/orderedType0.cmi + 0m00.00s | 13444 ko | gen-src/ordersFacts.cmi + 0m00.00s | 11760 ko | gen-src/ordersLists.cmi + 0m00.00s | 15096 ko | gen-src/ordersLists.cmx + 0m00.00s | 12464 ko | gen-src/ordersTac.cmi + 0m00.00s | 15060 ko | gen-src/pretty.cmi + 0m00.00s | 13160 ko | gen-src/specif.cmi + 0m00.00s | 12236 ko | gen-src/string0.cmi + 0m00.00s | 14128 ko | gen-src/univSubst0.cmi + 0m00.00s | 13520 ko | metacoq_erasure_plugin.cmxa + 0m00.00s | 13624 ko | metacoq_safechecker_plugin.cmxa + 0m00.00s | 13148 ko | run_template_monad.cmi + 0m00.00s | 13520 ko | template_coq.cmxa + 0m00.00s | 15004 ko | template_monad.cmi diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/007-no-output-sync/time-of-build.log.in b/test-suite/coq-makefile/timing/precomputed-time-tests/007-no-output-sync/time-of-build.log.in new file mode 100644 index 0000000000..47d0e09e1a --- /dev/null +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/007-no-output-sync/time-of-build.log.in @@ -0,0 +1,5629 @@ +[0KRunning with gitlab-runner 11.9.2 (fa86510e) +[0;m[0K on roquableu curNbQZR +[0;m[0KUsing Docker executor with image registry.gitlab.com/coq/coq:bionic_coq-V2020-08-28-V92 ... +[0;m[0KPulling docker image registry.gitlab.com/coq/coq:bionic_coq-V2020-08-28-V92 ... +[0;m[0KUsing docker image sha256:f232f9802a06400390b5d6afa5fd280d73c89890309a27e840013ef2e9809c91 for registry.gitlab.com/coq/coq:bionic_coq-V2020-08-28-V92 ... +[0;msection_start:1598963621:prepare_script
[0KRunning on runner-curNbQZR-project-6138686-concurrent-1 via roquableu... +section_end:1598963624:prepare_script
[0Ksection_start:1598963624:get_sources
[0KReinitialized existing Git repository in /builds/coq/coq/.git/ +Removing _build_ci/ +Removing _install_ci/ +Removing config/Makefile +Removing config/coq_config.ml +Removing config/coq_config.py +Removing test-suite/misc/universes/all_stdlib.v +Removing time-of-build.log +Removing tools/TimeFileMaker.pyc +[0;mClean repository +[32;1mFetching changes with git depth set to 10...[0;m +fatal: remote origin already exists. +Auto packing the repository in background for optimum performance. +See "git help gc" for manual housekeeping. +[32;1mChecking out fdbbc0cb as pr-12653...[0;m + +[32;1mSkipping Git submodules setup[0;m +section_end:1598963638:get_sources
[0Ksection_start:1598963638:restore_cache
[0Ksection_end:1598963641:restore_cache
[0Ksection_start:1598963641:download_artifacts
[0K[32;1mDownloading artifacts for build:base (713526714)...[0;m +Downloading artifacts from coordinator... ok [0;m id[0;m=713526714 responseStatus[0;m=200 OK token[0;m=CwEA_cmf +[32;1mDownloading artifacts for plugin:ci-equations (713526793)...[0;m +Downloading artifacts from coordinator... ok [0;m id[0;m=713526793 responseStatus[0;m=200 OK token[0;m=hxEjzCme +section_end:1598963691:download_artifacts
[0Ksection_start:1598963691:build_script
[0K[32;1m$ cat /proc/{cpu,mem}info || true[0;m +processor : 0 +vendor_id : GenuineIntel +cpu family : 6 +model : 45 +model name : Intel(R) Xeon(R) CPU E5-2667 0 @ 2.90GHz +stepping : 7 +microcode : 0x718 +cpu MHz : 3192.059 +cache size : 15360 KB +physical id : 0 +siblings : 12 +core id : 0 +cpu cores : 6 +apicid : 0 +initial apicid : 0 +fpu : yes +fpu_exception : yes +cpuid level : 13 +wp : yes +flags : fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov pat pse36 clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe syscall nx pdpe1gb rdtscp lm constant_tsc arch_perfmon pebs bts rep_good nopl xtopology nonstop_tsc cpuid aperfmperf pni pclmulqdq dtes64 monitor ds_cpl vmx smx est tm2 ssse3 cx16 xtpr pdcm pcid dca sse4_1 sse4_2 x2apic popcnt tsc_deadline_timer aes xsave avx lahf_lm epb pti ssbd ibrs ibpb stibp tpr_shadow vnmi flexpriority ept vpid xsaveopt dtherm ida arat pln pts md_clear flush_l1d +bugs : cpu_meltdown spectre_v1 spectre_v2 spec_store_bypass l1tf mds swapgs itlb_multihit +bogomips : 5785.73 +clflush size : 64 +cache_alignment : 64 +address sizes : 46 bits physical, 48 bits virtual +power management: + +processor : 1 +vendor_id : GenuineIntel +cpu family : 6 +model : 45 +model name : Intel(R) Xeon(R) CPU E5-2667 0 @ 2.90GHz +stepping : 7 +microcode : 0x718 +cpu MHz : 3192.128 +cache size : 15360 KB +physical id : 0 +siblings : 12 +core id : 1 +cpu cores : 6 +apicid : 2 +initial apicid : 2 +fpu : yes +fpu_exception : yes +cpuid level : 13 +wp : yes +flags : fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov pat pse36 clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe syscall nx pdpe1gb rdtscp lm constant_tsc arch_perfmon pebs bts rep_good nopl xtopology nonstop_tsc cpuid aperfmperf pni pclmulqdq dtes64 monitor ds_cpl vmx smx est tm2 ssse3 cx16 xtpr pdcm pcid dca sse4_1 sse4_2 x2apic popcnt tsc_deadline_timer aes xsave avx lahf_lm epb pti ssbd ibrs ibpb stibp tpr_shadow vnmi flexpriority ept vpid xsaveopt dtherm ida arat pln pts md_clear flush_l1d +bugs : cpu_meltdown spectre_v1 spectre_v2 spec_store_bypass l1tf mds swapgs itlb_multihit +bogomips : 5785.73 +clflush size : 64 +cache_alignment : 64 +address sizes : 46 bits physical, 48 bits virtual +power management: + +processor : 2 +vendor_id : GenuineIntel +cpu family : 6 +model : 45 +model name : Intel(R) Xeon(R) CPU E5-2667 0 @ 2.90GHz +stepping : 7 +microcode : 0x718 +cpu MHz : 3192.132 +cache size : 15360 KB +physical id : 0 +siblings : 12 +core id : 2 +cpu cores : 6 +apicid : 4 +initial apicid : 4 +fpu : yes +fpu_exception : yes +cpuid level : 13 +wp : yes +flags : fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov pat pse36 clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe syscall nx pdpe1gb rdtscp lm constant_tsc arch_perfmon pebs bts rep_good nopl xtopology nonstop_tsc cpuid aperfmperf pni pclmulqdq dtes64 monitor ds_cpl vmx smx est tm2 ssse3 cx16 xtpr pdcm pcid dca sse4_1 sse4_2 x2apic popcnt tsc_deadline_timer aes xsave avx lahf_lm epb pti ssbd ibrs ibpb stibp tpr_shadow vnmi flexpriority ept vpid xsaveopt dtherm ida arat pln pts md_clear flush_l1d +bugs : cpu_meltdown spectre_v1 spectre_v2 spec_store_bypass l1tf mds swapgs itlb_multihit +bogomips : 5785.73 +clflush size : 64 +cache_alignment : 64 +address sizes : 46 bits physical, 48 bits virtual +power management: + +processor : 3 +vendor_id : GenuineIntel +cpu family : 6 +model : 45 +model name : Intel(R) Xeon(R) CPU E5-2667 0 @ 2.90GHz +stepping : 7 +microcode : 0x718 +cpu MHz : 3192.131 +cache size : 15360 KB +physical id : 0 +siblings : 12 +core id : 3 +cpu cores : 6 +apicid : 6 +initial apicid : 6 +fpu : yes +fpu_exception : yes +cpuid level : 13 +wp : yes +flags : fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov pat pse36 clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe syscall nx pdpe1gb rdtscp lm constant_tsc arch_perfmon pebs bts rep_good nopl xtopology nonstop_tsc cpuid aperfmperf pni pclmulqdq dtes64 monitor ds_cpl vmx smx est tm2 ssse3 cx16 xtpr pdcm pcid dca sse4_1 sse4_2 x2apic popcnt tsc_deadline_timer aes xsave avx lahf_lm epb pti ssbd ibrs ibpb stibp tpr_shadow vnmi flexpriority ept vpid xsaveopt dtherm ida arat pln pts md_clear flush_l1d +bugs : cpu_meltdown spectre_v1 spectre_v2 spec_store_bypass l1tf mds swapgs itlb_multihit +bogomips : 5785.73 +clflush size : 64 +cache_alignment : 64 +address sizes : 46 bits physical, 48 bits virtual +power management: + +processor : 4 +vendor_id : GenuineIntel +cpu family : 6 +model : 45 +model name : Intel(R) Xeon(R) CPU E5-2667 0 @ 2.90GHz +stepping : 7 +microcode : 0x718 +cpu MHz : 3192.127 +cache size : 15360 KB +physical id : 0 +siblings : 12 +core id : 4 +cpu cores : 6 +apicid : 8 +initial apicid : 8 +fpu : yes +fpu_exception : yes +cpuid level : 13 +wp : yes +flags : fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov pat pse36 clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe syscall nx pdpe1gb rdtscp lm constant_tsc arch_perfmon pebs bts rep_good nopl xtopology nonstop_tsc cpuid aperfmperf pni pclmulqdq dtes64 monitor ds_cpl vmx smx est tm2 ssse3 cx16 xtpr pdcm pcid dca sse4_1 sse4_2 x2apic popcnt tsc_deadline_timer aes xsave avx lahf_lm epb pti ssbd ibrs ibpb stibp tpr_shadow vnmi flexpriority ept vpid xsaveopt dtherm ida arat pln pts md_clear flush_l1d +bugs : cpu_meltdown spectre_v1 spectre_v2 spec_store_bypass l1tf mds swapgs itlb_multihit +bogomips : 5785.73 +clflush size : 64 +cache_alignment : 64 +address sizes : 46 bits physical, 48 bits virtual +power management: + +processor : 5 +vendor_id : GenuineIntel +cpu family : 6 +model : 45 +model name : Intel(R) Xeon(R) CPU E5-2667 0 @ 2.90GHz +stepping : 7 +microcode : 0x718 +cpu MHz : 3192.186 +cache size : 15360 KB +physical id : 0 +siblings : 12 +core id : 5 +cpu cores : 6 +apicid : 10 +initial apicid : 10 +fpu : yes +fpu_exception : yes +cpuid level : 13 +wp : yes +flags : fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov pat pse36 clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe syscall nx pdpe1gb rdtscp lm constant_tsc arch_perfmon pebs bts rep_good nopl xtopology nonstop_tsc cpuid aperfmperf pni pclmulqdq dtes64 monitor ds_cpl vmx smx est tm2 ssse3 cx16 xtpr pdcm pcid dca sse4_1 sse4_2 x2apic popcnt tsc_deadline_timer aes xsave avx lahf_lm epb pti ssbd ibrs ibpb stibp tpr_shadow vnmi flexpriority ept vpid xsaveopt dtherm ida arat pln pts md_clear flush_l1d +bugs : cpu_meltdown spectre_v1 spectre_v2 spec_store_bypass l1tf mds swapgs itlb_multihit +bogomips : 5785.73 +clflush size : 64 +cache_alignment : 64 +address sizes : 46 bits physical, 48 bits virtual +power management: + +processor : 6 +vendor_id : GenuineIntel +cpu family : 6 +model : 45 +model name : Intel(R) Xeon(R) CPU E5-2667 0 @ 2.90GHz +stepping : 7 +microcode : 0x718 +cpu MHz : 3192.248 +cache size : 15360 KB +physical id : 1 +siblings : 12 +core id : 0 +cpu cores : 6 +apicid : 32 +initial apicid : 32 +fpu : yes +fpu_exception : yes +cpuid level : 13 +wp : yes +flags : fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov pat pse36 clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe syscall nx pdpe1gb rdtscp lm constant_tsc arch_perfmon pebs bts rep_good nopl xtopology nonstop_tsc cpuid aperfmperf pni pclmulqdq dtes64 monitor ds_cpl vmx smx est tm2 ssse3 cx16 xtpr pdcm pcid dca sse4_1 sse4_2 x2apic popcnt tsc_deadline_timer aes xsave avx lahf_lm epb pti ssbd ibrs ibpb stibp tpr_shadow vnmi flexpriority ept vpid xsaveopt dtherm ida arat pln pts md_clear flush_l1d +bugs : cpu_meltdown spectre_v1 spectre_v2 spec_store_bypass l1tf mds swapgs itlb_multihit +bogomips : 5792.29 +clflush size : 64 +cache_alignment : 64 +address sizes : 46 bits physical, 48 bits virtual +power management: + +processor : 7 +vendor_id : GenuineIntel +cpu family : 6 +model : 45 +model name : Intel(R) Xeon(R) CPU E5-2667 0 @ 2.90GHz +stepping : 7 +microcode : 0x718 +cpu MHz : 3192.131 +cache size : 15360 KB +physical id : 1 +siblings : 12 +core id : 1 +cpu cores : 6 +apicid : 34 +initial apicid : 34 +fpu : yes +fpu_exception : yes +cpuid level : 13 +wp : yes +flags : fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov pat pse36 clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe syscall nx pdpe1gb rdtscp lm constant_tsc arch_perfmon pebs bts rep_good nopl xtopology nonstop_tsc cpuid aperfmperf pni pclmulqdq dtes64 monitor ds_cpl vmx smx est tm2 ssse3 cx16 xtpr pdcm pcid dca sse4_1 sse4_2 x2apic popcnt tsc_deadline_timer aes xsave avx lahf_lm epb pti ssbd ibrs ibpb stibp tpr_shadow vnmi flexpriority ept vpid xsaveopt dtherm ida arat pln pts md_clear flush_l1d +bugs : cpu_meltdown spectre_v1 spectre_v2 spec_store_bypass l1tf mds swapgs itlb_multihit +bogomips : 5792.29 +clflush size : 64 +cache_alignment : 64 +address sizes : 46 bits physical, 48 bits virtual +power management: + +processor : 8 +vendor_id : GenuineIntel +cpu family : 6 +model : 45 +model name : Intel(R) Xeon(R) CPU E5-2667 0 @ 2.90GHz +stepping : 7 +microcode : 0x718 +cpu MHz : 3192.137 +cache size : 15360 KB +physical id : 1 +siblings : 12 +core id : 2 +cpu cores : 6 +apicid : 36 +initial apicid : 36 +fpu : yes +fpu_exception : yes +cpuid level : 13 +wp : yes +flags : fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov pat pse36 clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe syscall nx pdpe1gb rdtscp lm constant_tsc arch_perfmon pebs bts rep_good nopl xtopology nonstop_tsc cpuid aperfmperf pni pclmulqdq dtes64 monitor ds_cpl vmx smx est tm2 ssse3 cx16 xtpr pdcm pcid dca sse4_1 sse4_2 x2apic popcnt tsc_deadline_timer aes xsave avx lahf_lm epb pti ssbd ibrs ibpb stibp tpr_shadow vnmi flexpriority ept vpid xsaveopt dtherm ida arat pln pts md_clear flush_l1d +bugs : cpu_meltdown spectre_v1 spectre_v2 spec_store_bypass l1tf mds swapgs itlb_multihit +bogomips : 5792.29 +clflush size : 64 +cache_alignment : 64 +address sizes : 46 bits physical, 48 bits virtual +power management: + +processor : 9 +vendor_id : GenuineIntel +cpu family : 6 +model : 45 +model name : Intel(R) Xeon(R) CPU E5-2667 0 @ 2.90GHz +stepping : 7 +microcode : 0x718 +cpu MHz : 3192.147 +cache size : 15360 KB +physical id : 1 +siblings : 12 +core id : 3 +cpu cores : 6 +apicid : 38 +initial apicid : 38 +fpu : yes +fpu_exception : yes +cpuid level : 13 +wp : yes +flags : fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov pat pse36 clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe syscall nx pdpe1gb rdtscp lm constant_tsc arch_perfmon pebs bts rep_good nopl xtopology nonstop_tsc cpuid aperfmperf pni pclmulqdq dtes64 monitor ds_cpl vmx smx est tm2 ssse3 cx16 xtpr pdcm pcid dca sse4_1 sse4_2 x2apic popcnt tsc_deadline_timer aes xsave avx lahf_lm epb pti ssbd ibrs ibpb stibp tpr_shadow vnmi flexpriority ept vpid xsaveopt dtherm ida arat pln pts md_clear flush_l1d +bugs : cpu_meltdown spectre_v1 spectre_v2 spec_store_bypass l1tf mds swapgs itlb_multihit +bogomips : 5792.29 +clflush size : 64 +cache_alignment : 64 +address sizes : 46 bits physical, 48 bits virtual +power management: + +processor : 10 +vendor_id : GenuineIntel +cpu family : 6 +model : 45 +model name : Intel(R) Xeon(R) CPU E5-2667 0 @ 2.90GHz +stepping : 7 +microcode : 0x718 +cpu MHz : 3192.129 +cache size : 15360 KB +physical id : 1 +siblings : 12 +core id : 4 +cpu cores : 6 +apicid : 40 +initial apicid : 40 +fpu : yes +fpu_exception : yes +cpuid level : 13 +wp : yes +flags : fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov pat pse36 clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe syscall nx pdpe1gb rdtscp lm constant_tsc arch_perfmon pebs bts rep_good nopl xtopology nonstop_tsc cpuid aperfmperf pni pclmulqdq dtes64 monitor ds_cpl vmx smx est tm2 ssse3 cx16 xtpr pdcm pcid dca sse4_1 sse4_2 x2apic popcnt tsc_deadline_timer aes xsave avx lahf_lm epb pti ssbd ibrs ibpb stibp tpr_shadow vnmi flexpriority ept vpid xsaveopt dtherm ida arat pln pts md_clear flush_l1d +bugs : cpu_meltdown spectre_v1 spectre_v2 spec_store_bypass l1tf mds swapgs itlb_multihit +bogomips : 5792.29 +clflush size : 64 +cache_alignment : 64 +address sizes : 46 bits physical, 48 bits virtual +power management: + +processor : 11 +vendor_id : GenuineIntel +cpu family : 6 +model : 45 +model name : Intel(R) Xeon(R) CPU E5-2667 0 @ 2.90GHz +stepping : 7 +microcode : 0x718 +cpu MHz : 3192.131 +cache size : 15360 KB +physical id : 1 +siblings : 12 +core id : 5 +cpu cores : 6 +apicid : 42 +initial apicid : 42 +fpu : yes +fpu_exception : yes +cpuid level : 13 +wp : yes +flags : fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov pat pse36 clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe syscall nx pdpe1gb rdtscp lm constant_tsc arch_perfmon pebs bts rep_good nopl xtopology nonstop_tsc cpuid aperfmperf pni pclmulqdq dtes64 monitor ds_cpl vmx smx est tm2 ssse3 cx16 xtpr pdcm pcid dca sse4_1 sse4_2 x2apic popcnt tsc_deadline_timer aes xsave avx lahf_lm epb pti ssbd ibrs ibpb stibp tpr_shadow vnmi flexpriority ept vpid xsaveopt dtherm ida arat pln pts md_clear flush_l1d +bugs : cpu_meltdown spectre_v1 spectre_v2 spec_store_bypass l1tf mds swapgs itlb_multihit +bogomips : 5792.29 +clflush size : 64 +cache_alignment : 64 +address sizes : 46 bits physical, 48 bits virtual +power management: + +processor : 12 +vendor_id : GenuineIntel +cpu family : 6 +model : 45 +model name : Intel(R) Xeon(R) CPU E5-2667 0 @ 2.90GHz +stepping : 7 +microcode : 0x718 +cpu MHz : 3192.062 +cache size : 15360 KB +physical id : 0 +siblings : 12 +core id : 0 +cpu cores : 6 +apicid : 1 +initial apicid : 1 +fpu : yes +fpu_exception : yes +cpuid level : 13 +wp : yes +flags : fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov pat pse36 clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe syscall nx pdpe1gb rdtscp lm constant_tsc arch_perfmon pebs bts rep_good nopl xtopology nonstop_tsc cpuid aperfmperf pni pclmulqdq dtes64 monitor ds_cpl vmx smx est tm2 ssse3 cx16 xtpr pdcm pcid dca sse4_1 sse4_2 x2apic popcnt tsc_deadline_timer aes xsave avx lahf_lm epb pti ssbd ibrs ibpb stibp tpr_shadow vnmi flexpriority ept vpid xsaveopt dtherm ida arat pln pts md_clear flush_l1d +bugs : cpu_meltdown spectre_v1 spectre_v2 spec_store_bypass l1tf mds swapgs itlb_multihit +bogomips : 5785.73 +clflush size : 64 +cache_alignment : 64 +address sizes : 46 bits physical, 48 bits virtual +power management: + +processor : 13 +vendor_id : GenuineIntel +cpu family : 6 +model : 45 +model name : Intel(R) Xeon(R) CPU E5-2667 0 @ 2.90GHz +stepping : 7 +microcode : 0x718 +cpu MHz : 3192.084 +cache size : 15360 KB +physical id : 0 +siblings : 12 +core id : 1 +cpu cores : 6 +apicid : 3 +initial apicid : 3 +fpu : yes +fpu_exception : yes +cpuid level : 13 +wp : yes +flags : fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov pat pse36 clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe syscall nx pdpe1gb rdtscp lm constant_tsc arch_perfmon pebs bts rep_good nopl xtopology nonstop_tsc cpuid aperfmperf pni pclmulqdq dtes64 monitor ds_cpl vmx smx est tm2 ssse3 cx16 xtpr pdcm pcid dca sse4_1 sse4_2 x2apic popcnt tsc_deadline_timer aes xsave avx lahf_lm epb pti ssbd ibrs ibpb stibp tpr_shadow vnmi flexpriority ept vpid xsaveopt dtherm ida arat pln pts md_clear flush_l1d +bugs : cpu_meltdown spectre_v1 spectre_v2 spec_store_bypass l1tf mds swapgs itlb_multihit +bogomips : 5785.73 +clflush size : 64 +cache_alignment : 64 +address sizes : 46 bits physical, 48 bits virtual +power management: + +processor : 14 +vendor_id : GenuineIntel +cpu family : 6 +model : 45 +model name : Intel(R) Xeon(R) CPU E5-2667 0 @ 2.90GHz +stepping : 7 +microcode : 0x718 +cpu MHz : 3194.423 +cache size : 15360 KB +physical id : 0 +siblings : 12 +core id : 2 +cpu cores : 6 +apicid : 5 +initial apicid : 5 +fpu : yes +fpu_exception : yes +cpuid level : 13 +wp : yes +flags : fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov pat pse36 clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe syscall nx pdpe1gb rdtscp lm constant_tsc arch_perfmon pebs bts rep_good nopl xtopology nonstop_tsc cpuid aperfmperf pni pclmulqdq dtes64 monitor ds_cpl vmx smx est tm2 ssse3 cx16 xtpr pdcm pcid dca sse4_1 sse4_2 x2apic popcnt tsc_deadline_timer aes xsave avx lahf_lm epb pti ssbd ibrs ibpb stibp tpr_shadow vnmi flexpriority ept vpid xsaveopt dtherm ida arat pln pts md_clear flush_l1d +bugs : cpu_meltdown spectre_v1 spectre_v2 spec_store_bypass l1tf mds swapgs itlb_multihit +bogomips : 5785.73 +clflush size : 64 +cache_alignment : 64 +address sizes : 46 bits physical, 48 bits virtual +power management: + +processor : 15 +vendor_id : GenuineIntel +cpu family : 6 +model : 45 +model name : Intel(R) Xeon(R) CPU E5-2667 0 @ 2.90GHz +stepping : 7 +microcode : 0x718 +cpu MHz : 3192.132 +cache size : 15360 KB +physical id : 0 +siblings : 12 +core id : 3 +cpu cores : 6 +apicid : 7 +initial apicid : 7 +fpu : yes +fpu_exception : yes +cpuid level : 13 +wp : yes +flags : fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov pat pse36 clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe syscall nx pdpe1gb rdtscp lm constant_tsc arch_perfmon pebs bts rep_good nopl xtopology nonstop_tsc cpuid aperfmperf pni pclmulqdq dtes64 monitor ds_cpl vmx smx est tm2 ssse3 cx16 xtpr pdcm pcid dca sse4_1 sse4_2 x2apic popcnt tsc_deadline_timer aes xsave avx lahf_lm epb pti ssbd ibrs ibpb stibp tpr_shadow vnmi flexpriority ept vpid xsaveopt dtherm ida arat pln pts md_clear flush_l1d +bugs : cpu_meltdown spectre_v1 spectre_v2 spec_store_bypass l1tf mds swapgs itlb_multihit +bogomips : 5785.73 +clflush size : 64 +cache_alignment : 64 +address sizes : 46 bits physical, 48 bits virtual +power management: + +processor : 16 +vendor_id : GenuineIntel +cpu family : 6 +model : 45 +model name : Intel(R) Xeon(R) CPU E5-2667 0 @ 2.90GHz +stepping : 7 +microcode : 0x718 +cpu MHz : 3192.170 +cache size : 15360 KB +physical id : 0 +siblings : 12 +core id : 4 +cpu cores : 6 +apicid : 9 +initial apicid : 9 +fpu : yes +fpu_exception : yes +cpuid level : 13 +wp : yes +flags : fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov pat pse36 clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe syscall nx pdpe1gb rdtscp lm constant_tsc arch_perfmon pebs bts rep_good nopl xtopology nonstop_tsc cpuid aperfmperf pni pclmulqdq dtes64 monitor ds_cpl vmx smx est tm2 ssse3 cx16 xtpr pdcm pcid dca sse4_1 sse4_2 x2apic popcnt tsc_deadline_timer aes xsave avx lahf_lm epb pti ssbd ibrs ibpb stibp tpr_shadow vnmi flexpriority ept vpid xsaveopt dtherm ida arat pln pts md_clear flush_l1d +bugs : cpu_meltdown spectre_v1 spectre_v2 spec_store_bypass l1tf mds swapgs itlb_multihit +bogomips : 5785.73 +clflush size : 64 +cache_alignment : 64 +address sizes : 46 bits physical, 48 bits virtual +power management: + +processor : 17 +vendor_id : GenuineIntel +cpu family : 6 +model : 45 +model name : Intel(R) Xeon(R) CPU E5-2667 0 @ 2.90GHz +stepping : 7 +microcode : 0x718 +cpu MHz : 3191.946 +cache size : 15360 KB +physical id : 0 +siblings : 12 +core id : 5 +cpu cores : 6 +apicid : 11 +initial apicid : 11 +fpu : yes +fpu_exception : yes +cpuid level : 13 +wp : yes +flags : fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov pat pse36 clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe syscall nx pdpe1gb rdtscp lm constant_tsc arch_perfmon pebs bts rep_good nopl xtopology nonstop_tsc cpuid aperfmperf pni pclmulqdq dtes64 monitor ds_cpl vmx smx est tm2 ssse3 cx16 xtpr pdcm pcid dca sse4_1 sse4_2 x2apic popcnt tsc_deadline_timer aes xsave avx lahf_lm epb pti ssbd ibrs ibpb stibp tpr_shadow vnmi flexpriority ept vpid xsaveopt dtherm ida arat pln pts md_clear flush_l1d +bugs : cpu_meltdown spectre_v1 spectre_v2 spec_store_bypass l1tf mds swapgs itlb_multihit +bogomips : 5785.73 +clflush size : 64 +cache_alignment : 64 +address sizes : 46 bits physical, 48 bits virtual +power management: + +processor : 18 +vendor_id : GenuineIntel +cpu family : 6 +model : 45 +model name : Intel(R) Xeon(R) CPU E5-2667 0 @ 2.90GHz +stepping : 7 +microcode : 0x718 +cpu MHz : 3192.131 +cache size : 15360 KB +physical id : 1 +siblings : 12 +core id : 0 +cpu cores : 6 +apicid : 33 +initial apicid : 33 +fpu : yes +fpu_exception : yes +cpuid level : 13 +wp : yes +flags : fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov pat pse36 clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe syscall nx pdpe1gb rdtscp lm constant_tsc arch_perfmon pebs bts rep_good nopl xtopology nonstop_tsc cpuid aperfmperf pni pclmulqdq dtes64 monitor ds_cpl vmx smx est tm2 ssse3 cx16 xtpr pdcm pcid dca sse4_1 sse4_2 x2apic popcnt tsc_deadline_timer aes xsave avx lahf_lm epb pti ssbd ibrs ibpb stibp tpr_shadow vnmi flexpriority ept vpid xsaveopt dtherm ida arat pln pts md_clear flush_l1d +bugs : cpu_meltdown spectre_v1 spectre_v2 spec_store_bypass l1tf mds swapgs itlb_multihit +bogomips : 5792.29 +clflush size : 64 +cache_alignment : 64 +address sizes : 46 bits physical, 48 bits virtual +power management: + +processor : 19 +vendor_id : GenuineIntel +cpu family : 6 +model : 45 +model name : Intel(R) Xeon(R) CPU E5-2667 0 @ 2.90GHz +stepping : 7 +microcode : 0x718 +cpu MHz : 3192.134 +cache size : 15360 KB +physical id : 1 +siblings : 12 +core id : 1 +cpu cores : 6 +apicid : 35 +initial apicid : 35 +fpu : yes +fpu_exception : yes +cpuid level : 13 +wp : yes +flags : fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov pat pse36 clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe syscall nx pdpe1gb rdtscp lm constant_tsc arch_perfmon pebs bts rep_good nopl xtopology nonstop_tsc cpuid aperfmperf pni pclmulqdq dtes64 monitor ds_cpl vmx smx est tm2 ssse3 cx16 xtpr pdcm pcid dca sse4_1 sse4_2 x2apic popcnt tsc_deadline_timer aes xsave avx lahf_lm epb pti ssbd ibrs ibpb stibp tpr_shadow vnmi flexpriority ept vpid xsaveopt dtherm ida arat pln pts md_clear flush_l1d +bugs : cpu_meltdown spectre_v1 spectre_v2 spec_store_bypass l1tf mds swapgs itlb_multihit +bogomips : 5792.29 +clflush size : 64 +cache_alignment : 64 +address sizes : 46 bits physical, 48 bits virtual +power management: + +processor : 20 +vendor_id : GenuineIntel +cpu family : 6 +model : 45 +model name : Intel(R) Xeon(R) CPU E5-2667 0 @ 2.90GHz +stepping : 7 +microcode : 0x718 +cpu MHz : 3192.123 +cache size : 15360 KB +physical id : 1 +siblings : 12 +core id : 2 +cpu cores : 6 +apicid : 37 +initial apicid : 37 +fpu : yes +fpu_exception : yes +cpuid level : 13 +wp : yes +flags : fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov pat pse36 clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe syscall nx pdpe1gb rdtscp lm constant_tsc arch_perfmon pebs bts rep_good nopl xtopology nonstop_tsc cpuid aperfmperf pni pclmulqdq dtes64 monitor ds_cpl vmx smx est tm2 ssse3 cx16 xtpr pdcm pcid dca sse4_1 sse4_2 x2apic popcnt tsc_deadline_timer aes xsave avx lahf_lm epb pti ssbd ibrs ibpb stibp tpr_shadow vnmi flexpriority ept vpid xsaveopt dtherm ida arat pln pts md_clear flush_l1d +bugs : cpu_meltdown spectre_v1 spectre_v2 spec_store_bypass l1tf mds swapgs itlb_multihit +bogomips : 5792.29 +clflush size : 64 +cache_alignment : 64 +address sizes : 46 bits physical, 48 bits virtual +power management: + +processor : 21 +vendor_id : GenuineIntel +cpu family : 6 +model : 45 +model name : Intel(R) Xeon(R) CPU E5-2667 0 @ 2.90GHz +stepping : 7 +microcode : 0x718 +cpu MHz : 3192.131 +cache size : 15360 KB +physical id : 1 +siblings : 12 +core id : 3 +cpu cores : 6 +apicid : 39 +initial apicid : 39 +fpu : yes +fpu_exception : yes +cpuid level : 13 +wp : yes +flags : fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov pat pse36 clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe syscall nx pdpe1gb rdtscp lm constant_tsc arch_perfmon pebs bts rep_good nopl xtopology nonstop_tsc cpuid aperfmperf pni pclmulqdq dtes64 monitor ds_cpl vmx smx est tm2 ssse3 cx16 xtpr pdcm pcid dca sse4_1 sse4_2 x2apic popcnt tsc_deadline_timer aes xsave avx lahf_lm epb pti ssbd ibrs ibpb stibp tpr_shadow vnmi flexpriority ept vpid xsaveopt dtherm ida arat pln pts md_clear flush_l1d +bugs : cpu_meltdown spectre_v1 spectre_v2 spec_store_bypass l1tf mds swapgs itlb_multihit +bogomips : 5792.29 +clflush size : 64 +cache_alignment : 64 +address sizes : 46 bits physical, 48 bits virtual +power management: + +processor : 22 +vendor_id : GenuineIntel +cpu family : 6 +model : 45 +model name : Intel(R) Xeon(R) CPU E5-2667 0 @ 2.90GHz +stepping : 7 +microcode : 0x718 +cpu MHz : 3192.149 +cache size : 15360 KB +physical id : 1 +siblings : 12 +core id : 4 +cpu cores : 6 +apicid : 41 +initial apicid : 41 +fpu : yes +fpu_exception : yes +cpuid level : 13 +wp : yes +flags : fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov pat pse36 clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe syscall nx pdpe1gb rdtscp lm constant_tsc arch_perfmon pebs bts rep_good nopl xtopology nonstop_tsc cpuid aperfmperf pni pclmulqdq dtes64 monitor ds_cpl vmx smx est tm2 ssse3 cx16 xtpr pdcm pcid dca sse4_1 sse4_2 x2apic popcnt tsc_deadline_timer aes xsave avx lahf_lm epb pti ssbd ibrs ibpb stibp tpr_shadow vnmi flexpriority ept vpid xsaveopt dtherm ida arat pln pts md_clear flush_l1d +bugs : cpu_meltdown spectre_v1 spectre_v2 spec_store_bypass l1tf mds swapgs itlb_multihit +bogomips : 5792.29 +clflush size : 64 +cache_alignment : 64 +address sizes : 46 bits physical, 48 bits virtual +power management: + +processor : 23 +vendor_id : GenuineIntel +cpu family : 6 +model : 45 +model name : Intel(R) Xeon(R) CPU E5-2667 0 @ 2.90GHz +stepping : 7 +microcode : 0x718 +cpu MHz : 3195.640 +cache size : 15360 KB +physical id : 1 +siblings : 12 +core id : 5 +cpu cores : 6 +apicid : 43 +initial apicid : 43 +fpu : yes +fpu_exception : yes +cpuid level : 13 +wp : yes +flags : fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov pat pse36 clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe syscall nx pdpe1gb rdtscp lm constant_tsc arch_perfmon pebs bts rep_good nopl xtopology nonstop_tsc cpuid aperfmperf pni pclmulqdq dtes64 monitor ds_cpl vmx smx est tm2 ssse3 cx16 xtpr pdcm pcid dca sse4_1 sse4_2 x2apic popcnt tsc_deadline_timer aes xsave avx lahf_lm epb pti ssbd ibrs ibpb stibp tpr_shadow vnmi flexpriority ept vpid xsaveopt dtherm ida arat pln pts md_clear flush_l1d +bugs : cpu_meltdown spectre_v1 spectre_v2 spec_store_bypass l1tf mds swapgs itlb_multihit +bogomips : 5792.29 +clflush size : 64 +cache_alignment : 64 +address sizes : 46 bits physical, 48 bits virtual +power management: + +MemTotal: 65879492 kB +MemFree: 10395980 kB +MemAvailable: 59790724 kB +Buffers: 12390688 kB +Cached: 18542568 kB +SwapCached: 37680 kB +Active: 20395936 kB +Inactive: 14205172 kB +Active(anon): 3459064 kB +Inactive(anon): 165896 kB +Active(file): 16936872 kB +Inactive(file): 14039276 kB +Unevictable: 48 kB +Mlocked: 48 kB +SwapTotal: 4194300 kB +SwapFree: 3334988 kB +Dirty: 13300 kB +Writeback: 0 kB +AnonPages: 3648112 kB +Mapped: 555304 kB +Shmem: 784 kB +KReclaimable: 19083648 kB +Slab: 20438420 kB +SReclaimable: 19083648 kB +SUnreclaim: 1354772 kB +KernelStack: 16012 kB +PageTables: 33208 kB +NFS_Unstable: 0 kB +Bounce: 0 kB +WritebackTmp: 0 kB +CommitLimit: 37134044 kB +Committed_AS: 10963564 kB +VmallocTotal: 34359738367 kB +VmallocUsed: 161980 kB +VmallocChunk: 0 kB +Percpu: 137728 kB +HardwareCorrupted: 0 kB +AnonHugePages: 0 kB +ShmemHugePages: 0 kB +ShmemPmdMapped: 0 kB +FileHugePages: 0 kB +FilePmdMapped: 0 kB +CmaTotal: 0 kB +CmaFree: 0 kB +HugePages_Total: 0 +HugePages_Free: 0 +HugePages_Rsvd: 0 +HugePages_Surp: 0 +Hugepagesize: 2048 kB +Hugetlb: 0 kB +DirectMap4k: 10120980 kB +DirectMap2M: 56909824 kB +DirectMap1G: 0 kB +[32;1m$ ls -a[0;m +. +.. +.git +.gitattributes +.github +.gitignore +.gitlab-ci.yml +.mailmap +.merlin.in +.ocamlformat +.ocamlinit +CODE_OF_CONDUCT.md +CONTRIBUTING.md +CREDITS +INSTALL.md +LICENSE +META.coq.in +Makefile +Makefile.build +Makefile.checker +Makefile.ci +Makefile.common +Makefile.dev +Makefile.doc +Makefile.dune +Makefile.ide +Makefile.install +Makefile.make +Makefile.vofiles +README.md +_build_ci +_install_ci +azure-pipelines.yml +checker +clib +config +configure +configure.ml +coq-doc.opam +coq.opam +coq.opam.docker +coqide-server.opam +coqide.opam +coqpp +default.nix +dev +doc +dune +dune-project +engine +gramlib +ide +install.sh +interp +kernel +lib +library +man +parsing +plugins +pretyping +printing +proofs +shell.nix +stm +tactics +test-suite +theories +tools +topbin +toplevel +user-contrib +vernac +[32;1m$ printenv -0 | sort -z | tr '\0' '\n'[0;m +BASE_ONLY_OPAM=elpi.1.11.0 +BASE_OPAM=num zarith.1.9.1 ocamlfind.1.8.1 ounit2.2.2.3 odoc.1.5.0 +BASE_OPAM_EDGE=dune.2.5.1 dune-release.1.3.3 ocamlformat.0.14.2 +CACHEKEY=bionic_coq-V2020-08-28-V92 +CI=true +CI_API_V4_URL=https://gitlab.com/api/v4 +CI_BUILD_BEFORE_SHA=727d9e5de2b64fd98bc085089b92891bcbad095f +CI_BUILD_ID=713656562 +CI_BUILD_NAME=plugin:ci-metacoq +CI_BUILD_REF=fdbbc0cbc3906704e6e4e92d5bf2f6ffe8476357 +CI_BUILD_REF_NAME=pr-12653 +CI_BUILD_REF_SLUG=pr-12653 +CI_BUILD_STAGE=stage-3 +CI_BUILD_TOKEN=[MASKED] +CI_COMMIT_BEFORE_SHA=727d9e5de2b64fd98bc085089b92891bcbad095f +CI_COMMIT_BRANCH=pr-12653 +CI_COMMIT_DESCRIPTION= +Bot merge 0d30f79268fea18ef99c040a859956f61c3d978a and 7c1779e124fe4bf2733af12488b18bee92840127 +CI_COMMIT_MESSAGE=[CI merge] PR #12653: Syntax for specifying cumulative inductives + +Bot merge 0d30f79268fea18ef99c040a859956f61c3d978a and 7c1779e124fe4bf2733af12488b18bee92840127 + +CI_COMMIT_REF_NAME=pr-12653 +CI_COMMIT_REF_PROTECTED=false +CI_COMMIT_REF_SLUG=pr-12653 +CI_COMMIT_SHA=fdbbc0cbc3906704e6e4e92d5bf2f6ffe8476357 +CI_COMMIT_SHORT_SHA=fdbbc0cb +CI_COMMIT_TITLE=[CI merge] PR #12653: Syntax for specifying cumulative inductives +CI_CONFIG_PATH=.gitlab-ci.yml +CI_DEFAULT_BRANCH=master +CI_DISPOSABLE_ENVIRONMENT=true +CI_JOB_ID=713656562 +CI_JOB_JWT=[MASKED] +CI_JOB_NAME=plugin:ci-metacoq +CI_JOB_STAGE=stage-3 +CI_JOB_TOKEN=[MASKED] +CI_JOB_URL=https://gitlab.com/coq/coq/-/jobs/713656562 +CI_NODE_TOTAL=1 +CI_OPAM=menhir.20190626 ocamlgraph.1.8.8 +CI_PAGES_DOMAIN=gitlab.io +CI_PAGES_URL=https://coq.gitlab.io/coq +CI_PIPELINE_ID=184301476 +CI_PIPELINE_IID=17942 +CI_PIPELINE_SOURCE=push +CI_PIPELINE_URL=https://gitlab.com/coq/coq/-/pipelines/184301476 +CI_PROJECT_DIR=/builds/coq/coq +CI_PROJECT_ID=6138686 +CI_PROJECT_NAME=coq +CI_PROJECT_NAMESPACE=coq +CI_PROJECT_PATH=coq/coq +CI_PROJECT_PATH_SLUG=coq-coq +CI_PROJECT_REPOSITORY_LANGUAGES=ocaml,coq,shell,tex,c +CI_PROJECT_ROOT_NAMESPACE=coq +CI_PROJECT_TITLE=coq +CI_PROJECT_URL=https://gitlab.com/coq/coq +CI_PROJECT_VISIBILITY=public +CI_REGISTRY=registry.gitlab.com +CI_REGISTRY_IMAGE=registry.gitlab.com/coq/coq +CI_REGISTRY_PASSWORD=[MASKED] +CI_REGISTRY_USER=gitlab-ci-token +CI_REPOSITORY_URL=https://gitlab-ci-token:[MASKED]@gitlab.com/coq/coq.git +CI_RUNNER_DESCRIPTION=roquableu +CI_RUNNER_EXECUTABLE_ARCH=linux/amd64 +CI_RUNNER_ID=816543 +CI_RUNNER_REVISION=fa86510e +CI_RUNNER_TAGS= +CI_RUNNER_VERSION=11.9.2 +CI_SERVER=yes +CI_SERVER_HOST=gitlab.com +CI_SERVER_NAME=GitLab +CI_SERVER_PORT=443 +CI_SERVER_PROTOCOL=https +CI_SERVER_REVISION=e937f778b66 +CI_SERVER_TLS_CA_FILE=/builds/coq/coq.tmp/CI_SERVER_TLS_CA_FILE +CI_SERVER_URL=https://gitlab.com +CI_SERVER_VERSION=13.4.0-pre +CI_SERVER_VERSION_MAJOR=13 +CI_SERVER_VERSION_MINOR=4 +CI_SERVER_VERSION_PATCH=0 +COMPILER=4.05.0 +COMPILER_EDGE=4.10.0 +COQIDE_OPAM=cairo2.0.6.1 lablgtk3-sourceview3.3.1.0 +DEBIAN_FRONTEND=noninteractive +FF_K8S_USE_ENTRYPOINT_OVER_COMMAND=true +FULL_CI=true +GITLAB_CI=true +GITLAB_FEATURES=audit_events,blocked_issues,burndown_charts,code_owners,code_review_analytics,contribution_analytics,description_diffs,elastic_search,group_activity_analytics,group_bulk_edit,group_burndown_charts,group_webhooks,issuable_default_templates,issue_weights,iterations,jenkins_integration,ldap_group_sync,member_lock,merge_request_approvers,milestone_charts,multiple_issue_assignees,multiple_ldap_servers,multiple_merge_request_assignees,project_merge_request_analytics,protected_refs_for_users,push_rules,repository_mirrors,repository_size_limit,seat_link,send_emails_from_admin_area,scoped_issue_board,usage_quotas,visual_review_app,wip_limits,adjourned_deletion_for_projects_and_groups,admin_audit_log,auditor_user,blocking_merge_requests,board_assignee_lists,board_milestone_lists,ci_cd_projects,ci_secrets_management,cluster_agents,cluster_deployments,code_owner_approval_required,commit_committer_check,compliance_framework,cross_project_pipelines,custom_file_templates,custom_file_templates_for_namespace,custom_project_templates,cycle_analytics_for_groups,db_load_balancing,default_branch_protection_restriction_in_groups,default_project_deletion_protection,dependency_proxy,deploy_board,disable_name_update_for_users,email_additional_text,epics,extended_audit_events,external_authorization_service_api_management,feature_flags,file_locks,geo,generic_alert_fingerprinting,github_project_service_integration,group_allowed_email_domains,group_coverage_reports,group_forking_protection,group_ip_restriction,group_merge_request_analytics,group_project_templates,group_saml,issues_analytics,jira_dev_panel_integration,jira_issues_integration,ldap_group_sync_filter,merge_pipelines,merge_request_performance_metrics,admin_merge_request_approvers_rules,merge_trains,metrics_reports,multiple_approval_rules,multiple_group_issue_boards,object_storage,operations_dashboard,opsgenie_integration,package_forwarding,pages_size_limit,productivity_analytics,project_aliases,protected_environments,reject_unsigned_commits,required_ci_templates,scoped_labels,smartcard_auth,group_timelogs,type_of_work_analytics,unprotection_restrictions,ci_project_subscriptions,container_scanning,coverage_fuzzing,credentials_inventory,dast,dependency_scanning,enterprise_templates,api_fuzzing,group_level_compliance_dashboard,incident_management,insights,issuable_health_status,license_scanning,personal_access_token_api_management,personal_access_token_expiration_policy,enforce_pat_expiration,prometheus_alerts,pseudonymizer,release_evidence_test_artifacts,report_approver_rules,requirements,sast,secret_detection,security_dashboard,security_on_demand_scans,status_page,subepics,threat_monitoring,tracing,quality_management +GITLAB_USER_EMAIL=gaetan.gilbert@skyskimmer.net +GITLAB_USER_ID=1343245 +GITLAB_USER_LOGIN=SkySkimmer +GITLAB_USER_NAME=Gaëtan Gilbert +GIT_DEPTH=10 +HOME=/root +HOSTNAME=runner-curNbQZR-project-6138686-concurrent-1 +IMAGE=registry.gitlab.com/coq/coq:bionic_coq-V2020-08-28-V92 +NJOBS=2 +OLDPWD=/ +OPAMJOBS=2 +OPAMROOT=/root/.opamcache +OPAMROOTISOK=true +OPAMYES=true +OPAM_SWITCH=base +OPAM_VARIANT= +PATH=/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin +PWD=/builds/coq/coq +SHLVL=1 +SKIP_DOCKER=true +UNRELIABLE=enabled +WINDOWS=enabled +WINDOWS_ALL_ADDONS=disabled +_=/usr/bin/printenv +[32;1m$ declare -A switch_table[0;m +[32;1m$ switch_table=( ["base"]="$COMPILER" ["edge"]="$COMPILER_EDGE" )[0;m +[32;1m$ opam switch set -y "${switch_table[$OPAM_SWITCH]}$OPAM_VARIANT"[0;m +# Run eval $(opam env) to update the current shell environment +[32;1m$ eval $(opam env)[0;m +[32;1m$ opam list[0;m +# Packages matching: installed +# Name # Installed # Synopsis +astring 0.8.5 Alternative String module for OCaml +base-bigarray base +base-bytes base Bytes library distributed with the OCaml compiler +base-num base Num library distributed with the OCaml compiler +base-threads base +base-unix base +cairo2 0.6.1 Binding to Cairo, a 2D Vector Graphics Library +camlp5 7.12 Preprocessor-pretty-printer of OCaml +cmdliner 1.0.4 Declarative definition of command line interfaces for OCaml +conf-cairo 1 Virtual package relying on a Cairo system installation +conf-gmp 1 Virtual package relying on a GMP lib system installation +conf-gtk3 18 Virtual package relying on GTK+ 3 +conf-gtksourceview3 0+2 Virtual package relying on a GtkSourceView-3 system installation +conf-m4 1 Virtual package relying on m4 +conf-perl 1 Virtual package relying on perl +conf-pkg-config 1.3 Virtual package relying on pkg-config installation +cppo 1.6.6 Code preprocessor like cpp for OCaml +dune 2.7.0 Fast, portable, and opinionated build system +dune-configurator 2.7.0 Helper library for gathering system configuration +elpi 1.11.0 ELPI - Embeddable λProlog Interpreter +fpath 0.7.2 File system paths for OCaml +lablgtk3 3.1.0 OCaml interface to GTK+3 +lablgtk3-sourceview3 3.1.0 OCaml interface to GTK+ gtksourceview library +menhir 20190626 An LR(1) parser generator +num 0 The Num library for arbitrary-precision integer and rational arithmetic +ocaml 4.05.0 The OCaml compiler (virtual package) +ocaml-base-compiler 4.05.0 Official 4.05.0 release +ocaml-compiler-libs v0.12.1 OCaml compiler libraries repackaged +ocaml-config 1 OCaml Switch Configuration +ocaml-migrate-parsetree 1.7.3 Convert OCaml parsetrees between different versions +ocaml-secondary-compiler 4.08.1-1 OCaml 4.08.1 Secondary Switch Compiler +ocamlbuild 0.14.0 OCamlbuild is a build system with builtin rules to easily build most OCaml projects. +ocamlfind 1.8.1 A library manager for OCaml +ocamlfind-secondary 1.8.1 ocamlfind support for ocaml-secondary-compiler +ocamlgraph 1.8.8 A generic graph library for OCaml +odoc 1.5.0 OCaml documentation generator +ounit2 2.2.3 OUnit testing framework +ppx_derivers 1.2.1 Shared [@@deriving] plugin registry +ppx_deriving 4.5 Type-driven code generation for OCaml >=4.02.2 +ppx_tools 5.0+4.05.0 Tools for authors of ppx rewriters and other syntactic tools +ppxfind 1.4 Tool combining ocamlfind and ppx +ppxlib 0.15.0 Standard library for ppx rewriters +re 1.9.0 RE is a regular expression library for OCaml +result 1.5 Compatibility Result module +seq 0.2.2 Compatibility package for OCaml's standard iterator type starting from 4.07 +sexplib0 v0.14.0 Library containing the definition of S-expressions and some base converters +stdlib-shims 0.1.0 Backport some of the new stdlib features to older compiler +topkg 1.0.2 The transitory OCaml software packager +tyxml 4.4.0 TyXML is a library for building correct HTML and SVG documents +uchar 0.0.2 Compatibility library for OCaml's Uchar module +uutf 1.0.2 Non-blocking streaming Unicode codec for OCaml +zarith 1.9.1 Implements arithmetic and logical operations over arbitrary-precision integers +[32;1m$ opam config list[0;m + +<><> Global opam variables ><><><><><><><><><><><><><><><><><><><><><><><><><><> +arch x86_64 # Inferred from system +jobs 2 # The number of parallel jobs set up in opam configuration +make make # The 'make' command to use +opam-version 2.0.6 # The currently running opam version +os linux # Inferred from system +os-distribution ubuntu # Inferred from system +os-family debian # Inferred from system +os-version 18.04 # Inferred from system +root /root/.opamcache # The current opam root directory +switch 4.05.0 # The identifier of the current switch +sys-ocaml-version # OCaml version present on your system independently of opam, if any + +<><> Configuration variables from the current switch ><><><><><><><><><><><><><> +prefix /root/.opamcache/4.05.0 +lib /root/.opamcache/4.05.0/lib +bin /root/.opamcache/4.05.0/bin +sbin /root/.opamcache/4.05.0/sbin +share /root/.opamcache/4.05.0/share +doc /root/.opamcache/4.05.0/doc +etc /root/.opamcache/4.05.0/etc +man /root/.opamcache/4.05.0/man +toplevel /root/.opamcache/4.05.0/lib/toplevel +stublibs /root/.opamcache/4.05.0/lib/stublibs +user root +group root + +<><> Package variables ('opam config list PKG' to show) <><><><><><><><><><><><> +PKG:name # Name of the package +PKG:version # Version of the package +PKG:depends # Resolved direct dependencies of the package +PKG:installed # Whether the package is installed +PKG:enable # Takes the value "enable" or "disable" depending on whether the package is installed +PKG:pinned # Whether the package is pinned +PKG:bin # Binary directory for this package +PKG:sbin # System binary directory for this package +PKG:lib # Library directory for this package +PKG:man # Man directory for this package +PKG:doc # Doc directory for this package +PKG:share # Share directory for this package +PKG:etc # Etc directory for this package +PKG:build # Directory where the package was built +PKG:hash # Hash of the package archive +PKG:dev # True if this is a development package +PKG:build-id # A hash identifying the precise package version with all its dependencies +[32;1m$ set -e[0;m +[32;1m$ echo 'start:coq.test'[0;m +start:coq.test +[32;1m$ make -f Makefile.ci -j "$NJOBS" "${CI_JOB_NAME#*:}"[0;m +./dev/ci/ci-wrapper.sh equations +++ : 2 +++ export NJOBS +++ '[' -n true ']' +++ export OCAMLPATH=/builds/coq/coq/_install_ci/lib: +++ OCAMLPATH=/builds/coq/coq/_install_ci/lib: +++ export COQBIN=/builds/coq/coq/_install_ci/bin +++ COQBIN=/builds/coq/coq/_install_ci/bin +++ export CI_BRANCH=pr-12653 +++ CI_BRANCH=pr-12653 +++ [[ 12653 =~ ^[0-9]*$ ]] +++ export CI_PULL_REQUEST=12653 +++ CI_PULL_REQUEST=12653 +++ export PATH=/builds/coq/coq/_install_ci/bin:/root/.opamcache/4.05.0/bin:/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin +++ PATH=/builds/coq/coq/_install_ci/bin:/root/.opamcache/4.05.0/bin:/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin +++ export COQBIN=/builds/coq/coq/_install_ci/bin/ +++ COQBIN=/builds/coq/coq/_install_ci/bin/ +++ ls -l /builds/coq/coq/_install_ci/bin/ +total 377964 +-rwxr-xr-x 1 root root 1885376 Sep 1 11:46 coq-tex +-rwxr-xr-x 1 root root 2500248 Sep 1 11:46 coq_makefile +-rwxr-xr-x 1 root root 24673120 Sep 1 11:46 coqc +-rwxr-xr-x 1 root root 9648760 Sep 1 11:46 coqchk +-rwxr-xr-x 1 root root 5855160 Sep 1 11:46 coqdep +-rwxr-xr-x 1 root root 4413792 Sep 1 11:46 coqdoc +-rwxr-xr-x 1 root root 11526312 Sep 1 11:47 coqide +-rwxr-xr-x 1 root root 25110448 Sep 1 11:47 coqidetop +-rwxr-xr-x 1 root root 25110448 Sep 1 11:47 coqidetop.opt +-rwxr-xr-x 1 root root 449295 Sep 1 11:46 coqpp +-rwxr-xr-x 1 root root 32153472 Sep 1 11:47 coqproofworker.byte +-rwxr-xr-x 1 root root 24673424 Sep 1 11:46 coqproofworker.opt +-rwxr-xr-x 1 root root 32153472 Sep 1 11:47 coqqueryworker.byte +-rwxr-xr-x 1 root root 24673424 Sep 1 11:46 coqqueryworker.opt +-rwxr-xr-x 1 root root 32153477 Sep 1 11:47 coqtacticworker.byte +-rwxr-xr-x 1 root root 24673448 Sep 1 11:46 coqtacticworker.opt +-rwxr-xr-x 1 root root 24673288 Sep 1 11:46 coqtop +-rwxr-xr-x 1 root root 41805680 Sep 1 11:47 coqtop.byte +-rwxr-xr-x 1 root root 24673288 Sep 1 11:46 coqtop.opt +-rwxr-xr-x 1 root root 1821312 Sep 1 11:46 coqwc +-rwxr-xr-x 1 root root 2827416 Sep 1 11:46 coqworkmgr +-rwxr-xr-x 1 root root 5905992 Sep 1 11:47 fake_ide +-rwxr-xr-x 1 root root 1757920 Sep 1 11:46 ocamllibdep +-rwxr-xr-x 1 root root 1877056 Sep 1 11:46 votour +++ CI_BUILD_DIR=/builds/coq/coq/_build_ci +++ ls -l /builds/coq/coq/_build_ci +total 4 +drwxr-xr-x 8 root root 4096 Sep 1 11:51 equations +++ set +x ++ git_download equations ++ local PROJECT=equations ++ local DEST=/builds/coq/coq/_build_ci/equations ++ local GITURL_VAR=equations_CI_GITURL ++ local GITURL=https://github.com/SkySkimmer/Coq-Equations ++ local REF_VAR=equations_CI_REF ++ local REF=cumul-syntax ++ '[' -d /builds/coq/coq/_build_ci/equations ']' ++ echo 'Warning: download and unpacking of equations skipped because /builds/coq/coq/_build_ci/equations already exists.' +Warning: download and unpacking of equations skipped because /builds/coq/coq/_build_ci/equations already exists. ++ cd /builds/coq/coq/_build_ci/equations ++ ./configure.sh coq +Building Coq version (default) ++ make ci ++ '[' -z x ']' ++ command make ci ++ make ci +make[1]: Entering directory '/builds/coq/coq/_build_ci/equations' +make[2]: Nothing to be done for 'real-all'. +cd test-suite && make +cd examples && make +make[2]: Entering directory '/builds/coq/coq/_build_ci/equations/test-suite' +make[2]: Entering directory '/builds/coq/coq/_build_ci/equations/examples' +make[3]: Nothing to be done for 'real-all'. +make[2]: Leaving directory '/builds/coq/coq/_build_ci/equations/examples' +make[3]: Nothing to be done for 'real-all'. +make[2]: Leaving directory '/builds/coq/coq/_build_ci/equations/test-suite' +make[1]: Leaving directory '/builds/coq/coq/_build_ci/equations' ++ make install ++ '[' -z x ']' ++ command make install ++ make install +make[1]: Entering directory '/builds/coq/coq/_build_ci/equations' +INSTALL theories/Init.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL theories/Signature.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL theories/CoreTactics.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL theories/Prop/Logic.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/Classes.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/EqDec.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/EqDecInstances.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/Subterm.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/DepElim.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/Tactics.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/Constants.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/NoConfusion.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/FunctionalInduction.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/Loader.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/Telescopes.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/TransparentEquations.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/OpaqueEquations.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Equations.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL theories/Type/Logic.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/FunctionalExtensionality.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/Relation.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/Relation_Properties.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/WellFounded.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/Classes.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/EqDec.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/DepElim.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/Tactics.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/Subterm.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/Constants.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/EqDecInstances.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/NoConfusion.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/FunctionalInduction.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/Loader.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/Telescopes.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/WellFoundedInstances.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/All.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Init.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL theories/Signature.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL theories/CoreTactics.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL theories/Prop/Logic.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/Classes.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/EqDec.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/EqDecInstances.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/Subterm.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/DepElim.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/Tactics.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/Constants.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/NoConfusion.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/FunctionalInduction.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/Loader.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/Telescopes.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/TransparentEquations.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/OpaqueEquations.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Equations.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL theories/Type/Logic.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/FunctionalExtensionality.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/Relation.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/Relation_Properties.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/WellFounded.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/Classes.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/EqDec.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/DepElim.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/Tactics.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/Subterm.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/Constants.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/EqDecInstances.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/NoConfusion.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/FunctionalInduction.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/Loader.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/Telescopes.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/WellFoundedInstances.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/All.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Init.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL theories/Signature.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL theories/CoreTactics.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL theories/Prop/Logic.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/Classes.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/EqDec.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/EqDecInstances.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/Subterm.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/DepElim.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/Tactics.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/Constants.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/NoConfusion.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/FunctionalInduction.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/Loader.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/Telescopes.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/TransparentEquations.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Prop/OpaqueEquations.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Prop +INSTALL theories/Equations.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL theories/Type/Logic.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/FunctionalExtensionality.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/Relation.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/Relation_Properties.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/WellFounded.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/Classes.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/EqDec.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/DepElim.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/Tactics.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/Subterm.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/Constants.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/EqDecInstances.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/NoConfusion.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/FunctionalInduction.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/Loader.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/Telescopes.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/WellFoundedInstances.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL theories/Type/All.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations//Type +INSTALL src/g_equations.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/equations_common.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/ederive.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/sigma_types.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/subterm.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/eqdec.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/depelim.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/syntax.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/context_map.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/simplify.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/splitting.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/covering.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/principles_proofs.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/principles.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/equations.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/noconf_hom.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/noconf.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/extra_tactics.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/equations_plugin_mod.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/equations_common.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/ederive.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/sigma_types.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/subterm.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/eqdec.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/depelim.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/syntax.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/context_map.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/simplify.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/splitting.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/covering.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/principles_proofs.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/principles.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/equations.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/noconf_hom.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/noconf.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/extra_tactics.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/equations_plugin.cmxs /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/equations_plugin.cmxa /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/g_equations.cmx /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/equations_common.cmx /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/ederive.cmx /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/sigma_types.cmx /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/subterm.cmx /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/eqdec.cmx /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/depelim.cmx /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/syntax.cmx /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/context_map.cmx /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/simplify.cmx /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/splitting.cmx /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/covering.cmx /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/principles_proofs.cmx /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/principles.cmx /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/equations.cmx /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/noconf_hom.cmx /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/noconf.cmx /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/extra_tactics.cmx /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +INSTALL src/equations_plugin_mod.cmx /builds/coq/coq/_install_ci/lib/coq//user-contrib/Equations/ +make[2]: Entering directory '/builds/coq/coq/_build_ci/equations' +make[2]: Leaving directory '/builds/coq/coq/_build_ci/equations' +make[1]: Leaving directory '/builds/coq/coq/_build_ci/equations' +Aggregating timing log... +No timing data +./dev/ci/ci-wrapper.sh metacoq +++ : 2 +++ export NJOBS +++ '[' -n true ']' +++ export OCAMLPATH=/builds/coq/coq/_install_ci/lib: +++ OCAMLPATH=/builds/coq/coq/_install_ci/lib: +++ export COQBIN=/builds/coq/coq/_install_ci/bin +++ COQBIN=/builds/coq/coq/_install_ci/bin +++ export CI_BRANCH=pr-12653 +++ CI_BRANCH=pr-12653 +++ [[ 12653 =~ ^[0-9]*$ ]] +++ export CI_PULL_REQUEST=12653 +++ CI_PULL_REQUEST=12653 +++ export PATH=/builds/coq/coq/_install_ci/bin:/root/.opamcache/4.05.0/bin:/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin +++ PATH=/builds/coq/coq/_install_ci/bin:/root/.opamcache/4.05.0/bin:/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin +++ export COQBIN=/builds/coq/coq/_install_ci/bin/ +++ COQBIN=/builds/coq/coq/_install_ci/bin/ +++ ls -l /builds/coq/coq/_install_ci/bin/ +total 377964 +-rwxr-xr-x 1 root root 1885376 Sep 1 11:46 coq-tex +-rwxr-xr-x 1 root root 2500248 Sep 1 11:46 coq_makefile +-rwxr-xr-x 1 root root 24673120 Sep 1 11:46 coqc +-rwxr-xr-x 1 root root 9648760 Sep 1 11:46 coqchk +-rwxr-xr-x 1 root root 5855160 Sep 1 11:46 coqdep +-rwxr-xr-x 1 root root 4413792 Sep 1 11:46 coqdoc +-rwxr-xr-x 1 root root 11526312 Sep 1 11:47 coqide +-rwxr-xr-x 1 root root 25110448 Sep 1 11:47 coqidetop +-rwxr-xr-x 1 root root 25110448 Sep 1 11:47 coqidetop.opt +-rwxr-xr-x 1 root root 449295 Sep 1 11:46 coqpp +-rwxr-xr-x 1 root root 32153472 Sep 1 11:47 coqproofworker.byte +-rwxr-xr-x 1 root root 24673424 Sep 1 11:46 coqproofworker.opt +-rwxr-xr-x 1 root root 32153472 Sep 1 11:47 coqqueryworker.byte +-rwxr-xr-x 1 root root 24673424 Sep 1 11:46 coqqueryworker.opt +-rwxr-xr-x 1 root root 32153477 Sep 1 11:47 coqtacticworker.byte +-rwxr-xr-x 1 root root 24673448 Sep 1 11:46 coqtacticworker.opt +-rwxr-xr-x 1 root root 24673288 Sep 1 11:46 coqtop +-rwxr-xr-x 1 root root 41805680 Sep 1 11:47 coqtop.byte +-rwxr-xr-x 1 root root 24673288 Sep 1 11:46 coqtop.opt +-rwxr-xr-x 1 root root 1821312 Sep 1 11:46 coqwc +-rwxr-xr-x 1 root root 2827416 Sep 1 11:46 coqworkmgr +-rwxr-xr-x 1 root root 5905992 Sep 1 11:47 fake_ide +-rwxr-xr-x 1 root root 1757920 Sep 1 11:46 ocamllibdep +-rwxr-xr-x 1 root root 1877056 Sep 1 11:46 votour +++ CI_BUILD_DIR=/builds/coq/coq/_build_ci +++ ls -l /builds/coq/coq/_build_ci +total 4 +drwxr-xr-x 8 root root 4096 Sep 1 12:34 equations +++ set +x ++ git_download metacoq ++ local PROJECT=metacoq ++ local DEST=/builds/coq/coq/_build_ci/metacoq ++ local GITURL_VAR=metacoq_CI_GITURL ++ local GITURL=https://github.com/SkySkimmer/metacoq ++ local REF_VAR=metacoq_CI_REF ++ local REF=cumul-syntax ++ '[' -d /builds/coq/coq/_build_ci/metacoq ']' ++ '[' '' = 1 ']' ++ '[' true = '' ']' ++ local ARCHIVEURL_VAR=metacoq_CI_ARCHIVEURL ++ local ARCHIVEURL=https://github.com/SkySkimmer/metacoq/archive ++ mkdir -p /builds/coq/coq/_build_ci/metacoq ++ cd /builds/coq/coq/_build_ci/metacoq +++ git ls-remote https://github.com/SkySkimmer/metacoq refs/heads/cumul-syntax +++ cut -f 1 ++ local COMMIT=130dee007744c0e743d13613a398cfbe15ad95ff ++ [[ 130dee007744c0e743d13613a398cfbe15ad95ff == '' ]] ++ wget https://github.com/SkySkimmer/metacoq/archive/130dee007744c0e743d13613a398cfbe15ad95ff.tar.gz +--2020-09-01 12:34:56-- https://github.com/SkySkimmer/metacoq/archive/130dee007744c0e743d13613a398cfbe15ad95ff.tar.gz +Resolving github.com (github.com)... 140.82.121.3 +Connecting to github.com (github.com)|140.82.121.3|:443... connected. +HTTP request sent, awaiting response... 302 Found +Location: https://codeload.github.com/SkySkimmer/metacoq/tar.gz/130dee007744c0e743d13613a398cfbe15ad95ff [following] +--2020-09-01 12:34:56-- https://codeload.github.com/SkySkimmer/metacoq/tar.gz/130dee007744c0e743d13613a398cfbe15ad95ff +Resolving codeload.github.com (codeload.github.com)... 140.82.121.9 +Connecting to codeload.github.com (codeload.github.com)|140.82.121.9|:443... connected. +HTTP request sent, awaiting response... 200 OK +Length: unspecified [application/x-gzip] +Saving to: '130dee007744c0e743d13613a398cfbe15ad95ff.tar.gz' + + 0K .......... .......... .......... .......... .......... 1.14M + 50K .......... .......... .......... .......... .......... 2.37M + 100K .......... .......... .......... .......... .......... 10.9M + 150K .......... .......... .......... .......... .......... 10.9M + 200K .......... .......... .......... .......... .......... 3.08M + 250K .......... .......... .......... .......... .......... 10.9M + 300K .......... .......... .......... .......... .......... 11.4M + 350K .......... .......... .......... .......... .......... 10.9M + 400K .......... .......... .......... .......... .......... 7.25M + 450K .......... .......... .......... .......... .......... 9.97M + 500K .......... .......... .......... .......... .......... 10.9M + 550K .......... .......... .......... .......... .......... 3.39M + 600K .......... .......... .......... .......... .......... 10.8M + 650K .......... .......... .......... .......... .......... 2.57M + 700K .......... .......... .......... .......... .......... 11.4M + 750K .......... .......... .......... .......... .......... 10.8M + 800K .......... .......... .......... .......... ......... 11.3M=0.2s + +2020-09-01 12:34:57 (4.92 MB/s) - '130dee007744c0e743d13613a398cfbe15ad95ff.tar.gz' saved [869537] + ++ tar xfz 130dee007744c0e743d13613a398cfbe15ad95ff.tar.gz --strip-components=1 ++ rm -f 130dee007744c0e743d13613a398cfbe15ad95ff.tar.gz ++ cd /builds/coq/coq/_build_ci/metacoq ++ ./configure.sh local +make[1]: Entering directory '/builds/coq/coq/_build_ci/metacoq' +make -C template-coq mrproper +make[2]: Entering directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +rm -f Makefile.coq +rm -f Makefile.plugin +rm -f Makefile.template +make[2]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make -C pcuic mrproper +make[2]: Entering directory '/builds/coq/coq/_build_ci/metacoq/pcuic' +rm -f metacoq-config +rm -f Makefile.plugin _PluginProject +rm -f Makefile.pcuic _CoqProject +make[2]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/pcuic' +make -C safechecker mrproper +make[2]: Entering directory '/builds/coq/coq/_build_ci/metacoq/safechecker' +rm -f metacoq-config +rm -f Makefile.plugin _PluginProject +rm -f Makefile.safechecker _CoqProject +make[2]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/safechecker' +make -C erasure mrproper +make[2]: Entering directory '/builds/coq/coq/_build_ci/metacoq/erasure' +rm -f Makefile.plugin +rm -f Makefile.erasure +make[2]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/erasure' +make -C checker mrproper +make[2]: Entering directory '/builds/coq/coq/_build_ci/metacoq/checker' +rm -f Makefile.coq Makefile.plugin _CoqProject _PluginProject +make[2]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/checker' +make -C examples mrproper +make[2]: Entering directory '/builds/coq/coq/_build_ci/metacoq/examples' +rm -f Makefile.coq +make[2]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/examples' +make -C test-suite mrproper +make[2]: Entering directory '/builds/coq/coq/_build_ci/metacoq/test-suite' +rm -f Makefile.coq +make[2]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/test-suite' +make -C translations mrproper +make[2]: Entering directory '/builds/coq/coq/_build_ci/metacoq/translations' +rm -f Makefile.coq +make[2]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/translations' +make[1]: Leaving directory '/builds/coq/coq/_build_ci/metacoq' +Building MetaCoq locally ++ make .merlin ++ '[' -z x ']' ++ command make .merlin ++ make .merlin +make[1]: Entering directory '/builds/coq/coq/_build_ci/metacoq' +make -C template-coq .merlin +make[2]: Entering directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +coq_makefile -f _PluginProject -o Makefile.plugin +`which gsed || which sed` -i -e s/coqdeps/coqdeps.plugin/g Makefile.plugin +make -f Makefile.plugin .merlin +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +COQDEP VFILES +OCAMLLIBDEP gen-src/metacoq_template_plugin.mlpack +FILL .merlin +make[4]: Entering directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make[4]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make[2]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make -C pcuic .merlin +make[2]: Entering directory '/builds/coq/coq/_build_ci/metacoq/pcuic' +cat metacoq-config > _PluginProject +cat _PluginProject.in >> _PluginProject +coq_makefile -f _PluginProject -o Makefile.plugin +`which gsed || which sed` -i -e s/coqdeps/coqdeps.plugin/g Makefile.plugin +make -f Makefile.plugin .merlin +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/pcuic' +make[3]: warning: jobserver unavailable: using -j1. Add '+' to parent make rule. +COQDEP VFILES +Fatal error: exception Sys_error("../template-coq/build: No such file or directory") +OCAMLLIBDEP src/metacoq_pcuic_plugin.mlpack +Uncaught exception: Sys_error("../template-coq/build: No such file or directory") +FILL .merlin +make[4]: Entering directory '/builds/coq/coq/_build_ci/metacoq/pcuic' +COQDEP VFILES +Fatal error: exception Sys_error("../template-coq/build: No such file or directory") +OCAMLLIBDEP src/metacoq_pcuic_plugin.mlpack +Uncaught exception: Sys_error("../template-coq/build: No such file or directory") +make[4]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/pcuic' +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/pcuic' +make[2]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/pcuic' +make -C safechecker .merlin +make[2]: Entering directory '/builds/coq/coq/_build_ci/metacoq/safechecker' +cat metacoq-config > _PluginProject +cat _PluginProject.in >> _PluginProject +coq_makefile -f _PluginProject -o Makefile.plugin +`which gsed || which sed` -i -e s/coqdeps/coqdeps.plugin/g Makefile.plugin +make -f Makefile.plugin .merlin +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/safechecker' +make[3]: warning: jobserver unavailable: using -j1. Add '+' to parent make rule. +COQDEP VFILES +Fatal error: exception Sys_error("../template-coq/build: No such file or directory") +COQPP src/g_metacoq_safechecker.mlg +OCAMLLIBDEP src/metacoq_safechecker_plugin.mlpack +Uncaught exception: Sys_error("../template-coq/build: No such file or directory") +CAMLDEP src/g_metacoq_safechecker.ml +Bad -I option: ../template-coq/build: No such file or directory +FILL .merlin +make[4]: Entering directory '/builds/coq/coq/_build_ci/metacoq/safechecker' +COQDEP VFILES +Fatal error: exception Sys_error("../template-coq/build: No such file or directory") +OCAMLLIBDEP src/metacoq_safechecker_plugin.mlpack +Uncaught exception: Sys_error("../template-coq/build: No such file or directory") +CAMLDEP src/g_metacoq_safechecker.ml +Bad -I option: ../template-coq/build: No such file or directory +make[4]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/safechecker' +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/safechecker' +make[2]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/safechecker' +make -C erasure .merlin +make[2]: Entering directory '/builds/coq/coq/_build_ci/metacoq/erasure' +cat metacoq-config > _PluginProject +cat _PluginProject.in >> _PluginProject +coq_makefile -f _PluginProject -o Makefile.plugin +`which gsed || which sed` -i -e s/coqdeps/coqdeps.plugin/g Makefile.plugin +make -f Makefile.plugin .merlin +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/erasure' +make[3]: warning: jobserver unavailable: using -j1. Add '+' to parent make rule. +COQDEP VFILES +Fatal error: exception Sys_error("../template-coq/build: No such file or directory") +COQPP src/g_metacoq_erasure.mlg +OCAMLLIBDEP src/metacoq_erasure_plugin.mlpack +Uncaught exception: Sys_error("../template-coq/build: No such file or directory") +CAMLDEP src/g_metacoq_erasure.ml +Bad -I option: ../template-coq/build: No such file or directory +FILL .merlin +make[4]: Entering directory '/builds/coq/coq/_build_ci/metacoq/erasure' +COQDEP VFILES +Fatal error: exception Sys_error("../template-coq/build: No such file or directory") +OCAMLLIBDEP src/metacoq_erasure_plugin.mlpack +Uncaught exception: Sys_error("../template-coq/build: No such file or directory") +CAMLDEP src/g_metacoq_erasure.ml +Bad -I option: ../template-coq/build: No such file or directory +make[4]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/erasure' +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/erasure' +make[2]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/erasure' +make -C checker .merlin +make[2]: Entering directory '/builds/coq/coq/_build_ci/metacoq/checker' +cat metacoq-config > _PluginProject +cat _PluginProject.in >> _PluginProject +coq_makefile -f _PluginProject -o Makefile.plugin +make -f Makefile.plugin .merlin +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/checker' +make[3]: warning: jobserver unavailable: using -j1. Add '+' to parent make rule. +COQDEP VFILES +Fatal error: exception Sys_error("../template-coq/build: No such file or directory") +COQPP src/g_metacoq_checker.mlg +OCAMLLIBDEP src/metacoq_checker_plugin.mlpack +Uncaught exception: Sys_error("../template-coq/build: No such file or directory") +CAMLDEP src/g_metacoq_checker.ml +Bad -I option: ../template-coq/build: No such file or directory +FILL .merlin +make[4]: Entering directory '/builds/coq/coq/_build_ci/metacoq/checker' +COQDEP VFILES +Fatal error: exception Sys_error("../template-coq/build: No such file or directory") +OCAMLLIBDEP src/metacoq_checker_plugin.mlpack +Uncaught exception: Sys_error("../template-coq/build: No such file or directory") +CAMLDEP src/g_metacoq_checker.ml +Bad -I option: ../template-coq/build: No such file or directory +make[4]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/checker' +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/checker' +make[2]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/checker' +make[1]: Leaving directory '/builds/coq/coq/_build_ci/metacoq' ++ make ci-local ++ '[' -z x ']' ++ command make ci-local ++ make ci-local +make[1]: Entering directory '/builds/coq/coq/_build_ci/metacoq' +make all test-suite +make[2]: Entering directory '/builds/coq/coq/_build_ci/metacoq' +make -C template-coq +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +coq_makefile -f _CoqProject -o Makefile.coq +coq_makefile -f _TemplateCoqProject -o Makefile.template +`which gsed || which sed` -i -e s/coqdeps/coqdeps.template/g Makefile.template +make -f Makefile.coq +make[4]: Entering directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +COQDEP VFILES +COQC theories/utils/MCPrelude.v +COQC theories/utils/MCRelations.v +theories/utils/MCPrelude.vo (real: 0.09, user: 0.05, sys: 0.04, mem: 63096 ko) +COQC theories/utils/MCProd.v +theories/utils/MCRelations.vo (real: 0.09, user: 0.05, sys: 0.04, mem: 68156 ko) +COQC theories/utils/MCSquash.v +theories/utils/MCSquash.vo (real: 0.09, user: 0.04, sys: 0.04, mem: 61384 ko) +COQC theories/utils/MCArith.v +theories/utils/MCProd.vo (real: 0.14, user: 0.09, sys: 0.04, mem: 88348 ko) +COQC theories/utils/MCCompare.v +theories/utils/MCArith.vo (real: 0.70, user: 0.48, sys: 0.22, mem: 404556 ko) +COQC theories/utils/MCEquality.v +theories/utils/MCEquality.vo (real: 0.08, user: 0.04, sys: 0.03, mem: 62924 ko) +COQC theories/utils/LibHypsNaming.v +theories/utils/LibHypsNaming.vo (real: 0.60, user: 0.42, sys: 0.18, mem: 339136 ko) +COQC theories/config.v +theories/config.vo (real: 0.08, user: 0.04, sys: 0.03, mem: 61716 ko) +COQC theories/monad_utils.v +theories/monad_utils.vo (real: 0.22, user: 0.14, sys: 0.08, mem: 149456 ko) +COQC theories/utils/MCList.v +theories/utils/MCList.vo (real: 1.71, user: 1.47, sys: 0.22, mem: 452340 ko) +COQC theories/utils/MCOption.v +theories/utils/MCOption.vo (real: 0.79, user: 0.56, sys: 0.22, mem: 440168 ko) +COQC theories/utils/All_Forall.v +theories/utils/MCCompare.vo (real: 6.40, user: 6.04, sys: 0.32, mem: 529900 ko) +COQC theories/utils/MCString.v +theories/utils/MCString.vo (real: 0.44, user: 0.30, sys: 0.13, mem: 270156 ko) +theories/utils/All_Forall.vo (real: 3.03, user: 2.78, sys: 0.23, mem: 465984 ko) +COQC theories/utils.v +theories/utils.vo (real: 0.71, user: 0.52, sys: 0.18, mem: 385340 ko) +COQC theories/utils/wGraph.v +COQC theories/BasicAst.v +theories/BasicAst.vo (real: 0.98, user: 0.75, sys: 0.22, mem: 450728 ko) +COQC theories/Universes.v +theories/utils/wGraph.vo (real: 5.22, user: 4.72, sys: 0.47, mem: 498552 ko) +theories/Universes.vo (real: 4.54, user: 4.23, sys: 0.28, mem: 531272 ko) +COQC theories/common/uGraph.v +COQC theories/Environment.v +theories/Environment.vo (real: 1.35, user: 1.10, sys: 0.24, mem: 484172 ko) +COQC theories/Ast.v +theories/Ast.vo (real: 1.04, user: 0.79, sys: 0.24, mem: 479940 ko) +COQC theories/AstUtils.v +theories/AstUtils.vo (real: 1.24, user: 1.00, sys: 0.23, mem: 485664 ko) +COQC theories/TemplateMonad/Common.v +theories/TemplateMonad/Common.vo (real: 0.82, user: 0.60, sys: 0.22, mem: 437492 ko) +COQC theories/Induction.v +theories/Induction.vo (real: 1.45, user: 1.18, sys: 0.26, mem: 486324 ko) +COQC theories/EnvironmentTyping.v +theories/common/uGraph.vo (real: 6.23, user: 5.85, sys: 0.35, mem: 551516 ko) +COQC theories/WfInv.v +theories/WfInv.vo (real: 1.31, user: 1.05, sys: 0.25, mem: 489932 ko) +COQC theories/TemplateMonad/Core.v +theories/EnvironmentTyping.vo (real: 2.05, user: 1.77, sys: 0.27, mem: 491968 ko) +COQC theories/TemplateMonad/Extractable.v +theories/TemplateMonad/Core.vo (real: 0.97, user: 0.73, sys: 0.24, mem: 481988 ko) +COQC theories/LiftSubst.v +theories/TemplateMonad/Extractable.vo (real: 0.95, user: 0.70, sys: 0.23, mem: 481156 ko) +COQC theories/TemplateMonad.v +theories/TemplateMonad.vo (real: 0.79, user: 0.54, sys: 0.24, mem: 420452 ko) +COQC theories/Constants.v +theories/Constants.vo (real: 1.08, user: 0.82, sys: 0.25, mem: 498504 ko) +theories/LiftSubst.vo (real: 12.60, user: 11.81, sys: 0.72, mem: 532016 ko) +COQC theories/UnivSubst.v +COQC theories/Pretty.v +theories/Pretty.vo (real: 1.11, user: 0.87, sys: 0.24, mem: 486460 ko) +theories/UnivSubst.vo (real: 3.38, user: 3.11, sys: 0.24, mem: 490756 ko) +COQC theories/Typing.v +COQC theories/Extraction.v +theories/Extraction.vo (real: 9.78, user: 9.33, sys: 0.41, mem: 571876 ko) +theories/Typing.vo (real: 53.00, user: 51.78, sys: 0.98, mem: 809012 ko) +COQC theories/TypingWf.v +theories/TypingWf.vo (real: 8.46, user: 8.05, sys: 0.36, mem: 556676 ko) +./update_plugin.sh +Updating gen-src from src +Copying from src to gen-src +Renaming files to camelCase +Moving All_Forall.ml to all_Forall.ml +Moving All_Forall.mli to all_Forall.mli +Moving Ascii.ml to ascii.ml +Moving Ascii.mli to ascii.mli +Moving Ast0.ml to ast0.ml +Moving Ast0.mli to ast0.mli +Moving AstUtils.ml to astUtils.ml +Moving AstUtils.mli to astUtils.mli +Moving BasicAst.ml to basicAst.ml +Moving BasicAst.mli to basicAst.mli +Moving Basics.ml to basics.ml +Moving Basics.mli to basics.mli +Moving BinInt.ml to binInt.ml +Moving BinInt.mli to binInt.mli +Moving BinNat.ml to binNat.ml +Moving BinNat.mli to binNat.mli +Moving BinNums.ml to binNums.ml +Moving BinNums.mli to binNums.mli +Moving BinPos.ml to binPos.ml +Moving BinPos.mli to binPos.mli +Moving BinPosDef.ml to binPosDef.ml +Moving BinPosDef.mli to binPosDef.mli +Moving Bool.ml to bool.ml +Moving Bool.mli to bool.mli +Moving Byte.ml to byte.ml +Moving Byte.mli to byte.mli +Moving CRelationClasses.ml to cRelationClasses.ml +Moving CRelationClasses.mli to cRelationClasses.mli +Moving Common0.ml to common0.ml +Moving Common0.mli to common0.mli +Moving Compare_dec.ml to compare_dec.ml +Moving Compare_dec.mli to compare_dec.mli +Moving Datatypes.ml to datatypes.ml +Moving Datatypes.mli to datatypes.mli +Moving Decimal.ml to decimal.ml +Moving Decimal.mli to decimal.mli +Moving Environment.ml to environment.ml +Moving Environment.mli to environment.mli +Moving Equalities.ml to equalities.ml +Moving Equalities.mli to equalities.mli +Moving Extractable.ml to extractable.ml +Moving Extractable.mli to extractable.mli +Moving Hexadecimal.ml to hexadecimal.ml +Moving Hexadecimal.mli to hexadecimal.mli +Moving Induction.ml to induction.ml +Moving Induction.mli to induction.mli +Moving LiftSubst.ml to liftSubst.ml +Moving LiftSubst.mli to liftSubst.mli +Moving List0.ml to list0.ml +Moving List0.mli to list0.mli +Moving Logic0.ml to logic0.ml +Moving Logic0.mli to logic0.mli +Moving MCCompare.ml to mCCompare.ml +Moving MCCompare.mli to mCCompare.mli +Moving MCList.ml to mCList.ml +Moving MCList.mli to mCList.mli +Moving MCOption.ml to mCOption.ml +Moving MCOption.mli to mCOption.mli +Moving MCPrelude.ml to mCPrelude.ml +Moving MCPrelude.mli to mCPrelude.mli +Moving MCProd.ml to mCProd.ml +Moving MCProd.mli to mCProd.mli +Moving MCRelations.ml to mCRelations.ml +Moving MCRelations.mli to mCRelations.mli +Moving MCString.ml to mCString.ml +Moving MCString.mli to mCString.mli +Moving MSetDecide.ml to mSetDecide.ml +Moving MSetDecide.mli to mSetDecide.mli +Moving MSetFacts.ml to mSetFacts.ml +Moving MSetFacts.mli to mSetFacts.mli +Moving MSetInterface.ml to mSetInterface.ml +Moving MSetInterface.mli to mSetInterface.mli +Moving MSetList.ml to mSetList.ml +Moving MSetList.mli to mSetList.mli +Moving MSetProperties.ml to mSetProperties.ml +Moving MSetProperties.mli to mSetProperties.mli +Moving Nat0.ml to nat0.ml +Moving Nat0.mli to nat0.mli +Moving Numeral.ml to numeral.ml +Moving Numeral.mli to numeral.mli +Moving OrderedType0.ml to orderedType0.ml +Moving OrderedType0.mli to orderedType0.mli +Moving Orders.ml to orders.ml +Moving Orders.mli to orders.mli +Moving OrdersFacts.ml to ordersFacts.ml +Moving OrdersFacts.mli to ordersFacts.mli +Moving OrdersLists.ml to ordersLists.ml +Moving OrdersLists.mli to ordersLists.mli +Moving OrdersTac.ml to ordersTac.ml +Moving OrdersTac.mli to ordersTac.mli +Moving PeanoNat.ml to peanoNat.ml +Moving PeanoNat.mli to peanoNat.mli +Moving Pretty.ml to pretty.ml +Moving Pretty.mli to pretty.mli +Moving Specif.ml to specif.ml +Moving Specif.mli to specif.mli +Moving String0.ml to string0.ml +Moving String0.mli to string0.mli +Moving UnivSubst0.ml to univSubst0.ml +Moving UnivSubst0.mli to univSubst0.mli +Moving Universes0.ml to universes0.ml +Moving Universes0.mli to universes0.mli +patching file gen-src/cRelationClasses.mli +make[4]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make -f Makefile.template optfiles +make[4]: Entering directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +COQDEP VFILES +COQPP src/g_template_coq.mlg +CAMLDEP src/plugin_core.mli +CAMLDEP src/run_template_monad.mli +CAMLDEP src/template_monad.mli +OCAMLLIBDEP src/template_coq.mlpack +CAMLDEP src/plugin_core.ml +CAMLDEP src/run_template_monad.ml +CAMLDEP src/template_monad.ml +CAMLDEP src/constr_denoter.ml +CAMLDEP src/constr_quoter.ml +CAMLDEP src/constr_reification.ml +CAMLDEP src/denoter.ml +CAMLDEP src/quoter.ml +CAMLDEP src/reification.ml +CAMLDEP src/tm_util.ml +CAMLDEP src/g_template_coq.ml +CAMLOPT -c -for-pack Template_coq src/tm_util.ml +CAMLOPT -c -for-pack Template_coq src/reification.ml +src/reification.cmx (real: 0.04, user: 0.01, sys: 0.01, mem: 14796 ko) +CAMLOPT -c -for-pack Template_coq src/constr_reification.ml +src/tm_util.cmx (real: 0.07, user: 0.03, sys: 0.02, mem: 21812 ko) +CAMLC -c src/template_monad.mli +src/template_monad.cmi (real: 0.02, user: 0.00, sys: 0.01, mem: 15004 ko) +CAMLC -c src/plugin_core.mli +src/constr_reification.cmx (real: 0.07, user: 0.04, sys: 0.02, mem: 22020 ko) +CAMLOPT -c -for-pack Template_coq src/quoter.ml +src/plugin_core.cmi (real: 0.03, user: 0.01, sys: 0.01, mem: 17068 ko) +CAMLOPT -c -for-pack Template_coq src/denoter.ml +src/denoter.cmx (real: src/quoter.cmx (real: 0.22, user: 0.240.05, ,u sesry:s :0.16 , 0.02sy,s :m em: 0.0224280, mkeom:) +34576 ko) +CAMLOPT -c -for-pack Template_coq src/template_monad.ml +CAMLOPT -c -for-pack Template_coq src/plugin_core.ml +src/templaster_cm/opnaludg.inc_cmoxr e(.rcemaxl :( real: 0.10, user: 0.06, sys: 0.02, mem: 27236 ko) +0.10, user: 0.08, sys: 0.01, mem: 26216 ko) +CAMLC -c src/run_template_monad.mli +CAMLOPT -c -for-pack Template_coq src/constr_quoter.ml +src/run_template_monad.cmi (real: 0.01, user: 0.00, sys: 0.01, mem: 13148 ko) +CAMLOPT -c -for-pack Template_coq src/constr_denoter.ml +src/constr_denoter.cmx (real: 0.18, user: 0.14, sys: 0.01, mem: 31740 ko) +src/constr_quoter.cmx (real: 0.24, user: 0.17, sys: 0.03, mem: 33044 ko) +CAMLOPT -c -for-pack Template_coq src/run_template_monad.ml +src/run_template_monad.cmx (real: 0.28, user: 0.15, sys: 0.03, mem: 38520 ko) +CAMLOPT -c -for-pack Template_coq src/g_template_coq.ml +src/g_template_coq.cmx (real: 0.25, user: 0.10, sys: 0.02, mem: 33140 ko) +CAMLOPT -pack -o src/template_coq.cmx +src/template_coq.cmx (real: 0.13, user: 0.02, sys: 0.02, mem: 19956 ko) +CAMLOPT -a -o src/template_coq.cmxa +src/template_coq.cmxa (real: 0.03, user: 0.00, sys: 0.01, mem: 13520 ko) +CAMLOPT -shared -o src/template_coq.cmxs +src/template_coq.cmxs (real: 0.08, user: 0.05, sys: 0.03, mem: 16040 ko) +make[4]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +cp src/template_coq.cm* build/ +make -f Makefile.template +make[4]: Entering directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +COQC theories/Loader.v +theories/Loader.vo (real: 1.04, user: 0.77, sys: 0.26, mem: 500040 ko) +COQC theories/All.v +theories/All.vo (real: 1.25, user: 0.95, sys: 0.28, mem: 521596 ko) +make[4]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make -f Makefile.plugin +make[4]: Entering directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +CAMLDEP gen-src/univSubst0.mli +CAMLDEP gen-src/universes0.mli +CAMLDEP gen-src/string0.mli +CAMLDEP gen-src/specif.mli +CAMLDEP gen-src/run_extractable.mli +CAMLDEP gen-src/pretty.mli +CAMLDEP gen-src/plugin_core.mli +CAMLDEP gen-src/peanoNat.mli +CAMLDEP gen-src/ordersTac.mli +CAMLDEP gen-src/ordersLists.mli +CAMLDEP gen-src/orders.mli +CAMLDEP gen-src/ordersFacts.mli +CAMLDEP gen-src/orderedType0.mli +CAMLDEP gen-src/numeral.mli +CAMLDEP gen-src/nat0.mli +CAMLDEP gen-src/mSetProperties.mli +CAMLDEP gen-src/mSetList.mli +CAMLDEP gen-src/mSetInterface.mli +CAMLDEP gen-src/mSetFacts.mli +CAMLDEP gen-src/mSetDecide.mli +CAMLDEP gen-src/mCString.mli +CAMLDEP gen-src/mCRelations.mli +CAMLDEP gen-src/mCProd.mli +CAMLDEP gen-src/mCOption.mli +CAMLDEP gen-src/mCList.mli +CAMLDEP gen-src/mCCompare.mli +CAMLDEP gen-src/mCPrelude.mli +CAMLDEP gen-src/logic0.mli +CAMLDEP gen-src/list0.mli +CAMLDEP gen-src/liftSubst.mli +CAMLDEP gen-src/hexadecimal.mli +CAMLDEP gen-src/extractable.mli +CAMLDEP gen-src/equalities.mli +CAMLDEP gen-src/environment.mli +CAMLDEP gen-src/decimal.mli +CAMLDEP gen-src/datatypes.mli +CAMLDEP gen-src/cRelationClasses.mli +CAMLDEP gen-src/config0.mli +CAMLDEP gen-src/compare_dec.mli +CAMLDEP gen-src/common0.mli +CAMLDEP gen-src/bool.mli +CAMLDEP gen-src/binPos.mli +CAMLDEP gen-src/binPosDef.mli +CAMLDEP gen-src/binNums.mli +CAMLDEP gen-src/binNat.mli +CAMLDEP gen-src/binInt.mli +CAMLDEP gen-src/basics.mli +CAMLDEP gen-src/basicAst.mli +CAMLDEP gen-src/astUtils.mli +CAMLDEP gen-src/ast0.mli +CAMLDEP gen-src/ascii.mli +CAMLDEP gen-src/all_Forall.mli +OCAMLLIBDEP gen-src/metacoq_template_plugin.mlpack +CAMLDEP gen-src/univSubst0.ml +CAMLDEP gen-src/universes0.ml +CAMLDEP gen-src/tm_util.ml +CAMLDEP gen-src/string0.ml +CAMLDEP gen-src/specif.ml +CAMLDEP gen-src/run_extractable.ml +CAMLDEP gen-src/quoter.ml +CAMLDEP gen-src/reification.ml +CAMLDEP gen-src/pretty.ml +CAMLDEP gen-src/plugin_core.ml +CAMLDEP gen-src/peanoNat.ml +CAMLDEP gen-src/ordersTac.ml +CAMLDEP gen-src/orders.ml +CAMLDEP gen-src/ordersLists.ml +CAMLDEP gen-src/ordersFacts.ml +CAMLDEP gen-src/orderedType0.ml +CAMLDEP gen-src/numeral.ml +CAMLDEP gen-src/nat0.ml +CAMLDEP gen-src/mSetProperties.ml +CAMLDEP gen-src/mSetList.ml +CAMLDEP gen-src/mSetInterface.ml +CAMLDEP gen-src/mSetFacts.ml +CAMLDEP gen-src/mSetDecide.ml +CAMLDEP gen-src/mCString.ml +CAMLDEP gen-src/mCRelations.ml +CAMLDEP gen-src/mCProd.ml +CAMLDEP gen-src/mCOption.ml +CAMLDEP gen-src/mCList.ml +CAMLDEP gen-src/mCCompare.ml +CAMLDEP gen-src/mCPrelude.ml +CAMLDEP gen-src/logic0.ml +CAMLDEP gen-src/list0.ml +CAMLDEP gen-src/liftSubst.ml +CAMLDEP gen-src/hexadecimal.ml +CAMLDEP gen-src/extractable.ml +CAMLDEP gen-src/equalities.ml +CAMLDEP gen-src/environment.ml +CAMLDEP gen-src/denoter.ml +CAMLDEP gen-src/decimal.ml +CAMLDEP gen-src/datatypes.ml +CAMLDEP gen-src/cRelationClasses.ml +CAMLDEP gen-src/config0.ml +CAMLDEP gen-src/compare_dec.ml +CAMLDEP gen-src/common0.ml +CAMLDEP gen-src/bool.ml +CAMLDEP gen-src/binPos.ml +CAMLDEP gen-src/binPosDef.ml +CAMLDEP gen-src/binNums.ml +CAMLDEP gen-src/binNat.ml +CAMLDEP gen-src/binInt.ml +CAMLDEP gen-src/basics.ml +CAMLDEP gen-src/basicAst.ml +CAMLDEP gen-src/astUtils.ml +CAMLDEP gen-src/ast_quoter.ml +CAMLDEP gen-src/ast_denoter.ml +CAMLDEP gen-src/ast0.ml +CAMLDEP gen-src/ascii.ml +CAMLDEP gen-src/all_Forall.ml +CAMLC -c gen-src/datatypes.mli +CAMLC -c gen-src/basics.mli +gen-src/basics.cmi (real: 0.01, user: 0.00, sys: 0.00, mem: 11244 ko) +CAMLC -c gen-src/binNums.mli +gen-src/datatypes.cmi (real: 0.01, user: 0.00, sys: 0.00, mem: 12948 ko) +CAMLC -c gen-src/mCPrelude.mli +gen-src/binNums.cmi (real: 0.01, user: 0.00, sys: 0.00, mem: 11340 ko) +CAMLC -c gen-src/mCRelations.mli +gen-src/mCPrelude.cmi (real: 0.01, user: 0.00, sys: 0.00, mem: 11228 ko) +CAMLC -c gen-src/mCProd.mli +gen-src/mCRelations.cmi (real: 0.01, user: 0.00, sys: 0.00, mem: 11080 ko) +CAMLC -c gen-src/config0.mli +gen-src/mCProd.cmi (real: 0.01, user: 0.00, sys: 0.00, mem: 11620 ko) +CAMLC -c gen-src/logic0.mli +gen-src/config0.cmi (real: 0.01, user: 0.00, sys: 0.00, mem: 11112 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/tm_util.ml +gen-src/logic0.cmi (real: 0.01, user: 0.00, sys: 0.00, mem: 11524 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/reification.ml +gen-src/reification.cmx (real: 0.02, user: 0.01, sys: 0.00, mem: 14848 ko) +CAMLC -c gen-src/plugin_core.mli +gen-src/plugin_core.cmi (real: 0.02, user: 0.01, sys: 0.00, mem: 17156 ko) +CAMLC -c gen-src/tm_util.ml +gen-src/tm_util.cmo (real: 0.03, user: 0.02, sys: 0.01, mem: 18388 ko) +CAMLC -c gen-src/reification.ml +gen-src/reification.cmo (real: 0.01, user: 0.00, sys: 0.00, mem: 11740 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/datatypes.ml +gen-src/datatypes.cmx (real: 0.15, user: 0.01, sys: 0.01, mem: 16200 ko) +gen-src/tm_util.cmx (real: 0.26, user: 0.03, sys: 0.02, mem: 22128 ko) +CAMLC -c gen-src/bool.mli +CAMLC -c gen-src/decimal.mli +gen-src/decimal.cmi (real: 0.01, user: 0.00, sys: 0.00, mem: 12404 ko) +gen-src/bool.cmi (real: 0.01, user: 0.00, sys: 0.00, mem: 11744 ko) +CAMLC -c gen-src/specif.mli +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/basics.ml +gen-src/specif.cmi (real: 0.01, user: 0.00, sys: 0.00, mem: 13160 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/binNums.ml +ggeenn--ssrrcc//bbaisniNcusm.sc.mcxm x( r(eraela:l : 0.040.05,, uusseerr:: 0.010.00,, ssyyss:: 0.010.01,, mmeemm:: 1566414584 kkoo)) + +CAMLC -c gen-src/cRelationClasses.mli +CAMLC -c gen-src/compare_dec.mli +gen-src/compare_dec.cmi (real: 0.01, user: 0.00, sys: 0.00, mem: 11720 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/mCPrelude.ml +gen-src/cRelationClasses.cmi (real: 0.01, user: 0.01, sys: 0.00, mem: 13388 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/mCRelations.ml +gen-src/mCPrelude.cmx (real: 0.04, user: 0.00, sys: 0.01, mem: 14368 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/mCProd.ml +gen-src/mCRelations.cmx (real: 0.09, user: 0.00, sys: 0.01, mem: 14184 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/config0.ml +gen-src/mCProd.cmx (real: 0.07, user: 0.01, sys: 0.01, mem: 15708 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/logic0.ml +gen-src/logic0.cmx (real: 0.02, user: 0.00, sys: 0.01, mem: 15516 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/quoter.ml +gen-src/config0.cmx (real: 0.09, user: 0.00, sys: 0.01, mem: 14648 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/denoter.ml +gen-src/denoter.cmx (real: 0.07, user: 0.05, sys: 0.01, mem: 24396 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/plugin_core.ml +gen-src/quoter.cmx (real: 0.17, user: 0.14, sys: 0.02, mem: 34476 ko) +CAMLC -c gen-src/quoter.ml +gen-src/plugin_core.cmx (real: 0.09, user: 0.06, sys: 0.02, mem: 27344 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/bool.ml +gen-src/bool.cmx (real: 0.02, user: 0.01, sys: 0.01, mem: 15772 ko) +CAMLC -c gen-src/equalities.mli +gen-src/equalities.cmi (real: 0.04, user: 0.00, sys: 0.00, mem: 13240 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/decimal.ml +gen-src/quoter.cmo (real: 0.16, user: 0.08, sys: 0.01, mem: 26408 ko) +CAMLC -c gen-src/hexadecimal.mli +gen-src/hexadecimal.cmi (real: 0.01, user: 0.00, sys: 0.00, mem: 13064 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/specif.ml +gen-src/decimal.cmx (real: 0.24, user: 0.03, sys: 0.01, mem: 17936 ko) +gen-src/specif.cmx (real: 0.17, user: 0.02, sys: 0.01, mem: 16332 ko) +CAMLC -c gen-src/orders.mli +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/cRelationClasses.ml +gen-src/orders.cmi (real: 0.02, user: 0.01, sys: 0.00, mem: 13748 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/compare_dec.ml +gen-src/cRelationClasses.cmx (real: 0.04, user: 0.02, sys: 0.01, mem: 16836 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/equalities.ml +gen-src/compare_dec.cmx (real: 0.03, user: 0.01, sys: 0.01, mem: 15536 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/hexadecimal.ml +gen-src/equalities.cmx (real: 0.03, user: 0.01, sys: 0.01, mem: 15840 ko) +CAMLC -c gen-src/numeral.mli +gen-src/numeral.cmi (real: 0.01, user: 0.00, sys: 0.00, mem: 11900 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/orders.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/orders.cmx (real: 0.04, user: 0.01, sys: 0.01, mem: 16768 ko) +CAMLC -c gen-src/ordersTac.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/ordersTac.cmi (real: 0.01, user: 0.00, sys: 0.00, mem: 12464 ko) +CAMLC -c gen-src/ordersLists.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/ordersLists.cmi (real: 0.01, user: 0.00, sys: 0.00, mem: 11760 ko) +CAMLC -c gen-src/orderedType0.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/orderedType0.cmi (real: 0.01, user: 0.00, sys: 0.01, mem: 12108 ko) +gen-src/hexadecimal.cmx (real: 0.13, user: 0.09, sys: 0.02, mem: 20020 ko) +CAMLC -c gen-src/nat0.mli +CAMLC -c gen-src/peanoNat.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/peanoNat.cmi (real: 0.01, user: 0.01, sys:g e0.00n,- smrecm/:n at133640 .kco)m +i (real: 0.02, user: 0.01, sys: 0.00, mem: 13460 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/ordersTac.ml +CAMLC -c gen-src/ordersFacts.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/ordersFacts.cmi (real: 0.01, user: 0.00, sys: 0.01, mem: 13444 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/ordersLists.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/ordersLists.cmx (real: 0.20, user: 0.00, sys: 0.01, mem: 15096 ko) +CAMLC -c gen-src/mSetInterface.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/mSetInterface.cmi (real: 0.02, user: 0.02, sys: 0.00, mem: 15244 ko) +CAMLC -c gen-src/mCCompare.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/mCCompare.cmi (real: 0.01, user: 0.00, sys: 0.00, mem: 11644 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/numeral.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/ordersTac.cmx (real: 0.27, user: 0.01, sys: 0.01, mem: 15844 ko) +CAMLC -c gen-src/list0.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/list0.cmi (real: 0.02, user: 0.01, sys: 0.00, mem: 13404 ko) +CAMLC -c gen-src/binPosDef.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/numeral.cmx (real: 0.04, user: 0.00, sys: 0.01, mem: 15820 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/ordersFacts.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/binPosDef.cmi (real: 0.01, user: 0.00, sys: 0.01, mem: 13536 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/orderedType0.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/ordersFacts.cmx (real: 0.02, user: 0.01, sys: 0.01, mem: 16032 ko) +CAMLC -c gen-src/mSetFacts.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/mSetFacts.cmi (real: 0.02, user: 0.01, sys: 0.00, mem: 13748 ko) +CAMLC -c gen-src/mSetList.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/mSetList.cmi (real: 0.02, user: 0.01, sys: 0.00, mem: 15760 ko) +CAMLC -c gen-src/mCList.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/orderedType0.cmx (real: 0.07, user: 0.01, sys: 0.01, mem: 15860 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/nat0.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/mCList.cmi (real: 0.01, user: 0.00, sys: 0.01, mem: 13612 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/peanoNat.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/nat0.cmx (real: 0.21, user: 0.04, sys: 0.01, mem: 18464 ko) +CAMLC -c gen-src/binPos.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/binPos.cmi (real: 0.01, user: 0.01, sys: 0.00, mem: 14264 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/mSetInterface.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/peanoNat.cmx (real: 0.26, user: 0.07, sys: 0.02, mem: 19912 ko) +CAMLC -c gen-src/mSetDecide.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/mSetDecide.cmi (real: 0.01, user: 0.00, sys: 0.00, mem: 13776 ko) +CAMLC -c gen-src/mCOption.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/mCOption.cmi (real: 0.01, user: 0.00, sys: 0.00, mem: 12200 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/mCCompare.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/mSetInterface.cmx (real: 0.11, user: 0.05, sys: 0.02, mem: 20324 ko) +CAMLC -c gen-src/all_Forall.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/all_Forall.cmi (real: 0.02, user: 0.01, sys: 0.00, mem: 14992 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/list0.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/mCCompare.cmx (real: 0.08, user: 0.01, sys: 0.01, mem: 15672 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/binPosDef.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/list0.cmx (real: 0.04, user: 0.03, sys: 0.01, mem: 17796 ko) +CAMLC -c gen-src/binNat.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/binNat.cmi (real: 0.01, user: 0.00, sys: 0.00, mem: 13444 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/mSetFacts.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/mSetFacts.cmx (real: 0.12, user: 0.01, sys: 0.01, mem: 17012 ko) +gen-src/binPosDef.cmx (real: 0.18, user: 0.13, sys: 0.03, mem: 23892 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/mSetList.ml +CAMLC -c gen-src/mSetProperties.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/mSetProperties.cmi (real: 0.07, user: 0.02, sys: 0.00, mem: 15212 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/mCList.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/mSetList.cmx (real: 0.28, user: 0.08, sys: 0.02, mem: 21352 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/binPos.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/mCList.cmx (real: 0.25, user: 0.01, sys: 0.01, mem: 16712 ko) +CAMLC -c gen-src/binInt.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/binInt.cmi (real: 0.02, user: 0.01, sys: 0.01, mem: 13564 ko) +CAMLC -c gen-src/ascii.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/ascii.cmi (real: 0.01, user: 0.00, sys: 0.01, mem: 12228 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/mSetDecide.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/binPos.cmx (real: 0.19, user: 0.15, sys: 0.03, mem: 25208 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/mCOption.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/mSetDecide.cmx (real: 0.18g, euns-esrr:c /mC0.01O,p tsiyosn:. cm0.01x, (mreema:l : 17180 ko) +0.08, user: 0.01, sys: 0.01, mem: 16020 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/binNat.ml +CAMLC -c gen-src/string0.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/string0.cmi (real: 0.01, user: 0.00, sys: 0.01, mem: 12236 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/mSetProperties.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/mSetProperties.cmx (real: 0.10, user: 0.04, sys: 0.01, mem: 19600 ko) +CAMLC -c gen-src/mCString.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/binNat.cmx (real: 0.13, user: 0.10, sys: 0.02, mem: 20796 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/all_Forall.ml +gen-src/mCString.cmi (real: 0.01, user: 0.00, sys: 0.00, mem: 11712 ko) +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/binInt.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/binInt.cmx (real: 0.32, user: 0.12, sys: 0.02, mem: 22784 ko) +gen-src/all_Forall.cmx (real: 0.33, user: 0.14, sys: 0.02, mem: 25372 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/ascii.ml +CAMLC -c gen-src/basicAst.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/basicAst.cmi (real: 0.02, user: 0.01, sys: 0.00, mem: 14404 ko) +CAMLC -c gen-src/universes0.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/ascii.cmx (real: 0.06, user: 0.02, sys: 0.01, mem: 16900 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/string0.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/universes0.cmi (real: 0.06, user: 0.04, sys: 0.01, mem: 18504 ko) +CAMLC -c gen-src/environment.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/string0.cmx (real: 0.04, user: 0.02, sys: 0.01, mem: 16504 ko) +CAMLC -c gen-src/ast0.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/environment.cmi (real: 0.02, user: 0.01, sys: 0.01, mem: 14988 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/mCString.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/ast0.cmi (real: 0.03, user: 0.01, sys: 0.01, mem: 15204 ko) +CAMLC -c gen-src/astUtils.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/astUtils.cmi (real: 0.01, user: 0.00, sys: 0.00, mem: 14040 ko) +CAMLC -c gen-src/liftSubst.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/liftSubst.cmi (real: 0.01, user: 0.00, sys: 0.00, mem: 13680 ko) +CAMLC -c gen-src/univSubst0.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/univSubst0.cmi (real: 0.01, user: 0.00, sys: 0.00, mem: 14128 ko) +CAMLC -c gen-src/pretty.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/pretty.cmi (real: 0.01, user: 0.00, sys: 0.01, mem: 15060 ko) +CAMLC -c gen-src/common0.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/common0.cmi (real: 0.01, user: 0.00, sys: 0.00, mem: 13492 ko) +CAMLC -c gen-src/ast_quoter.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/ast_quoter.cmo (real: 0.06, user: 0.04, sys: 0.01, mem: 22660 ko) +CAMLC -c gen-src/extractable.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/mCString.cmx (real: 0.24, user: 0.02, sys: 0.01, mem: 16472 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/basicAst.ml +gen-src/extractable.cmi (real: 0.07, user: 0.00, sys: 0.00, mem: 13580 ko) +CAMLC -c gen-src/run_extractable.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/run_extractable.cmi (real: 0.01, user: 0.00, sys: 0.00, mem: 13668 ko) +gen-src/basicAst.cmx (real: 0.05, user: 0.03, sys: 0.01, mem: 18744 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/universes0.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/universes0.cmx (real: 0.59, user: 0.41, sys: 0.03, mem: 39160 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/environment.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/environment.cmx (real: 0.16, user: 0.03, sys: 0.01, mem: 19716 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/ast0.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/ast0.cmx (real: 0.25, user: 0.09, sys: 0.02, mem: 24572 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/astUtils.ml +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/liftSubst.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/astUtils.cmx (real: 0.05, user: 0.04, sys: 0.01, mem: 19608 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/univSubst0.ml +gen-src/liftSubst.cmx (real: 0.06, user: 0.04, sys: 0.01, mem: 19008 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/common0.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/common0.cmx (real: 0.05, user: 0.02, sys: 0.01, mem: 16420 ko) +gen-src/univSubst0.cmx (real: 0.05, user: 0.03, sys: 0.01, mem: 18548 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/ast_quoter.ml +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/pretty.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/pretty.cmx (real: 0.11, user: 0.08, sys: 0.01, mem: 22020 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/extractable.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/extractable.cmx (real: 0.08, user: 0.04, sys: 0.01, mem: 18780 ko) +gen-src/ast_quoter.cmx (real: 0.20, user: 0.10, sys: 0.02, mem: 27252 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/ast_denoter.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/ast_denoter.cmx (real: 0.12, user: 0.07, sys: 0.02, mem: 27180 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/run_extractable.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/run_extractable.cmx (real: 0.13, user: 0.10, sys: 0.02, mem: 30484 ko) +CAMLOPT -pack -o gen-src/metacoq_template_plugin.cmx +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/metacoq_template_plugin.cmx (real: 0.15, user: 0.09, sys: 0.04, mem: 31648 ko) +CAMLOPT -a -o gen-src/metacoq_template_plugin.cmxa +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/metacoq_template_plugin.cmxa (real: 0.03, user: 0.01, sys: 0.02, mem: 13896 ko) +CAMLOPT -shared -o gen-src/metacoq_template_plugin.cmxs +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/metacoq_template_plugin.cmxs (real: 0.13, user: 0.09, sys: 0.03, mem: 18540 ko) +COQC theories/ExtractableLoader.v +theories/ExtractableLoader.vo (real: 0.09, user: 0.05, sys: 0.03, mem: 62540 ko) +cp gen-src/metacoq_template_plugin.cm* build/ +make[4]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make -C checker +make -C pcuic +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/checker' +cat metacoq-config > _CoqProject +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/pcuic' +cat metacoq-config > _CoqProject +cat _CoqProject.in >> _CoqProject +cat _CoqProject.in >> _CoqProject +coq_makefile -f _CoqProject -o Makefile.pcuic +coq_makefile -f _CoqProject -o Makefile.coq +Warning: ../template-coq/theories (used in -R or -Q) is not a subdirectory of the current directory + +make -f Makefile.coq +Warning: ../template-coq/theories (used in -R or -Q) is not a subdirectory of the current directory + +make -f Makefile.pcuic +make[4]: Entering directory '/builds/coq/coq/_build_ci/metacoq/checker' +make[4]: Entering directory '/builds/coq/coq/_build_ci/metacoq/pcuic' +COQDEP VFILES +COQDEP VFILES +COQC theories/Reflect.v +COQC theories/PCUICAst.v +theories/PCUICAst.vo (real: 0.99, user: 0.75, sys: 0.23, mem: 477372 ko) +COQC theories/PCUICSize.v +theories/PCUICSize.vo (real: 1.73, user: 1.44, sys: 0.28, mem: 503484 ko) +COQC theories/PCUICInduction.v +theories/PCUICInduction.vo (real: 1.19, user: 0.89, sys: 0.29, mem: 481312 ko) +COQC theories/PCUICCheckerCompleteness.v +theories/PCUICCheckerCompleteness.vo (real: 0.85, user: 0.60, sys: 0.24, mem: 433064 ko) +COQC theories/TemplateToPCUIC.v +theories/Reflect.vo (real: 5.26, user: 4.53, sys: 0.70, mem: 552364 ko) +COQC theories/WeakeningEnv.v +theories/TemplateToPCUIC.vo (real: 0.98, user: 0.69, sys: 0.27, mem: 482472 ko) +COQC theories/PCUICAstUtils.v +theories/WeakeningEnv.vo (real: 3.33, user: 2.80, sys: 0.50, mem: 512292 ko) +COQC theories/Checker.v +theories/PCUICAstUtils.vo (real: 3.13, user: 2.78, sys: 0.32, mem: 543424 ko) +COQC theories/PCUICReflect.v +theories/Checker.vo (real: 4.71, user: 4.00, sys: 0.69, mem: 555748 ko) +COQC theories/WcbvEval.v +theories/PCUICReflect.vo (real: 4.46, user: 4.11, sys: 0.32, mem: 543956 ko) +COQC theories/PCUICLiftSubst.v +theories/WcbvEval.vo (real: 5.56, user: 4.94, sys: 0.59, mem: 533768 ko) +COQC theories/Retyping.v +theories/Retyping.vo (real: 1.16, user: 0.90, sys: 0.26, mem: 524140 ko) +COQC theories/Normal.v +theories/Normal.vo (real: 1.10, user: 0.84, sys: 0.25, mem: 497360 ko) +COQC theories/Generation.v +theories/Generation.vo (real: 1.95, user: 1.69, sys: 0.25, mem: 514692 ko) +COQC theories/Closed.v +File "./theories/Closed.v", line 299, characters 2-42: +Warning: +Automatically inlined signature for type All_local_env. Use [Derive Signature for All_local_env.] to avoid this. +theories/PCUICLiftSubst.vo (real: 27.51, user: 26.28, sys: 0.94, mem: 597996 ko) +COQC theories/PCUICToTemplate.v +theories/PCUICToTemplate.vo (real: 1.33, user: 1.04, sys: 0.28, mem: 527408 ko) +COQC theories/PCUICUtils.v +theories/PCUICUtils.vo (real: 1.81, user: 1.47, sys: 0.33, mem: 527440 ko) +COQC theories/PCUICUnivSubst.v +theories/Closed.vo (real: 22.03, user: 21.55, sys: 0.36, mem: 603616 ko) +COQC theories/Weakening.v +theories/PCUICUnivSubst.vo (real: 3.67, user: 3.33, sys: 0.32, mem: 533884 ko) +COQC theories/PCUICEquality.v +theories/Weakening.vo (real: 16.17, user: 15.64, sys: 0.43, mem: 579100 ko) +COQC theories/Substitution.v +theories/PCUICEquality.vo (real: 40.79, user: 39.04, sys: 1.52, mem: 790088 ko) +COQC theories/PCUICPosition.v +theories/Substitution.vo (real: 29.09, user: 27.93, sys: 0.98, mem: 621392 ko) +COQC theories/All.v +theories/All.vo (real: 1.65, user: 1.29, sys: 0.34, mem: 545736 ko) +./update_plugin.sh +Renaming extracted files +make[4]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/checker' +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/checker' +make -C examples +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/examples' +coq_makefile -f _CoqProject -o Makefile.coq +Warning: ../template-coq/theories (used in -R or -Q) is not a subdirectory of the current directory + +make -f Makefile.coq pretty-timed +make[4]: Entering directory '/builds/coq/coq/_build_ci/metacoq/examples' +COQDEP VFILES +COQC demo.v +demo.vo (real: 1.94, user: 1.56, sys: 0.36, mem: 527740 ko) +COQC add_constructor.v +add_constructor.vo (real: 1.44, user: 1.13, sys: 0.30, mem: 524144 ko) +COQC tauto.v +tauto.vo (real: 20.77, user: 19.93, sys: 0.72, mem: 581920 ko) + Time | Peak Mem | File Name +-------------------------------------------- +0m22.62s | 581920 ko | Total Time / Peak Mem +-------------------------------------------- +0m19.93s | 581920 ko | tauto.vo +0m01.56s | 527740 ko | demo.vo +0m01.13s | 524144 ko | add_constructor.vo +make[4]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/examples' +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/examples' +theories/PCUICPosition.vo (real: 29.43, user: 28.24, sys: 1.03, mem: 723216 ko) +COQC theories/PCUICTyping.v +Axioms: +ind_guard : mutual_inductive_body -> bool +fix_guard : mfixpoint term -> bool +cofix_guard : mfixpoint term -> bool +theories/PCUICTyping.vo (real: 44.26, user: 42.82, sys: 1.17, mem: 727688 ko) +COQC theories/PCUICReduction.v +COQC theories/PCUICWeakeningEnv.v +theories/PCUICWeakeningEnv.vo (real: 5.17, user: 4.38, sys: 0.74, mem: 571076 ko) +COQC theories/PCUICGeneration.v +theories/PCUICReduction.vo (real: 6.98, user: 6.16, sys: 0.78, mem: 583116 ko) +COQC theories/PCUICNormal.v +theories/PCUICNormal.vo (real: 1.72, user: 1.37, sys: 0.33, mem: 551200 ko) +COQC theories/PCUICNameless.v +theories/PCUICGeneration.vo (real: 3.72, user: 3.34, sys: 0.36, mem: 586388 ko) +COQC theories/PCUICMetaTheory.v +theories/PCUICMetaTheory.vo (real: 1.26, user: 0.96, sys: 0.29, mem: 546928 ko) +COQC theories/PCUICChecker.v +theories/PCUICChecker.vo (real: 1.41, user: 1.11, sys: 0.29, mem: 549776 ko) +COQC theories/PCUICToTemplateCorrectness.v +theories/PCUICToTemplateCorrectness.vo (real: 8.69, user: 7.84, sys: 0.79, mem: 608576 ko) +COQC theories/PCUICCumulativity.v +theories/PCUICCumulativity.vo (real: 2.17, user: 1.85, sys: 0.30, mem: 561876 ko) +COQC theories/PCUICClosed.v +theories/PCUICNameless.vo (real: 15.98, user: 14.98, sys: 0.89, mem: 623196 ko) +COQC theories/PCUICPretty.v +theories/PCUICPretty.vo (real: 1.64, user: 1.30, sys: 0.33, mem: 551364 ko) +theories/PCUICClosed.vo (real: 24.65, user: 23.99, sys: 0.51, mem: 654592 ko) +COQC theories/PCUICWeakening.v +COQC theories/PCUICCSubst.v +theories/PCUICCSubst.vo (real: 1.93, user: 1.55, sys: 0.36, mem: 562424 ko) +COQC theories/PCUICWcbvEval.v +theories/PCUICWcbvEval.vo (real: 12.05, user: 11.54, sys: 0.43, mem: 589944 ko) +theories/PCUICWeakening.vo (real: 24.20, user: 23.42, sys: 0.64, mem: 685852 ko) +COQC theories/PCUICSigmaCalculus.v +COQC theories/PCUICUnivSubstitution.v +theories/PCUICUnivSubstitution.vo (real: 10.93, user: 10.41, sys: 0.45, mem: 621644 ko) +theories/PCUICSigmaCalculus.vo (real: 39.32, user: 38.12, sys: 0.96, mem: 657100 ko) +COQC theories/PCUICSubstitution.v +theories/PCUICSubstitution.vo (real: 26.54, user: 25.65, sys: 0.68, mem: 673140 ko) +COQC theories/PCUICParallelReduction.v +COQC theories/TemplateToPCUICCorrectness.v +theories/TemplateToPCUICCorrectness.vo (real: 13.77, user: 13.16, sys: 0.52, mem: 641024 ko) +theories/PCUICParallelReduction.vo (real: 29.43, user: 28.26, sys: 0.87, mem: 779308 ko) +COQC theories/PCUICParallelReductionConfluence.v +Axioms: +ind_guard : mutual_inductive_body → bool +FunctionalExtensionality.functional_extensionality_dep + : ∀ (A : Type) (B : A → Type) (f g : ∀ x : A, B x), + (∀ x : A, f x = g x) → f = g +fix_guard : mfixpoint term → bool +cofix_guard : mfixpoint term → bool +theories/PCUICParallelReductionConfluence.vo (real: 96.83, user: 94.58, sys: 1.69, mem: 849824 ko) +COQC theories/PCUICConfluence.v +theories/PCUICConfluence.vo (real: 35.96, user: 34.44, sys: 1.27, mem: 742788 ko) +COQC theories/PCUICContextConversion.v +theories/PCUICContextConversion.vo (real: 9.28, user: 8.74, sys: 0.48, mem: 629108 ko) +COQC theories/PCUICConversion.v +File "./theories/PCUICConversion.v", line 2097, characters 4-13: +Warning: +Automatically inlined signature for type clos_refl_trans_1n. Use [Derive Signature for clos_refl_trans_1n.] to avoid this. +File "./theories/PCUICConversion.v", line 2234, characters 4-37: +Warning: Cannot remove s'. [cannot-remove-as-expected,tactics] +theories/PCUICConversion.vo (real: 30.61, user: 29.65, sys: 0.79, mem: 750296 ko) +COQC theories/PCUICInversion.v +COQC theories/PCUICRetyping.v +theories/PCUICRetyping.vo (real: 1.94, user: 1.58, sys: 0.34, mem: 589768 ko) +theories/PCUICInversion.vo (real: 10.19, user: 9.35, sys: 0.77, mem: 622488 ko) +COQC theories/PCUICCtxShape.v +theories/PCUICCtxShape.vo (real: 2.23, user: 1.75, sys: 0.38, mem: 598288 ko) +COQC theories/PCUICContexts.v +theories/PCUICContexts.vo (real: 6.83, user: 6.33, sys: 0.45, mem: 615568 ko) +COQC theories/PCUICArities.v +theories/PCUICArities.vo (real: 8.61, user: 7.75, sys: 0.80, mem: 625664 ko) +COQC theories/PCUICSpine.v +theories/PCUICSpine.vo (real: 23.61, user: 22.85, sys: 0.63, mem: 706592 ko) +COQC theories/PCUICInductives.v +theories/PCUICInductives.vo (real: 19.89, user: 19.08, sys: 0.66, mem: 683776 ko) +COQC theories/PCUICValidity.v +theories/PCUICValidity.vo (real: 4.40, user: 3.99, sys: 0.36, mem: 624912 ko) +COQC theories/PCUICAlpha.v +COQC theories/PCUICInductiveInversion.v +theories/PCUICAlpha.vo (real: 10.12, user: 9.58, sys: 0.47, mem: 684644 ko) +theories/PCUICInductiveInversion.vo (real: 10.95, user: 10.39, sys: 0.48, mem: 661964 ko) +COQC theories/PCUICSR.v +Axioms: +todounivs : forall A : Type, A +todoeta : forall A : Type, A +ind_guard : mutual_inductive_body -> bool +FunctionalExtensionality.functional_extensionality_dep + : forall (A : Type) (B : A -> Type) (f g : forall x : A, B x), + (forall x : A, f x = g x) -> f = g +fix_guard_subst_instance + : forall (mfix : mfixpoint term) (u : Instance.t), + fix_guard mfix -> + fix_guard + (map (map_def (subst_instance_constr u) (subst_instance_constr u)) mfix) +fix_guard_subst + : forall (mfix : list (def term)) (s : list term) (k : nat), + let k' := #|mfix| + k in + let mfix' := map (map_def (subst s k) (subst s k')) mfix in + fix_guard mfix -> fix_guard mfix' +fix_guard_red1 + : forall (Σ : global_env) (Γ : context) (mfix mfix' : mfixpoint term) + (idx : nat), + fix_guard mfix -> + red1 Σ Γ (tFix mfix idx) (tFix mfix' idx) -> fix_guard mfix' +fix_guard_lift + : forall (mfix : list (def term)) (n k : nat), + let k' := #|mfix| + k in + let mfix' := map (map_def (lift n k) (lift n k')) mfix in + fix_guard mfix -> fix_guard mfix' +fix_guard : mfixpoint term -> bool +cofix_guard_subst_instance + : forall (mfix : mfixpoint term) (u : Instance.t), + cofix_guard mfix -> + cofix_guard + (map (map_def (subst_instance_constr u) (subst_instance_constr u)) mfix) +cofix_guard_subst + : forall (mfix : list (def term)) (s : list term) (k : nat), + let k' := #|mfix| + k in + let mfix' := map (map_def (subst s k) (subst s k')) mfix in + cofix_guard mfix -> cofix_guard mfix' +cofix_guard_red1 + : forall (Σ : global_env) (Γ : context) (mfix mfix' : mfixpoint term) + (idx : nat), + cofix_guard mfix -> + red1 Σ Γ (tCoFix mfix idx) (tCoFix mfix' idx) -> cofix_guard mfix' +cofix_guard_lift + : forall (mfix : list (def term)) (n k : nat), + let k' := #|mfix| + k in + let mfix' := map (map_def (lift n k) (lift n k')) mfix in + cofix_guard mfix -> cofix_guard mfix' +cofix_guard : mfixpoint term -> bool +theories/PCUICSR.vo (real: 82.63, user: 80.36, sys: 1.84, mem: 975764 ko) +COQC theories/PCUICPrincipality.v +Axioms: +todounivs : forall A : Type@{todounivs.u0}, A +todoeta : forall A : Type@{todoeta.u0}, A +ind_guard : mutual_inductive_body -> bool +FunctionalExtensionality.functional_extensionality_dep + : forall + (A : Type@{FunctionalExtensionality.functional_extensionality_dep.u0}) + (B : A -> + Type@{FunctionalExtensionality.functional_extensionality_dep.u1}) + (f g : forall x : A, B x), (forall x : A, f x = g x) -> f = g +PCUICUnivSubstitution.fix_guard_subst_instance + : forall (mfix : mfixpoint term) (u : Instance.t), + fix_guard mfix -> + fix_guard + (map (map_def (subst_instance_constr u) (subst_instance_constr u)) mfix) +fix_guard_subst + : forall (mfix : list (def term)) (s : list term) (k : nat), + let k' := #|mfix| + k in + let mfix' := map (map_def (subst s k) (subst s k')) mfix in + fix_guard mfix -> fix_guard mfix' +fix_guard_red1 + : forall (Σ : global_env) (Γ : context) (mfix mfix' : mfixpoint term) + (idx : nat), + fix_guard mfix -> + red1 Σ Γ (tFix mfix idx) (tFix mfix' idx) -> fix_guard mfix' +fix_guard_lift + : forall (mfix : list (def term)) (n k : nat), + let k' := #|mfix| + k in + let mfix' := map (map_def (lift n k) (lift n k')) mfix in + fix_guard mfix -> fix_guard mfix' +fix_guard_eq_term + : forall (mfix mfix' : mfixpoint term) (idx : nat), + fix_guard mfix -> tFix mfix idx ≡ tFix mfix' idx -> fix_guard mfix' +fix_guard : mfixpoint term -> bool +PCUICUnivSubstitution.cofix_guard_subst_instance + : forall (mfix : mfixpoint term) (u : Instance.t), + cofix_guard mfix -> + cofix_guard + (map (map_def (subst_instance_constr u) (subst_instance_constr u)) mfix) +cofix_guard_subst + : forall (mfix : list (def term)) (s : list term) (k : nat), + let k' := #|mfix| + k in + let mfix' := map (map_def (subst s k) (subst s k')) mfix in + cofix_guard mfix -> cofix_guard mfix' +cofix_guard_red1 + : forall (Σ : global_env) (Γ : context) (mfix mfix' : mfixpoint term) + (idx : nat), + cofix_guard mfix -> + red1 Σ Γ (tCoFix mfix idx) (tCoFix mfix' idx) -> cofix_guard mfix' +cofix_guard_lift + : forall (mfix : list (def term)) (n k : nat), + let k' := #|mfix| + k in + let mfix' := map (map_def (lift n k) (lift n k')) mfix in + cofix_guard mfix -> cofix_guard mfix' +cofix_guard_eq_term + : forall (mfix mfix' : mfixpoint term) (idx : nat), + cofix_guard mfix -> + tCoFix mfix idx ≡ tCoFix mfix' idx -> cofix_guard mfix' +cofix_guard : mfixpoint term -> bool +theories/PCUICPrincipality.vo (real: 27.66, user: 26.11, sys: 1.08, mem: 959132 ko) +COQC theories/PCUICSafeLemmata.v +theories/PCUICSafeLemmata.vo (real: 7.45, user: 6.54, sys: 0.85, mem: 667924 ko) +COQC theories/PCUICSN.v +COQC theories/PCUICElimination.v +theories/PCUICSN.vo (real: 2.47, user: 2.12, sys: 0.33, mem: 630488 ko) +theories/PCUICElimination.vo (real: 8.12, user: 7.64, sys: 0.44, mem: 646256 ko) +# echo "All done, moving extraction files!" +# ./clean_extraction.sh +make[4]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/pcuic' +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/pcuic' +make -C safechecker +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/safechecker' +cat metacoq-config > _CoqProject +cat _CoqProject.in >> _CoqProject +coq_makefile -f _CoqProject -o Makefile.safechecker +Warning: ../template-coq/theories (used in -R or -Q) is not a subdirectory of the current directory + +make -f Makefile.safechecker +make[4]: Entering directory '/builds/coq/coq/_build_ci/metacoq/safechecker' +COQDEP VFILES +COQC theories/PCUICSafeReduce.v +theories/PCUICSafeReduce.vo (real: 121.19, user: 119.92, sys: 0.74, mem: 1136588 ko) +COQC theories/PCUICSafeConversion.v +theories/PCUICSafeConversion.vo (real: 140.66, user: 139.40, sys: 0.64, mem: 1007764 ko) +COQC theories/PCUICSafeChecker.v +File "./theories/PCUICSafeChecker.v", line 1035, characters 4-15: +Warning: +Automatically inlined signature for type Forall. Use [Derive Signature for Forall.] to avoid this. +File "./theories/PCUICSafeChecker.v", line 1039, characters 4-19: +Warning: +Automatically inlined signature for type Forall. Use [Derive Signature for Forall.] to avoid this. +Axioms: +todounivs : forall A : Type, A +todoeta : forall A : Type, A +todo : string -> forall A : Type, A +proof_irrelevance : forall (P : Prop) (p1 p2 : P), p1 = p2 +normalisation' + : forall (cf : checker_flags) (Σ : global_env_ext) (Γ : context) (t : term), + wf Σ -> wellformed Σ Γ t -> Acc (cored Σ.1 Γ) t +ind_guard : mutual_inductive_body -> bool +functional_extensionality_dep + : forall (A : Type) (B : A -> Type) (f g : forall x : A, B x), + (forall x : A, f x = g x) -> f = g +PCUICUnivSubstitution.fix_guard_subst_instance + : forall (mfix : mfixpoint term) (u : Instance.t), + fix_guard mfix -> + fix_guard + (map (map_def (subst_instance_constr u) (subst_instance_constr u)) mfix) +fix_guard_subst + : forall (mfix : list (def term)) (s : list term) (k : nat), + let k' := (#|mfix| + k)%nat in + let mfix' := map (map_def (subst s k) (subst s k')) mfix in + fix_guard mfix -> fix_guard mfix' +fix_guard_red1 + : forall (Σ : global_env) (Γ : context) (mfix mfix' : mfixpoint term) + (idx : nat), + fix_guard mfix -> + red1 Σ Γ (tFix mfix idx) (tFix mfix' idx) -> fix_guard mfix' +fix_guard_lift + : forall (mfix : list (def term)) (n k : nat), + let k' := (#|mfix| + k)%nat in + let mfix' := map (map_def (lift n k) (lift n k')) mfix in + fix_guard mfix -> fix_guard mfix' +fix_guard_eq_term + : forall (mfix mfix' : mfixpoint term) (idx : nat), + fix_guard mfix -> tFix mfix idx ≡ tFix mfix' idx -> fix_guard mfix' +fix_guard : mfixpoint term -> bool +PCUICUnivSubstitution.cofix_guard_subst_instance + : forall (mfix : mfixpoint term) (u : Instance.t), + cofix_guard mfix -> + cofix_guard + (map (map_def (subst_instance_constr u) (subst_instance_constr u)) mfix) +cofix_guard_subst + : forall (mfix : list (def term)) (s : list term) (k : nat), + let k' := (#|mfix| + k)%nat in + let mfix' := map (map_def (subst s k) (subst s k')) mfix in + cofix_guard mfix -> cofix_guard mfix' +cofix_guard_red1 + : forall (Σ : global_env) (Γ : context) (mfix mfix' : mfixpoint term) + (idx : nat), + cofix_guard mfix -> + red1 Σ Γ (tCoFix mfix idx) (tCoFix mfix' idx) -> cofix_guard mfix' +cofix_guard_lift + : forall (mfix : list (def term)) (n k : nat), + let k' := (#|mfix| + k)%nat in + let mfix' := map (map_def (lift n k) (lift n k')) mfix in + cofix_guard mfix -> cofix_guard mfix' +cofix_guard_eq_term + : forall (mfix mfix' : mfixpoint term) (idx : nat), + cofix_guard mfix -> + tCoFix mfix idx ≡ tCoFix mfix' idx -> cofix_guard mfix' +cofix_guard : mfixpoint term -> bool +theories/PCUICSafeChecker.vo (real: 56.94, user: 56.09, sys: 0.61, mem: 958816 ko) +COQC theories/SafeTemplateChecker.v +COQC theories/PCUICSafeRetyping.v +theories/SafeTemplateChecker.vo (real: 2.78, user: 2.42, sys: 0.35, mem: 703592 ko) +COQC theories/Extraction.v +theories/PCUICSafeRetyping.vo (real: 6.81, user: 6.30, sys: 0.48, mem: 733700 ko) +theories/Extraction.vo (real: 4.93, user: 4.47, sys: 0.43, mem: 749140 ko) +echo "Done extracting the safe checker, moving extraction files!" +Done extracting the safe checker, moving extraction files! +./clean_extraction.sh +Cleaning result of extraction +Moving All_Forall.ml to all_Forall.ml +Moving All_Forall.mli to all_Forall.mli +Moving Ascii.ml to ascii.ml +Moving Ascii.mli to ascii.mli +Moving Ast0.ml to ast0.ml +Moving Ast0.mli to ast0.mli +Moving BasicAst.ml to basicAst.ml +Moving BasicAst.mli to basicAst.mli +Moving Basics.ml to basics.ml +Moving Basics.mli to basics.mli +Moving BinInt.ml to binInt.ml +Moving BinInt.mli to binInt.mli +Moving BinNat.ml to binNat.ml +Moving BinNat.mli to binNat.mli +Moving BinNums.ml to binNums.ml +Moving BinNums.mli to binNums.mli +Moving BinPos.ml to binPos.ml +Moving BinPos.mli to binPos.mli +Moving Bool.ml to bool.ml +Moving Bool.mli to bool.mli +Moving Byte.ml to byte.ml +Moving Byte.mli to byte.mli +Moving Classes0.ml to classes0.ml +Moving Classes0.mli to classes0.mli +Moving Compare_dec.ml to compare_dec.ml +Moving Compare_dec.mli to compare_dec.mli +Moving Datatypes.ml to datatypes.ml +Moving Datatypes.mli to datatypes.mli +Moving Environment.ml to environment.ml +Moving Environment.mli to environment.mli +Moving EqDecInstances.ml to eqDecInstances.ml +Moving EqDecInstances.mli to eqDecInstances.mli +Moving EqdepFacts.ml to eqdepFacts.ml +Moving EqdepFacts.mli to eqdepFacts.mli +Moving Equalities.ml to equalities.ml +Moving Equalities.mli to equalities.mli +Moving List0.ml to list0.ml +Moving List0.mli to list0.mli +Moving MCCompare.ml to mCCompare.ml +Moving MCCompare.mli to mCCompare.mli +Moving MCList.ml to mCList.ml +Moving MCList.mli to mCList.mli +Moving MCOption.ml to mCOption.ml +Moving MCOption.mli to mCOption.mli +Moving MCProd.ml to mCProd.ml +Moving MCProd.mli to mCProd.mli +Moving MCString.ml to mCString.ml +Moving MCString.mli to mCString.mli +Moving MSetDecide.ml to mSetDecide.ml +Moving MSetDecide.mli to mSetDecide.mli +Moving MSetFacts.ml to mSetFacts.ml +Moving MSetFacts.mli to mSetFacts.mli +Moving MSetInterface.ml to mSetInterface.ml +Moving MSetInterface.mli to mSetInterface.mli +Moving MSetList.ml to mSetList.ml +Moving MSetList.mli to mSetList.mli +Moving MSetProperties.ml to mSetProperties.ml +Moving MSetProperties.mli to mSetProperties.mli +Moving MSetWeakList.ml to mSetWeakList.ml +Moving MSetWeakList.mli to mSetWeakList.mli +Moving Nat0.ml to nat0.ml +Moving Nat0.mli to nat0.mli +Moving Orders.ml to orders.ml +Moving Orders.mli to orders.mli +Moving OrdersFacts.ml to ordersFacts.ml +Moving OrdersFacts.mli to ordersFacts.mli +Moving OrdersLists.ml to ordersLists.ml +Moving OrdersLists.mli to ordersLists.mli +Moving OrdersTac.ml to ordersTac.ml +Moving OrdersTac.mli to ordersTac.mli +Moving PCUICAst.ml to pCUICAst.ml +Moving PCUICAst.mli to pCUICAst.mli +Moving PCUICAstUtils.ml to pCUICAstUtils.ml +Moving PCUICAstUtils.mli to pCUICAstUtils.mli +Moving PCUICChecker.ml to pCUICChecker.ml +Moving PCUICChecker.mli to pCUICChecker.mli +Moving PCUICCumulativity.ml to pCUICCumulativity.ml +Moving PCUICCumulativity.mli to pCUICCumulativity.mli +Moving PCUICEquality.ml to pCUICEquality.ml +Moving PCUICEquality.mli to pCUICEquality.mli +Moving PCUICLiftSubst.ml to pCUICLiftSubst.ml +Moving PCUICLiftSubst.mli to pCUICLiftSubst.mli +Moving PCUICNormal.ml to pCUICNormal.ml +Moving PCUICNormal.mli to pCUICNormal.mli +Moving PCUICPosition.ml to pCUICPosition.ml +Moving PCUICPosition.mli to pCUICPosition.mli +Moving PCUICPretty.ml to pCUICPretty.ml +Moving PCUICPretty.mli to pCUICPretty.mli +Moving PCUICReflect.ml to pCUICReflect.ml +Moving PCUICReflect.mli to pCUICReflect.mli +Moving PCUICSafeChecker.ml to pCUICSafeChecker.ml +Moving PCUICSafeChecker.mli to pCUICSafeChecker.mli +Moving PCUICSafeConversion.ml to pCUICSafeConversion.ml +Moving PCUICSafeConversion.mli to pCUICSafeConversion.mli +Moving PCUICSafeLemmata.ml to pCUICSafeLemmata.ml +Moving PCUICSafeLemmata.mli to pCUICSafeLemmata.mli +Moving PCUICSafeReduce.ml to pCUICSafeReduce.ml +Moving PCUICSafeReduce.mli to pCUICSafeReduce.mli +Moving PCUICTyping.ml to pCUICTyping.ml +Moving PCUICTyping.mli to pCUICTyping.mli +Moving PCUICUnivSubst.ml to pCUICUnivSubst.ml +Moving PCUICUnivSubst.mli to pCUICUnivSubst.mli +Moving PeanoNat.ml to peanoNat.ml +Moving PeanoNat.mli to peanoNat.mli +Moving SafeTemplateChecker.ml to safeTemplateChecker.ml +Moving SafeTemplateChecker.mli to safeTemplateChecker.mli +Moving Specif.ml to specif.ml +Moving Specif.mli to specif.mli +Moving String0.ml to string0.ml +Moving String0.mli to string0.mli +Moving TemplateToPCUIC.ml to templateToPCUIC.ml +Moving TemplateToPCUIC.mli to templateToPCUIC.mli +Moving Typing0.ml to typing0.ml +Moving Typing0.mli to typing0.mli +Moving UnivSubst0.ml to univSubst0.ml +Moving UnivSubst0.mli to univSubst0.mli +Moving Universes0.ml to universes0.ml +Moving Universes0.mli to universes0.mli +Moving config0.ml to config0.ml +mv: 'config0.ml' and 'config0.ml' are the same file +Moving config0.mli to config0.mli +mv: 'config0.mli' and 'config0.mli' are the same file +Moving g_metacoq_safechecker.ml to g_metacoq_safechecker.ml +mv: 'g_metacoq_safechecker.ml' and 'g_metacoq_safechecker.ml' are the same file +Moving g_metacoq_safechecker.mlg to g_metacoq_safechecker.mlg +mv: 'g_metacoq_safechecker.mlg' and 'g_metacoq_safechecker.mlg' are the same file +Moving metacoq_safechecker_plugin.mlpack to metacoq_safechecker_plugin.mlpack +mv: 'metacoq_safechecker_plugin.mlpack' and 'metacoq_safechecker_plugin.mlpack' are the same file +Moving monad_utils.ml to monad_utils.ml +mv: 'monad_utils.ml' and 'monad_utils.ml' are the same file +Moving monad_utils.mli to monad_utils.mli +mv: 'monad_utils.mli' and 'monad_utils.mli' are the same file +Moving ssrbool.ml to ssrbool.ml +mv: 'ssrbool.ml' and 'ssrbool.ml' are the same file +Moving ssrbool.mli to ssrbool.mli +mv: 'ssrbool.mli' and 'ssrbool.mli' are the same file +Moving uGraph0.ml to uGraph0.ml +mv: 'uGraph0.ml' and 'uGraph0.ml' are the same file +Moving uGraph0.mli to uGraph0.mli +mv: 'uGraph0.mli' and 'uGraph0.mli' are the same file +Moving utils.ml to utils.ml +mv: 'utils.ml' and 'utils.ml' are the same file +Moving utils.mli to utils.mli +mv: 'utils.mli' and 'utils.mli' are the same file +Moving wGraph.ml to wGraph.ml +mv: 'wGraph.ml' and 'wGraph.ml' are the same file +Moving wGraph.mli to wGraph.mli +mv: 'wGraph.mli' and 'wGraph.mli' are the same file +Removing: src/all_Forall.ml src/all_Forall.mli src/ascii.ml src/ascii.mli src/ast0.ml src/ast0.mli src/ast_denoter.ml src/ast_quoter.ml src/astUtils.ml src/astUtils.mli src/basicAst.ml src/basicAst.mli src/basics.ml src/basics.mli src/binInt.ml src/binInt.mli src/binNat.ml src/binNat.mli src/binNums.ml src/binNums.mli src/binPosDef.ml src/binPosDef.mli src/binPos.ml src/binPos.mli src/bool.ml src/bool.mli src/common0.ml src/common0.mli src/compare_dec.ml src/compare_dec.mli src/config0.ml src/config0.mli src/cRelationClasses.ml src/cRelationClasses.mli src/datatypes.ml src/datatypes.mli src/decimal.ml src/decimal.mli src/denoter.ml src/environment.ml src/environment.mli src/equalities.ml src/equalities.mli src/extractable.ml src/extractable.mli src/hexadecimal.ml src/hexadecimal.mli src/liftSubst.ml src/liftSubst.mli src/list0.ml src/list0.mli src/logic0.ml src/logic0.mli src/mCPrelude.mli src/mCPrelude.ml src/mCCompare.ml src/mCCompare.mli src/mCList.ml src/mCList.mli src/mCOption.ml src/mCOption.mli src/mCProd.ml src/mCProd.mli src/mCRelations.ml src/mCRelations.mli src/mCString.ml src/mCString.mli src/mSetDecide.ml src/mSetDecide.mli src/mSetFacts.ml src/mSetFacts.mli src/mSetInterface.ml src/mSetInterface.mli src/mSetList.ml src/mSetList.mli src/mSetProperties.ml src/mSetProperties.mli src/nat0.ml src/nat0.mli src/numeral.ml src/numeral.mli src/orderedType0.ml src/orderedType0.mli src/ordersFacts.ml src/ordersFacts.mli src/ordersLists.ml src/ordersLists.mli src/orders.ml src/orders.mli src/ordersTac.ml src/ordersTac.mli src/peanoNat.ml src/peanoNat.mli src/plugin_core.ml src/plugin_core.mli src/pretty.ml src/pretty.mli src/reification.ml src/quoter.ml src/run_extractable.ml src/run_extractable.mli src/specif.ml src/specif.mli src/string0.ml src/string0.mli src/tm_util.ml src/universes0.ml src/universes0.mli src/univSubst0.ml src/univSubst0.mli +make[4]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/safechecker' +make -f Makefile.plugin +make[4]: Entering directory '/builds/coq/coq/_build_ci/metacoq/safechecker' +COQDEP VFILES +CAMLDEP src/safeTemplateChecker.mli +CAMLDEP src/pCUICSafeChecker.mli +CAMLDEP src/pCUICSafeConversion.mli +CAMLDEP src/pCUICSafeReduce.mli +CAMLDEP src/pCUICPretty.mli +CAMLDEP src/pCUICChecker.mli +CAMLDEP src/templateToPCUIC.mli +CAMLDEP src/pCUICSafeLemmata.mli +CAMLDEP src/pCUICNormal.mli +CAMLDEP src/pCUICCumulativity.mli +CAMLDEP src/pCUICPosition.mli +CAMLDEP src/pCUICUnivSubst.mli +CAMLDEP src/pCUICTyping.mli +CAMLDEP src/pCUICEquality.mli +CAMLDEP src/pCUICReflect.mli +CAMLDEP src/eqDecInstances.mli +CAMLDEP src/pCUICLiftSubst.mli +CAMLDEP src/pCUICAstUtils.mli +CAMLDEP src/pCUICAst.mli +CAMLDEP src/typing0.mli +CAMLDEP src/wGraph.mli +CAMLDEP src/uGraph0.mli +CAMLDEP src/utils.mli +CAMLDEP src/monad_utils.mli +CAMLDEP src/ssrbool.mli +CAMLDEP src/eqdepFacts.mli +CAMLDEP src/mSetWeakList.mli +CAMLDEP src/classes0.mli +OCAMLLIBDEP src/metacoq_safechecker_plugin.mlpack +CAMLDEP src/safeTemplateChecker.ml +CAMLDEP src/pCUICSafeChecker.ml +CAMLDEP src/pCUICSafeConversion.ml +CAMLDEP src/pCUICSafeReduce.ml +CAMLDEP src/pCUICPretty.ml +CAMLDEP src/pCUICChecker.ml +CAMLDEP src/templateToPCUIC.ml +CAMLDEP src/pCUICSafeLemmata.ml +CAMLDEP src/pCUICNormal.ml +CAMLDEP src/pCUICPosition.ml +CAMLDEP src/pCUICCumulativity.ml +CAMLDEP src/pCUICUnivSubst.ml +CAMLDEP src/pCUICTyping.ml +CAMLDEP src/pCUICEquality.ml +CAMLDEP src/pCUICReflect.ml +CAMLDEP src/eqDecInstances.ml +CAMLDEP src/pCUICLiftSubst.ml +CAMLDEP src/pCUICAstUtils.ml +CAMLDEP src/pCUICAst.ml +CAMLDEP src/typing0.ml +CAMLDEP src/wGraph.ml +CAMLDEP src/uGraph0.ml +CAMLDEP src/utils.ml +CAMLDEP src/monad_utils.ml +CAMLDEP src/ssrbool.ml +CAMLDEP src/eqdepFacts.ml +CAMLDEP src/classes0.ml +CAMLDEP src/mSetWeakList.ml +CAMLDEP src/g_metacoq_safechecker.ml +CAMLC -c src/monad_utils.mli +CAMLC -c src/mSetWeakList.mli +src/monad_utils.cmi (real: 0.10, user: 0.03, sys: 0.01, mem: 19196 ko) +CAMLC -c src/eqdepFacts.mli +src/mSetWeakList.cmi (real: 0.10, user: 0.03, sys: 0.01, mem: 20008 ko) +CAMLC -c src/utils.mli +src/utils.cmi (real: src/eqdep0.04Fac,t s.ucsmie r(:re al:0.03 , sys: 0.01, mem: 19340 ko) +0.04, user: 0.03, sys: 0.01, mem: 19268 ko) +CAMLC -c src/ssrbool.mli +CAMLC -c src/typing0.mli +src/typing0.cmi (real: 0.04, user: 0.02, sys: 0.01, mem: 20364 ko) +CAMLC -c src/classes0.mli +src/ssrbool.cmi (real: 0.05, user: 0.03, sys: 0.01, mem: 19332 ko) +CAMLC -c src/pCUICAst.mli +src/classes0.cmi (real: 0.05, user: 0.03, sys: 0.01, mem: 19328 ko) +CAMLC -c src/pCUICNormal.mli +src/pCUICAst.cmi (real: 0.05, user: 0.03, sys: 0.01, mem: 21440 ko) +CAMLC -c src/pCUICCumulativity.mli +src/pCUICNormal.cmi (real: 0.04, user: 0.03, sys: 0.01, mem: 19372 ko) +CAMLOPT -c -for-pack Metacoq_safechecker_plugin src/monad_utils.ml +src/pCUICCumulativity.cmi (real: 0.03, user: 0.02, sys: 0.01, mem: 19220 ko) +CAMLOPT -c -for-pack Metacoq_safechecker_plugin src/mSetWeakList.ml +src/monad_utils.cmx (real: 0.05, user: 0.03, sys: 0.01, mem: 21960 ko) +CAMLOPT -c -for-pack Metacoq_safechecker_plugin src/eqdepFacts.ml +src/mSetWeakList.cmx (real: 0.07, user: 0.05, sys: 0.01, mem: 25168 ko) +CAMLOPT -c -for-pack Metacoq_safechecker_plugin src/utils.ml +src/eqdepFacts.cmx (real: 0.04, user: 0.02, sys: 0.02, mem: 22016 ko) +CAMLOPT -c -for-pack Metacoq_safechecker_plugin src/ssrbool.ml +src/utils.cmx (real: 0.05, user: 0.03, sys: 0.01, mem: 22096 ko) +CAMLC -c src/wGraph.mli +src/ssrbool.cmx (real: 0.04, user: 0.02, sys: 0.01, mem: 22104 ko) +CAMLOPT -c -for-pack Metacoq_safechecker_plugin src/typing0.ml +src/wGraph.cmi (real: 0.05, user: 0.04, sys: 0.01, mem: 22812 ko) +CAMLOPT -c -for-pack Metacoq_safechecker_plugin src/classes0.ml +src/typing0.cmx (real: 0.07, user: 0.04, sys: 0.02, mem: 24164 ko) +CAMLOPT -c -for-pack Metacoq_safechecker_plugin src/pCUICAst.ml +src/classes0.cmx (real: 0.04, user: 0.03, sys: 0.01, mem: 22056 ko) +CAMLC -c src/pCUICAstUtils.mli +src/pCUICAstUtils.cmi (real: 0.04, user: 0.03, sys: 0.01, mem: 20292 ko) +CAMLC -c src/pCUICUnivSubst.mli +src/pCUICAst.cmx (real: 0.08, user: 0.05, sys: 0.02, mem: 26084 ko) +CAMLC -c src/pCUICLiftSubst.mli +src/pCUICUnivSubst.cmi (real: 0.04, user: 0.04, sys: 0.00, mem: 20452 ko) +CAMLC -c src/eqDecInstances.mli +src/pCUICLiftSubst.cmi (real: 0.04, user: 0.02, sys: 0.01, mem: 20432 ko) +CAMLC -c src/pCUICReflect.mli +src/eqDecInstances.cmi (real: 0.03, user: 0.02, sys: 0.01, mem: 19260 ko) +CAMLOPT -c -for-pack Metacoq_safechecker_plugin src/pCUICNormal.ml +src/pCUICReflect.cmi (real: 0.04, user: 0.02, sys: 0.01, mem: 20232 ko) +CAMLC -c src/pCUICPosition.mli +src/pCUICNormal.cmx (real: 0.04, user: 0.03, sys: 0.01, mem: 22004 ko) +CAMLC -c src/templateToPCUIC.mli +src/pCUICPosition.cmi (real: 0.04, user: 0.02, sys: 0.01, mem: 20460 ko) +CAMLC -c src/pCUICSafeLemmata.mli +src/pCUICSafeLemmata.cmi (real: 0.03, user: 0.02, sys: 0.01, mem: 19172 ko) +CAMLOPT -c -for-pack Metacoq_safechecker_plugin src/pCUICCumulativity.ml +src/templateToPCUIC.cmi (real: 0.05, user: 0.04, sys: 0.01, mem: 20348 ko) +CAMLOPT -c -for-pack Metacoq_safechecker_plugin src/wGraph.ml +src/pCUICCumulativity.cmx (real: 0.04, user: 0.03, sys: 0.01, mem: 22036 ko) +CAMLC -c src/uGraph0.mli +src/uGraph0.cmi (real: 0.07, user: 0.05, sys: 0.01, mem: 24772 ko) +CAMLOPT -c -for-pack Metacoq_safechecker_plugin src/pCUICAstUtils.ml +src/wGraph.cmx (real: 0.14, user: 0.12, sys: 0.02, mem: 31828 ko) +CAMLOPT -c -for-pack Metacoq_safechecker_plugin src/pCUICUnivSubst.ml +src/pCUICAstUtils.cmx (real: 0.08, user: 0.06, sys: 0.02, mem: 25948 ko) +CAMLOPT -c -for-pack Metacoq_safechecker_plugin src/pCUICLiftSubst.ml +src/pCUICUnivSubst.cmx (real: 0.06, user: 0.04, sys: 0.01, mem: 25096 ko) +CAMLOPT -c -for-pack Metacoq_safechecker_plugin src/eqDecInstances.ml +src/eqDecInstances.cmx (real: 0.05, user: 0.03, sys: 0.02, mem: 22024 ko) +CAMLOPT -c -for-pack Metacoq_safechecker_plugin src/pCUICReflect.ml +src/pCUICLiftSubst.cmx (real: 0.08, user: 0.06, sys: 0.02, mem: 26296 ko) +CAMLC -c src/pCUICEquality.mli +src/pCUICReflect.cmx (real: 0.06, user: 0.05, sys: 0.01, mem: 24360 ko) +CAMLC -c src/pCUICTyping.mli +src/pCUICEquality.cmi (real: 0.04, user: 0.03, sys: 0.01, mem: 20432 ko) +CAMLOPT -c -for-pack Metacoq_safechecker_plugin src/pCUICPosition.ml +src/pCUICTyping.cmi (real: 0.04, user: 0.03, sys: 0.01, mem: 21428 ko) +CAMLOPT -c -for-pack Metacoq_safechecker_plugin src/templateToPCUIC.ml +src/pCUICPosition.cmx (real: 0.09, user: 0.07, sys: 0.01, mem: 26028 ko) +CAMLOPT -c -for-pack Metacoq_safechecker_plugin src/pCUICSafeLemmata.ml +src/templateToPCUIC.cmx (real: 0.07, user: 0.06, sys: 0.01, mem: 25572 ko) +CAMLC -c src/pCUICSafeReduce.mli +src/pCUICSafeLemmata.cmx (real: 0.05, user: 0.03, sys: 0.01, mem: 22056 ko) +CAMLOPT -c -for-pack Metacoq_safechecker_plugin src/uGraph0.ml +src/pCUICSafeReduce.cmi (real: 0.04, user: 0.03, sys: 0.01, mem: 21588 ko) +CAMLOPT -c -for-pack Metacoq_safechecker_plugin src/pCUICEquality.ml +src/pCUICEquality.cmx (real: 0.07, user: 0.05, sys: 0.02, mem: 26416 ko) +CAMLOPT -c -for-pack Metacoq_safechecker_plugin src/pCUICTyping.ml +src/uGraph0.cmx (real: 0.13, user: 0.11, sys: 0.02, mem: 30828 ko) +CAMLC -c src/pCUICChecker.mli +src/pCUICChecker.cmi (real: 0.04, user: 0.03, sys: 0.01, mem: 21248 ko) +CAMLC -c src/pCUICSafeConversion.mli +src/pCUICTyping.cmx (real: 0.10, user: 0.08, sys: 0.02, mem: 27292 ko) +CAMLOPT -c -for-pack Metacoq_safechecker_plugin src/pCUICChecker.ml +src/pCUICSafeConversion.cmi (real: 0.05, user: 0.04, sys: 0.01, mem: 23348 ko) +CAMLC -c src/pCUICPretty.mli +src/pCUICChecker.cmx (real: 0.06, user: 0.04, sys: 0.02, mem: 25104 ko) +CAMLOPT -c -for-pack Metacoq_safechecker_plugin src/pCUICSafeReduce.ml +src/pCUICPretty.cmi (real: 0.04, user: 0.03, sys: 0.01, mem: 20340 ko) +CAMLOPT -c -for-pack Metacoq_safechecker_plugin src/pCUICPretty.ml +src/pCUICSafeReduce.cmx (real: 0.10, user: 0.07, sys: 0.02, mem: 27680 ko) +CAMLC -c src/pCUICSafeChecker.mli +src/pCUICPretty.cmx (real: 0.11, user: 0.09, sys: 0.02, mem: 28948 ko) +CAMLOPT -c -for-pack Metacoq_safechecker_plugin src/pCUICSafeConversion.ml +src/pCUICSafeChecker.cmi (real: 0.06, user: 0.06, sys: 0.00, mem: 24128 ko) +CAMLC -c src/safeTemplateChecker.mli +src/safeTemplateChecker.cmi (real: 0.05, user: 0.03, sys: 0.01, mem: 21632 ko) +src/pCUICSafeConversion.cmx (real: 0.27, user: 0.24, sys: 0.03, mem: 43304 ko) +CAMLOPT -c -for-pack Metacoq_safechecker_plugin src/pCUICSafeChecker.ml +src/pCUICSafeChecker.cmx (real: 0.34, user: 0.29, sys: 0.04, mem: 43492 ko) +CAMLOPT -c -for-pack Metacoq_safechecker_plugin src/safeTemplateChecker.ml +src/safeTemplateChecker.cmx (real: 0.07, user: 0.05, sys: 0.01, mem: 27148 ko) +CAMLOPT -c -for-pack Metacoq_safechecker_plugin src/g_metacoq_safechecker.ml +src/g_metacoq_safechecker.cmx (real: 0.11, user: 0.09, sys: 0.02, mem: 35368 ko) +CAMLOPT -pack -o src/metacoq_safechecker_plugin.cmx +src/metacoq_safechecker_plugin.cmx (real: 0.10, user: 0.06, sys: 0.03, mem: 30436 ko) +CAMLOPT -a -o src/metacoq_safechecker_plugin.cmxa +src/metacoq_safechecker_plugin.cmxa (real: 0.05, user: 0.00, sys: 0.01, mem: 13624 ko) +CAMLOPT -shared -o src/metacoq_safechecker_plugin.cmxs +src/metacoq_safechecker_plugin.cmxs (real: 0.14, user: 0.11, sys: 0.03, mem: 20224 ko) +COQC theories/Loader.v +theories/Loader.vo (real: 0.09, user: 0.05, sys: 0.03, mem: 63536 ko) +make[4]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/safechecker' +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/safechecker' +make -C erasure +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/erasure' +cat metacoq-config > _CoqProject +cat _CoqProject.in >> _CoqProject +coq_makefile -f _CoqProject -o Makefile.erasure +Warning: ../template-coq/theories (used in -R or -Q) is not a subdirectory of the current directory + +make -f Makefile.erasure +make[4]: Entering directory '/builds/coq/coq/_build_ci/metacoq/erasure' +COQDEP VFILES +COQC theories/EAst.v +theories/EAst.vo (real: 0.97, user: 0.72, sys: 0.24, mem: 477800 ko) +COQC theories/EAstUtils.v +COQC theories/EInduction.v +theories/EInduction.vo (real: 0.97, user: 0.71, sys: 0.25, mem: 479012 ko) +COQC theories/Extract.v +theories/EAstUtils.vo (real: 1.36, user: 1.10, sys: 0.26, mem: 487520 ko) +COQC theories/ELiftSubst.v +theories/Extract.vo (real: 1.89, user: 1.57, sys: 0.32, mem: 617808 ko) +COQC theories/EArities.v +theories/EArities.vo (real: 6.12, user: 5.66, sys: 0.42, mem: 643396 ko) +theories/ELiftSubst.vo (real: 10.89, user: 10.08, sys: 0.75, mem: 521520 ko) +COQC theories/ETyping.v +COQC theories/ECSubst.v +theories/ETyping.vo (real: 1.01, user: 0.73, sys: 0.27, mem: 487644 ko) +COQC theories/EPretty.v +theories/ECSubst.vo (real: 1.31, user: 1.05, sys: 0.25, mem: 512080 ko) +COQC theories/EWndEval.v +theories/EPretty.vo (real: 1.02, user: 0.77, sys: 0.24, mem: 488076 ko) +COQC theories/EWcbvEval.v +theories/EWndEval.vo (real: 0.97, user: 0.70, sys: 0.26, mem: 485084 ko) +theories/EWcbvEval.vo (real: 4.15, user: 3.85, sys: 0.28, mem: 520080 ko) +COQC theories/EAll.v +COQC theories/Prelim.v +theories/EAll.vo (real: 1.76, user: 1.42, sys: 0.32, mem: 619396 ko) +theories/Prelim.vo (real: 3.82, user: 3.39, sys: 0.40, mem: 741428 ko) +COQC theories/ESubstitution.v +COQC theories/EInversion.v +theories/EInversion.vo (real: 3.19, user: 2.67, sys: 0.50, mem: 729072 ko) +theories/ESubstitution.vo (real: 14.12, user: 13.39, sys: 0.67, mem: 794032 ko) +COQC theories/ErasureCorrectness.v +Axioms: +todounivs : forall A : Type, A +todoeta : forall A : Type, A +todo : string -> forall A : Type, A +ind_guard : mutual_inductive_body -> bool +functional_extensionality_dep + : forall (A : Type) (B : A -> Type) (f g : forall x : A, B x), + (forall x : A, f x = g x) -> f = g +fix_guard_subst_instance + : forall (mfix : mfixpoint term) (u : Instance.t), + fix_guard mfix -> + fix_guard + (map (map_def (subst_instance_constr u) (subst_instance_constr u)) mfix) +fix_guard_subst + : forall (mfix : list (def term)) (s : list term) (k : nat), + let k' := #|mfix| + k in + let mfix' := + map (map_def (PCUICLiftSubst.subst s k) (PCUICLiftSubst.subst s k')) + mfix in + fix_guard mfix -> fix_guard mfix' +fix_guard_red1 + : forall (Σ : global_env) (Γ : context) (mfix mfix' : mfixpoint term) + (idx : nat), + fix_guard mfix -> + red1 Σ Γ (tFix mfix idx) (tFix mfix' idx) -> fix_guard mfix' +fix_guard_lift + : forall (mfix : list (def term)) (n k : nat), + let k' := #|mfix| + k in + let mfix' := + map (map_def (PCUICLiftSubst.lift n k) (PCUICLiftSubst.lift n k')) mfix + in + fix_guard mfix -> fix_guard mfix' +fix_guard_eq_term + : forall (mfix mfix' : mfixpoint term) (idx : nat), + fix_guard mfix -> + PCUICEquality.upto_names (tFix mfix idx) (tFix mfix' idx) -> + fix_guard mfix' +fix_guard : mfixpoint term -> bool +erases_closed + : forall (Σ : global_env_ext) (Γ : list context_decl) + (a : term) (e : E.term), + PCUICLiftSubst.closedn #|Γ| a -> Σ;;; Γ |- a ⇝ℇ e -> closedn #|Γ| e +cofix_guard_subst_instance + : forall (mfix : mfixpoint term) (u : Instance.t), + cofix_guard mfix -> + cofix_guard + (map (map_def (subst_instance_constr u) (subst_instance_constr u)) mfix) +cofix_guard_subst + : forall (mfix : list (def term)) (s : list term) (k : nat), + let k' := #|mfix| + k in + let mfix' := + map (map_def (PCUICLiftSubst.subst s k) (PCUICLiftSubst.subst s k')) + mfix in + cofix_guard mfix -> cofix_guard mfix' +cofix_guard_red1 + : forall (Σ : global_env) (Γ : context) (mfix mfix' : mfixpoint term) + (idx : nat), + cofix_guard mfix -> + red1 Σ Γ (tCoFix mfix idx) (tCoFix mfix' idx) -> cofix_guard mfix' +cofix_guard_lift + : forall (mfix : list (def term)) (n k : nat), + let k' := #|mfix| + k in + let mfix' := + map (map_def (PCUICLiftSubst.lift n k) (PCUICLiftSubst.lift n k')) mfix + in + cofix_guard mfix -> cofix_guard mfix' +cofix_guard_eq_term + : forall (mfix mfix' : mfixpoint term) (idx : nat), + cofix_guard mfix -> + PCUICEquality.upto_names (tCoFix mfix idx) (tCoFix mfix' idx) -> + cofix_guard mfix' +cofix_guard : mfixpoint term -> bool +theories/ErasureCorrectness.vo (real: 58.09, user: 56.17, sys: 1.60, mem: 1113548 ko) +COQC theories/ErasureFunction.v +COQC theories/SafeErasureFunction.v +theories/SafeErasureFunction.vo (real: 24.59, user: 23.34, sys: 1.11, mem: 854428 ko) +Axioms: +todounivs : forall A : Type, A +todoeta : forall A : Type, A +todo : string -> forall A : Type, A +proof_irrelevance : forall (P : Prop) (p1 p2 : P), p1 = p2 +normalisation' + : forall (cf : checker_flags) (Σ : global_env_ext) (Γ : context) (t : term), + wf Σ -> wellformed Σ Γ t -> Acc (cored Σ.1 Γ) t +ind_guard : mutual_inductive_body -> bool +functional_extensionality_dep + : forall (A : Type) (B : A -> Type) (f g : forall x : A, B x), + (forall x : A, f x = g x) -> f = g +PCUICUnivSubstitution.fix_guard_subst_instance + : forall (mfix : mfixpoint term) (u : Instance.t), + fix_guard mfix -> + fix_guard + (map + (map_def (PCUICUnivSubst.subst_instance_constr u) + (PCUICUnivSubst.subst_instance_constr u)) mfix) +fix_guard_subst + : forall (mfix : list (def term)) (s : list term) (k : nat), + let k' := (#|mfix| + k)%nat in + let mfix' := map (map_def (subst s k) (subst s k')) mfix in + fix_guard mfix -> fix_guard mfix' +fix_guard_red1 + : forall (Σ : global_env) (Γ : context) (mfix mfix' : mfixpoint term) + (idx : nat), + fix_guard mfix -> + red1 Σ Γ (tFix mfix idx) (tFix mfix' idx) -> fix_guard mfix' +fix_guard_lift + : forall (mfix : list (def term)) (n k : nat), + let k' := (#|mfix| + k)%nat in + let mfix' := map (map_def (lift n k) (lift n k')) mfix in + fix_guard mfix -> fix_guard mfix' +fix_guard_eq_term + : forall (mfix mfix' : mfixpoint term) (idx : nat), + fix_guard mfix -> + PCUICEquality.upto_names (tFix mfix idx) (tFix mfix' idx) -> + fix_guard mfix' +fix_guard : mfixpoint term -> bool +PCUICUnivSubstitution.cofix_guard_subst_instance + : forall (mfix : mfixpoint term) (u : Instance.t), + cofix_guard mfix -> + cofix_guard + (map + (map_def (PCUICUnivSubst.subst_instance_constr u) + (PCUICUnivSubst.subst_instance_constr u)) mfix) +cofix_guard_subst + : forall (mfix : list (def term)) (s : list term) (k : nat), + let k' := (#|mfix| + k)%nat in + let mfix' := map (map_def (subst s k) (subst s k')) mfix in + cofix_guard mfix -> cofix_guard mfix' +cofix_guard_red1 + : forall (Σ : global_env) (Γ : context) (mfix mfix' : mfixpoint term) + (idx : nat), + cofix_guard mfix -> + red1 Σ Γ (tCoFix mfix idx) (tCoFix mfix' idx) -> cofix_guard mfix' +cofix_guard_lift + : forall (mfix : list (def term)) (n k : nat), + let k' := (#|mfix| + k)%nat in + let mfix' := map (map_def (lift n k) (lift n k')) mfix in + cofix_guard mfix -> cofix_guard mfix' +cofix_guard_eq_term + : forall (mfix mfix' : mfixpoint term) (idx : nat), + cofix_guard mfix -> + PCUICEquality.upto_names (tCoFix mfix idx) (tCoFix mfix' idx) -> + cofix_guard mfix' +cofix_guard : mfixpoint term -> bool +theories/ErasureFunction.vo (real: 40.61, user: 39.21, sys: 1.22, mem: 1012876 ko) +COQC theories/SafeTemplateErasure.v +theories/SafeTemplateErasure.vo (real: 4.47, user: 3.99, sys: 0.45, mem: 806128 ko) +COQC theories/Extraction.v +theories/Extraction.vo (real: 6.38, user: 5.74, sys: 0.59, mem: 872556 ko) +echo "Done extracting the erasure, moving extraction files!" +Done extracting the erasure, moving extraction files! +./clean_extraction.sh +Cleaning result of extraction +Moving All_Forall.ml to all_Forall.ml +Moving All_Forall.mli to all_Forall.mli +Moving Ascii.ml to ascii.ml +Moving Ascii.mli to ascii.mli +Moving Ast0.ml to ast0.ml +Moving Ast0.mli to ast0.mli +Moving AstUtils.ml to astUtils.ml +Moving AstUtils.mli to astUtils.mli +Moving BasicAst.ml to basicAst.ml +Moving BasicAst.mli to basicAst.mli +Moving Basics.ml to basics.ml +Moving Basics.mli to basics.mli +Moving BinInt.ml to binInt.ml +Moving BinInt.mli to binInt.mli +Moving BinNat.ml to binNat.ml +Moving BinNat.mli to binNat.mli +Moving BinNums.ml to binNums.ml +Moving BinNums.mli to binNums.mli +Moving BinPos.ml to binPos.ml +Moving BinPos.mli to binPos.mli +Moving Bool.ml to bool.ml +Moving Bool.mli to bool.mli +Moving Byte.ml to byte.ml +Moving Byte.mli to byte.mli +Moving Classes0.ml to classes0.ml +Moving Classes0.mli to classes0.mli +Moving Compare_dec.ml to compare_dec.ml +Moving Compare_dec.mli to compare_dec.mli +Moving Datatypes.ml to datatypes.ml +Moving Datatypes.mli to datatypes.mli +Moving EAst.ml to eAst.ml +Moving EAst.mli to eAst.mli +Moving EAstUtils.ml to eAstUtils.ml +Moving EAstUtils.mli to eAstUtils.mli +Moving ELiftSubst.ml to eLiftSubst.ml +Moving ELiftSubst.mli to eLiftSubst.mli +Moving EPretty.ml to ePretty.ml +Moving EPretty.mli to ePretty.mli +Moving ETyping.ml to eTyping.ml +Moving ETyping.mli to eTyping.mli +Moving Environment.ml to environment.ml +Moving Environment.mli to environment.mli +Moving EqDecInstances.ml to eqDecInstances.ml +Moving EqDecInstances.mli to eqDecInstances.mli +Moving EqdepFacts.ml to eqdepFacts.ml +Moving EqdepFacts.mli to eqdepFacts.mli +Moving Equalities.ml to equalities.ml +Moving Equalities.mli to equalities.mli +Moving ErasureFunction.ml to erasureFunction.ml +Moving ErasureFunction.mli to erasureFunction.mli +Moving Extract.ml to extract.ml +Moving Extract.mli to extract.mli +Moving Init.ml to init.ml +Moving Init.mli to init.mli +Moving LiftSubst.ml to liftSubst.ml +Moving LiftSubst.mli to liftSubst.mli +Moving List0.ml to list0.ml +Moving List0.mli to list0.mli +Moving MCCompare.ml to mCCompare.ml +Moving MCCompare.mli to mCCompare.mli +Moving MCList.ml to mCList.ml +Moving MCList.mli to mCList.mli +Moving MCOption.ml to mCOption.ml +Moving MCOption.mli to mCOption.mli +Moving MCProd.ml to mCProd.ml +Moving MCProd.mli to mCProd.mli +Moving MCString.ml to mCString.ml +Moving MCString.mli to mCString.mli +Moving MSetDecide.ml to mSetDecide.ml +Moving MSetDecide.mli to mSetDecide.mli +Moving MSetFacts.ml to mSetFacts.ml +Moving MSetFacts.mli to mSetFacts.mli +Moving MSetInterface.ml to mSetInterface.ml +Moving MSetInterface.mli to mSetInterface.mli +Moving MSetList.ml to mSetList.ml +Moving MSetList.mli to mSetList.mli +Moving MSetProperties.ml to mSetProperties.ml +Moving MSetProperties.mli to mSetProperties.mli +Moving MSetWeakList.ml to mSetWeakList.ml +Moving MSetWeakList.mli to mSetWeakList.mli +Moving Nat0.ml to nat0.ml +Moving Nat0.mli to nat0.mli +Moving Orders.ml to orders.ml +Moving Orders.mli to orders.mli +Moving OrdersFacts.ml to ordersFacts.ml +Moving OrdersFacts.mli to ordersFacts.mli +Moving OrdersLists.ml to ordersLists.ml +Moving OrdersLists.mli to ordersLists.mli +Moving OrdersTac.ml to ordersTac.ml +Moving OrdersTac.mli to ordersTac.mli +Moving PCUICAst.ml to pCUICAst.ml +Moving PCUICAst.mli to pCUICAst.mli +Moving PCUICAstUtils.ml to pCUICAstUtils.ml +Moving PCUICAstUtils.mli to pCUICAstUtils.mli +Moving PCUICChecker.ml to pCUICChecker.ml +Moving PCUICChecker.mli to pCUICChecker.mli +Moving PCUICCumulativity.ml to pCUICCumulativity.ml +Moving PCUICCumulativity.mli to pCUICCumulativity.mli +Moving PCUICEquality.ml to pCUICEquality.ml +Moving PCUICEquality.mli to pCUICEquality.mli +Moving PCUICLiftSubst.ml to pCUICLiftSubst.ml +Moving PCUICLiftSubst.mli to pCUICLiftSubst.mli +Moving PCUICNormal.ml to pCUICNormal.ml +Moving PCUICNormal.mli to pCUICNormal.mli +Moving PCUICPosition.ml to pCUICPosition.ml +Moving PCUICPosition.mli to pCUICPosition.mli +Moving PCUICPretty.ml to pCUICPretty.ml +Moving PCUICPretty.mli to pCUICPretty.mli +Moving PCUICReflect.ml to pCUICReflect.ml +Moving PCUICReflect.mli to pCUICReflect.mli +Moving PCUICSafeChecker.ml to pCUICSafeChecker.ml +Moving PCUICSafeChecker.mli to pCUICSafeChecker.mli +Moving PCUICSafeConversion.ml to pCUICSafeConversion.ml +Moving PCUICSafeConversion.mli to pCUICSafeConversion.mli +Moving PCUICSafeLemmata.ml to pCUICSafeLemmata.ml +Moving PCUICSafeLemmata.mli to pCUICSafeLemmata.mli +Moving PCUICSafeReduce.ml to pCUICSafeReduce.ml +Moving PCUICSafeReduce.mli to pCUICSafeReduce.mli +Moving PCUICSafeRetyping.ml to pCUICSafeRetyping.ml +Moving PCUICSafeRetyping.mli to pCUICSafeRetyping.mli +Moving PCUICTyping.ml to pCUICTyping.ml +Moving PCUICTyping.mli to pCUICTyping.mli +Moving PCUICUnivSubst.ml to pCUICUnivSubst.ml +Moving PCUICUnivSubst.mli to pCUICUnivSubst.mli +Moving PeanoNat.ml to peanoNat.ml +Moving PeanoNat.mli to peanoNat.mli +Moving Pretty.ml to pretty.ml +Moving Pretty.mli to pretty.mli +Moving SafeErasureFunction.ml to safeErasureFunction.ml +Moving SafeErasureFunction.mli to safeErasureFunction.mli +Moving SafeTemplateChecker.ml to safeTemplateChecker.ml +Moving SafeTemplateChecker.mli to safeTemplateChecker.mli +Moving SafeTemplateErasure.ml to safeTemplateErasure.ml +Moving SafeTemplateErasure.mli to safeTemplateErasure.mli +Moving Specif.ml to specif.ml +Moving Specif.mli to specif.mli +Moving String0.ml to string0.ml +Moving String0.mli to string0.mli +Moving TemplateToPCUIC.ml to templateToPCUIC.ml +Moving TemplateToPCUIC.mli to templateToPCUIC.mli +Moving Typing0.ml to typing0.ml +Moving Typing0.mli to typing0.mli +Moving UnivSubst0.ml to univSubst0.ml +Moving UnivSubst0.mli to univSubst0.mli +Moving Universes0.ml to universes0.ml +Moving Universes0.mli to universes0.mli +Moving config0.ml to config0.ml +mv: 'config0.ml' and 'config0.ml' are the same file +Moving config0.mli to config0.mli +mv: 'config0.mli' and 'config0.mli' are the same file +Moving g_metacoq_erasure.ml to g_metacoq_erasure.ml +mv: 'g_metacoq_erasure.ml' and 'g_metacoq_erasure.ml' are the same file +Moving g_metacoq_erasure.mlg to g_metacoq_erasure.mlg +mv: 'g_metacoq_erasure.mlg' and 'g_metacoq_erasure.mlg' are the same file +Moving metacoq_erasure_plugin.mlpack to metacoq_erasure_plugin.mlpack +mv: 'metacoq_erasure_plugin.mlpack' and 'metacoq_erasure_plugin.mlpack' are the same file +Moving monad_utils.ml to monad_utils.ml +mv: 'monad_utils.ml' and 'monad_utils.ml' are the same file +Moving monad_utils.mli to monad_utils.mli +mv: 'monad_utils.mli' and 'monad_utils.mli' are the same file +Moving ssrbool.ml to ssrbool.ml +mv: 'ssrbool.ml' and 'ssrbool.ml' are the same file +Moving ssrbool.mli to ssrbool.mli +mv: 'ssrbool.mli' and 'ssrbool.mli' are the same file +Moving uGraph0.ml to uGraph0.ml +mv: 'uGraph0.ml' and 'uGraph0.ml' are the same file +Moving uGraph0.mli to uGraph0.mli +mv: 'uGraph0.mli' and 'uGraph0.mli' are the same file +Moving utils.ml to utils.ml +mv: 'utils.ml' and 'utils.ml' are the same file +Moving utils.mli to utils.mli +mv: 'utils.mli' and 'utils.mli' are the same file +Moving wGraph.ml to wGraph.ml +mv: 'wGraph.ml' and 'wGraph.ml' are the same file +Moving wGraph.mli to wGraph.mli +mv: 'wGraph.mli' and 'wGraph.mli' are the same file +Removing: src/all_Forall.ml src/all_Forall.mli src/ascii.ml src/ascii.mli src/ast0.ml src/ast0.mli src/ast_denoter.ml src/ast_quoter.ml src/astUtils.ml src/astUtils.mli src/basicAst.ml src/basicAst.mli src/basics.ml src/basics.mli src/binInt.ml src/binInt.mli src/binNat.ml src/binNat.mli src/binNums.ml src/binNums.mli src/binPosDef.ml src/binPosDef.mli src/binPos.ml src/binPos.mli src/bool.ml src/bool.mli src/common0.ml src/common0.mli src/compare_dec.ml src/compare_dec.mli src/config0.ml src/config0.mli src/cRelationClasses.ml src/cRelationClasses.mli src/datatypes.ml src/datatypes.mli src/decimal.ml src/decimal.mli src/denoter.ml src/environment.ml src/environment.mli src/equalities.ml src/equalities.mli src/extractable.ml src/extractable.mli src/hexadecimal.ml src/hexadecimal.mli src/liftSubst.ml src/liftSubst.mli src/list0.ml src/list0.mli src/logic0.ml src/logic0.mli src/mCPrelude.mli src/mCPrelude.ml src/mCCompare.ml src/mCCompare.mli src/mCList.ml src/mCList.mli src/mCOption.ml src/mCOption.mli src/mCProd.ml src/mCProd.mli src/mCRelations.ml src/mCRelations.mli src/mCString.ml src/mCString.mli src/mSetDecide.ml src/mSetDecide.mli src/mSetFacts.ml src/mSetFacts.mli src/mSetInterface.ml src/mSetInterface.mli src/mSetList.ml src/mSetList.mli src/mSetProperties.ml src/mSetProperties.mli src/nat0.ml src/nat0.mli src/numeral.ml src/numeral.mli src/orderedType0.ml src/orderedType0.mli src/ordersFacts.ml src/ordersFacts.mli src/ordersLists.ml src/ordersLists.mli src/orders.ml src/orders.mli src/ordersTac.ml src/ordersTac.mli src/peanoNat.ml src/peanoNat.mli src/plugin_core.ml src/plugin_core.mli src/pretty.ml src/pretty.mli src/reification.ml src/quoter.ml src/run_extractable.ml src/run_extractable.mli src/specif.ml src/specif.mli src/string0.ml src/string0.mli src/tm_util.ml src/universes0.ml src/universes0.mli src/univSubst0.ml src/univSubst0.mli +make[4]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/erasure' +./clean_extraction.sh +Cleaning result of extraction +Moving byte.ml to byte.ml +mv: 'byte.ml' and 'byte.ml' are the same file +Moving byte.mli to byte.mli +mv: 'byte.mli' and 'byte.mli' are the same file +Moving classes0.ml to classes0.ml +mv: 'classes0.ml' and 'classes0.ml' are the same file +Moving classes0.mli to classes0.mli +mv: 'classes0.mli' and 'classes0.mli' are the same file +Moving eAst.ml to eAst.ml +mv: 'eAst.ml' and 'eAst.ml' are the same file +Moving eAst.mli to eAst.mli +mv: 'eAst.mli' and 'eAst.mli' are the same file +Moving eAstUtils.ml to eAstUtils.ml +mv: 'eAstUtils.ml' and 'eAstUtils.ml' are the same file +Moving eAstUtils.mli to eAstUtils.mli +mv: 'eAstUtils.mli' and 'eAstUtils.mli' are the same file +Moving eLiftSubst.ml to eLiftSubst.ml +mv: 'eLiftSubst.ml' and 'eLiftSubst.ml' are the same file +Moving eLiftSubst.mli to eLiftSubst.mli +mv: 'eLiftSubst.mli' and 'eLiftSubst.mli' are the same file +Moving ePretty.ml to ePretty.ml +mv: 'ePretty.ml' and 'ePretty.ml' are the same file +Moving ePretty.mli to ePretty.mli +mv: 'ePretty.mli' and 'ePretty.mli' are the same file +Moving eTyping.ml to eTyping.ml +mv: 'eTyping.ml' and 'eTyping.ml' are the same file +Moving eTyping.mli to eTyping.mli +mv: 'eTyping.mli' and 'eTyping.mli' are the same file +Moving eqDecInstances.ml to eqDecInstances.ml +mv: 'eqDecInstances.ml' and 'eqDecInstances.ml' are the same file +Moving eqDecInstances.mli to eqDecInstances.mli +mv: 'eqDecInstances.mli' and 'eqDecInstances.mli' are the same file +Moving eqdepFacts.ml to eqdepFacts.ml +mv: 'eqdepFacts.ml' and 'eqdepFacts.ml' are the same file +Moving eqdepFacts.mli to eqdepFacts.mli +mv: 'eqdepFacts.mli' and 'eqdepFacts.mli' are the same file +Moving erasureFunction.ml to erasureFunction.ml +mv: 'erasureFunction.ml' and 'erasureFunction.ml' are the same file +Moving erasureFunction.mli to erasureFunction.mli +mv: 'erasureFunction.mli' and 'erasureFunction.mli' are the same file +Moving extract.ml to extract.ml +mv: 'extract.ml' and 'extract.ml' are the same file +Moving extract.mli to extract.mli +mv: 'extract.mli' and 'extract.mli' are the same file +Moving g_metacoq_erasure.ml to g_metacoq_erasure.ml +mv: 'g_metacoq_erasure.ml' and 'g_metacoq_erasure.ml' are the same file +Moving g_metacoq_erasure.mlg to g_metacoq_erasure.mlg +mv: 'g_metacoq_erasure.mlg' and 'g_metacoq_erasure.mlg' are the same file +Moving init.ml to init.ml +mv: 'init.ml' and 'init.ml' are the same file +Moving init.mli to init.mli +mv: 'init.mli' and 'init.mli' are the same file +Moving mSetWeakList.ml to mSetWeakList.ml +mv: 'mSetWeakList.ml' and 'mSetWeakList.ml' are the same file +Moving mSetWeakList.mli to mSetWeakList.mli +mv: 'mSetWeakList.mli' and 'mSetWeakList.mli' are the same file +Moving metacoq_erasure_plugin.mlpack to metacoq_erasure_plugin.mlpack +mv: 'metacoq_erasure_plugin.mlpack' and 'metacoq_erasure_plugin.mlpack' are the same file +Moving monad_utils.ml to monad_utils.ml +mv: 'monad_utils.ml' and 'monad_utils.ml' are the same file +Moving monad_utils.mli to monad_utils.mli +mv: 'monad_utils.mli' and 'monad_utils.mli' are the same file +Moving pCUICAst.ml to pCUICAst.ml +mv: 'pCUICAst.ml' and 'pCUICAst.ml' are the same file +Moving pCUICAst.mli to pCUICAst.mli +mv: 'pCUICAst.mli' and 'pCUICAst.mli' are the same file +Moving pCUICAstUtils.ml to pCUICAstUtils.ml +mv: 'pCUICAstUtils.ml' and 'pCUICAstUtils.ml' are the same file +Moving pCUICAstUtils.mli to pCUICAstUtils.mli +mv: 'pCUICAstUtils.mli' and 'pCUICAstUtils.mli' are the same file +Moving pCUICChecker.ml to pCUICChecker.ml +mv: 'pCUICChecker.ml' and 'pCUICChecker.ml' are the same file +Moving pCUICChecker.mli to pCUICChecker.mli +mv: 'pCUICChecker.mli' and 'pCUICChecker.mli' are the same file +Moving pCUICCumulativity.ml to pCUICCumulativity.ml +mv: 'pCUICCumulativity.ml' and 'pCUICCumulativity.ml' are the same file +Moving pCUICCumulativity.mli to pCUICCumulativity.mli +mv: 'pCUICCumulativity.mli' and 'pCUICCumulativity.mli' are the same file +Moving pCUICEquality.ml to pCUICEquality.ml +mv: 'pCUICEquality.ml' and 'pCUICEquality.ml' are the same file +Moving pCUICEquality.mli to pCUICEquality.mli +mv: 'pCUICEquality.mli' and 'pCUICEquality.mli' are the same file +Moving pCUICLiftSubst.ml to pCUICLiftSubst.ml +mv: 'pCUICLiftSubst.ml' and 'pCUICLiftSubst.ml' are the same file +Moving pCUICLiftSubst.mli to pCUICLiftSubst.mli +mv: 'pCUICLiftSubst.mli' and 'pCUICLiftSubst.mli' are the same file +Moving pCUICNormal.ml to pCUICNormal.ml +mv: 'pCUICNormal.ml' and 'pCUICNormal.ml' are the same file +Moving pCUICNormal.mli to pCUICNormal.mli +mv: 'pCUICNormal.mli' and 'pCUICNormal.mli' are the same file +Moving pCUICPosition.ml to pCUICPosition.ml +mv: 'pCUICPosition.ml' and 'pCUICPosition.ml' are the same file +Moving pCUICPosition.mli to pCUICPosition.mli +mv: 'pCUICPosition.mli' and 'pCUICPosition.mli' are the same file +Moving pCUICPretty.ml to pCUICPretty.ml +mv: 'pCUICPretty.ml' and 'pCUICPretty.ml' are the same file +Moving pCUICPretty.mli to pCUICPretty.mli +mv: 'pCUICPretty.mli' and 'pCUICPretty.mli' are the same file +Moving pCUICReflect.ml to pCUICReflect.ml +mv: 'pCUICReflect.ml' and 'pCUICReflect.ml' are the same file +Moving pCUICReflect.mli to pCUICReflect.mli +mv: 'pCUICReflect.mli' and 'pCUICReflect.mli' are the same file +Moving pCUICSafeChecker.ml to pCUICSafeChecker.ml +mv: 'pCUICSafeChecker.ml' and 'pCUICSafeChecker.ml' are the same file +Moving pCUICSafeChecker.mli to pCUICSafeChecker.mli +mv: 'pCUICSafeChecker.mli' and 'pCUICSafeChecker.mli' are the same file +Moving pCUICSafeConversion.ml to pCUICSafeConversion.ml +mv: 'pCUICSafeConversion.ml' and 'pCUICSafeConversion.ml' are the same file +Moving pCUICSafeConversion.mli to pCUICSafeConversion.mli +mv: 'pCUICSafeConversion.mli' and 'pCUICSafeConversion.mli' are the same file +Moving pCUICSafeLemmata.ml to pCUICSafeLemmata.ml +mv: 'pCUICSafeLemmata.ml' and 'pCUICSafeLemmata.ml' are the same file +Moving pCUICSafeLemmata.mli to pCUICSafeLemmata.mli +mv: 'pCUICSafeLemmata.mli' and 'pCUICSafeLemmata.mli' are the same file +Moving pCUICSafeReduce.ml to pCUICSafeReduce.ml +mv: 'pCUICSafeReduce.ml' and 'pCUICSafeReduce.ml' are the same file +Moving pCUICSafeReduce.mli to pCUICSafeReduce.mli +mv: 'pCUICSafeReduce.mli' and 'pCUICSafeReduce.mli' are the same file +Moving pCUICSafeRetyping.ml to pCUICSafeRetyping.ml +mv: 'pCUICSafeRetyping.ml' and 'pCUICSafeRetyping.ml' are the same file +Moving pCUICSafeRetyping.mli to pCUICSafeRetyping.mli +mv: 'pCUICSafeRetyping.mli' and 'pCUICSafeRetyping.mli' are the same file +Moving pCUICTyping.ml to pCUICTyping.ml +mv: 'pCUICTyping.ml' and 'pCUICTyping.ml' are the same file +Moving pCUICTyping.mli to pCUICTyping.mli +mv: 'pCUICTyping.mli' and 'pCUICTyping.mli' are the same file +Moving pCUICUnivSubst.ml to pCUICUnivSubst.ml +mv: 'pCUICUnivSubst.ml' and 'pCUICUnivSubst.ml' are the same file +Moving pCUICUnivSubst.mli to pCUICUnivSubst.mli +mv: 'pCUICUnivSubst.mli' and 'pCUICUnivSubst.mli' are the same file +Moving safeErasureFunction.ml to safeErasureFunction.ml +mv: 'safeErasureFunction.ml' and 'safeErasureFunction.ml' are the same file +Moving safeErasureFunction.mli to safeErasureFunction.mli +mv: 'safeErasureFunction.mli' and 'safeErasureFunction.mli' are the same file +Moving safeTemplateChecker.ml to safeTemplateChecker.ml +mv: 'safeTemplateChecker.ml' and 'safeTemplateChecker.ml' are the same file +Moving safeTemplateChecker.mli to safeTemplateChecker.mli +mv: 'safeTemplateChecker.mli' and 'safeTemplateChecker.mli' are the same file +Moving safeTemplateErasure.ml to safeTemplateErasure.ml +mv: 'safeTemplateErasure.ml' and 'safeTemplateErasure.ml' are the same file +Moving safeTemplateErasure.mli to safeTemplateErasure.mli +mv: 'safeTemplateErasure.mli' and 'safeTemplateErasure.mli' are the same file +Moving ssrbool.ml to ssrbool.ml +mv: 'ssrbool.ml' and 'ssrbool.ml' are the same file +Moving ssrbool.mli to ssrbool.mli +mv: 'ssrbool.mli' and 'ssrbool.mli' are the same file +Moving templateToPCUIC.ml to templateToPCUIC.ml +mv: 'templateToPCUIC.ml' and 'templateToPCUIC.ml' are the same file +Moving templateToPCUIC.mli to templateToPCUIC.mli +mv: 'templateToPCUIC.mli' and 'templateToPCUIC.mli' are the same file +Moving typing0.ml to typing0.ml +mv: 'typing0.ml' and 'typing0.ml' are the same file +Moving typing0.mli to typing0.mli +mv: 'typing0.mli' and 'typing0.mli' are the same file +Moving uGraph0.ml to uGraph0.ml +mv: 'uGraph0.ml' and 'uGraph0.ml' are the same file +Moving uGraph0.mli to uGraph0.mli +mv: 'uGraph0.mli' and 'uGraph0.mli' are the same file +Moving utils.ml to utils.ml +mv: 'utils.ml' and 'utils.ml' are the same file +Moving utils.mli to utils.mli +mv: 'utils.mli' and 'utils.mli' are the same file +Moving wGraph.ml to wGraph.ml +mv: 'wGraph.ml' and 'wGraph.ml' are the same file +Moving wGraph.mli to wGraph.mli +mv: 'wGraph.mli' and 'wGraph.mli' are the same file +Removing: src/all_Forall.ml src/all_Forall.mli src/ascii.ml src/ascii.mli src/ast0.ml src/ast0.mli src/ast_denoter.ml src/ast_quoter.ml src/astUtils.ml src/astUtils.mli src/basicAst.ml src/basicAst.mli src/basics.ml src/basics.mli src/binInt.ml src/binInt.mli src/binNat.ml src/binNat.mli src/binNums.ml src/binNums.mli src/binPosDef.ml src/binPosDef.mli src/binPos.ml src/binPos.mli src/bool.ml src/bool.mli src/common0.ml src/common0.mli src/compare_dec.ml src/compare_dec.mli src/config0.ml src/config0.mli src/cRelationClasses.ml src/cRelationClasses.mli src/datatypes.ml src/datatypes.mli src/decimal.ml src/decimal.mli src/denoter.ml src/environment.ml src/environment.mli src/equalities.ml src/equalities.mli src/extractable.ml src/extractable.mli src/hexadecimal.ml src/hexadecimal.mli src/liftSubst.ml src/liftSubst.mli src/list0.ml src/list0.mli src/logic0.ml src/logic0.mli src/mCPrelude.mli src/mCPrelude.ml src/mCCompare.ml src/mCCompare.mli src/mCList.ml src/mCList.mli src/mCOption.ml src/mCOption.mli src/mCProd.ml src/mCProd.mli src/mCRelations.ml src/mCRelations.mli src/mCString.ml src/mCString.mli src/mSetDecide.ml src/mSetDecide.mli src/mSetFacts.ml src/mSetFacts.mli src/mSetInterface.ml src/mSetInterface.mli src/mSetList.ml src/mSetList.mli src/mSetProperties.ml src/mSetProperties.mli src/nat0.ml src/nat0.mli src/numeral.ml src/numeral.mli src/orderedType0.ml src/orderedType0.mli src/ordersFacts.ml src/ordersFacts.mli src/ordersLists.ml src/ordersLists.mli src/orders.ml src/orders.mli src/ordersTac.ml src/ordersTac.mli src/peanoNat.ml src/peanoNat.mli src/plugin_core.ml src/plugin_core.mli src/pretty.ml src/pretty.mli src/reification.ml src/quoter.ml src/run_extractable.ml src/run_extractable.mli src/specif.ml src/specif.mli src/string0.ml src/string0.mli src/tm_util.ml src/universes0.ml src/universes0.mli src/univSubst0.ml src/univSubst0.mli +make -f Makefile.plugin +make[4]: Entering directory '/builds/coq/coq/_build_ci/metacoq/erasure' +COQDEP VFILES +CAMLDEP src/safeTemplateErasure.mli +CAMLDEP src/ePretty.mli +CAMLDEP src/safeErasureFunction.mli +CAMLDEP src/extract.mli +CAMLDEP src/erasureFunction.mli +CAMLDEP src/eTyping.mli +CAMLDEP src/eLiftSubst.mli +CAMLDEP src/eAstUtils.mli +CAMLDEP src/eAst.mli +CAMLDEP src/safeTemplateChecker.mli +CAMLDEP src/pCUICSafeRetyping.mli +CAMLDEP src/pCUICSafeChecker.mli +CAMLDEP src/pCUICSafeConversion.mli +CAMLDEP src/pCUICSafeReduce.mli +CAMLDEP src/templateToPCUIC.mli +CAMLDEP src/pCUICSafeLemmata.mli +CAMLDEP src/pCUICPretty.mli +CAMLDEP src/pCUICChecker.mli +CAMLDEP src/pCUICNormal.mli +CAMLDEP src/pCUICPosition.mli +CAMLDEP src/pCUICCumulativity.mli +CAMLDEP src/pCUICUnivSubst.mli +CAMLDEP src/pCUICTyping.mli +CAMLDEP src/pCUICReflect.mli +CAMLDEP src/pCUICEquality.mli +CAMLDEP src/eqDecInstances.mli +CAMLDEP src/pCUICLiftSubst.mli +CAMLDEP src/pCUICAstUtils.mli +CAMLDEP src/pCUICAst.mli +CAMLDEP src/typing0.mli +CAMLDEP src/wGraph.mli +CAMLDEP src/uGraph0.mli +CAMLDEP src/monad_utils.mli +CAMLDEP src/utils.mli +CAMLDEP src/ssrbool.mli +CAMLDEP src/eqdepFacts.mli +CAMLDEP src/mSetWeakList.mli +CAMLDEP src/classes0.mli +CAMLDEP src/init.mli +OCAMLLIBDEP src/metacoq_erasure_plugin.mlpack +CAMLDEP src/safeTemplateErasure.ml +CAMLDEP src/ePretty.ml +CAMLDEP src/safeErasureFunction.ml +CAMLDEP src/erasureFunction.ml +CAMLDEP src/extract.ml +CAMLDEP src/eTyping.ml +CAMLDEP src/eLiftSubst.ml +CAMLDEP src/eAstUtils.ml +CAMLDEP src/eAst.ml +CAMLDEP src/safeTemplateChecker.ml +CAMLDEP src/pCUICSafeRetyping.ml +CAMLDEP src/pCUICSafeChecker.ml +CAMLDEP src/pCUICSafeConversion.ml +CAMLDEP src/pCUICSafeReduce.ml +CAMLDEP src/templateToPCUIC.ml +CAMLDEP src/pCUICSafeLemmata.ml +CAMLDEP src/pCUICPretty.ml +CAMLDEP src/pCUICChecker.ml +CAMLDEP src/pCUICNormal.ml +CAMLDEP src/pCUICPosition.ml +CAMLDEP src/pCUICCumulativity.ml +CAMLDEP src/pCUICUnivSubst.ml +CAMLDEP src/pCUICTyping.ml +CAMLDEP src/pCUICEquality.ml +CAMLDEP src/pCUICReflect.ml +CAMLDEP src/eqDecInstances.ml +CAMLDEP src/pCUICLiftSubst.ml +CAMLDEP src/pCUICAstUtils.ml +CAMLDEP src/pCUICAst.ml +CAMLDEP src/typing0.ml +CAMLDEP src/wGraph.ml +CAMLDEP src/uGraph0.ml +CAMLDEP src/monad_utils.ml +CAMLDEP src/utils.ml +CAMLDEP src/ssrbool.ml +CAMLDEP src/eqdepFacts.ml +CAMLDEP src/mSetWeakList.ml +CAMLDEP src/classes0.ml +CAMLDEP src/init.ml +CAMLDEP src/g_metacoq_erasure.ml +CAMLC -c src/mSetWeakList.mli +CAMLC -c src/monad_utils.mli +src/monad_utils.cmi (real: 0.04, user: 0.03, sys: 0.01, mem: 19272 ko) +CAMLC -c src/eqdepFacts.mli +src/mSetWeakList.cmi (real: 0.06, user: 0.04, sys: 0.01, mem: 20108 ko) +CAMLC -c src/ssrbool.mli +src/eqdepFacts.cmi (real: 0.04, user: 0.03, sys: 0.01, mem: 19396 ko) +CAMLC -c src/utils.mli +src/ssrbool.cmi (real: 0.04, user: 0.02, sys: 0.01, mem: 19220 ko) +CAMLC -c src/typing0.mli +src/typing0.cmi (real: 0.04, user: 0.03, sys: 0.01, mem: 20300 ko) +CAMLC -c src/init.mli +src/utils.cmi (real: 0.05, user: 0.04, sys: 0.01, mem: 19228 ko) +CAMLC -c src/classes0.mli +src/init.cmi (real: 0.04, user: 0.03, sys: 0.01, mem: 19324 ko) +CAMLC -c src/pCUICAst.mli +src/classes0.cmi (real: 0.05, user: 0.03, sys: 0.01, mem: 19340 ko) +CAMLC -c src/pCUICNormal.mli +src/pCUICNormal.cmi (real: 0.03, user: 0.02, sys: 0.01, mem: 19304 ko) +CAMLC -c src/pCUICCumulativity.mli +src/pCUICAst.cmi (real: 0.06, user: 0.04, sys: 0.01, mem: 21244 ko) +CAMLC -c src/safeTemplateChecker.mli +src/pCUICCumulativity.cmi (real: 0.03, user: 0.02, sys: 0.01, mem: 19224 ko) +CAMLC -c src/eAst.mli +src/safeTemplateChecker.cmi (real: 0.05, user: 0.04, sys: 0.01, mem: 20348 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/monad_utils.ml +src/eAst.cmi (real: 0.05, user: 0.03, sys: 0.01, mem: 20908 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/mSetWeakList.ml +src/monad_utils.cmx (real: 0.07, user: 0.04, sys: 0.02, mem: 22452 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/eqdepFacts.ml +src/mSetWeakList.cmx (real: 0.08, user: 0.06, sys: 0.01, mem: 25216 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/ssrbool.ml +src/eqdepFacts.cmx (real: 0.05, user: 0.03, sys: 0.01, mem: 22072 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/utils.ml +src/ssrbool.cmx (real: 0.05, user: 0.02, sys: 0.02, mem: 21912 ko) +CAMLC -c src/wGraph.mli +src/utils.cmx (real: 0.06, user: 0.04, sys: 0.02, mem: 22212 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/typing0.ml +src/wGraph.cmi (real: 0.06, user: 0.05, sys: 0.00, mem: 22824 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/init.ml +src/typing0.cmx (real: 0.07, user: 0.05, sys: 0.01, mem: 24076 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/classes0.ml +src/init.cmx (real: 0.05, user: 0.03, sys: 0.02, mem: 22188 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/pCUICAst.ml +src/classes0.cmx (real: 0.05, user: 0.02, sys: 0.02, mem: 21960 ko) +CAMLC -c src/pCUICAstUtils.mli +src/pCUICAst.cmx (real: 0.07, user: 0.05, sys: 0.01, mem: 26032 ko) +CAMLC -c src/pCUICUnivSubst.mli +src/pCUICAstUtils.cmi (real: 0.06, user: 0.04, sys: 0.01, mem: 20412 ko) +CAMLC -c src/pCUICLiftSubst.mli +src/pCUICUnivSubst.cmi (real: 0.04, user: 0.03, sys: 0.01, mem: 20308 ko) +CAMLC -c src/eqDecInstances.mli +src/pCUICLiftSubst.cmi (real: 0.05, user: 0.03, sys: 0.01, mem: 20444 ko) +CAMLC -c src/pCUICReflect.mli +src/eqDecInstances.cmi (real: 0.04, user: 0.03, sys: 0.01, mem: 19268 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/pCUICNormal.ml +src/pCUICReflect.cmi (real: 0.04, user: 0.03, sys: 0.01, mem: 20240 ko) +CAMLC -c src/pCUICPosition.mli +src/pCUICNormal.cmx (real: 0.05, user: 0.03, sys: 0.02, mem: 22044 ko) +CAMLC -c src/templateToPCUIC.mli +src/pCUICPosition.cmi (real: 0.04, user: 0.03, sys: 0.01, mem: 20488 ko) +CAMLC -c src/pCUICSafeLemmata.mli +src/pCUICSafeLemmata.cmi (real: 0.04, user: 0.03, sys: 0.00, mem: 19348 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/pCUICCumulativity.ml +src/templateToPCUIC.cmi (real: 0.06, user: 0.05, sys: 0.01, mem: 21328 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/safeTemplateChecker.ml +src/pCUICCumulativity.cmx (real: 0.04, user: 0.02, sys: 0.02, mem: 21940 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/eAst.ml +src/safeTemplateChecker.cmx (real: 0.08, user: 0.06, sys: 0.02, mem: 25408 ko) +CAMLC -c src/eAstUtils.mli +src/eAstUtils.cmi (real: 0.04, user: 0.03, sys: 0.01, mem: 19496 ko) +CAMLC -c src/eLiftSubst.mli +src/eAst.cmx (real: 0.12, user: 0.10, sys: 0.02, mem: 28644 ko) +CAMLC -c src/extract.mli +src/eLiftSubst.cmi (real: 0.04, user: 0.02, sys: 0.01, mem: 19300 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/wGraph.ml +src/extract.cmi (real: 0.05, user: 0.03, sys: 0.01, mem: 21060 ko) +CAMLC -c src/uGraph0.mli +src/uGraph0.cmi (real: 0.08, user: 0.06, sys: 0.01, mem: 24780 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/pCUICAstUtils.ml +src/wGraph.cmx (real: 0.17, user: 0.14, sys: 0.02, mem: 31636 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/pCUICUnivSubst.ml +src/pCUICAstUtils.cmx (real: 0.11, user: 0.08, sys: 0.02, mem: 26392 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/pCUICLiftSubst.ml +src/pCUICUnivSubst.cmx (real: 0.08, user: 0.05, sys: 0.02, mem: 25180 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/eqDecInstances.ml +src/eqDecInstances.cmx (real: 0.06, user: 0.03, sys: 0.02, mem: 22196 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/pCUICReflect.ml +src/pCUICLiftSubst.cmx (real: 0.09, user: 0.06, sys: 0.02, mem: 26244 ko) +CAMLC -c src/pCUICEquality.mli +src/pCUICEquality.cmi (real: 0.05, user: 0.03, sys: 0.01, mem: 20372 ko) +CAMLC -c src/pCUICTyping.mli +src/pCUICReflect.cmx (real: 0.07, user: 0.05, sys: 0.02, mem: 24336 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/pCUICPosition.ml +src/pCUICTyping.cmi (real: 0.05, user: 0.04, sys: 0.01, mem: 21400 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/templateToPCUIC.ml +src/pCUICPosition.cmx (real: 0.08, user: 0.06, sys: 0.01, mem: 26048 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/pCUICSafeLemmata.ml +src/templateToPCUIC.cmx (real: 0.08, user: 0.06, sys: 0.02, mem: 26384 ko) +src/pCUICSafeLemmata.cmx (real: 0.05, user: 0.02, sys: 0.02, mem: 22084 ko) +CAMLC -c src/pCUICSafeReduce.mli +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/eAstUtils.ml +src/pCUICSafeReduce.cmi (real: 0.06, user: 0.05, sys: 0.01, mem: 21556 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/eLiftSubst.ml +src/eAstUtils.cmx (real: 0.08, user: 0.05, sys: 0.02, mem: 24800 ko) +CAMLC -c src/eTyping.mli +src/eTyping.cmi (real: 0.04, user: 0.03, sys: 0.00, mem: 20252 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/extract.ml +src/eLiftSubst.cmx (real: 0.07, user: 0.05, sys: 0.02, mem: 25192 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/uGraph0.ml +src/extract.cmx (real: 0.07, user: 0.04, sys: 0.02, mem: 23032 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/pCUICEquality.ml +src/uGraph0.cmx (real: 0.13, user: 0.11, sys: 0.02, mem: 30984 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/pCUICTyping.ml +src/pCUICEquality.cmx (real: 0.09, user: 0.06, sys: 0.02, mem: 26256 ko) +CAMLC -c src/pCUICChecker.mli +src/pCUICChecker.cmi (real: 0.06, user: 0.04, sys: 0.01, mem: 21236 ko) +CAMLC -c src/pCUICSafeConversion.mli +src/pCUICTyping.cmx (real: 0.11, user: 0.08, sys: 0.03, mem: 27752 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/eTyping.ml +src/pCUICSafeConversion.cmi (real: 0.08, user: 0.06, sys: 0.02, mem: 23232 ko) +CAMLC -c src/ePretty.mli +src/eTyping.cmx (real: 0.08, user: 0.06, sys: 0.02, mem: 24684 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/pCUICChecker.ml +src/ePretty.cmi (real: 0.06, user: 0.04, sys: 0.01, mem: 20540 ko) +CAMLC -c src/pCUICPretty.mli +src/pCUICPretty.cmi (real: 0.05, user: 0.04, sys: 0.01, mem: 20560 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/pCUICSafeReduce.ml +src/pCUICChecker.cmx (real: 0.07, user: 0.05, sys: 0.02, mem: 25140 ko) +CAMLC -c src/pCUICSafeChecker.mli +src/pCUICSafeChecker.cmi (real: 0.07, user: 0.05, sys: 0.01, mem: 24300 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/ePretty.ml +src/pCUICSafeReduce.cmx (real: 0.09, user: 0.07, sys: 0.02, mem: 27792 ko) +CAMLC -c src/erasureFunction.mli +src/erasureFunction.cmi (real: 0.08, user: 0.06, sys: 0.01, mem: 22652 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/pCUICPretty.ml +src/ePretty.cmx (real: 0.11, user: 0.09, sys: 0.02, mem: 26992 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/pCUICSafeConversion.ml +src/pCUICPretty.cmx (real: 0.11, user: 0.09, sys: 0.02, mem: 29148 ko) +CAMLC -c src/pCUICSafeRetyping.mli +src/pCUICSafeRetyping.cmi (real: 0.05, user: 0.03, sys: 0.01, mem: 21604 ko) +CAMLC -c src/safeErasureFunction.mli +src/safeErasureFunction.cmi (real: 0.07, user: 0.05, sys: 0.01, mem: 21660 ko) +CAMLC -c src/safeTemplateErasure.mli +src/safeTemplateErasure.cmi (real: 0.07, user: 0.05, sys: 0.01, mem: 23148 ko) +src/pCUICSafeConversion.cmx (real: 0.31, user: 0.27, sys: 0.03, mem: 43056 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/pCUICSafeChecker.ml +src/pCUICSafeChecker.cmx (real: 0.37, user: 0.33, sys: 0.03, mem: 45284 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/pCUICSafeRetyping.ml +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/erasureFunction.ml +src/pCUICSafeRetyping.cmx (real: 0.09, user: 0.06, sys: 0.02, mem: 27380 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/safeErasureFunction.ml +src/erasureFunction.cmx (real: 0.14, user: 0.11, sys: 0.02, mem: 31208 ko) +src/safeErasureFunction.cmx (real: 0.12, user: 0.09, sys: 0.01, mem: 29852 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/safeTemplateErasure.ml +src/safeTemplateErasure.cmx (real: 0.09, user: 0.07, sys: 0.02, mem: 30244 ko) +CAMLOPT -c -for-pack Metacoq_erasure_plugin src/g_metacoq_erasure.ml +src/g_metacoq_erasure.cmx (real: 0.09, user: 0.06, sys: 0.02, mem: 30052 ko) +CAMLOPT -pack -o src/metacoq_erasure_plugin.cmx +src/metacoq_erasure_plugin.cmx (real: 0.12, user: 0.08, sys: 0.03, mem: 32668 ko) +CAMLOPT -a -o src/metacoq_erasure_plugin.cmxa +src/metacoq_erasure_plugin.cmxa (real: 0.02, user: 0.00, sys: 0.01, mem: 13520 ko) +CAMLOPT -shared -o src/metacoq_erasure_plugin.cmxs +src/metacoq_erasure_plugin.cmxs (real: 0.17, user: 0.13, sys: 0.03, mem: 20232 ko) +COQC theories/Loader.v +theories/Loader.vo (real: 0.41, user: 0.30, sys: 0.11, mem: 237756 ko) +make[4]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/erasure' +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/erasure' +make -C test-suite +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/test-suite' +coq_makefile -f _CoqProject -o Makefile.coq +make -C plugin-demo +make[4]: Entering directory '/builds/coq/coq/_build_ci/metacoq/test-suite/plugin-demo' +coq_makefile -f _CoqProject -o Makefile.coq +Warning: ../template-coq/theories (used in -R or -Q) is not a subdirectory of the current directory + +make -f Makefile.coq pretty-timed +make[4]: Entering directory '/builds/coq/coq/_build_ci/metacoq/test-suite' +Warning: ../../template-coq/theories (used in -R or -Q) is not a subdirectory of the current directory + +make -f Makefile.coq +make[5]: Entering directory '/builds/coq/coq/_build_ci/metacoq/test-suite/plugin-demo' +COQDEP VFILES +COQDEP VFILES +*** Warning: in file theories/MyPlugin.v, + required library Loader matches several files in path + (found Loader.v in ../../template-coq/theories and theories; used the latter) +COQC theories/Lens.v +theories/Lens.vo (real: 0.10, user: 0.05, sys: 0.04, mem: 64048 ko) +COQC theories/MyPlugin.v +COQC bug1.v +File "./theories/MyPlugin.v", line 10, characters 0-24: +Warning: Interpreting this declaration as if a global declaration prefixed by +"Local", i.e. as a global declaration which shall not be available without +qualification when imported. [local-declaration,scope] +theories/MyPlugin.vo (real: 1.20, user: 0.91, sys: 0.28, mem: 513348 ko) +COQC theories/Extraction.v +bug1.vo (real: 1.30, user: 1.03, sys: 0.26, mem: 510284 ko) +COQC bug2.v +bug2.vo (real: 1.09, user: 0.81, sys: 0.26, mem: 500380 ko) +COQC bug5.v +File "./theories/Extraction.v", line 7, characters 0-28: +Warning: The extraction is currently set to bypass opacity, the following +opaque constant bodies have been accessed +: All_Forall.All2_firstn All_Forall.All2_All_mix_right + CRelationClasses.PartialOrder_inverse All_Forall.All_All2_All2_mix + fold_rec_bis cardinal_inv_2b All_Forall.All_rev All_Forall.All_mix + All_Forall.All_map All_Forall.All_app + All_Forall.OnOne2_impl_exist_and_All_r Universes.fresh_universe + All_Forall.Alli_rev All_Forall.Alli_mix All_Forall.Alli_app + All_Forall.Alli_All All_Forall.All_prod All_Forall.All_mapi + All_Forall.All_impl All_Forall.All_Alli All_Forall.All_All2 + List.Forall_rect All_Forall.All2_sym All_Forall.All2_rev + All_Forall.All2_nth All_Forall.All2_mix All_Forall.All2_map + All_Forall.All2_app All_Forall.All2_All fold_rec_nodep + Universes.Level.eqb_spec All_Forall.Alli_shiftn_inv Universes.fresh_level + All_Forall.All2_All_mix_left All_Forall.All2_nth_error_Some_r + All_Forall.Alli_nth_error All_Forall.forall_nth_error_All + All_Forall.forall_nth_error_Alli All_Forall.All2_nth_error + All_Forall.nth_error_all All_Forall.All2_prod_inv All_Forall.Alli_mapi + List.nth_in_or_default All_Forall.forallb_nth' + CRelationClasses.partial_order_antisym All_Forall.All_skipn + CRelationClasses.flip_PreOrder All_Forall.Alli_shiftn All_Forall.Forall_All + CRelationClasses.relation_implication_preorder + All_Forall.OnOne2_impl_exist_and_All All_Forall.All2i_rev + All_Forall.All2i_app All_Forall.All2_symP All_Forall.All2_swap + All_Forall.All2_same All_Forall.All2_mapi All_Forall.All2_impl + All_Forall.All2_app_inv String.eqb_spec All_Forall.OnOne2_All_mix_left + List.exists_last All_Forall.All2i_mapi All_Forall.All2i_impl + All_Forall.All_nth_error All_Forall.All_repeat All_Forall.Alli_app_inv + All_Forall.All2_trans All_Forall.All2_skipn All_Forall.All2_right + All_Forall.All2_eq_eq All_Forall.All2_app_r All_Forall.All_firstn + All_Forall.All2_All_right All_Forall.All2_map_left MCOption.option_map_Some + CRelationClasses.flip_Reflexive All_Forall.All2_map_right + All_Forall.All2_map_left' All_Forall.forallb2_All2 All_Forall.All_app_inv + MCList.rev_case CRelationClasses.flip_StrictOrder MCList.nth_error_spec + List.destruct_list CRelationClasses.relation_equivalence_equivalence + All_Forall.OnOne2_split All_Forall.OnOne2_ind_l All_Forall.OnOne2_exist + cardinal_inv_2 All_Forall.All2_All_left All_Forall.OnOne2_mapP + All_Forall.OnOne2_impl All_Forall.nth_error_alli + Universes.ConstraintType.eq_dec MCList.rev_list_ind In_dec Ascii.eqb_spec + All_Forall.All_prod_inv set_induction_min set_induction_max + MCCompare.string_Compare All_Forall.All2_nth_error_Some_right + MCList.nth_error_Some' All_Forall.map_option_out_All All_Forall.All_rev_map + All_Forall.All_rev_inv All_Forall.All_All2_refl + CRelationClasses.flip_Antisymmetric All_Forall.All2_app_inv_r fold_rel + fold_rec MCCompare.ascii_Compare CRelationClasses.flip_PER + All_Forall.Alli_All_mix set_induction All_Forall.All2_mix_inv + CRelationClasses.flip_Equivalence All_Forall.forallb_All + All_Forall.All2_map_inv MCList.rev_ind All_Forall.All2_right_triv + set_induction_bis MCList.list_rect_rev fold_rec_weak BasicAst.ident_eq_spec + All_Forall.OnOne2_sym All_Forall.OnOne2_map All_Forall.OnOne2_app + All_Forall.All2_from_nth_error All_Forall.map_eq_inj + All_Forall.Alli_rev_nth_error All_Forall.All2_map_right' + All_Forall.All2_nth_error_Some All_Forall.OnOne2_nth_error + All_Forall.All2_All_left_pack All_Forall.All_safe_nth + CRelationClasses.subrelation_symmetric MCOption.nth_map_option_out + All_Forall.All_map_inv All_Forall.Alli_shift All_Forall.All2_impl_In. + [extraction-opaque-accessed,extraction] +bug5.vo (real: 1.92, user: 1.62, sys: 0.29, mem: 512080 ko) +COQC bug6.v +File "./theories/Extraction.v", line 7, characters 0-28: +Warning: The identifier __top_assumption_ contains __ which is reserved for +the extraction [extraction-reserved-identifier,extraction] +File "./theories/Extraction.v", line 7, characters 0-28: +Warning: The identifier __top_assumption_ contains __ which is reserved for +the extraction [extraction-reserved-identifier,extraction] +File "./theories/Extraction.v", line 7, characters 0-28: +Warning: The identifier t__rect contains __ which is reserved for the +extraction [extraction-reserved-identifier,extraction] +File "./theories/Extraction.v", line 7, characters 0-28: +Warning: The identifier t__rec contains __ which is reserved for the +extraction [extraction-reserved-identifier,extraction] +File "./theories/Extraction.v", line 7, characters 0-28: +Warning: The identifier t__rect contains __ which is reserved for the +extraction [extraction-reserved-identifier,extraction] +File "./theories/Extraction.v", line 7, characters 0-28: +Warning: The identifier t__rec contains __ which is reserved for the +extraction [extraction-reserved-identifier,extraction] +File "./theories/Extraction.v", line 7, characters 0-28: +Warning: The identifier t__rect contains __ which is reserved for the +extraction [extraction-reserved-identifier,extraction] +File "./theories/Extraction.v", line 7, characters 0-28: +Warning: The identifier t__rec contains __ which is reserved for the +extraction [extraction-reserved-identifier,extraction] +File "./theories/Extraction.v", line 7, characters 0-28: +Warning: The identifier t__rect contains __ which is reserved for the +extraction [extraction-reserved-identifier,extraction] +File "./theories/Extraction.v", line 7, characters 0-28: +Warning: The identifier t__rec contains __ which is reserved for the +extraction [extraction-reserved-identifier,extraction] +theories/Extraction.vo (real: 3.67, user: 3.11, sys: 0.54, mem: 561316 ko) +make[5]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/test-suite/plugin-demo' +cd gen-src && ./to-lower.sh +Moving Lens.ml to lens.ml +Moving Lens.mli to lens.mli +Moving MyPlugin.ml to myPlugin.ml +Moving MyPlugin.mli to myPlugin.mli +make -f Makefile.plugin +make[5]: Entering directory '/builds/coq/coq/_build_ci/metacoq/test-suite/plugin-demo' +Makefile.plugin:20: Makefile.plugin.conf: No such file or directory +COQDEP VFILES +*** Warning: in file test/test.v, + required library Loader matches several files in path + (found Loader.v in ../../template-coq/theories and theories; used the latter) +coq_makefile -f _PluginProject -o Makefile.plugin +Warning: ../../template-coq/theories (used in -R or -Q) is not a subdirectory of the current directory + +COQPP src/g_demo_plugin.mlg +CAMLDEP gen-src/lens.mli +CAMLDEP gen-src/myPlugin.mli +OCAMLLIBDEP src/demo_plugin.mlpack +CAMLDEP gen-src/lens.ml +CAMLDEP gen-src/myPlugin.ml +CAMLDEP src/g_demo_plugin.ml +CAMLC -c gen-src/lens.mli +gen-src/lens.cmi (real: 0.04, user: 0.03, sys: 0.01, mem: 19172 ko) +CAMLC -c gen-src/myPlugin.mli +gen-src/myPlugin.cmi (real: 0.05, user: 0.04, sys: 0.01, mem: 20208 ko) +CAMLOPT -c -for-pack Demo_plugin gen-src/lens.ml +gen-src/lens.cmx (real: 0.07, user: 0.04, sys: 0.02, mem: 22124 ko) +CAMLOPT -c -for-pack Demo_plugin gen-src/myPlugin.ml +bug6.vo (real: 1.11, user: 0.85, sys: 0.25, mem: 500408 ko) +COQC bug7.v +gen-src/myPlugin.cmx (real: 0.12, user: 0.10, sys: 0.02, mem: 27228 ko) +CAMLOPT -c -for-pack Demo_plugin src/g_demo_plugin.ml +src/g_demo_plugin.cmx (real: 0.09, user: 0.06, sys: 0.02, mem: 27844 ko) +CAMLOPT -pack -o src/demo_plugin.cmx +src/demo_plugin.cmx (real: 0.06, user: 0.04, sys: 0.02, mem: 21964 ko) +CAMLOPT -a -o src/demo_plugin.cmxa +src/demo_plugin.cmxa (real: 0.02, user: 0.00, sys: 0.01, mem: 13200 ko) +CAMLOPT -shared -o src/demo_plugin.cmxs +src/demo_plugin.cmxs (real: 0.04, user: 0.01, sys: 0.02, mem: 14256 ko) +COQC theories/Loader.v +theories/Loader.vo (real: 0.10, user: 0.05, sys: 0.04, mem: 62308 ko) +COQC test/test.v +bug7.vo (real: 1.21, user: 0.89, sys: 0.31, mem: 500252 ko) +COQC bug8.v +Notation plus := Nat.add +Expands to: Notation Coq.Init.Peano.plus +(1 + 2) +File "./test/test.v", line 19, characters 0-16: +Warning: SSReflect's Search command has been moved to the ssrsearch module; +please Require that module if you still want to use SSReflect's Search +command [ssr-search-moved,deprecated] +x: Point -> nat +y: Point -> nat +Build_Point: nat -> nat -> Point +_y: Lens Point Point nat nat +_x: Lens Point Point nat nat +test/test.vo (real: 1.51, user: 1.21, sys: 0.29, mem: 513888 ko) +make[5]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/test-suite/plugin-demo' +make[4]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/test-suite/plugin-demo' +COQC bugkncst.v +bug8.vo (real: 1.10, user: 0.84, sys: 0.25, mem: 500436 ko) +COQC case.v +File "./bugkncst.v", line 12, characters 21-36: +Warning: omega is deprecated since 8.12; use “lia” instead. +[omega-is-deprecated,deprecated] +case.vo (real: 1.12, user: 0.88, sys: 0.23, mem: 500120 ko) +COQC castprop.v +castprop.vo (real: 1.23, user: 0.94, sys: 0.28, mem: 510368 ko) +COQC cofix.v +cofix.vo (real: 1.11, user: 0.81, sys: 0.29, mem: 500192 ko) +COQC erasure_live_test.v +bugkncst.vo (real: 57.89, user: 56.51, sys: 1.14, mem: 896928 ko) +COQC vs.v +File "./vs.v", line 91, characters 0-145: +Warning: omega is deprecated since 8.12; use “lia” instead. +[omega-is-deprecated,deprecated] +File "./vs.v", line 1065, characters 1-7: +Warning: omega is deprecated since 8.12; use “lia” instead. +[omega-is-deprecated,deprecated] +File "./vs.v", line 1066, characters 1-7: +Warning: omega is deprecated since 8.12; use “lia” instead. +[omega-is-deprecated,deprecated] +File "./vs.v", line 1486, characters 0-143: +Warning: omega is deprecated since 8.12; use “lia” instead. +[omega-is-deprecated,deprecated] +File "./vs.v", line 1519, characters 0-4: +Warning: Cannot define graph(s) for main [funind-cannot-define-graph,funind] +File "./vs.v", line 1519, characters 0-4: +Warning: Cannot build inversion information +[funind-cannot-build-inversion,funind] +File "./vs.v", line 1870, characters 0-758: +Warning: Not a truly recursive fixpoint. [non-recursive,fixpoints] +File "./vs.v", line 2020, characters 0-145: +Warning: omega is deprecated since 8.12; use “lia” instead. +[omega-is-deprecated,deprecated] +File "./vs.v", line 2347, characters 0-27: +Warning: The extraction is currently set to bypass opacity, the following +opaque constant bodies have been accessed +: the_loop_terminate main_terminate. + [extraction-opaque-accessed,extraction] +File "./vs.v", line 2370, characters 0-21: +Warning: The extraction is currently set to bypass opacity, the following +opaque constant bodies have been accessed +: the_loop_terminate main_terminate. + [extraction-opaque-accessed,extraction] +vs.vo (real: 5.44, user: 4.90, sys: 0.51, mem: 501352 ko) +COQC evars.v +evars.vo (real: 1.10, user: 0.79, sys: 0.29, mem: 500100 ko) +COQC extractable.v +extractable.vo (real: 1.17, user: 0.88, sys: 0.29, mem: 501748 ko) +COQC hnf_ctor.v +hnf_ctor.vo (real: 1.11, user: 0.80, sys: 0.30, mem: 502088 ko) +COQC issue27.v +issue27.vo (real: 1.35, user: 1.02, sys: 0.31, mem: 522688 ko) +COQC issue28.v +File "./issue28.v", line 31, characters 0-282: +Warning: Interpreting this declaration as if a global declaration prefixed by +"Local", i.e. as a global declaration which shall not be available without +qualification when imported. [local-declaration,scope] +issue28.vo (real: 1.35, user: 1.05, sys: 0.29, mem: 522968 ko) +COQC letin.v +letin.vo (real: 1.21, user: 0.90, sys: 0.29, mem: 500080 ko) +COQC modules_sections.v +modules_sections.vo (real: 1.73, user: 1.35, sys: 0.35, mem: 526276 ko) +COQC mutind.v +mutind.vo (real: 1.19, user: 0.89, sys: 0.29, mem: 500068 ko) +COQC opaque.v +opaque.vo (real: 1.26, user: 0.94, sys: 0.31, mem: 500016 ko) +COQC proj.v +proj.vo (real: 1.52, user: 1.21, sys: 0.29, mem: 524028 ko) +COQC run_in_tactic.v +run_in_tactic.vo (real: 1.34, user: 1.03, sys: 0.29, mem: 522996 ko) +COQC safechecker_test.v +File "./safechecker_test.v", line 39, characters 0-27: +Warning: To avoid stack overflow, large numbers in nat are interpreted as +applications of Nat.of_num_uint. [abstract-large-number,numbers] +File "./safechecker_test.v", line 54, characters 0-44: +Warning: Notation "_ * _" was already used in scope type_scope. +[notation-overridden,parsing] +File "./safechecker_test.v", line 70, characters 0-50: +Warning: Notation "_ = _ :> _" was already used in scope type_scope. +[notation-overridden,parsing] +File "./safechecker_test.v", line 72, characters 0-45: +Warning: Notation "_ = _" was already used in scope type_scope. +[notation-overridden,parsing] +File "./safechecker_test.v", line 88, characters 0-68: +Warning: Notation "{ _ : _ & _ }" was already used in scope type_scope. +[notation-overridden,parsing] +File "./safechecker_test.v", line 432, characters 0-221: +Warning: +Ignored instance declaration for “e_inv”: “forall + (A : Type@{Var(0)}) + (B : Type@{Var(1)}) + (f : A -> B), + IsEquiv@{Var(0) Var(1)} f -> + B -> A” is not a class +[not-a-class,typeclasses] +File "./safechecker_test.v", line 440, characters 0-83: +Warning: +Ignored instance declaration for “e_fun”: “forall + (A : Type@{Var(0)}) + (B : Type@{Var(1)}), + Equiv@{Var(0) Var(1)} A B -> + A -> B” is not a class +[not-a-class,typeclasses] +safechecker_test.vo (real: 3.34, user: 2.89, sys: 0.44, mem: 726228 ko) +COQC tmExistingInstance.v +tmExistingInstance.vo (real: 1.21, user: 0.92, sys: 0.28, mem: 522724 ko) +COQC tmInferInstance.v +tmInferInstance.vo (real: 1.30, user: 0.98, sys: 0.31, mem: 522552 ko) +COQC TypingTests.v +TypingTests.vo (real: 2.62, user: 2.27, sys: 0.34, mem: 558304 ko) +COQC unfold.v +unfold.vo (real: 1.35, user: 1.03, sys: 0.31, mem: 522248 ko) +COQC univ.v +univ.vo (real: 1.28, user: 0.99, sys: 0.28, mem: 522992 ko) +COQC tmVariable.v +tmVariable.vo (real: 1.31, user: 1.01, sys: 0.29, mem: 524932 ko) +COQC order_rec.v +order_rec.vo (real: 1.41, user: 1.09, sys: 0.30, mem: 525128 ko) +COQC erasure_test.v +erasure_live_test.vo (real: 88.03, user: 86.21, sys: 1.46, mem: 1038900 ko) +File "./erasure_test.v", line 44, characters 0-27: +Warning: To avoid stack overflow, large numbers in nat are interpreted as +applications of Nat.of_num_uint. [abstract-large-number,numbers] +erasure_test.vo (real: 1.42, user: 1.10, sys: 0.31, mem: 543584 ko) + Time | Peak Mem | File Name +--------------------------------------------- +2m59.43s | 1038900 ko | Total Time / Peak Mem +--------------------------------------------- +1m26.21s | 1038900 ko | erasure_live_test.vo +0m56.51s | 896928 ko | bugkncst.vo +0m04.90s | 501352 ko | vs.vo +0m02.89s | 726228 ko | safechecker_test.vo +0m02.27s | 558304 ko | TypingTests.vo +0m01.62s | 512080 ko | bug5.vo +0m01.35s | 526276 ko | modules_sections.vo +0m01.21s | 524028 ko | proj.vo +0m01.10s | 543584 ko | erasure_test.vo +0m01.09s | 525128 ko | order_rec.vo +0m01.05s | 522968 ko | issue28.vo +0m01.03s | 510284 ko | bug1.vo +0m01.03s | 522996 ko | run_in_tactic.vo +0m01.03s | 522248 ko | unfold.vo +0m01.02s | 522688 ko | issue27.vo +0m01.01s | 524932 ko | tmVariable.vo +0m00.99s | 522992 ko | univ.vo +0m00.98s | 522552 ko | tmInferInstance.vo +0m00.94s | 510368 ko | castprop.vo +0m00.94s | 500016 ko | opaque.vo +0m00.92s | 522724 ko | tmExistingInstance.vo +0m00.90s | 500080 ko | letin.vo +0m00.89s | 500252 ko | bug7.vo +0m00.89s | 500068 ko | mutind.vo +0m00.88s | 500120 ko | case.vo +0m00.88s | 501748 ko | extractable.vo +0m00.85s | 500408 ko | bug6.vo +0m00.84s | 500436 ko | bug8.vo +0m00.81s | 500380 ko | bug2.vo +0m00.81s | 500192 ko | cofix.vo +0m00.80s | 502088 ko | hnf_ctor.vo +0m00.79s | 500100 ko | evars.vo +make[4]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/test-suite' +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/test-suite' +make[2]: Leaving directory '/builds/coq/coq/_build_ci/metacoq' +make[1]: Leaving directory '/builds/coq/coq/_build_ci/metacoq' ++ make install ++ '[' -z x ']' ++ command make install ++ make install +make[1]: Entering directory '/builds/coq/coq/_build_ci/metacoq' +make -C template-coq +make[2]: Entering directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make -f Makefile.coq +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make[4]: Nothing to be done for 'real-all'. +./update_plugin.sh +Updating gen-src from src +Copying from src to gen-src +Renaming files to camelCase +patching file gen-src/cRelationClasses.mli +Reversed (or previously applied) patch detected! Skipping patch. +1 out of 1 hunk ignored -- saving rejects to file gen-src/cRelationClasses.mli.rej +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make -f Makefile.template optfiles +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make[3]: Nothing to be done for 'optfiles'. +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +cp src/template_coq.cm* build/ +make -f Makefile.template +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make[4]: Nothing to be done for 'real-all'. +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make -f Makefile.plugin +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +CAMLDEP gen-src/univSubst0.mli +CAMLDEP gen-src/universes0.mli +CAMLDEP gen-src/string0.mli +CAMLDEP gen-src/run_extractable.mli +CAMLDEP gen-src/specif.mli +CAMLDEP gen-src/pretty.mli +CAMLDEP gen-src/plugin_core.mli +CAMLDEP gen-src/peanoNat.mli +CAMLDEP gen-src/ordersTac.mli +CAMLDEP gen-src/orders.mli +CAMLDEP gen-src/ordersLists.mli +CAMLDEP gen-src/ordersFacts.mli +CAMLDEP gen-src/orderedType0.mli +CAMLDEP gen-src/numeral.mli +CAMLDEP gen-src/nat0.mli +CAMLDEP gen-src/mSetProperties.mli +CAMLDEP gen-src/mSetList.mli +CAMLDEP gen-src/mSetInterface.mli +CAMLDEP gen-src/mSetFacts.mli +CAMLDEP gen-src/mSetDecide.mli +CAMLDEP gen-src/mCString.mli +CAMLDEP gen-src/mCRelations.mli +CAMLDEP gen-src/mCProd.mli +CAMLDEP gen-src/mCOption.mli +CAMLDEP gen-src/mCList.mli +CAMLDEP gen-src/mCCompare.mli +CAMLDEP gen-src/mCPrelude.mli +CAMLDEP gen-src/logic0.mli +CAMLDEP gen-src/list0.mli +CAMLDEP gen-src/liftSubst.mli +CAMLDEP gen-src/hexadecimal.mli +CAMLDEP gen-src/extractable.mli +CAMLDEP gen-src/equalities.mli +CAMLDEP gen-src/environment.mli +CAMLDEP gen-src/decimal.mli +CAMLDEP gen-src/datatypes.mli +CAMLDEP gen-src/cRelationClasses.mli +CAMLDEP gen-src/config0.mli +CAMLDEP gen-src/compare_dec.mli +CAMLDEP gen-src/common0.mli +CAMLDEP gen-src/bool.mli +CAMLDEP gen-src/binPos.mli +CAMLDEP gen-src/binPosDef.mli +CAMLDEP gen-src/binNums.mli +CAMLDEP gen-src/binNat.mli +CAMLDEP gen-src/binInt.mli +CAMLDEP gen-src/basics.mli +CAMLDEP gen-src/basicAst.mli +CAMLDEP gen-src/astUtils.mli +CAMLDEP gen-src/ast0.mli +CAMLDEP gen-src/ascii.mli +CAMLDEP gen-src/all_Forall.mli +OCAMLLIBDEP gen-src/metacoq_template_plugin.mlpack +CAMLDEP gen-src/univSubst0.ml +CAMLDEP gen-src/universes0.ml +CAMLDEP gen-src/tm_util.ml +CAMLDEP gen-src/string0.ml +CAMLDEP gen-src/specif.ml +CAMLDEP gen-src/run_extractable.ml +CAMLDEP gen-src/quoter.ml +CAMLDEP gen-src/reification.ml +CAMLDEP gen-src/pretty.ml +CAMLDEP gen-src/plugin_core.ml +CAMLDEP gen-src/peanoNat.ml +CAMLDEP gen-src/ordersTac.ml +CAMLDEP gen-src/orders.ml +CAMLDEP gen-src/ordersLists.ml +CAMLDEP gen-src/ordersFacts.ml +CAMLDEP gen-src/orderedType0.ml +CAMLDEP gen-src/numeral.ml +CAMLDEP gen-src/nat0.ml +CAMLDEP gen-src/mSetProperties.ml +CAMLDEP gen-src/mSetList.ml +CAMLDEP gen-src/mSetInterface.ml +CAMLDEP gen-src/mSetFacts.ml +CAMLDEP gen-src/mSetDecide.ml +CAMLDEP gen-src/mCString.ml +CAMLDEP gen-src/mCRelations.ml +CAMLDEP gen-src/mCProd.ml +CAMLDEP gen-src/mCOption.ml +CAMLDEP gen-src/mCList.ml +CAMLDEP gen-src/mCCompare.ml +CAMLDEP gen-src/mCPrelude.ml +CAMLDEP gen-src/logic0.ml +CAMLDEP gen-src/list0.ml +CAMLDEP gen-src/liftSubst.ml +CAMLDEP gen-src/hexadecimal.ml +CAMLDEP gen-src/extractable.ml +CAMLDEP gen-src/equalities.ml +CAMLDEP gen-src/environment.ml +CAMLDEP gen-src/denoter.ml +CAMLDEP gen-src/decimal.ml +CAMLDEP gen-src/datatypes.ml +CAMLDEP gen-src/cRelationClasses.ml +CAMLDEP gen-src/config0.ml +CAMLDEP gen-src/compare_dec.ml +CAMLDEP gen-src/common0.ml +CAMLDEP gen-src/bool.ml +CAMLDEP gen-src/binPos.ml +CAMLDEP gen-src/binPosDef.ml +CAMLDEP gen-src/binNums.ml +CAMLDEP gen-src/binNat.ml +CAMLDEP gen-src/binInt.ml +CAMLDEP gen-src/basics.ml +CAMLDEP gen-src/basicAst.ml +CAMLDEP gen-src/astUtils.ml +CAMLDEP gen-src/ast_quoter.ml +CAMLDEP gen-src/ast_denoter.ml +CAMLDEP gen-src/ast0.ml +CAMLDEP gen-src/ascii.ml +CAMLDEP gen-src/all_Forall.ml +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/tm_util.ml +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/reification.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/reification.cmx (real: 0.03, user: 0.01, sys: 0.01, mem: 14744 ko) +CAMLC -c gen-src/plugin_core.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/plugin_core.cmi (real: 0.02, user: 0.01, sys: 0.01, mem: 17304 ko) +CAMLC -c gen-src/tm_util.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/tm_util.cmx (real: 0.08, user: 0.04, sys: 0.03, mem: 21988 ko) +CAMLC -c gen-src/reification.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/reification.cmo (real: 0.01, user: 0.00, sys: 0.01, mem: 11896 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/quoter.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/tm_util.cmo (real: 0.04, user: 0.03, sys: 0.01, mem: 18588 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/denoter.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/denoter.cmx (real: 0.08, user: 0.06, sys: 0.02, mem: 24368 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/plugin_core.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/plugin_core.cmx (real: 0.10, user: 0.07, sys: 0.02, mem: 27576 ko) +gen-src/quoter.cmx (real: 0.20, user: 0.16, sys: 0.03, mem: 34528 ko) +CAMLC -c gen-src/quoter.ml +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/ast_quoter.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/quoter.cmo (real: 0.12, user: 0.09, sys: 0.02, mem: 26444 ko) +CAMLC -c gen-src/ast_quoter.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/ast_quoter.cmx (real: 0.12, user: 0.09, sys: 0.03, mem: 27268 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/ast_denoter.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/ast_quoter.cmo (real: 0.07, user: 0.05, sys: 0.02, mem: 22532 ko) +CAMLC -c gen-src/run_extractable.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/run_extractable.cmi (real: 0.02, user: 0.01, sys: 0.00, mem: 13788 ko) +gen-src/ast_denoter.cmx (real: 0.09, user: 0.07, sys: 0.02, mem: 27192 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/run_extractable.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/run_extractable.cmx (real: 0.14, user: 0.11, sys: 0.02, mem: 30592 ko) +CAMLOPT -pack -o gen-src/metacoq_template_plugin.cmx +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/metacoq_template_plugin.cmx (real: 0.21, user: 0.09, sys: 0.04, mem: 31480 ko) +CAMLOPT -a -o gen-src/metacoq_template_plugin.cmxa +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/metacoq_template_plugin.cmxa (real: 0.03, user: 0.01, sys: 0.02, mem: 13916 ko) +CAMLOPT -shared -o gen-src/metacoq_template_plugin.cmxs +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/metacoq_template_plugin.cmxs (real: 0.14, user: 0.10, sys: 0.03, mem: 18520 ko) +COQC theories/ExtractableLoader.v +theories/ExtractableLoader.vo (real: 0.10, user: 0.06, sys: 0.04, mem: 62624 ko) +cp gen-src/metacoq_template_plugin.cm* build/ +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make[2]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make -C checker +make -C pcuic +make[2]: Entering directory '/builds/coq/coq/_build_ci/metacoq/checker' +make -f Makefile.coq +make[2]: Entering directory '/builds/coq/coq/_build_ci/metacoq/pcuic' +make -f Makefile.pcuic +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/checker' +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/pcuic' +make[4]: Nothing to be done for 'real-all'. +./update_plugin.sh +Renaming extracted files +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/checker' +make[2]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/checker' +make -C examples +make[2]: Entering directory '/builds/coq/coq/_build_ci/metacoq/examples' +make -f Makefile.coq pretty-timed +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/examples' +make[4]: Nothing to be done for 'real-all'. +# echo "All done, moving extraction files!" +# ./clean_extraction.sh +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/pcuic' +make[2]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/pcuic' +make -C safechecker +make[2]: Entering directory '/builds/coq/coq/_build_ci/metacoq/safechecker' +make -f Makefile.safechecker +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/safechecker' +make[6]: Nothing to be done for 'real-all'. +make[4]: Nothing to be done for 'real-all'. +echo "Done extracting the safe checker, moving extraction files!" +Done extracting the safe checker, moving extraction files! +./clean_extraction.sh +Cleaning result of extraction +Extraction up-to date +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/safechecker' +make -f Makefile.plugin +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/safechecker' + Time | Peak Mem | File Name +-------------------------------------------- +0m22.62s | 581920 ko | Total Time / Peak Mem +-------------------------------------------- +0m19.93s | 581920 ko | tauto.vo +0m01.56s | 527740 ko | demo.vo +0m01.13s | 524144 ko | add_constructor.vo +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/examples' +make[2]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/examples' +COQC theories/Loader.v +theories/Loader.vo (real: 0.11, user: 0.07, sys: 0.03, mem: 63372 ko) +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/safechecker' +make[2]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/safechecker' +make -C erasure +make[2]: Entering directory '/builds/coq/coq/_build_ci/metacoq/erasure' +make -f Makefile.erasure +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/erasure' +make[4]: Nothing to be done for 'real-all'. +echo "Done extracting the erasure, moving extraction files!" +Done extracting the erasure, moving extraction files! +./clean_extraction.sh +Cleaning result of extraction +Extraction up-to date +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/erasure' +./clean_extraction.sh +Cleaning result of extraction +Extraction up-to date +make -f Makefile.plugin +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/erasure' +COQC theories/Loader.v +theories/Loader.vo (real: 0.44, user: 0.28, sys: 0.15, mem: 237408 ko) +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/erasure' +make[2]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/erasure' +make -C template-coq install +make[2]: Entering directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make -f Makefile.coq +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make[4]: Nothing to be done for 'real-all'. +./update_plugin.sh +Updating gen-src from src +Copying from src to gen-src +Renaming files to camelCase +patching file gen-src/cRelationClasses.mli +Reversed (or previously applied) patch detected! Skipping patch. +1 out of 1 hunk ignored -- saving rejects to file gen-src/cRelationClasses.mli.rej +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make -f Makefile.template optfiles +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make[3]: Nothing to be done for 'optfiles'. +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +cp src/template_coq.cm* build/ +make -f Makefile.template +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make[4]: Nothing to be done for 'real-all'. +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make -f Makefile.plugin +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +CAMLDEP gen-src/univSubst0.mli +CAMLDEP gen-src/universes0.mli +CAMLDEP gen-src/string0.mli +CAMLDEP gen-src/specif.mli +CAMLDEP gen-src/run_extractable.mli +CAMLDEP gen-src/pretty.mli +CAMLDEP gen-src/plugin_core.mli +CAMLDEP gen-src/peanoNat.mli +CAMLDEP gen-src/ordersTac.mli +CAMLDEP gen-src/orders.mli +CAMLDEP gen-src/ordersLists.mli +CAMLDEP gen-src/ordersFacts.mli +CAMLDEP gen-src/orderedType0.mli +CAMLDEP gen-src/numeral.mli +CAMLDEP gen-src/nat0.mli +CAMLDEP gen-src/mSetProperties.mli +CAMLDEP gen-src/mSetList.mli +CAMLDEP gen-src/mSetFacts.mli +CAMLDEP gen-src/mSetInterface.mli +CAMLDEP gen-src/mSetDecide.mli +CAMLDEP gen-src/mCString.mli +CAMLDEP gen-src/mCRelations.mli +CAMLDEP gen-src/mCProd.mli +CAMLDEP gen-src/mCOption.mli +CAMLDEP gen-src/mCList.mli +CAMLDEP gen-src/mCCompare.mli +CAMLDEP gen-src/mCPrelude.mli +CAMLDEP gen-src/logic0.mli +CAMLDEP gen-src/list0.mli +CAMLDEP gen-src/liftSubst.mli +CAMLDEP gen-src/hexadecimal.mli +CAMLDEP gen-src/extractable.mli +CAMLDEP gen-src/equalities.mli +CAMLDEP gen-src/environment.mli +CAMLDEP gen-src/decimal.mli +CAMLDEP gen-src/datatypes.mli +CAMLDEP gen-src/cRelationClasses.mli +CAMLDEP gen-src/config0.mli +CAMLDEP gen-src/compare_dec.mli +CAMLDEP gen-src/common0.mli +CAMLDEP gen-src/bool.mli +CAMLDEP gen-src/binPos.mli +CAMLDEP gen-src/binPosDef.mli +CAMLDEP gen-src/binNums.mli +CAMLDEP gen-src/binNat.mli +CAMLDEP gen-src/binInt.mli +CAMLDEP gen-src/basics.mli +CAMLDEP gen-src/basicAst.mli +CAMLDEP gen-src/astUtils.mli +CAMLDEP gen-src/ast0.mli +CAMLDEP gen-src/ascii.mli +CAMLDEP gen-src/all_Forall.mli +OCAMLLIBDEP gen-src/metacoq_template_plugin.mlpack +CAMLDEP gen-src/univSubst0.ml +CAMLDEP gen-src/universes0.ml +CAMLDEP gen-src/tm_util.ml +CAMLDEP gen-src/string0.ml +CAMLDEP gen-src/specif.ml +CAMLDEP gen-src/run_extractable.ml +CAMLDEP gen-src/quoter.ml +CAMLDEP gen-src/reification.ml +CAMLDEP gen-src/pretty.ml +CAMLDEP gen-src/plugin_core.ml +CAMLDEP gen-src/peanoNat.ml +CAMLDEP gen-src/ordersTac.ml +CAMLDEP gen-src/orders.ml +CAMLDEP gen-src/ordersLists.ml +CAMLDEP gen-src/ordersFacts.ml +CAMLDEP gen-src/orderedType0.ml +CAMLDEP gen-src/numeral.ml +CAMLDEP gen-src/nat0.ml +CAMLDEP gen-src/mSetProperties.ml +CAMLDEP gen-src/mSetList.ml +CAMLDEP gen-src/mSetInterface.ml +CAMLDEP gen-src/mSetFacts.ml +CAMLDEP gen-src/mSetDecide.ml +CAMLDEP gen-src/mCString.ml +CAMLDEP gen-src/mCRelations.ml +CAMLDEP gen-src/mCProd.ml +CAMLDEP gen-src/mCOption.ml +CAMLDEP gen-src/mCList.ml +CAMLDEP gen-src/mCCompare.ml +CAMLDEP gen-src/mCPrelude.ml +CAMLDEP gen-src/logic0.ml +CAMLDEP gen-src/list0.ml +CAMLDEP gen-src/liftSubst.ml +CAMLDEP gen-src/hexadecimal.ml +CAMLDEP gen-src/extractable.ml +CAMLDEP gen-src/equalities.ml +CAMLDEP gen-src/environment.ml +CAMLDEP gen-src/denoter.ml +CAMLDEP gen-src/decimal.ml +CAMLDEP gen-src/datatypes.ml +CAMLDEP gen-src/cRelationClasses.ml +CAMLDEP gen-src/config0.ml +CAMLDEP gen-src/compare_dec.ml +CAMLDEP gen-src/common0.ml +CAMLDEP gen-src/bool.ml +CAMLDEP gen-src/binPos.ml +CAMLDEP gen-src/binPosDef.ml +CAMLDEP gen-src/binNums.ml +CAMLDEP gen-src/binNat.ml +CAMLDEP gen-src/binInt.ml +CAMLDEP gen-src/basics.ml +CAMLDEP gen-src/astUtils.ml +CAMLDEP gen-src/basicAst.ml +CAMLDEP gen-src/ast_denoter.ml +CAMLDEP gen-src/ast_quoter.ml +CAMLDEP gen-src/ast0.ml +CAMLDEP gen-src/ascii.ml +CAMLDEP gen-src/all_Forall.ml +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/reification.ml +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/tm_util.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/reification.cmx (real: 0.02, user: 0.01, sys: 0.01, mem: 14740 ko) +CAMLC -c gen-src/plugin_core.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/plugin_core.cmi (real: 0.03, user: 0.02, sys: 0.00, mem: 17196 ko) +CAMLC -c gen-src/tm_util.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/tm_util.cmx (real: 0.08, user: 0.04, sys: 0.02, mem: 22136 ko) +CAMLC -c gen-src/reification.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/reification.cmo (real: 0.02, user: 0.01, sys: 0.00, mem: 11760 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/quoter.ml +gen-src/tm_util.cmo (real: 0.04, user: 0.02, sys: 0.01, mem: 18448 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/denoter.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/denoter.cmx (real: 0.12, user: 0.08, sys: 0.02, mem: 24324 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/plugin_core.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/quoter.cmx (real: 0.22, user: 0.19, sys: 0.03, mem: 34468 ko) +CAMLC -c gen-src/quoter.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/quoter.cmo (real: 0.12, user: 0.10, sys: 0.01, mem: 26404 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/ast_quoter.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/plugin_core.cmx (real: 0.28, user: 0.07, sys: 0.03, mem: 27504 ko) +CAMLC -c gen-src/ast_quoter.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/ast_quoter.cmo (real: 0.09, user: 0.05, sys: 0.02, mem: 22440 ko) +CAMLC -c gen-src/run_extractable.mli +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/run_extractable.cmi (real: 0.02, user: 0.01, sys: 0.00, mem: 13824 ko) +gen-src/ast_quoter.cmx (real: 0.20, user: 0.10, sys: 0.03, mem: 27364 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/ast_denoter.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/ast_denoter.cmx (real: 0.19, user: 0.08, sys: 0.03, mem: 27288 ko) +CAMLOPT -c -for-pack Metacoq_template_plugin gen-src/run_extractable.ml +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/run_extractable.cmx (real: 0.18, user: 0.09, sys: 0.03, mem: 30504 ko) +CAMLOPT -pack -o gen-src/metacoq_template_plugin.cmx +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/metacoq_template_plugin.cmx (real: 0.18, user: 0.11, sys: 0.04, mem: 31632 ko) +CAMLOPT -a -o gen-src/metacoq_template_plugin.cmxa +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/metacoq_template_plugin.cmxa (real: 0.05, user: 0.01, sys: 0.02, mem: 14056 ko) +CAMLOPT -shared -o gen-src/metacoq_template_plugin.cmxs +findlib: [WARNING] Interface numeral.cmi occurs in several directories: /builds/coq/coq/_install_ci/lib/coq/plugins/syntax, gen-src +gen-src/metacoq_template_plugin.cmxs (real: 0.15, user: 0.10, sys: 0.04, mem: 18416 ko) +COQC theories/ExtractableLoader.v +theories/ExtractableLoader.vo (real: 0.09, user: 0.04, sys: 0.04, mem: 62716 ko) +cp gen-src/metacoq_template_plugin.cm* build/ +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make -f Makefile.coq install +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +INSTALL theories/utils/MCPrelude.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/All_Forall.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/MCArith.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/MCCompare.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/MCEquality.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/LibHypsNaming.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/MCList.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/MCOption.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/MCProd.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/MCRelations.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/MCSquash.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/MCString.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/wGraph.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/common/uGraph.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//common +INSTALL theories/utils.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/config.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/Universes.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/BasicAst.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/Environment.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/Ast.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/AstUtils.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/Induction.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/LiftSubst.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/UnivSubst.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/Pretty.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/EnvironmentTyping.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/WfInv.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/Typing.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/TypingWf.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/TemplateMonad.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/TemplateMonad/Common.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//TemplateMonad +INSTALL theories/TemplateMonad/Core.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//TemplateMonad +INSTALL theories/TemplateMonad/Extractable.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//TemplateMonad +INSTALL theories/monad_utils.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/Constants.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/Extraction.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/utils/MCPrelude.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/All_Forall.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/MCArith.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/MCCompare.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/MCEquality.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/LibHypsNaming.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/MCList.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/MCOption.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/MCProd.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/MCRelations.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/MCSquash.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/MCString.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/wGraph.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/common/uGraph.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//common +INSTALL theories/utils.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/config.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/Universes.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/BasicAst.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/Environment.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/Ast.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/AstUtils.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/Induction.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/LiftSubst.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/UnivSubst.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/Pretty.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/EnvironmentTyping.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/WfInv.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/Typing.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/TypingWf.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/TemplateMonad.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/TemplateMonad/Common.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//TemplateMonad +INSTALL theories/TemplateMonad/Core.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//TemplateMonad +INSTALL theories/TemplateMonad/Extractable.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//TemplateMonad +INSTALL theories/monad_utils.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/Constants.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/Extraction.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/utils/MCPrelude.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/All_Forall.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/MCArith.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/MCCompare.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/MCEquality.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/LibHypsNaming.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/MCList.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/MCOption.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/MCProd.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/MCRelations.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/MCSquash.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/MCString.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/utils/wGraph.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//utils +INSTALL theories/common/uGraph.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//common +INSTALL theories/utils.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/config.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/Universes.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/BasicAst.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/Environment.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/Ast.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/AstUtils.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/Induction.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/LiftSubst.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/UnivSubst.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/Pretty.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/EnvironmentTyping.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/WfInv.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/Typing.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/TypingWf.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/TemplateMonad.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/TemplateMonad/Common.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//TemplateMonad +INSTALL theories/TemplateMonad/Core.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//TemplateMonad +INSTALL theories/TemplateMonad/Extractable.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template//TemplateMonad +INSTALL theories/monad_utils.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/Constants.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/Extraction.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +make[4]: Entering directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make[4]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make -f Makefile.template install +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +INSTALL theories/Loader.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/All.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/Loader.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/All.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/Loader.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/All.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL src/template_coq.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL src/template_coq.cmxs /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL src/template_coq.cmxs /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL src/template_coq.cmxa /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL src/template_coq.cmx /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +make[4]: Entering directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make[4]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make -f Makefile.plugin install +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +INSTALL theories/ExtractableLoader.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/ExtractableLoader.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL theories/ExtractableLoader.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL gen-src/mCPrelude.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL gen-src/metacoq_template_plugin.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL gen-src/mCPrelude.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL gen-src/metacoq_template_plugin.cmxs /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL gen-src/metacoq_template_plugin.cmxs /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL gen-src/metacoq_template_plugin.cmxa /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL gen-src/mCPrelude.cmx /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +INSTALL gen-src/metacoq_template_plugin.cmx /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Template/ +make[4]: Entering directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make[4]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make[2]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/template-coq' +make -C checker install +make[2]: Entering directory '/builds/coq/coq/_build_ci/metacoq/checker' +make -f Makefile.coq +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/checker' +make[4]: Nothing to be done for 'real-all'. +./update_plugin.sh +Renaming extracted files +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/checker' +make -f Makefile.coq install +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/checker' +INSTALL theories/Reflect.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Checker/ +INSTALL theories/Generation.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Checker/ +INSTALL theories/WeakeningEnv.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Checker/ +INSTALL theories/Closed.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Checker/ +INSTALL theories/Weakening.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Checker/ +INSTALL theories/Substitution.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Checker/ +INSTALL theories/Checker.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Checker/ +INSTALL theories/WcbvEval.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Checker/ +INSTALL theories/Retyping.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Checker/ +INSTALL theories/Normal.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Checker/ +INSTALL theories/All.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Checker/ +INSTALL theories/Reflect.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Checker/ +INSTALL theories/Generation.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Checker/ +INSTALL theories/WeakeningEnv.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Checker/ +INSTALL theories/Closed.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Checker/ +INSTALL theories/Weakening.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Checker/ +INSTALL theories/Substitution.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Checker/ +INSTALL theories/Checker.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Checker/ +INSTALL theories/WcbvEval.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Checker/ +INSTALL theories/Retyping.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Checker/ +INSTALL theories/Normal.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Checker/ +INSTALL theories/All.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Checker/ +INSTALL theories/Reflect.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Checker/ +INSTALL theories/Generation.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Checker/ +INSTALL theories/WeakeningEnv.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Checker/ +INSTALL theories/Closed.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Checker/ +INSTALL theories/Weakening.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Checker/ +INSTALL theories/Substitution.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Checker/ +INSTALL theories/Checker.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Checker/ +INSTALL theories/WcbvEval.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Checker/ +INSTALL theories/Retyping.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Checker/ +INSTALL theories/Normal.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Checker/ +INSTALL theories/All.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Checker/ +make[4]: Entering directory '/builds/coq/coq/_build_ci/metacoq/checker' +make[4]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/checker' +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/checker' +# make -f Makefile.plugin install +make[2]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/checker' +make -C pcuic install +make[2]: Entering directory '/builds/coq/coq/_build_ci/metacoq/pcuic' +make -f Makefile.pcuic +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/pcuic' +make[4]: Nothing to be done for 'real-all'. +# echo "All done, moving extraction files!" +# ./clean_extraction.sh +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/pcuic' +make -f Makefile.pcuic install +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/pcuic' +INSTALL theories/PCUICUtils.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICAst.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICSize.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICAstUtils.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICInduction.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICReflect.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICLiftSubst.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICUnivSubst.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICTyping.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICInversion.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICPosition.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICNormal.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICNameless.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICEquality.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICWeakeningEnv.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICClosed.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICWeakening.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICUnivSubstitution.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICSubstitution.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICCumulativity.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICReduction.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICParallelReduction.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICParallelReductionConfluence.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICConfluence.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICContextConversion.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICConversion.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICGeneration.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICAlpha.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICPrincipality.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICCtxShape.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICContexts.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICArities.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICSpine.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICInductives.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICValidity.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICInductiveInversion.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICSR.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICMetaTheory.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICCSubst.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICWcbvEval.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICChecker.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICPretty.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICCheckerCompleteness.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICRetyping.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICElimination.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICSN.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICSigmaCalculus.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICSafeLemmata.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/TemplateToPCUIC.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/TemplateToPCUICCorrectness.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICToTemplate.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICToTemplateCorrectness.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICUtils.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICAst.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICSize.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICAstUtils.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICInduction.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICReflect.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICLiftSubst.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICUnivSubst.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICTyping.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICInversion.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICPosition.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICNormal.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICNameless.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICEquality.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICWeakeningEnv.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICClosed.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICWeakening.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICUnivSubstitution.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICSubstitution.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICCumulativity.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICReduction.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICParallelReduction.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICParallelReductionConfluence.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICConfluence.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICContextConversion.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICConversion.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICGeneration.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICAlpha.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICPrincipality.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICCtxShape.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICContexts.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICArities.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICSpine.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICInductives.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICValidity.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICInductiveInversion.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICSR.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICMetaTheory.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICCSubst.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICWcbvEval.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICChecker.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICPretty.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICCheckerCompleteness.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICRetyping.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICElimination.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICSN.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICSigmaCalculus.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICSafeLemmata.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/TemplateToPCUIC.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/TemplateToPCUICCorrectness.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICToTemplate.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICToTemplateCorrectness.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICUtils.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICAst.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICSize.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICAstUtils.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICInduction.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICReflect.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICLiftSubst.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICUnivSubst.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICTyping.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICInversion.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICPosition.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICNormal.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICNameless.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICEquality.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICWeakeningEnv.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICClosed.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICWeakening.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICUnivSubstitution.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICSubstitution.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICCumulativity.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICReduction.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICParallelReduction.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICParallelReductionConfluence.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICConfluence.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICContextConversion.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICConversion.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICGeneration.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICAlpha.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICPrincipality.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICCtxShape.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICContexts.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICArities.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICSpine.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICInductives.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICValidity.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICInductiveInversion.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICSR.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICMetaTheory.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICCSubst.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICWcbvEval.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICChecker.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICPretty.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICCheckerCompleteness.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICRetyping.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICElimination.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICSN.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICSigmaCalculus.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICSafeLemmata.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/TemplateToPCUIC.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/TemplateToPCUICCorrectness.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICToTemplate.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +INSTALL theories/PCUICToTemplateCorrectness.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/PCUIC/ +make[4]: Entering directory '/builds/coq/coq/_build_ci/metacoq/pcuic' +make[4]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/pcuic' +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/pcuic' +# make -f Makefile.plugin install +make[2]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/pcuic' +make -C safechecker install +make[2]: Entering directory '/builds/coq/coq/_build_ci/metacoq/safechecker' +make -f Makefile.safechecker +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/safechecker' +make[4]: Nothing to be done for 'real-all'. +echo "Done extracting the safe checker, moving extraction files!" +Done extracting the safe checker, moving extraction files! +./clean_extraction.sh +Cleaning result of extraction +Extraction up-to date +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/safechecker' +make -f Makefile.plugin +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/safechecker' +COQC theories/Loader.v +theories/Loader.vo (real: 0.12, user: 0.07, sys: 0.04, mem: 63996 ko) +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/safechecker' +make -f Makefile.safechecker install +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/safechecker' +INSTALL theories/PCUICSafeReduce.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/SafeChecker/ +INSTALL theories/PCUICSafeConversion.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/SafeChecker/ +INSTALL theories/PCUICSafeChecker.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/SafeChecker/ +INSTALL theories/SafeTemplateChecker.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/SafeChecker/ +INSTALL theories/PCUICSafeRetyping.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/SafeChecker/ +INSTALL theories/Extraction.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/SafeChecker/ +INSTALL theories/PCUICSafeReduce.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/SafeChecker/ +INSTALL theories/PCUICSafeConversion.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/SafeChecker/ +INSTALL theories/PCUICSafeChecker.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/SafeChecker/ +INSTALL theories/SafeTemplateChecker.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/SafeChecker/ +INSTALL theories/PCUICSafeRetyping.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/SafeChecker/ +INSTALL theories/Extraction.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/SafeChecker/ +INSTALL theories/PCUICSafeReduce.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/SafeChecker/ +INSTALL theories/PCUICSafeConversion.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/SafeChecker/ +INSTALL theories/PCUICSafeChecker.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/SafeChecker/ +INSTALL theories/SafeTemplateChecker.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/SafeChecker/ +INSTALL theories/PCUICSafeRetyping.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/SafeChecker/ +INSTALL theories/Extraction.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/SafeChecker/ +make[4]: Entering directory '/builds/coq/coq/_build_ci/metacoq/safechecker' +make[4]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/safechecker' +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/safechecker' +make -f Makefile.plugin install +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/safechecker' +INSTALL theories/Loader.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/SafeChecker/ +INSTALL theories/Loader.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/SafeChecker/ +INSTALL theories/Loader.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/SafeChecker/ +INSTALL src/metacoq_safechecker_plugin.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/SafeChecker/ +INSTALL src/metacoq_safechecker_plugin.cmxs /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/SafeChecker/ +INSTALL src/metacoq_safechecker_plugin.cmxs /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/SafeChecker/ +INSTALL src/metacoq_safechecker_plugin.cmxa /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/SafeChecker/ +INSTALL src/metacoq_safechecker_plugin.cmx /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/SafeChecker/ +make[4]: Entering directory '/builds/coq/coq/_build_ci/metacoq/safechecker' +make[4]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/safechecker' +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/safechecker' +make[2]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/safechecker' +make -C erasure install +make[2]: Entering directory '/builds/coq/coq/_build_ci/metacoq/erasure' +make -f Makefile.erasure +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/erasure' +make[4]: Nothing to be done for 'real-all'. +echo "Done extracting the erasure, moving extraction files!" +Done extracting the erasure, moving extraction files! +./clean_extraction.sh +Cleaning result of extraction +Extraction up-to date +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/erasure' +./clean_extraction.sh +Cleaning result of extraction +Extraction up-to date +make -f Makefile.plugin +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/erasure' +COQC theories/Loader.v +theories/Loader.vo (real: 0.45, user: 0.29, sys: 0.15, mem: 238116 ko) +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/erasure' +make -f Makefile.erasure install +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/erasure' +INSTALL theories/EAst.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/EAstUtils.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/EInduction.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/ELiftSubst.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/EPretty.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/ECSubst.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/EWcbvEval.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/EWndEval.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/ETyping.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/Extract.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/EAll.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/Extraction.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/Prelim.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/ESubstitution.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/EInversion.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/EArities.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/ErasureCorrectness.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/ErasureFunction.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/SafeErasureFunction.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/SafeTemplateErasure.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/EAst.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/EAstUtils.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/EInduction.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/ELiftSubst.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/EPretty.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/ECSubst.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/EWcbvEval.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/EWndEval.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/ETyping.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/Extract.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/EAll.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/Extraction.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/Prelim.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/ESubstitution.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/EInversion.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/EArities.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/ErasureCorrectness.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/ErasureFunction.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/SafeErasureFunction.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/SafeTemplateErasure.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/EAst.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/EAstUtils.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/EInduction.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/ELiftSubst.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/EPretty.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/ECSubst.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/EWcbvEval.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/EWndEval.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/ETyping.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/Extract.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/EAll.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/Extraction.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/Prelim.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/ESubstitution.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/EInversion.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/EArities.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/ErasureCorrectness.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/ErasureFunction.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/SafeErasureFunction.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/SafeTemplateErasure.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +make[4]: Entering directory '/builds/coq/coq/_build_ci/metacoq/erasure' +make[4]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/erasure' +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/erasure' +make -f Makefile.plugin install +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/erasure' +INSTALL theories/Loader.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/Loader.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL theories/Loader.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL src/metacoq_erasure_plugin.cmi /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL src/metacoq_erasure_plugin.cmxs /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL src/metacoq_erasure_plugin.cmxs /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL src/metacoq_erasure_plugin.cmxa /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +INSTALL src/metacoq_erasure_plugin.cmx /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Erasure/ +make[4]: Entering directory '/builds/coq/coq/_build_ci/metacoq/erasure' +make[4]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/erasure' +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/erasure' +make[2]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/erasure' +make -C translations install +make[2]: Entering directory '/builds/coq/coq/_build_ci/metacoq/translations' +cat metacoq-config > _CoqProject +cat _CoqProject.in >> _CoqProject +coq_makefile -f _CoqProject -o Makefile.coq +Warning: ../template-coq/theories (used in -R or -Q) is not a subdirectory of the current directory + +make -f Makefile.coq pretty-timed +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/translations' +COQDEP VFILES +*** Warning: in file sigma.v, + required library Loader matches several files in path + (found Loader.v in ../template-coq/theories and ../checker/theories; used the latter) +COQC sigma.v +COQC MiniHoTT.v +File "./MiniHoTT.v", line 37, characters 0-198: +Warning: Notation "exists _ .. _ , _" was already used in scope type_scope. +[notation-overridden,parsing] +File "./MiniHoTT.v", line 41, characters 0-64: +Warning: Notation "{ _ : _ & _ }" was already used in scope type_scope. +[notation-overridden,parsing] +File "./MiniHoTT.v", line 96, characters 0-37: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope equiv_scope.". [undeclared-scope,deprecated] +File "./MiniHoTT.v", line 98, characters 0-35: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope path_scope.". [undeclared-scope,deprecated] +File "./MiniHoTT.v", line 99, characters 0-45: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope fibration_scope.". [undeclared-scope,deprecated] +File "./MiniHoTT.v", line 100, characters 0-37: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope trunc_scope.". [undeclared-scope,deprecated] +File "./MiniHoTT.v", line 136, characters 0-21: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./MiniHoTT.v", line 139, characters 0-52: +Warning: Notation "_ = _ :> _" was already used in scope type_scope. +[notation-overridden,parsing] +File "./MiniHoTT.v", line 140, characters 0-45: +Warning: Notation "_ = _" was already used in scope type_scope. +[notation-overridden,parsing] +sigma.vo (real: 1.17, user: 0.86, sys: 0.30, mem: 500064 ko) +COQC MiniHoTT_paths.v +File "./MiniHoTT_paths.v", line 41, characters 0-198: +Warning: Notation "exists _ .. _ , _" was already used in scope type_scope. +[notation-overridden,parsing] +File "./MiniHoTT_paths.v", line 45, characters 0-64: +Warning: Notation "{ _ : _ & _ }" was already used in scope type_scope. +[notation-overridden,parsing] +File "./MiniHoTT_paths.v", line 100, characters 0-37: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope equiv_scope.". [undeclared-scope,deprecated] +File "./MiniHoTT_paths.v", line 102, characters 0-35: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope path_scope.". [undeclared-scope,deprecated] +File "./MiniHoTT_paths.v", line 103, characters 0-45: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope fibration_scope.". [undeclared-scope,deprecated] +File "./MiniHoTT_paths.v", line 104, characters 0-37: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope trunc_scope.". [undeclared-scope,deprecated] +File "./MiniHoTT_paths.v", line 140, characters 0-21: +Warning: Adding and removing hints in the core database implicitly is +deprecated. Please specify a hint database. +[implicit-core-hint-db,deprecated] +File "./MiniHoTT_paths.v", line 143, characters 0-52: +Warning: Notation "_ = _ :> _" was already used in scope type_scope. +[notation-overridden,parsing] +File "./MiniHoTT_paths.v", line 144, characters 0-45: +Warning: Notation "_ = _" was already used in scope type_scope. +[notation-overridden,parsing] +MiniHoTT_paths.vo (real: 3.65, user: 3.42, sys: 0.20, mem: 350716 ko) +COQC translation_utils.v +MiniHoTT.vo (real: 4.94, user: 4.41, sys: 0.50, mem: 348856 ko) +translation_utils.vo (real: 2.16, user: 1.82, sys: 0.33, mem: 554420 ko) +COQC param_original.v +COQC param_cheap_packed.v +Coq.Init.Datatypes.nat has been translated. +Coq.Init.Datatypes.list has been translated. +listᵗ : forall A : TYPE, list A.1 -> Type + : forall A : TYPE, list A.1 -> Type +nilᵗ : forall A : TYPE, listᵗ A [] + : forall A : TYPE, listᵗ A [] +consᵗ +: +forall (A : TYPE) (x : El A) (lH : ∃ l : list A.1, listᵗ A l), +listᵗ A (x.1 :: lH.1) + : forall (A : TYPE) (x : El A) (lH : ∃ l : list A.1, listᵗ A l), + listᵗ A (x.1 :: lH.1) +param_cheap_packed.vo (real: 1.82, user: 1.49, sys: 0.32, mem: 553352 ko) +COQC param_generous_packed.v +"T has been translated as Tᵗ" +"tm has been translated as tmᵗ" +Coq.Init.Datatypes.nat has been translated. +Coq.Init.Datatypes.bool has been translated. +"pred has been translated as predᵗ" +"ID has been translated as IDᵗ" +"toto has been translated as totoᵗ" +"my_id has been translated as my_idᵗ" +"~~~~~~~~~~~~~~~~~~" +"Translating Coq.Init.Logic.eq" +"Coq.Init.Logic.eq has been translated." +"Translating MetaCoq.Translations.param_original.Id2.ID" +"ID has been translated as IDᵗ" +"~~~~~~~~~~~~~~~~~~" +"Translating Coq.Init.Logic.eq" +"Coq.Init.Logic.eq was already translated" +"Translating Coq.Init.Logic.eq_trans" +"eq_trans has been translated as eq_transᵗ" +"Translating Coq.Init.Logic.eq_sym" +"eq_sym has been translated as eq_symᵗ" +"Translating MetaCoq.Translations.param_original.Id2.ID" +"MetaCoq.Translations.param_original.Id2.ID was already translated" +"Translating MetaCoq.Translations.param_original.Id2.myf" +"myf has been translated as myfᵗ" +Coq.Vectors.VectorDef.t has been translated. +Coq.Arith.Even.even has been translated. +File "./param_generous_packed.v", line 7, characters 0-30: +Warning: Notation "exists _ .. _ , _" was already used in scope type_scope. +[notation-overridden,parsing] +File "./param_generous_packed.v", line 7, characters 0-30: +Warning: Notation "{ _ : _ & _ }" was already used in scope type_scope. +[notation-overridden,parsing] +File "./param_generous_packed.v", line 7, characters 0-30: +Warning: Notation "_ = _ :> _" was already used in scope type_scope. +[notation-overridden,parsing] +File "./param_generous_packed.v", line 7, characters 0-30: +Warning: Notation "_ = _" was already used in scope type_scope. +[notation-overridden,parsing] +Coq.Init.Datatypes.list has been translated. +"rev_type has been translated as rev_typeᵗ" +Fresh universe MetaCoq.Translations.param_generous_packed.603 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.604 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.605 was added to the context. +"Ty has been translated as Tyᵗ" +Tyᵗ : El Tyᵗ + : El Tyᵗ +File "./param_original.v", line 261, characters 0-24: +Warning: Notation "exists _ .. _ , _" was already used in scope type_scope. +[notation-overridden,parsing] +File "./param_original.v", line 261, characters 0-24: +Warning: Notation "{ _ : _ & _ }" was already used in scope type_scope. +[notation-overridden,parsing] +File "./param_original.v", line 261, characters 0-24: +Warning: Notation "_ = _ :> _" was already used in scope type_scope. +[notation-overridden,parsing] +File "./param_original.v", line 261, characters 0-24: +Warning: Notation "_ = _" was already used in scope type_scope. +[notation-overridden,parsing] +"sigT has been translated as sigTᵗ" +"~~~~~~~~~~~~~~~~~~" +"Translating Coq.Init.Logic.eq" +"Coq.Init.Logic.eq has been translated." +"Translating MetaCoq.Translations.MiniHoTT.paths" +"paths has been translated as pathsᵗ" +"existT has been translated as existTᵗ" +"Translating MetaCoq.Translations.param_original.Axioms.UIP" +"UIP has been translated as UIPᵗ" +"wFunext has been translated as wFunextᵗ" +"~~~~~~~~~~~~~~~~~~" +"Translating Coq.Init.Logic.eq" +"Coq.Init.Logic.eq was already translated" +"Translating MetaCoq.Translations.MiniHoTT.paths" +"MetaCoq.Translations.MiniHoTT.paths was already translated" +"Translating MetaCoq.Translations.MiniHoTT.Sect" +"Sect has been translated as Sectᵗ" +"Translating MetaCoq.Translations.MiniHoTT.idpath" +"idpath has been translated as idpathᵗ" +"Translating MetaCoq.Translations.MiniHoTT.paths_ind" +"paths_ind has been translated as paths_indᵗ" +"Translating MetaCoq.Translations.MiniHoTT.transport" +"transport has been translated as transportᵗ" +Finished transaction in 1.071 secs (0.906u,0.16s) (successful) +"Translating MetaCoq.Translations.MiniHoTT.ap" +"ap has been translated as apᵗ" +"sigT_ind has been translated as sigT_indᵗ" +"Translating MetaCoq.Translations.MiniHoTT.IsEquiv" +"MetaCoq.Translations.MiniHoTT.IsEquiv has been translated." +"paths has been translated as pathsᵗ" +"idpath has been translated as idpathᵗ" +"Translating MetaCoq.Translations.MiniHoTT.Equiv" +"MetaCoq.Translations.MiniHoTT.Equiv has been translated." +"paths_ind has been translated as paths_indᵗ" +"Translating MetaCoq.Translations.param_original.Axioms.wUnivalence" +"wUnivalence has been translated as wUnivalenceᵗ" +Fresh universe MetaCoq.Translations.param_generous_packed.696 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.697 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.698 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.699 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.700 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.701 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.702 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.703 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.704 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.705 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.706 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.707 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.708 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.709 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.710 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.711 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.712 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.713 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.714 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.715 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.716 was added to the context. +"Funext has been translated as Funextᵗ" +Fresh universe MetaCoq.Translations.param_generous_packed.728 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.729 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.730 was added to the context. +"FALSE has been translated as FALSEᵗ" +"~~~~~~~~~~~~~~~~~~" +"Translating Coq.Init.Logic.eq" +"Coq.Init.Logic.eq was already translated" +"Translating MetaCoq.Translations.MiniHoTT.paths" +"MetaCoq.Translations.MiniHoTT.paths was already translated" +"Translating MetaCoq.Translations.MiniHoTT.Sect" +"MetaCoq.Translations.MiniHoTT.Sect was already translated" +"Translating MetaCoq.Translations.MiniHoTT.idpath" +"MetaCoq.Translations.MiniHoTT.idpath was already translated" +"Translating MetaCoq.Translations.MiniHoTT.paths_ind" +"MetaCoq.Translations.MiniHoTT.paths_ind was already translated" +"Translating MetaCoq.Translations.MiniHoTT.transport" +"MetaCoq.Translations.MiniHoTT.transport was already translated" +"Translating MetaCoq.Translations.MiniHoTT.ap" +"MetaCoq.Translations.MiniHoTT.ap was already translated" +"UIP has been translated as UIPᵗ" +"Translating MetaCoq.Translations.MiniHoTT.IsEquiv" +"MetaCoq.Translations.MiniHoTT.IsEquiv was already translated" +"Translating MetaCoq.Translations.param_original.Axioms.coe" +"coe has been translated as coeᵗ" +"False has been translated as Falseᵗ" +"Translating MetaCoq.Translations.param_original.Axioms.Univalence'" +"Univalence' has been translated as Univalence'ᵗ" +"~~~~~~~~~~~~~~~~~~" +"Translating Coq.Init.Logic.eq" +"Coq.Init.Logic.eq was already translated" +"Translating MetaCoq.Translations.MiniHoTT.paths" +"MetaCoq.Translations.MiniHoTT.paths was already translated" +"Translating MetaCoq.Translations.MiniHoTT.Sect" +"MetaCoq.Translations.MiniHoTT.Sect was already translated" +"Translating MetaCoq.Translations.MiniHoTT.idpath" +"MetaCoq.Translations.MiniHoTT.idpath was already translated" +"Translating MetaCoq.Translations.MiniHoTT.paths_ind" +"MetaCoq.Translations.MiniHoTT.paths_ind was already translated" +"Translating MetaCoq.Translations.MiniHoTT.transport" +"MetaCoq.Translations.MiniHoTT.transport was already translated" +"Translating MetaCoq.Translations.MiniHoTT.ap" +"MetaCoq.Translations.MiniHoTT.ap was already translated" +"Translating MetaCoq.Translations.MiniHoTT.IsEquiv" +"MetaCoq.Translations.MiniHoTT.IsEquiv was already translated" +"Translating MetaCoq.Translations.param_original.Axioms.coe" +"MetaCoq.Translations.param_original.Axioms.coe was already translated" +"Translating MetaCoq.Translations.param_original.Axioms.Univalence'" +"MetaCoq.Translations.param_original.Axioms.Univalence' was already translated" +"Translating MetaCoq.Translations.MiniHoTT.Equiv" +"MetaCoq.Translations.MiniHoTT.Equiv was already translated" +"Translating MetaCoq.Translations.MiniHoTT.equiv_fun" +"equiv_fun has been translated as equiv_funᵗ" +Fresh universe MetaCoq.Translations.param_generous_packed.764 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.765 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.766 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.767 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.768 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.769 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.770 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.771 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.772 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.773 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.774 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.775 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.776 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.777 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.778 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.779 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.780 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.781 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.782 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.783 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.784 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.785 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.786 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.787 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.788 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.789 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.790 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.791 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.792 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.793 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.794 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.795 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.796 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.797 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.798 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.799 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.800 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.801 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.802 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.803 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.804 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.805 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.806 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.807 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.808 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.809 was added to the context. +Fresh universe MetaCoq.Translations.param_generous_packed.810 was added to the context. +"equiv has been translated as equivᵗ" +"Translating MetaCoq.Translations.MiniHoTT.isequiv_idmap" +"isequiv_idmap has been translated as isequiv_idmapᵗ" +param_generous_packed.vo (real: 9.61, user: 8.61, sys: 0.95, mem: 892080 ko) +COQC times_bool_fun.v +"Translating MetaCoq.Translations.MiniHoTT.equiv_idmap" +"equiv_idmap has been translated as equiv_idmapᵗ" +File "./times_bool_fun.v", line 2, characters 0-68: +Warning: Notation "exists _ .. _ , _" was already used in scope type_scope. +[notation-overridden,parsing] +File "./times_bool_fun.v", line 2, characters 0-68: +Warning: Notation "{ _ : _ & _ }" was already used in scope type_scope. +[notation-overridden,parsing] +File "./times_bool_fun.v", line 2, characters 0-68: +Warning: Notation "_ = _ :> _" was already used in scope type_scope. +[notation-overridden,parsing] +File "./times_bool_fun.v", line 2, characters 0-68: +Warning: Notation "_ = _" was already used in scope type_scope. +[notation-overridden,parsing] +File "./times_bool_fun.v", line 15, characters 0-48: +Warning: Declaring a scope implicitly is deprecated; use in advance an +explicit "Declare Scope prod_scope.". [undeclared-scope,deprecated] +"~~~~~~~~~~~~~~~~~~" +"Translating Coq.Init.Logic.eq" +"Translating MetaCoq.Translations.param_original.Axioms.equiv_paths" +"Coq.Init.Logic.eq has been translated." +"Translating MetaCoq.Translations.MiniHoTT.paths" +"paths has been translated as pathsᵗ" +"Translating Coq.Init.Logic.False" +"Coq.Init.Logic.False has been translated." +"Translating MetaCoq.Translations.times_bool_fun.NotFunext" +"NotFunext has been translated as NotFunextᵗ" +"equiv_paths has been translated as equiv_pathsᵗ" +"notFunext has been translated as notFunextᵗ" +"notη has been translated as notηᵗ" +"~~~~~~~~~~~~~~~~~~" +"Translating Coq.Init.Logic.eq" +"Coq.Init.Logic.eq was already translated" +"Translating MetaCoq.Translations.MiniHoTT.paths" +"MetaCoq.Translations.MiniHoTT.paths was already translated" +"Translating MetaCoq.Translations.times_bool_fun.UIP" +"UIP has been translated as UIPᵗ" +"~~~~~~~~~~~~~~~~~~" +"Translating Coq.Init.Logic.eq" +"Coq.Init.Logic.eq was already translated" +"Translating MetaCoq.Translations.MiniHoTT.paths" +"MetaCoq.Translations.MiniHoTT.paths was already translated" +"Translating MetaCoq.Translations.times_bool_fun.wFunext" +"wFunext has been translated as wFunextᵗ" +"Translating Coq.Init.Logic.False" +"Coq.Init.Logic.False was already translated" +"Translating MetaCoq.Translations.param_original.Axioms.Univalence" +"notwFunext has been translated as notwFunextᵗ" +"Univalence has been translated as Univalenceᵗ" +"idpath has been translated as idpathᵗ" +"paths_ind has been translated as paths_indᵗ" +"Translating MetaCoq.Translations.param_original.Axioms.UU'" +"~~~~~~~~~~~~~~~~~~" +"Translating Coq.Init.Logic.eq" +"Coq.Init.Logic.eq was already translated" +"Translating MetaCoq.Translations.MiniHoTT.paths" +"MetaCoq.Translations.MiniHoTT.paths was already translated" +"Translating MetaCoq.Translations.MiniHoTT.Sect" +Fresh universe MetaCoq.Translations.times_bool_fun.576 was added to the context. +Fresh universe MetaCoq.Translations.times_bool_fun.577 was added to the context. +Fresh universe MetaCoq.Translations.times_bool_fun.578 was added to the context. +Fresh universe MetaCoq.Translations.times_bool_fun.579 was added to the context. +"Sect has been translated as Sectᵗ" +"Translating MetaCoq.Translations.MiniHoTT.idpath" +"MetaCoq.Translations.MiniHoTT.idpath was already translated" +"UU' has been translated as UU'ᵗ" +"Translating MetaCoq.Translations.MiniHoTT.paths_ind" +"MetaCoq.Translations.MiniHoTT.paths_ind was already translated" +"Translating MetaCoq.Translations.MiniHoTT.transport" +"transport has been translated as transportᵗ" +"Translating MetaCoq.Translations.MiniHoTT.ap" +"ap has been translated as apᵗ" +"Translating MetaCoq.Translations.MiniHoTT.IsEquiv" +"MetaCoq.Translations.MiniHoTT.IsEquiv has been translated." +"Translating MetaCoq.Translations.MiniHoTT.Equiv" +param_original.vo (real: 18.98, user: 17.91, sys: 0.96, mem: 741808 ko) +COQC param_binary.v +"MetaCoq.Translations.MiniHoTT.Equiv has been translated." +File "./param_binary.v", line 207, characters 23-24: +Warning: Ignoring implicit binder declaration in unexpected position. +[unexpected-implicit-declaration,syntax] +File "./param_binary.v", line 207, characters 25-26: +Warning: Ignoring implicit binder declaration in unexpected position. +[unexpected-implicit-declaration,syntax] +Coq.Init.Datatypes.nat has been translated. +Coq.Init.Datatypes.bool has been translated. +Coq.Init.Datatypes.list has been translated. +"HD has been translated as HDᵗ" +"MAP has been translated as MAPᵗ" +param_binary.vo (real: 2.24, user: 1.93, sys: 0.29, mem: 556444 ko) +COQC standard_model.v +"Translating MetaCoq.Translations.times_bool_fun.wUnivalence" +"wUnivalence has been translated as wUnivalenceᵗ" +check_guarded: true +check_positive: true +check_universes: true +cumulative sprop: false +definitional uip: false +"toto has been translated as totoᵗ" +totoᵗ : unit -> (forall A : Type, A -> A) -> Type -> Type + : unit -> (forall A : Type, A -> A) -> Type -> Type +"FALSE has been translated as FALSEᵗ" +"toto" +"a has been translated as aᵗ" +"T has been translated as Tᵗ" +"tm has been translated as tmᵗ" +standard_model.vo (real: 1.63, user: 1.34, sys: 0.28, mem: 549492 ko) +Fresh universe MetaCoq.Translations.times_bool_fun.631 was added to the context. +Fresh universe MetaCoq.Translations.times_bool_fun.632 was added to the context. +Fresh universe MetaCoq.Translations.times_bool_fun.633 was added to the context. +"isequiv_idmap has been translated as isequiv_idmapᵗ" +Fresh universe MetaCoq.Translations.times_bool_fun.635 was added to the context. +Fresh universe MetaCoq.Translations.times_bool_fun.636 was added to the context. +Fresh universe MetaCoq.Translations.times_bool_fun.637 was added to the context. +Fresh universe MetaCoq.Translations.times_bool_fun.638 was added to the context. +Fresh universe MetaCoq.Translations.times_bool_fun.639 was added to the context. +"equiv_idmap has been translated as equiv_idmapᵗ" +Fresh universe MetaCoq.Translations.times_bool_fun.641 was added to the context. +Fresh universe MetaCoq.Translations.times_bool_fun.642 was added to the context. +Fresh universe MetaCoq.Translations.times_bool_fun.643 was added to the context. +Fresh universe MetaCoq.Translations.times_bool_fun.644 was added to the context. +Fresh universe MetaCoq.Translations.times_bool_fun.645 was added to the context. +Fresh universe MetaCoq.Translations.times_bool_fun.646 was added to the context. +Fresh universe MetaCoq.Translations.times_bool_fun.647 was added to the context. +Fresh universe MetaCoq.Translations.times_bool_fun.648 was added to the context. +Fresh universe MetaCoq.Translations.times_bool_fun.649 was added to the context. +"UA has been translated as UAᵗ" +"notUA has been translated as notUAᵗ" +times_bool_fun.vo (real: 27.19, user: 25.86, sys: 1.20, mem: 857128 ko) +COQC times_bool_fun2.v +File "./times_bool_fun2.v", line 4, characters 0-83: +Warning: Notation "exists _ .. _ , _" was already used in scope type_scope. +[notation-overridden,parsing] +File "./times_bool_fun2.v", line 4, characters 0-83: +Warning: Notation "{ _ : _ & _ }" was already used in scope type_scope. +[notation-overridden,parsing] +File "./times_bool_fun2.v", line 4, characters 0-83: +Warning: Notation "_ = _ :> _" was already used in scope type_scope. +[notation-overridden,parsing] +File "./times_bool_fun2.v", line 4, characters 0-83: +Warning: Notation "_ = _" was already used in scope type_scope. +[notation-overridden,parsing] +"paths has been translated as pathsᵗ" +"idpath has been translated as idpathᵗ" +"paths_ind has been translated as paths_indᵗ" +"transport has been translated as transportᵗ" +Fresh universe MetaCoq.Translations.times_bool_fun2.269 was added to the context. +"sigT has been translated as sigTᵗ" +"projT1 has been translated as projT1ᵗ" +"projT2 has been translated as projT2ᵗ" +"existT has been translated as existTᵗ" +Fresh universe MetaCoq.Translations.times_bool_fun2.377 was added to the context. +Fresh universe MetaCoq.Translations.times_bool_fun2.378 was added to the context. +Fresh universe MetaCoq.Translations.times_bool_fun2.379 was added to the context. +Fresh universe MetaCoq.Translations.times_bool_fun2.380 was added to the context. +Fresh universe MetaCoq.Translations.times_bool_fun2.381 was added to the context. +"isequiv has been translated as isequivᵗ" +Fresh universe MetaCoq.Translations.times_bool_fun2.383 was added to the context. +Fresh universe MetaCoq.Translations.times_bool_fun2.384 was added to the context. +Fresh universe MetaCoq.Translations.times_bool_fun2.385 was added to the context. +"equiv has been translated as equivᵗ" +"eq has been translated as eqᵗ" +"inverse has been translated as inverseᵗ" +Fresh universe MetaCoq.Translations.times_bool_fun2.416 was added to the context. +Fresh universe MetaCoq.Translations.times_bool_fun2.417 was added to the context. +"contr has been translated as contrᵗ" +"weakFunext has been translated as weakFunextᵗ" +times_bool_fun2.vo (real: 7.77, user: 7.23, sys: 0.50, mem: 614752 ko) + Time | Peak Mem | File Name +----------------------------------------------- +1m14.87s | 892080 ko | Total Time / Peak Mem +----------------------------------------------- +0m25.86s | 857128 ko | times_bool_fun.vo +0m17.91s | 741808 ko | param_original.vo +0m08.61s | 892080 ko | param_generous_packed.vo +0m07.23s | 614752 ko | times_bool_fun2.vo +0m04.41s | 348856 ko | MiniHoTT.vo +0m03.42s | 350716 ko | MiniHoTT_paths.vo +0m01.93s | 556444 ko | param_binary.vo +0m01.82s | 554420 ko | translation_utils.vo +0m01.49s | 553352 ko | param_cheap_packed.vo +0m01.34s | 549492 ko | standard_model.vo +0m00.86s | 500064 ko | sigma.vo +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/translations' +make -f Makefile.coq install +make[3]: Entering directory '/builds/coq/coq/_build_ci/metacoq/translations' +INSTALL sigma.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Translations/ +INSTALL MiniHoTT.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Translations/ +INSTALL MiniHoTT_paths.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Translations/ +INSTALL translation_utils.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Translations/ +INSTALL param_original.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Translations/ +INSTALL param_cheap_packed.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Translations/ +INSTALL param_generous_packed.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Translations/ +INSTALL times_bool_fun.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Translations/ +INSTALL times_bool_fun2.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Translations/ +INSTALL param_binary.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Translations/ +INSTALL standard_model.vo /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Translations/ +INSTALL sigma.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Translations/ +INSTALL MiniHoTT.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Translations/ +INSTALL MiniHoTT_paths.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Translations/ +INSTALL translation_utils.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Translations/ +INSTALL param_original.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Translations/ +INSTALL param_cheap_packed.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Translations/ +INSTALL param_generous_packed.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Translations/ +INSTALL times_bool_fun.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Translations/ +INSTALL times_bool_fun2.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Translations/ +INSTALL param_binary.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Translations/ +INSTALL standard_model.v /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Translations/ +INSTALL sigma.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Translations/ +INSTALL MiniHoTT.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Translations/ +INSTALL MiniHoTT_paths.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Translations/ +INSTALL translation_utils.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Translations/ +INSTALL param_original.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Translations/ +INSTALL param_cheap_packed.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Translations/ +INSTALL param_generous_packed.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Translations/ +INSTALL times_bool_fun.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Translations/ +INSTALL times_bool_fun2.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Translations/ +INSTALL param_binary.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Translations/ +INSTALL standard_model.glob /builds/coq/coq/_install_ci/lib/coq//user-contrib/MetaCoq/Translations/ +make[4]: Entering directory '/builds/coq/coq/_build_ci/metacoq/translations' +make[4]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/translations' +make[3]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/translations' +make[2]: Leaving directory '/builds/coq/coq/_build_ci/metacoq/translations' +make[1]: Leaving directory '/builds/coq/coq/_build_ci/metacoq' +Aggregating timing log... +Traceback (most recent call last): + File "./tools/make-one-time-file.py", line 13, in <module> + stats_dict = get_times_and_mems(args.FILE_NAME, use_real=args.real, include_mem=args.include_mem) + File "/builds/coq/coq/tools/TimeFileMaker.py", line 161, in get_times_and_mems + return merge_dicts(get_times_of_lines(lines, use_real=use_real), + File "/builds/coq/coq/tools/TimeFileMaker.py", line 156, in get_times_of_lines + return dict((name, {TIME_KEY:reformat_time_string(time)}) for name, time in times) + File "/builds/coq/coq/tools/TimeFileMaker.py", line 156, in <genexpr> + return dict((name, {TIME_KEY:reformat_time_string(time)}) for name, time in times) + File "/builds/coq/coq/tools/TimeFileMaker.py", line 104, in reformat_time_string + seconds, milliseconds = time.split('.') +ValueError: too many values to unpack +Makefile.ci:90: recipe for target 'ci-metacoq' failed +make: *** [ci-metacoq] Error 1 +section_end:1598965182:build_script
[0Ksection_start:1598965182:after_script
[0Ksection_end:1598965184:after_script
[0Ksection_start:1598965184:upload_artifacts_on_failure
[0Ksection_end:1598965189:upload_artifacts_on_failure
[0K[31;1mERROR: Job failed: exit code 1 +[0;m
\ No newline at end of file diff --git a/test-suite/coq-makefile/timing/precomputed-time-tests/run.sh b/test-suite/coq-makefile/timing/precomputed-time-tests/run.sh index 123b272a69..f6c283d53c 100755 --- a/test-suite/coq-makefile/timing/precomputed-time-tests/run.sh +++ b/test-suite/coq-makefile/timing/precomputed-time-tests/run.sh @@ -13,3 +13,4 @@ export COQLIB ./004-per-file-fuzz/run.sh ./005-correct-diff-sorting-order-mem/run.sh ./006-zero-before/run.sh +./007-no-output-sync/run.sh 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/misc/coq_makefile_destination_of.sh b/test-suite/misc/coq_makefile_destination_of.sh new file mode 100755 index 0000000000..fc8e089ccf --- /dev/null +++ b/test-suite/misc/coq_makefile_destination_of.sh @@ -0,0 +1,26 @@ +#!/usr/bin/env bash + +export COQBIN=$BIN +export PATH=$COQBIN:$PATH + +TMP=`mktemp -d` +cd $TMP + +function assert_eq() { + if [ "$1" != "$2" ]; then + echo "coq_makefile generates destination" $1 "!=" $2 + cd / + rm -rf $TMP + exit 1 + fi +} + +assert_eq `coq_makefile -destination-of src/Y/Z/Test.v -Q src X` "X//Y/Z" +mkdir src +assert_eq `coq_makefile -destination-of src/Y/Z/Test.v -Q src X` "X//Y/Z" +mkdir -p src/Y/Z +touch src/Y/Z/Test.v +assert_eq `coq_makefile -destination-of src/Y/Z/Test.v -Q src X` "X//Y/Z" +cd / +rm -rf $TMP +exit 0 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_ltac_1.out b/test-suite/output/ErrorLocation_ltac_1.out new file mode 100644 index 0000000000..a9014c4b46 --- /dev/null +++ b/test-suite/output/ErrorLocation_ltac_1.out @@ -0,0 +1,3 @@ +File "stdin", line 2, characters 7-11: +Error: Tactic failure: Cannot solve this goal. + diff --git a/test-suite/output/ErrorLocation_ltac_1.v b/test-suite/output/ErrorLocation_ltac_1.v new file mode 100644 index 0000000000..368a4592f2 --- /dev/null +++ b/test-suite/output/ErrorLocation_ltac_1.v @@ -0,0 +1,3 @@ +Goal False. +idtac; easy. +Abort. diff --git a/test-suite/output/ErrorLocation_ltac_2.out b/test-suite/output/ErrorLocation_ltac_2.out new file mode 100644 index 0000000000..d38727ffa4 --- /dev/null +++ b/test-suite/output/ErrorLocation_ltac_2.out @@ -0,0 +1,3 @@ +File "stdin", line 3, characters 7-8: +Error: Tactic failure. + diff --git a/test-suite/output/ErrorLocation_ltac_2.v b/test-suite/output/ErrorLocation_ltac_2.v new file mode 100644 index 0000000000..c3a9bd626a --- /dev/null +++ b/test-suite/output/ErrorLocation_ltac_2.v @@ -0,0 +1,4 @@ +Ltac f := fail. +Goal False. +idtac; f. +Abort. diff --git a/test-suite/output/ErrorLocation_ltac_3.out b/test-suite/output/ErrorLocation_ltac_3.out new file mode 100644 index 0000000000..409b72bba8 --- /dev/null +++ b/test-suite/output/ErrorLocation_ltac_3.out @@ -0,0 +1,3 @@ +File "stdin", line 3, characters 7-10: +Error: Not a negated primitive equality. + diff --git a/test-suite/output/ErrorLocation_ltac_3.v b/test-suite/output/ErrorLocation_ltac_3.v new file mode 100644 index 0000000000..43ce1fc6e2 --- /dev/null +++ b/test-suite/output/ErrorLocation_ltac_3.v @@ -0,0 +1,4 @@ +Ltac inj := injection. +Goal False. +idtac; inj. +Abort. diff --git a/test-suite/output/ErrorLocation_ltac_4.out b/test-suite/output/ErrorLocation_ltac_4.out new file mode 100644 index 0000000000..f9107cdc3f --- /dev/null +++ b/test-suite/output/ErrorLocation_ltac_4.out @@ -0,0 +1,3 @@ +File "stdin", line 2, characters 22-23: +Error: Tactic failure. + diff --git a/test-suite/output/ErrorLocation_ltac_4.v b/test-suite/output/ErrorLocation_ltac_4.v new file mode 100644 index 0000000000..58c370c31b --- /dev/null +++ b/test-suite/output/ErrorLocation_ltac_4.v @@ -0,0 +1,3 @@ +Goal False. +let x := fail in x || x. +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/Notations3.out b/test-suite/output/Notations3.out index abada44da7..bd22d45059 100644 --- a/test-suite/output/Notations3.out +++ b/test-suite/output/Notations3.out @@ -231,16 +231,13 @@ fun l : list nat => match l with : list nat -> list nat Arguments foo _%list_scope -Notation -"'exists' x .. y , p" := ex (fun x => .. (ex (fun y => p)) ..) : type_scope -(default interpretation) -"'exists' ! x .. y , p" := ex - (unique - (fun x => .. (ex (unique (fun y => p))) ..)) -: type_scope (default interpretation) -Notation -"( x , y , .. , z )" := pair .. (pair x y) .. z : core_scope -(default interpretation) +Notation "'exists' x .. y , p" := (ex (fun x => .. (ex (fun y => p)) ..)) + : type_scope (default interpretation) +Notation "'exists' ! x .. y , p" := + (ex (unique (fun x => .. (ex (unique (fun y => p))) ..))) : type_scope + (default interpretation) +Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope + (default interpretation) 1 subgoal ============================ diff --git a/test-suite/output/Notations4.out b/test-suite/output/Notations4.out index fa03ec8193..a42518822f 100644 --- a/test-suite/output/Notations4.out +++ b/test-suite/output/Notations4.out @@ -1,6 +1,6 @@ [< 0 > + < 1 > * < 2 >] : nat -Entry constr:myconstr is +Entry custom:myconstr is [ "6" RIGHTA [ ] | "5" RIGHTA @@ -8,7 +8,7 @@ Entry constr:myconstr is | "4" RIGHTA [ SELF; "*"; NEXT ] | "3" RIGHTA - [ "<"; constr:operconstr LEVEL "10"; ">" ] ] + [ "<"; operconstr LEVEL "10"; ">" ] ] [< b > + < b > * < 2 >] : nat @@ -75,9 +75,9 @@ The command has indeed failed with message: The format is not the same on the right- and left-hand sides of the special token "..". The command has indeed failed with message: The format is not the same on the right- and left-hand sides of the special token "..". -Entry constr:expr is +Entry custom:expr is [ "201" RIGHTA - [ "{"; constr:operconstr LEVEL "200"; "}" ] ] + [ "{"; operconstr LEVEL "200"; "}" ] ] fun x : nat => [ x ] : nat -> nat @@ -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..d8d3f696b7 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 |= *) @@ -67,9 +67,9 @@ mono The command has indeed failed with message: Universe u already exists. bobmorane = -let tt := Type@{UnivBinders.33} in -let ff := Type@{UnivBinders.35} in tt -> ff - : Type@{max(UnivBinders.32,UnivBinders.34)} +let tt := Type@{UnivBinders.32} in +let ff := Type@{UnivBinders.34} in tt -> ff + : Type@{max(UnivBinders.31,UnivBinders.33)} The command has indeed failed with message: Universe u already bound. foo@{E M N} = @@ -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_10803.out b/test-suite/output/bug_10803.out new file mode 100644 index 0000000000..04d190a5d1 --- /dev/null +++ b/test-suite/output/bug_10803.out @@ -0,0 +1,10 @@ +a ! + : Foo +where +?y : [ |- nat] +a ! + : Foo +a + : Foo -> Foo +a ! + : Foo diff --git a/test-suite/output/bug_10803.v b/test-suite/output/bug_10803.v new file mode 100644 index 0000000000..1f2027d061 --- /dev/null +++ b/test-suite/output/bug_10803.v @@ -0,0 +1,14 @@ +Inductive Foo := foo. +Declare Scope foo_scope. +Delimit Scope foo_scope with foo. +Bind Scope foo_scope with Foo. +Notation "'!'" := foo : foo_scope. +Definition of_foo {x : nat} {y : nat} (f : Foo) := f. +Notation a := (@of_foo O). +Notation b := (@a). +Check a !. +Check @a O !. +Check @b O. +Check @b O !. (* was failing *) +(* All are printed "a !", without making explicit the "0", which is + incidentally disputable *) 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/bug_12908.out b/test-suite/output/bug_12908.out new file mode 100644 index 0000000000..54c4f98422 --- /dev/null +++ b/test-suite/output/bug_12908.out @@ -0,0 +1,7 @@ +forall m n : nat, m * n = (2 * m * n)%nat + : Prop +File "stdin", line 11, characters 0-31: +Warning: Notation "_ * _" was already used in scope nat_scope. +[notation-overridden,parsing] +forall m n : nat, m * n = Nat.mul (Nat.mul 2 m) n + : Prop diff --git a/test-suite/output/bug_12908.v b/test-suite/output/bug_12908.v new file mode 100644 index 0000000000..6f7be22fa0 --- /dev/null +++ b/test-suite/output/bug_12908.v @@ -0,0 +1,13 @@ +Definition mult' m n := 2 * m * n. + +Module A. +(* Test hiding of a scoped notation by a lonely notation *) +Infix "*" := mult'. +Check forall m n, mult' m n = Nat.mul (Nat.mul 2 m) n. +End A. + +Module B. +(* Test that an overriden scoped notation is deactivated *) +Infix "*" := mult' : nat_scope. +Check forall m n, mult' m n = Nat.mul (Nat.mul 2 m) n. +End B. diff --git a/test-suite/output/bug_13004.out b/test-suite/output/bug_13004.out new file mode 100644 index 0000000000..2bd7d67535 --- /dev/null +++ b/test-suite/output/bug_13004.out @@ -0,0 +1,2 @@ +Ltac bug_13004.t := ltac2:(print (of_string "hi")) +Ltac bug_13004.u := ident:(H) diff --git a/test-suite/output/bug_13004.v b/test-suite/output/bug_13004.v new file mode 100644 index 0000000000..bf4a8285d0 --- /dev/null +++ b/test-suite/output/bug_13004.v @@ -0,0 +1,7 @@ +Require Import Ltac2.Ltac2 Ltac2.Message. + +Ltac t := ltac2:(print (of_string "hi")). +Ltac u := ident:(H). + +Print t. +Print u. diff --git a/test-suite/output/bug_13018.out b/test-suite/output/bug_13018.out new file mode 100644 index 0000000000..2f60409e23 --- /dev/null +++ b/test-suite/output/bug_13018.out @@ -0,0 +1,14 @@ +gargs:( (!) ) + : list nat +gargs:( (!, !, !) ) + : list nat +OnlyGargs[ (!) ] + : list nat +gargs999:( (!) ) + : list nat +gargs999:( (!, !, !) ) + : list nat +OnlyGargs[ (!) ] + : list nat +OnlyGargs999[ (!) ] + : list nat diff --git a/test-suite/output/bug_13018.v b/test-suite/output/bug_13018.v new file mode 100644 index 0000000000..3fb8b7f905 --- /dev/null +++ b/test-suite/output/bug_13018.v @@ -0,0 +1,30 @@ +Undelimit Scope list_scope. +Declare Custom Entry gnat. +Declare Custom Entry gargs. + +Notation "!" := 42 (in custom gnat). +Notation "gargs:( e )" := e (e custom gargs). +Notation "( x )" := (cons x (@nil nat)) (in custom gargs, x custom gnat). +Notation "( x , y , .. , z )" := (cons x (cons y .. (cons z nil) ..)) + (in custom gargs, x custom gnat, y custom gnat, z custom gnat). + +Check gargs:( (!) ). (* cons 42 nil *) +Check gargs:( (!, !, !) ). (* cons 42 (42 :: 42 :: nil) *) + +Definition OnlyGargs {T} (x:T) := x. +Notation "OnlyGargs[ x ]" := (OnlyGargs x) (at level 10, x custom gargs). +Check OnlyGargs[ (!) ]. (* OnlyGargs[ cons 42 nil] *) + +Declare Custom Entry gargs999. +Notation "gargs999:( e )" := e (e custom gargs999 at level 999). +Notation "( x )" := (cons x (@nil nat)) (in custom gargs999, x custom gnat at level 999). +Notation "( x , y , .. , z )" := (cons x (cons y .. (cons z nil) ..)) + (in custom gargs999, x custom gnat at level 999, y custom gnat at level 999, z custom gnat at level 999). + +Check gargs999:( (!) ). (* gargs999:( (!)) *) +Check gargs999:( (!, !, !) ). (* gargs999:( (!, !, !)) *) +Check OnlyGargs[ (!) ]. (* OnlyGargs[ gargs999:( (!))] *) + +Definition OnlyGargs999 {T} (x:T) := x. +Notation "OnlyGargs999[ x ]" := (OnlyGargs999 x) (at level 10, x custom gargs999 at level 999). +Check OnlyGargs999[ (!) ]. (* OnlyGargs999[ (!)] *) diff --git a/test-suite/output/bug_13112.out b/test-suite/output/bug_13112.out new file mode 100644 index 0000000000..a8a98d6b68 --- /dev/null +++ b/test-suite/output/bug_13112.out @@ -0,0 +1,4 @@ +0 + 0 + : nat +HI + : nat diff --git a/test-suite/output/bug_13112.v b/test-suite/output/bug_13112.v new file mode 100644 index 0000000000..9fee5e09d8 --- /dev/null +++ b/test-suite/output/bug_13112.v @@ -0,0 +1,5 @@ +Reserved Notation "'HI'". +Notation "'HI'" := (O + O) (only parsing). +Check HI. (* 0 + 0 : nat *) +Notation "'HI'" := (O + O) (only printing). +Check HI. (* 0 + 0 : nat *) diff --git a/test-suite/output/bug_9180.out b/test-suite/output/bug_9180.out index ed4892b389..f035d0252a 100644 --- a/test-suite/output/bug_9180.out +++ b/test-suite/output/bug_9180.out @@ -1,4 +1,3 @@ -Notation -"n .+1" := S n : nat_scope (default interpretation) +Notation "n .+1" := (S n) : nat_scope (default interpretation) forall x : nat, x.+1 = x.+1 : Prop diff --git a/test-suite/output/bug_9403.out b/test-suite/output/bug_9403.out new file mode 100644 index 0000000000..850760d5ed --- /dev/null +++ b/test-suite/output/bug_9403.out @@ -0,0 +1,6 @@ +1 subgoal + + X : tele + α, β, γ1, γ2 : X → Prop + ============================ + accessor α β γ1 → accessor α β (λ.. x : X, γ1 x ∨ γ2 x) diff --git a/test-suite/output/bug_9403.v b/test-suite/output/bug_9403.v new file mode 100644 index 0000000000..b915e7fbce --- /dev/null +++ b/test-suite/output/bug_9403.v @@ -0,0 +1,99 @@ +(* Uselessly long but why not *) + +From Coq Require Export Utf8. + +Local Set Universe Polymorphism. + +Module tele. +(** Telescopes *) +Inductive tele : Type := + | TeleO : tele + | TeleS {X} (binder : X → tele) : tele. + +Arguments TeleS {_} _. + +(** The telescope version of Coq's function type *) +Fixpoint tele_fun (TT : tele) (T : Type) : Type := + match TT with + | TeleO => T + | TeleS b => ∀ x, tele_fun (b x) T + end. + +Notation "TT -t> A" := + (tele_fun TT A) (at level 99, A at level 200, right associativity). + +(** An eliminator for elements of [tele_fun]. + We use a [fix] because, for some reason, that makes stuff print nicer + in the proofs in iris:bi/lib/telescopes.v *) +Definition tele_fold {X Y} {TT : tele} (step : ∀ {A : Type}, (A → Y) → Y) (base : X → Y) + : (TT -t> X) → Y := + (fix rec {TT} : (TT -t> X) → Y := + match TT as TT return (TT -t> X) → Y with + | TeleO => λ x : X, base x + | TeleS b => λ f, step (λ x, rec (f x)) + end) TT. +Arguments tele_fold {_ _ !_} _ _ _ /. + +(** A sigma-like type for an "element" of a telescope, i.e. the data it + takes to get a [T] from a [TT -t> T]. *) +Inductive tele_arg : tele → Type := +| TargO : tele_arg TeleO +(* the [x] is the only relevant data here *) +| TargS {X} {binder} (x : X) : tele_arg (binder x) → tele_arg (TeleS binder). + +Definition tele_app {TT : tele} {T} (f : TT -t> T) : tele_arg TT → T := + λ a, (fix rec {TT} (a : tele_arg TT) : (TT -t> T) → T := + match a in tele_arg TT return (TT -t> T) → T with + | TargO => λ t : T, t + | TargS x a => λ f, rec a (f x) + end) TT a f. +Arguments tele_app {!_ _} _ !_ /. + +Coercion tele_arg : tele >-> Sortclass. +Local Coercion tele_app : tele_fun >-> Funclass. + +(** Operate below [tele_fun]s with argument telescope [TT]. *) +Fixpoint tele_bind {U} {TT : tele} : (TT → U) → TT -t> U := + match TT as TT return (TT → U) → TT -t> U with + | TeleO => λ F, F TargO + | @TeleS X b => λ (F : TeleS b → U) (x : X), (* b x -t> U *) + tele_bind (λ a, F (TargS x a)) + end. +Arguments tele_bind {_ !_} _ /. + +(** Notation-compatible telescope mapping *) +(* This adds (tele_app ∘ tele_bind), which is an identity function, around every + binder so that, after simplifying, this matches the way we typically write + notations involving telescopes. *) +Notation "t $ r" := (t r) + (at level 65, right associativity, only parsing). +Notation "'λ..' x .. y , e" := + (tele_app $ tele_bind (λ x, .. (tele_app $ tele_bind (λ y, e)) .. )) + (at level 200, x binder, y binder, right associativity, + format "'[ ' 'λ..' x .. y ']' , e"). + +(** Telescopic quantifiers *) +Definition texist {TT : tele} (Ψ : TT → Prop) : Prop := + tele_fold ex (λ x, x) (tele_bind Ψ). +Arguments texist {!_} _ /. + +Notation "'∃..' x .. y , P" := (texist (λ x, .. (texist (λ y, P)) .. )) + (at level 200, x binder, y binder, right associativity, + format "∃.. x .. y , P"). +End tele. +Import tele. + +(* This is like Iris' accessors, but in Prop. Just to play with telescopes. *) +Definition accessor {X : tele} (α β γ : X → Prop) : Prop := + ∃.. x, α x ∧ (β x → γ x). + +(* Working with abstract telescopes. *) +Section tests. +Context {X : tele}. +Implicit Types α β γ : X → Prop. + +Lemma acc_mono_disj α β γ1 γ2 : + accessor α β γ1 → accessor α β (λ.. x, γ1 x ∨ γ2 x). +Show. +Abort. +End tests. diff --git a/test-suite/output/bug_9682.out b/test-suite/output/bug_9682.out new file mode 100644 index 0000000000..45d9e4cad1 --- /dev/null +++ b/test-suite/output/bug_9682.out @@ -0,0 +1,9 @@ +mmatch 1 + 2 + 3 + 4 + 5 + 6 in nat as x +return M (x = x) with +| 1 +end + : unit +# + : True +## + : True diff --git a/test-suite/output/bug_9682.v b/test-suite/output/bug_9682.v new file mode 100644 index 0000000000..fa30d323ef --- /dev/null +++ b/test-suite/output/bug_9682.v @@ -0,0 +1,28 @@ +Declare Scope blafu. +Delimit Scope blafu with B. +Axiom DoesNotMatch : Type. +Axiom consumer : forall {A} (B : A -> Type) (E:Type) (x : A) (ls : list nat), unit. + +Notation "| p1 | .. | pn" := (@cons _ p1 .. (@cons _ pn nil) ..) (at level 91) : blafu. +Notation "'mmatch_do_not_write' x 'in' T 'as' y 'return' 'M' p 'with_do_not_write' ls" := + (@consumer _ (fun y : T => p%type) DoesNotMatch x ls%B) + (at level 200, ls at level 91, only parsing). +Notation "'mmatch' x 'in' T 'as' y 'return' 'M' p 'with' ls 'end'" := + (mmatch_do_not_write x in T as y return M p with_do_not_write ls) + (at level 200, ls at level 91, p at level 10, only parsing). +(* This should not gives a warning *) +Notation "'mmatch' x 'in' T 'as' y 'return' 'M' p 'with' ls 'end'" := + (@consumer _ (fun y : T => p%type) DoesNotMatch x ls%B) + (at level 200, ls at level 91, p at level 10, only printing, + format "'[ ' mmatch '/' x ']' '/' '[ ' in '/' T ']' '/' '[ ' as '/' y ']' '/' '[ ' return M p ']' with '//' '[' ls ']' '//' end" + ). +(* Check use of "mmatch" *) +Check (mmatch 1 + 2 + 3 + 4 + 5 + 6 in nat as x return M (x = x) with | 1 end). + +(* 2nd example *) +Notation "#" := I (at level 0, only parsing). +Notation "#" := I (at level 0, only printing). +Check #. +Notation "##" := I (at level 0, only printing). +Notation "##" := I (at level 0, only parsing). +Check ##. diff --git a/test-suite/output/locate.out b/test-suite/output/locate.out index 473db2d312..93d9d6cf7b 100644 --- a/test-suite/output/locate.out +++ b/test-suite/output/locate.out @@ -1,3 +1,2 @@ -Notation -"b1 && b2" := if b1 then b2 else false (default interpretation) -"x && y" := andb x y : bool_scope +Notation "b1 && b2" := (if b1 then b2 else false) (default interpretation) +Notation "x && y" := (andb x y) : bool_scope diff --git a/test-suite/output/print_ltac.out b/test-suite/output/print_ltac.out index 58931c4b82..5f88ec2e41 100644 --- a/test-suite/output/print_ltac.out +++ b/test-suite/output/print_ltac.out @@ -4,7 +4,7 @@ Ltac t2 := let x := string:("my tactic") in x Ltac t3 := idtacstr "my tactic" Ltac t4 x := match x with - | ?A => (A, A) + | ?A => constr:((A, A)) end The command has indeed failed with message: idnat is bound to a notation that does not denote a reference. 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/eqtacticsnois.v b/test-suite/success/eqtacticsnois.v new file mode 100644 index 0000000000..7869532c67 --- /dev/null +++ b/test-suite/success/eqtacticsnois.v @@ -0,0 +1,15 @@ +(* coq-prog-args: ("-nois") *) + +Inductive eq {A : Type} (x : A) : forall a:A, Prop := eq_refl : eq x x. + +Axiom sym : forall A (x y : A) (_ : eq x y), eq y x. +Require Import Ltac. + +Register eq as core.eq.type. +Register sym as core.eq.sym. + +Goal forall A (x y:A) (_ : forall z, eq y z), eq x x. +intros * H. replace x with y. +- reflexivity. +- apply H. +Qed. diff --git a/test-suite/success/induct.v b/test-suite/success/induct.v index 73fe53c757..4983ee3c0d 100644 --- a/test-suite/success/induct.v +++ b/test-suite/success/induct.v @@ -159,6 +159,8 @@ Abort. (* This was failing in 8.5 and before because of a bug in the order of hypotheses *) +Set Warnings "-deprecated". + Inductive I2 : Type := C2 : forall x:nat, x=x -> I2. Goal forall a b:I2, a = b. @@ -196,3 +198,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/success/polymorphism.v b/test-suite/success/polymorphism.v index 9ab8ace39e..0796b507a1 100644 --- a/test-suite/success/polymorphism.v +++ b/test-suite/success/polymorphism.v @@ -457,5 +457,10 @@ Module ObligationRegression. (** Test for a regression encountered when fixing obligations for stronger restriction of universe context. *) Require Import CMorphisms. - Check trans_co_eq_inv_arrow_morphism@{_ _ _ _ _ _ _ _}. + Check trans_co_eq_inv_arrow_morphism@{_ _ _ _ _ _ _}. End ObligationRegression. + +Axiom poly@{i} : forall(A : Type@{i}) (a : A), unit. + +Definition nonpoly := @poly True Logic.I. +Definition check := nonpoly@{}. 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/Arith/Between.v b/theories/Arith/Between.v index 1db3f87cac..74d1e391c4 100644 --- a/theories/Arith/Between.v +++ b/theories/Arith/Between.v @@ -110,7 +110,7 @@ Section Between. Lemma between_in_int : forall k l, between k l -> forall r, in_int k l r -> P r. Proof. - induction 1; intros. + intro k; induction 1 as [|l]; intros r ?. - absurd (k < k). { auto with arith. } eapply in_int_lt; eassumption. - destruct (in_int_p_Sq k l r) as [| ->]; auto with arith. @@ -125,7 +125,7 @@ Section Between. Lemma exists_in_int : forall k l, exists_between k l -> exists2 m : nat, in_int k l m & Q m. Proof. - induction 1 as [* ? (p, ?, ?)|]. + induction 1 as [* ? (p, ?, ?)|l]. - exists p; auto with arith. - exists l; auto with arith. Qed. @@ -154,7 +154,7 @@ Section Between. between k l -> (forall n:nat, in_int k l n -> P n -> ~ Q n) -> ~ exists_between k l. Proof. - induction 1; red; intros. + intro k; induction 1 as [|l]; red; intros. - absurd (k < k); auto with arith. - absurd (Q l). { auto with arith. } destruct (exists_in_int k (S l)) as (l',[],?). diff --git a/theories/Arith/Compare_dec.v b/theories/Arith/Compare_dec.v index 341dd7de5d..1afc49b7ff 100644 --- a/theories/Arith/Compare_dec.v +++ b/theories/Arith/Compare_dec.v @@ -21,7 +21,7 @@ Defined. Definition lt_eq_lt_dec n m : {n < m} + {n = m} + {m < n}. Proof. - induction n in m |- *; destruct m; auto with arith. + induction n as [|n IHn] in m |- *; destruct m as [|m]; auto with arith. destruct (IHn m) as [H|H]; auto with arith. destruct H; auto with arith. Defined. @@ -33,9 +33,9 @@ Defined. Definition le_lt_dec n m : {n <= m} + {m < n}. Proof. - induction n in m |- *. + induction n as [|n IHn] in m |- *. - left; auto with arith. - - destruct m. + - destruct m as [|m]. + right; auto with arith. + elim (IHn m); [left|right]; auto with arith. Defined. diff --git a/theories/Arith/EqNat.v b/theories/Arith/EqNat.v index 62a0f0a0ae..593d8c5934 100644 --- a/theories/Arith/EqNat.v +++ b/theories/Arith/EqNat.v @@ -34,7 +34,7 @@ Hint Resolve eq_nat_refl: arith. Theorem eq_nat_is_eq n m : eq_nat n m <-> n = m. Proof. split. - - revert m; induction n; destruct m; simpl; contradiction || auto. + - revert m; induction n; intro m; destruct m; simpl; contradiction || auto. - intros <-; apply eq_nat_refl. Qed. @@ -53,12 +53,12 @@ Hint Immediate eq_eq_nat eq_nat_eq: arith. Theorem eq_nat_elim : forall n (P:nat -> Prop), P n -> forall m, eq_nat n m -> P m. Proof. - intros; replace m with n; auto with arith. + intros n P ? m ?; replace m with n; auto with arith. Qed. Theorem eq_nat_decide : forall n m, {eq_nat n m} + {~ eq_nat n m}. Proof. - induction n; destruct m; simpl. + intro n; induction n as [|n IHn]; intro m; destruct m; simpl. - left; trivial. - right; intro; trivial. - right; intro; trivial. @@ -96,7 +96,7 @@ Qed. Definition beq_nat_eq : forall n m, true = (n =? m) -> n = m. Proof. - induction n; destruct m; simpl. + intro n; induction n as [|n IHn]; intro m; destruct m; simpl. - reflexivity. - discriminate. - discriminate. diff --git a/theories/Arith/Factorial.v b/theories/Arith/Factorial.v index 0871c4af67..f87d7e810a 100644 --- a/theories/Arith/Factorial.v +++ b/theories/Arith/Factorial.v @@ -33,7 +33,7 @@ Qed. Lemma fact_le n m : n <= m -> fact n <= fact m. Proof. - induction 1. + induction 1 as [|m ?]. - apply le_n. - simpl. transitivity (fact m). trivial. apply Nat.le_add_r. Qed. diff --git a/theories/Arith/Le.v b/theories/Arith/Le.v index 4f17a7a8d3..4e71465452 100644 --- a/theories/Arith/Le.v +++ b/theories/Arith/Le.v @@ -80,7 +80,7 @@ Lemma le_elim_rel : (forall p (q:nat), p <= q -> P p q -> P (S p) (S q)) -> forall n m, n <= m -> P n m. Proof. - intros P H0 HS. + intros P H0 HS n. induction n; trivial. intros m Le. elim Le; auto with arith. Qed. diff --git a/theories/Arith/Mult.v b/theories/Arith/Mult.v index 507d956e81..d7f703e6e4 100644 --- a/theories/Arith/Mult.v +++ b/theories/Arith/Mult.v @@ -158,7 +158,7 @@ Fixpoint mult_acc (s:nat) m n : nat := Lemma mult_acc_aux : forall n m p, m + n * p = mult_acc m p n. Proof. - induction n as [| n IHn]; simpl; auto. + intro n; induction n as [| n IHn]; simpl; auto. intros. rewrite Nat.add_assoc, IHn. f_equal. rewrite Nat.add_comm. apply plus_tail_plus. Qed. diff --git a/theories/Arith/PeanoNat.v b/theories/Arith/PeanoNat.v index 6f5339227a..37704704a0 100644 --- a/theories/Arith/PeanoNat.v +++ b/theories/Arith/PeanoNat.v @@ -75,7 +75,9 @@ Theorem recursion_succ : Aeq a a -> Proper (eq==>Aeq==>Aeq) f -> forall n : nat, Aeq (recursion a f (S n)) (f n (recursion a f n)). Proof. -unfold Proper, respectful in *; induction n; simpl; auto. +unfold Proper, respectful in *. +intros A Aeq a f ? ? n. +induction n; simpl; auto. Qed. (** ** Remaining constants not defined in Coq.Init.Nat *) @@ -126,7 +128,7 @@ Qed. Lemma sub_succ_r n m : n - (S m) = pred (n - m). Proof. -revert m. induction n; destruct m; simpl; auto. apply sub_0_r. +revert m. induction n; intro m; destruct m; simpl; auto. apply sub_0_r. Qed. Lemma mul_0_l n : 0 * n = 0. @@ -136,9 +138,9 @@ Qed. Lemma mul_succ_l n m : S n * m = n * m + m. Proof. -assert (succ_r : forall x y, x+S y = S(x+y)) by now induction x. +assert (succ_r : forall x y, x+S y = S(x+y)) by now intro x; induction x. assert (comm : forall x y, x+y = y+x). -{ induction x; simpl; auto. intros; rewrite succ_r; now f_equal. } +{ intro x; induction x; simpl; auto. intros; rewrite succ_r; now f_equal. } now rewrite comm. Qed. @@ -152,7 +154,7 @@ Qed. Lemma eqb_eq n m : eqb n m = true <-> n = m. Proof. revert m. - induction n; destruct m; simpl; rewrite ?IHn; split; try easy. + induction n as [|n IHn]; intro m; destruct m; simpl; rewrite ?IHn; split; try easy. - now intros ->. - now injection 1. Qed. @@ -160,7 +162,7 @@ Qed. Lemma leb_le n m : (n <=? m) = true <-> n <= m. Proof. revert m. - induction n; destruct m; simpl. + induction n as [|n IHn]; intro m; destruct m; simpl. - now split. - split; trivial. intros; apply Peano.le_0_n. - now split. @@ -178,7 +180,7 @@ Qed. Lemma eq_dec : forall n m : nat, {n = m} + {n <> m}. Proof. - induction n; destruct m. + intro n; induction n as [|n IHn]; intro m; destruct m as [|m]. - now left. - now right. - now right. @@ -193,12 +195,14 @@ Defined. Lemma compare_eq_iff n m : (n ?= m) = Eq <-> n = m. Proof. - revert m; induction n; destruct m; simpl; rewrite ?IHn; split; auto; easy. + revert m; induction n as [|n IHn]; intro m; destruct m; + simpl; rewrite ?IHn; split; auto; easy. Qed. Lemma compare_lt_iff n m : (n ?= m) = Lt <-> n < m. Proof. - revert m; induction n; destruct m; simpl; rewrite ?IHn; split; try easy. + revert m; induction n as [|n IHn]; intro m; destruct m; + simpl; rewrite ?IHn; split; try easy. - intros _. apply Peano.le_n_S, Peano.le_0_n. - apply Peano.le_n_S. - apply Peano.le_S_n. @@ -206,7 +210,7 @@ Qed. Lemma compare_le_iff n m : (n ?= m) <> Gt <-> n <= m. Proof. - revert m; induction n; destruct m; simpl; rewrite ?IHn. + revert m; induction n as [|n IHn]; intro m; destruct m; simpl; rewrite ?IHn. - now split. - split; intros. apply Peano.le_0_n. easy. - split. now destruct 1. inversion 1. @@ -215,7 +219,7 @@ Qed. Lemma compare_antisym n m : (m ?= n) = CompOpp (n ?= m). Proof. - revert m; induction n; destruct m; simpl; trivial. + revert m; induction n; intro m; destruct m; simpl; trivial. Qed. Lemma compare_succ n m : (S n ?= S m) = (n ?= m). @@ -292,7 +296,7 @@ Lemma Even_2 n : Even n <-> Even (S (S n)). Proof. split; intros (m,H). - exists (S m). rewrite H. simpl. now rewrite plus_n_Sm. - - destruct m; try discriminate. + - destruct m as [|m]; try discriminate. exists m. simpl in H. rewrite <- plus_n_Sm in H. now inversion H. Qed. @@ -305,7 +309,7 @@ Lemma Odd_2 n : Odd n <-> Odd (S (S n)). Proof. split; intros (m,H). - exists (S m). rewrite H. simpl. now rewrite <- (plus_n_Sm m). - - destruct m; try discriminate. + - destruct m as [|m]; try discriminate. exists m. simpl in H. rewrite <- plus_n_Sm in H. inversion H. simpl. now rewrite <- !plus_n_Sm, <- !plus_n_O. Qed. @@ -316,7 +320,7 @@ Import Private_Parity. Lemma even_spec : forall n, even n = true <-> Even n. Proof. fix even_spec 1. - destruct n as [|[|n]]; simpl. + intro n; destruct n as [|[|n]]; simpl. - split; [ now exists 0 | trivial ]. - split; [ discriminate | intro H; elim (Even_1 H) ]. - rewrite even_spec. apply Even_2. @@ -326,7 +330,7 @@ Lemma odd_spec : forall n, odd n = true <-> Odd n. Proof. unfold odd. fix odd_spec 1. - destruct n as [|[|n]]; simpl. + intro n; destruct n as [|[|n]]; simpl. - split; [ discriminate | intro H; elim (Odd_0 H) ]. - split; [ now exists 0 | trivial ]. - rewrite odd_spec. apply Odd_2. @@ -338,9 +342,9 @@ Lemma divmod_spec : forall x y q u, u <= y -> let (q',u') := divmod x y q u in x + (S y)*q + (y-u) = (S y)*q' + (y-u') /\ u' <= y. Proof. - induction x. + intro x; induction x as [|x IHx]. - simpl; intuition. - - intros y q u H. destruct u; simpl divmod. + - intros y q u H. destruct u as [|u]; simpl divmod. + generalize (IHx y (S q) y (le_n y)). destruct divmod as (q',u'). intros (EQ,LE); split; trivial. rewrite <- EQ, sub_0_r, sub_diag, add_0_r. @@ -356,7 +360,7 @@ Qed. Lemma div_mod x y : y<>0 -> x = y*(x/y) + x mod y. Proof. intros Hy. - destruct y; [ now elim Hy | clear Hy ]. + destruct y as [|y]; [ now elim Hy | clear Hy ]. unfold div, modulo. generalize (divmod_spec x y 0 y (le_n y)). destruct divmod as (q,u). @@ -380,7 +384,7 @@ Lemma sqrt_iter_spec : forall k p q r, let s := sqrt_iter k p q r in s*s <= k + p*p + (q - r) < (S s)*(S s). Proof. - induction k. + intro k; induction k as [|k IHk]. - (* k = 0 *) simpl; intros p q r Hq Hr. split. @@ -391,7 +395,7 @@ Proof. apply add_le_mono_l. rewrite <- Hq. apply le_sub_l. - (* k = S k' *) - destruct r. + intros p q r; destruct r as [|r]. + (* r = 0 *) intros Hq _. replace (S k + p*p + (q-0)) with (k + (S p)*(S p) + (S (S q) - S (S q))). @@ -427,7 +431,7 @@ Lemma log2_iter_spec : forall k p q r, let s := log2_iter k p q r in 2^s <= k + q < 2^(S s). Proof. - induction k. + intro k; induction k as [|k IHk]. - (* k = 0 *) intros p q r EQ LT. simpl log2_iter. cbv zeta. split. @@ -438,7 +442,7 @@ Proof. + rewrite EQ, add_comm. apply add_lt_mono_l. apply lt_succ_r, le_0_l. - (* k = S k' *) - intros p q r EQ LT. destruct r. + intros p q r EQ LT. destruct r as [|r]. + (* r = 0 *) rewrite add_succ_r, add_0_r in EQ. rewrite add_succ_l, <- add_succ_r. apply IHk. @@ -537,7 +541,7 @@ Lemma le_div2 n : div2 (S n) <= n. Proof. revert n. fix le_div2 1. - destruct n; simpl; trivial. apply lt_succ_r. + intro n; destruct n as [|n]; simpl; trivial. apply lt_succ_r. destruct n; [simpl|]; trivial. now constructor. Qed. @@ -550,7 +554,7 @@ Qed. Lemma div2_decr a n : a <= S n -> div2 a <= n. Proof. - destruct a; intros H. + destruct a as [|a]; intros H. - simpl. apply le_0_l. - apply succ_le_mono in H. apply le_trans with a; [ apply le_div2 | trivial ]. @@ -563,7 +567,7 @@ Qed. Lemma testbit_0_l : forall n, testbit 0 n = false. Proof. - now induction n. + now intro n; induction n. Qed. Lemma testbit_odd_0 a : testbit (2*a+1) 0 = true. @@ -592,7 +596,7 @@ Qed. Lemma shiftr_specif : forall a n m, testbit (shiftr a n) m = testbit a (m+n). Proof. - induction n; intros m. trivial. + intros a n; induction n as [|n IHn]; intros m. trivial. now rewrite add_0_r. now rewrite add_succ_r, <- add_succ_l, <- IHn. Qed. @@ -600,7 +604,7 @@ Qed. Lemma shiftl_specif_high : forall a n m, n<=m -> testbit (shiftl a n) m = testbit a (m-n). Proof. - induction n; intros m H. trivial. + intros a n; induction n as [|n IHn]; intros m H. trivial. now rewrite sub_0_r. destruct m. inversion H. simpl. apply succ_le_mono in H. @@ -611,7 +615,7 @@ Qed. Lemma shiftl_spec_low : forall a n m, m<n -> testbit (shiftl a n) m = false. Proof. - induction n; intros m H. inversion H. + intros a n; induction n as [|n IHn]; intros m H. inversion H. change (shiftl a (S n)) with (double (shiftl a n)). destruct m; simpl. unfold odd. apply negb_false_iff. @@ -623,7 +627,7 @@ Qed. Lemma div2_bitwise : forall op n a b, div2 (bitwise op (S n) a b) = bitwise op n (div2 a) (div2 b). Proof. - intros. unfold bitwise; fold bitwise. + intros op n a b. unfold bitwise; fold bitwise. destruct (op (odd a) (odd b)). now rewrite div2_succ_double. now rewrite add_0_l, div2_double. @@ -632,7 +636,7 @@ Qed. Lemma odd_bitwise : forall op n a b, odd (bitwise op (S n) a b) = op (odd a) (odd b). Proof. - intros. unfold bitwise; fold bitwise. + intros op n a b. unfold bitwise; fold bitwise. destruct (op (odd a) (odd b)). apply odd_spec. rewrite add_comm. eexists; eauto. unfold odd. apply negb_false_iff. apply even_spec. @@ -644,7 +648,7 @@ Lemma testbit_bitwise_1 : forall op, (forall b, op false b = false) -> testbit (bitwise op n a b) m = op (testbit a m) (testbit b m). Proof. intros op Hop. - induction n; intros m a b Ha. + intro n; induction n as [|n IHn]; intros m a b Ha. simpl. inversion Ha; subst. now rewrite testbit_0_l. destruct m. apply odd_bitwise. @@ -657,7 +661,7 @@ Lemma testbit_bitwise_2 : forall op, op false false = false -> testbit (bitwise op n a b) m = op (testbit a m) (testbit b m). Proof. intros op Hop. - induction n; intros m a b Ha Hb. + intro n; induction n as [|n IHn]; intros m a b Ha Hb. simpl. inversion Ha; inversion Hb; subst. now rewrite testbit_0_l. destruct m. apply odd_bitwise. @@ -682,11 +686,11 @@ Lemma lor_spec a b n : Proof. unfold lor. apply testbit_bitwise_2. - trivial. - - destruct (compare_spec a b). + - destruct (compare_spec a b) as [H|H|H]. + rewrite max_l; subst; trivial. + apply lt_le_incl in H. now rewrite max_r. + apply lt_le_incl in H. now rewrite max_l. - - destruct (compare_spec a b). + - destruct (compare_spec a b) as [H|H|H]. + rewrite max_r; subst; trivial. + apply lt_le_incl in H. now rewrite max_r. + apply lt_le_incl in H. now rewrite max_l. @@ -697,11 +701,11 @@ Lemma lxor_spec a b n : Proof. unfold lxor. apply testbit_bitwise_2. - trivial. - - destruct (compare_spec a b). + - destruct (compare_spec a b) as [H|H|H]. + rewrite max_l; subst; trivial. + apply lt_le_incl in H. now rewrite max_r. + apply lt_le_incl in H. now rewrite max_l. - - destruct (compare_spec a b). + - destruct (compare_spec a b) as [H|H|H]. + rewrite max_r; subst; trivial. + apply lt_le_incl in H. now rewrite max_r. + apply lt_le_incl in H. now rewrite max_l. diff --git a/theories/Arith/Peano_dec.v b/theories/Arith/Peano_dec.v index a673a1119f..9a7a397023 100644 --- a/theories/Arith/Peano_dec.v +++ b/theories/Arith/Peano_dec.v @@ -16,7 +16,7 @@ Implicit Types m n x y : nat. Theorem O_or_S n : {m : nat | S m = n} + {0 = n}. Proof. - induction n. + induction n as [|n IHn]. - now right. - left; exists n; auto. Defined. @@ -47,7 +47,7 @@ pose (def_n2 := eq_refl n0); transitivity (eq_ind _ _ le_mn2 _ def_n2). 2: reflexivity. generalize def_n2; revert le_mn1 le_mn2. generalize n0 at 1 4 5 7; intros n1 le_mn1. -destruct le_mn1; intros le_mn2; destruct le_mn2. +destruct le_mn1 as [|? le_mn1]; intros le_mn2; destruct le_mn2 as [|? le_mn2]. + now intros def_n0; rewrite (UIP_nat _ _ def_n0 eq_refl). + intros def_n0; generalize le_mn2; rewrite <-def_n0; intros le_mn0. now destruct (Nat.nle_succ_diag_l _ le_mn0). diff --git a/theories/Arith/Plus.v b/theories/Arith/Plus.v index ec7426e648..5da7738adc 100644 --- a/theories/Arith/Plus.v +++ b/theories/Arith/Plus.v @@ -156,7 +156,7 @@ Fixpoint tail_plus n m : nat := Lemma plus_tail_plus : forall n m, n + m = tail_plus n m. Proof. -induction n as [| n IHn]; simpl; auto. +intro n; induction n as [| n IHn]; simpl; auto. intro m; rewrite <- IHn; simpl; auto. Qed. diff --git a/theories/Arith/Wf_nat.v b/theories/Arith/Wf_nat.v index 3bfef93726..ebd909c1dc 100644 --- a/theories/Arith/Wf_nat.v +++ b/theories/Arith/Wf_nat.v @@ -27,8 +27,8 @@ Definition gtof (a b:A) := f b > f a. Theorem well_founded_ltof : well_founded ltof. Proof. assert (H : forall n (a:A), f a < n -> Acc ltof a). - { induction n. - - intros; absurd (f a < 0); auto with arith. + { intro n; induction n as [|n IHn]. + - intros a Ha; absurd (f a < 0); auto with arith. - intros a Ha. apply Acc_intro. unfold ltof at 1. intros b Hb. apply IHn. apply Nat.lt_le_trans with (f a); auto with arith. } intros a. apply (H (S (f a))). auto with arith. @@ -69,8 +69,8 @@ Theorem induction_ltof1 : Proof. intros P F. assert (H : forall n (a:A), f a < n -> P a). - { induction n. - - intros; absurd (f a < 0); auto with arith. + { intro n; induction n as [|n IHn]. + - intros a Ha; absurd (f a < 0); auto with arith. - intros a Ha. apply F. unfold ltof. intros b Hb. apply IHn. apply Nat.lt_le_trans with (f a); auto with arith. } intros a. apply (H (S (f a))). auto with arith. @@ -107,8 +107,8 @@ Hypothesis H_compat : forall x y:A, R x y -> f x < f y. Theorem well_founded_lt_compat : well_founded R. Proof. assert (H : forall n (a:A), f a < n -> Acc R a). - { induction n. - - intros; absurd (f a < 0); auto with arith. + { intro n; induction n as [|n IHn]. + - intros a Ha; absurd (f a < 0); auto with arith. - intros a Ha. apply Acc_intro. intros b Hb. apply IHn. apply Nat.lt_le_trans with (f a); auto with arith. } intros a. apply (H (S (f a))). auto with arith. @@ -212,26 +212,26 @@ Section LT_WF_REL. Remark acc_lt_rel : forall x:A, (exists n, F x n) -> Acc R x. Proof. intros x [n fxn]; generalize dependent x. - pattern n; apply lt_wf_ind; intros. - constructor; intros. + pattern n; apply lt_wf_ind; intros n0 H x fxn. + constructor; intros y H0. destruct (F_compat y x) as (x0,H1,H2); trivial. apply (H x0); auto. Qed. Theorem well_founded_inv_lt_rel_compat : well_founded R. Proof. - constructor; intros. - case (F_compat y a); trivial; intros. + intro a; constructor; intros y H. + case (F_compat y a); trivial; intros x **. apply acc_lt_rel; trivial. exists x; trivial. Qed. End LT_WF_REL. -Lemma well_founded_inv_rel_inv_lt_rel : - forall (A:Set) (F:A -> nat -> Prop), well_founded (inv_lt_rel A F). +Lemma well_founded_inv_rel_inv_lt_rel (A:Set) (F:A -> nat -> Prop) : + well_founded (inv_lt_rel A F). Proof. - intros; apply (well_founded_inv_lt_rel_compat A (inv_lt_rel A F) F); trivial. + apply (well_founded_inv_lt_rel_compat A (inv_lt_rel A F) F); trivial. Qed. (** A constructive proof that any non empty decidable subset of @@ -253,8 +253,8 @@ Proof. intros P Pdec (n0,HPn0). assert (forall n, (exists n', n'<n /\ P n' /\ forall n'', P n'' -> n'<=n'') - \/ (forall n', P n' -> n<=n')). - { induction n. + \/ (forall n', P n' -> n<=n')) as H. + { intro n; induction n as [|n IHn]. - right. intros. apply Nat.le_0_l. - destruct IHn as [(n' & IH1 & IH2)|IH]. + left. exists n'; auto with arith. 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..4cc3597029 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -74,31 +74,31 @@ Section Facts. (** *** Generic facts *) (** Discrimination *) - Theorem nil_cons : forall (x:A) (l:list A), [] <> x :: l. + Theorem nil_cons (x:A) (l:list A) : [] <> x :: l. Proof. - intros; discriminate. + discriminate. Qed. (** Destruction *) - Theorem destruct_list : forall l : list A, {x:A & {tl:list A | l = x::tl}}+{l = []}. + Theorem destruct_list (l : list A) : {x:A & {tl:list A | l = x::tl}}+{l = []}. Proof. induction l as [|a tail]. right; reflexivity. left; exists a, tail; reflexivity. Qed. - Lemma hd_error_tl_repr : forall l (a:A) r, + Lemma hd_error_tl_repr l (a:A) r : hd_error l = Some a /\ tl l = r <-> l = a :: r. Proof. destruct l as [|x xs]. - - unfold hd_error, tl; intros a r. split; firstorder discriminate. + - unfold hd_error, tl; split; firstorder discriminate. - intros. simpl. split. * intros (H1, H2). inversion H1. rewrite H2. reflexivity. * inversion 1. subst. auto. Qed. - Lemma hd_error_some_nil : forall l (a:A), hd_error l = Some a -> l <> nil. + Lemma hd_error_some_nil l (a:A) : hd_error l = Some a -> l <> nil. Proof. unfold hd_error. destruct l; now discriminate. Qed. Theorem length_zero_iff_nil (l : list A): @@ -114,9 +114,9 @@ Section Facts. simpl; reflexivity. Qed. - Theorem hd_error_cons : forall (l : list A) (x : A), hd_error (x::l) = Some x. + Theorem hd_error_cons (l : list A) (x : A) : hd_error (x::l) = Some x. Proof. - intros; simpl; reflexivity. + simpl; reflexivity. Qed. @@ -125,41 +125,41 @@ Section Facts. (**************************) (** Discrimination *) - Theorem app_cons_not_nil : forall (x y:list A) (a:A), [] <> x ++ a :: y. + Theorem app_cons_not_nil (x y:list A) (a:A) : [] <> x ++ a :: y. Proof. unfold not. - destruct x as [| a l]; simpl; intros. + destruct x; simpl; intros H. discriminate H. discriminate H. Qed. (** Concat with [nil] *) - Theorem app_nil_l : forall l:list A, [] ++ l = l. + Theorem app_nil_l (l:list A) : [] ++ l = l. Proof. reflexivity. Qed. - Theorem app_nil_r : forall l:list A, l ++ [] = l. + Theorem app_nil_r (l:list A) : l ++ [] = l. Proof. induction l; simpl; f_equal; auto. Qed. (* begin hide *) (* Deprecated *) - Theorem app_nil_end : forall (l:list A), l = l ++ []. + Theorem app_nil_end (l:list A) : l = l ++ []. Proof. symmetry; apply app_nil_r. Qed. (* end hide *) (** [app] is associative *) - Theorem app_assoc : forall l m n:list A, l ++ m ++ n = (l ++ m) ++ n. + Theorem app_assoc (l m n:list A) : l ++ m ++ n = (l ++ m) ++ n. Proof. - intros l m n; induction l; simpl; f_equal; auto. + induction l; simpl; f_equal; auto. Qed. (* begin hide *) (* Deprecated *) - Theorem app_assoc_reverse : forall l m n:list A, (l ++ m) ++ n = l ++ m ++ n. + Theorem app_assoc_reverse (l m n:list A) : (l ++ m) ++ n = l ++ m ++ n. Proof. auto using app_assoc. Qed. @@ -167,70 +167,76 @@ Section Facts. (* end hide *) (** [app] commutes with [cons] *) - Theorem app_comm_cons : forall (x y:list A) (a:A), a :: (x ++ y) = (a :: x) ++ y. + Theorem app_comm_cons (x y:list A) (a:A) : a :: (x ++ y) = (a :: x) ++ y. Proof. auto. Qed. (** Facts deduced from the result of a concatenation *) - Theorem app_eq_nil : forall l l':list A, l ++ l' = [] -> l = [] /\ l' = []. + Theorem app_eq_nil (l l':list A) : l ++ l' = [] -> l = [] /\ l' = []. Proof. destruct l as [| x l]; destruct l' as [| y l']; simpl; auto. intro; discriminate. intros H; discriminate H. Qed. - Theorem app_eq_unit : - forall (x y:list A) (a:A), + Theorem app_eq_unit (x y:list A) (a:A) : x ++ y = [a] -> x = [] /\ y = [a] \/ x = [a] /\ y = []. Proof. - destruct x as [| a l]; [ destruct y as [| a l] | destruct y as [| a0 l0] ]; + destruct x as [|a' l]; [ destruct y as [|a' l] | destruct y as [| a0 l0] ]; simpl. - intros a H; discriminate H. + intros H; discriminate H. left; split; auto. - right; split; auto. + intro H; right; split; auto. generalize H. generalize (app_nil_r l); intros E. rewrite -> E; auto. - intros. + intros H. injection H as [= H H0]. - assert ([] = l ++ a0 :: l0) by auto. + assert ([] = l ++ a0 :: l0) as H1 by auto. apply app_cons_not_nil in H1 as []. Qed. - Lemma elt_eq_unit : forall l1 l2 (a b : A), + Lemma elt_eq_unit l1 l2 (a b : A) : l1 ++ a :: l2 = [b] -> a = b /\ l1 = [] /\ l2 = []. Proof. - intros l1 l2 a b Heq. + intros Heq. apply app_eq_unit in Heq. 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]; + intro x; induction x as [| x l IHl]; intro y; [ 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]) as H 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 *) Lemma app_length : forall l l' : list A, length (l++l') = length l + length l'. Proof. - induction l; simpl; auto. + intro l; induction l; simpl; auto. Qed. Lemma last_length : forall (l : list A) a, length (l ++ a :: nil) = S (length l). @@ -239,17 +245,25 @@ 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. + intro l; induction l as [|? l IHl]; split; intros H; 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: forall l l1 l2 : list A, l1 ++ l = l2 ++ l -> l1 = l2. Proof. intros l l1 l2; revert l1 l2 l. - induction l1 as [ | x1 l1]; destruct l2 as [ | x2 l2]; + intro l1; induction l1 as [ | x1 l1]; intro l2; destruct l2 as [ | x2 l2]; simpl; auto; intros l H. absurd (length (x2 :: l2 ++ l) <= length l). simpl; rewrite app_length; auto with arith. @@ -260,6 +274,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] *) (************************) @@ -323,7 +343,7 @@ Section Facts. Theorem in_split : forall x (l:list A), In x l -> exists l1 l2, l = l1++x::l2. Proof. - induction l; simpl; destruct 1. + intros x l; induction l as [|a l IHl]; simpl; [destruct 1|destruct 1 as [?|H]]. subst a; auto. exists [], l; auto. destruct (IHl H) as (l1,(l2,H0)). @@ -354,7 +374,7 @@ Section Facts. (forall x y:A, {x = y} + {x <> y}) -> forall (a:A) (l:list A), {In a l} + {~ In a l}. Proof. - intro H; induction l as [| a0 l IHl]. + intros H a l; induction l as [| a0 l IHl]. right; apply in_nil. destruct (H a0 a); simpl; auto. destruct IHl; simpl; auto. @@ -404,8 +424,8 @@ Section Elts. Lemma nth_in_or_default : forall (n:nat) (l:list A) (d:A), {In (nth n l d) l} + {nth n l d = d}. Proof. - intros n l d; revert n; induction l. - - right; destruct n; trivial. + intros n l d; revert n; induction l as [|? ? IHl]. + - intro n; right; destruct n; trivial. - intros [|n]; simpl. * left; auto. * destruct (IHl n); auto. @@ -434,7 +454,7 @@ Section Elts. Lemma nth_default_eq : forall n l (d:A), nth_default d l n = nth n l d. Proof. - unfold nth_default; induction n; intros [ | ] ?; simpl; auto. + unfold nth_default; intro n; induction n; intros [ | ] ?; simpl; auto. Qed. (** Results about [nth] *) @@ -442,7 +462,7 @@ Section Elts. Lemma nth_In : forall (n:nat) (l:list A) (d:A), n < length l -> In (nth n l d) l. Proof. - unfold lt; induction n as [| n hn]; simpl. + unfold lt; intro n; induction n as [| n hn]; simpl; intro l. - destruct l; simpl; [ inversion 2 | auto ]. - destruct l; simpl. * inversion 2. @@ -462,7 +482,8 @@ Section Elts. Lemma nth_overflow : forall l n d, length l <= n -> nth n l d = d. Proof. - induction l; destruct n; simpl; intros; auto. + intro l; induction l as [|? ? IHl]; intro n; destruct n; + simpl; intros d H; auto. - inversion H. - apply IHl; auto with arith. Qed. @@ -470,7 +491,7 @@ Section Elts. Lemma nth_indep : forall l n d d', n < length l -> nth n l d = nth n l d'. Proof. - induction l. + intro l; induction l. - inversion 1. - intros [|n] d d'; simpl; auto with arith. Qed. @@ -478,7 +499,7 @@ Section Elts. Lemma app_nth1 : forall l l' d n, n < length l -> nth n (l++l') d = nth n l d. Proof. - induction l. + intro l; induction l. - inversion 1. - intros l' d [|n]; simpl; auto with arith. Qed. @@ -486,7 +507,7 @@ Section Elts. Lemma app_nth2 : forall l l' d n, n >= length l -> nth n (l++l') d = nth (n-length l) l' d. Proof. - induction l; intros l' d [|n]; auto. + intro l; induction l as [|? ? IHl]; intros l' d [|n]; auto. - inversion 1. - intros; simpl; rewrite IHl; auto with arith. Qed. @@ -520,7 +541,8 @@ Section Elts. Lemma nth_ext : forall l l' d d', length l = length l' -> (forall n, n < length l -> nth n l d = nth n l' d') -> l = l'. Proof. - induction l; intros l' d d' Hlen Hnth; destruct l' as [| b l']. + intro l; induction l as [|a l IHl]; + intros l' d d' Hlen Hnth; destruct l' as [| b l']. - reflexivity. - inversion Hlen. - inversion Hlen. @@ -554,7 +576,7 @@ Section Elts. Lemma nth_error_None l n : nth_error l n = None <-> length l <= n. Proof. - revert n. induction l; destruct n; simpl. + revert n. induction l as [|? ? IHl]; intro n; destruct n; simpl. - split; auto. - split; auto with arith. - split; now auto with arith. @@ -563,7 +585,7 @@ Section Elts. Lemma nth_error_Some l n : nth_error l n <> None <-> n < length l. Proof. - revert n. induction l; destruct n; simpl. + revert n. induction l as [|? ? IHl]; intro n; destruct n; simpl. - split; [now destruct 1 | inversion 1]. - split; [now destruct 1 | inversion 1]. - split; now auto with arith. @@ -584,7 +606,7 @@ Section Elts. nth_error (l++l') n = nth_error l n. Proof. revert l. - induction n; intros [|a l] H; auto; try solve [inversion H]. + induction n as [|n IHn]; intros [|a l] H; auto; try solve [inversion H]. simpl in *. apply IHn. auto with arith. Qed. @@ -592,7 +614,7 @@ Section Elts. nth_error (l++l') n = nth_error l' (n-length l). Proof. revert l. - induction n; intros [|a l] H; auto; try solve [inversion H]. + induction n as [|n IHn]; intros [|a l] H; auto; try solve [inversion H]. simpl in *. apply IHn. auto with arith. Qed. @@ -611,7 +633,7 @@ Section Elts. n < length l -> nth_error l n = Some (nth n l d). Proof. intros l n d H. - apply nth_split with (d:=d) in H. destruct H as [l1 [l2 [H H']]]. + apply (nth_split _ d) in H. destruct H as [l1 [l2 [H H']]]. subst. rewrite H. rewrite nth_error_app2; [|auto]. rewrite app_nth2; [| auto]. repeat (rewrite Nat.sub_diag). reflexivity. Qed. @@ -632,7 +654,7 @@ Section Elts. Lemma last_last : forall l a d, last (l ++ [a]) d = a. Proof. - induction l; intros; [ reflexivity | ]. + intro l; induction l as [|? l IHl]; intros; [ reflexivity | ]. simpl; rewrite IHl. destruct l; reflexivity. Qed. @@ -649,17 +671,17 @@ Section Elts. Lemma app_removelast_last : forall l d, l <> [] -> l = removelast l ++ [last l d]. Proof. - induction l. + intro l; induction l as [|? l IHl]. destruct 1; auto. intros d _. - destruct l; auto. + destruct l as [|a0 l]; auto. pattern (a0::l) at 1; rewrite IHl with d; auto; discriminate. Qed. Lemma exists_last : forall l, l <> [] -> { l' : (list A) & { a : A | l = l' ++ [a]}}. Proof. - induction l. + intro l; induction l as [|a l IHl]. destruct 1; auto. intros _. destruct l. @@ -672,10 +694,10 @@ Section Elts. Lemma removelast_app : forall l l', l' <> [] -> removelast (l++l') = l ++ removelast l'. Proof. - induction l. + intro l; induction l as [|? l IHl]. simpl; auto. - simpl; intros. - assert (l++l' <> []). + simpl; intros l' H. + assert (l++l' <> []) as H0. destruct l. simpl; auto. simpl; discriminate. @@ -712,7 +734,7 @@ Section Elts. Lemma remove_app : forall x l1 l2, remove x (l1 ++ l2) = remove x l1 ++ remove x l2. Proof. - induction l1; intros l2; simpl. + intros x l1; induction l1 as [|a l1 IHl1]; intros l2; simpl. - reflexivity. - destruct (eq_dec x a). + apply IHl1. @@ -722,7 +744,7 @@ Section Elts. Theorem remove_In : forall (l : list A) (x : A), ~ In x (remove x l). Proof. - induction l as [|x l]; auto. + intro l; induction l as [|x l IHl]; auto. intro y; simpl; destruct (eq_dec y x) as [yeqx | yneqx]. apply IHl. unfold not; intro HF; simpl in HF; destruct HF; auto. @@ -739,7 +761,7 @@ Section Elts. Lemma in_remove: forall l x y, In x (remove y l) -> In x l /\ x <> y. Proof. - induction l as [|z l]; intros x y Hin. + intro l; induction l as [|z l IHl]; intros x y Hin. - inversion Hin. - simpl in Hin. destruct (eq_dec y z) as [Heq|Hneq]; subst; split. @@ -754,7 +776,7 @@ Section Elts. Lemma in_in_remove : forall l x y, x <> y -> In x l -> In x (remove y l). Proof. - induction l as [|z l]; simpl; intros x y Hneq Hin. + intro l; induction l as [|z l IHl]; simpl; intros x y Hneq Hin. - apply Hin. - destruct (eq_dec y z); subst. + destruct Hin. @@ -767,7 +789,7 @@ Section Elts. Lemma remove_remove_comm : forall l x y, remove x (remove y l) = remove y (remove x l). Proof. - induction l as [| z l]; simpl; intros x y. + intro l; induction l as [| z l IHl]; simpl; intros x y. - reflexivity. - destruct (eq_dec y z); simpl; destruct (eq_dec x z); try rewrite IHl; auto. + subst; symmetry; apply remove_cons. @@ -779,7 +801,7 @@ Section Elts. Lemma remove_length_le : forall l x, length (remove x l) <= length l. Proof. - induction l as [|y l IHl]; simpl; intros x; trivial. + intro l; induction l as [|y l IHl]; simpl; intros x; trivial. destruct (eq_dec x y); simpl. - rewrite IHl; constructor; reflexivity. - apply (proj1 (Nat.succ_le_mono _ _) (IHl x)). @@ -787,7 +809,7 @@ Section Elts. Lemma remove_length_lt : forall l x, In x l -> length (remove x l) < length l. Proof. - induction l as [|y l IHl]; simpl; intros x Hin. + intro l; induction l as [|y l IHl]; simpl; intros x Hin. - contradiction Hin. - destruct Hin as [-> | Hin]. + destruct (eq_dec x x); intuition. @@ -812,7 +834,7 @@ Section Elts. (** Compatibility of count_occ with operations on list *) Theorem count_occ_In l x : In x l <-> count_occ l x > 0. Proof. - induction l as [|y l]; simpl. + induction l as [|y l IHl]; simpl. - split; [destruct 1 | apply gt_irrefl]. - destruct eq_dec as [->|Hneq]; rewrite IHl; intuition. Qed. @@ -871,8 +893,8 @@ Section ListOps. Lemma rev_app_distr : forall x y:list A, rev (x ++ y) = rev y ++ rev x. Proof. - induction x as [| a l IHl]. - destruct y as [| a l]. + intro x; induction x as [| a l IHl]. + intro y; destruct y as [| a l]. simpl. auto. @@ -887,13 +909,13 @@ Section ListOps. Remark rev_unit : forall (l:list A) (a:A), rev (l ++ [a]) = a :: rev l. Proof. - intros. + intros l a. apply (rev_app_distr l [a]); simpl; auto. Qed. Lemma rev_involutive : forall l:list A, rev (rev l) = l. Proof. - induction l as [| a l IHl]. + intro l; induction l as [| a l IHl]. simpl; auto. simpl. @@ -912,11 +934,11 @@ Section ListOps. Lemma in_rev : forall l x, In x l <-> In x (rev l). Proof. - induction l. + intro l; induction l. simpl; intuition. intros. simpl. - intuition. + split; intro H; [destruct H|]. subst. apply in_or_app; right; simpl; auto. apply in_or_app; left; firstorder. @@ -925,7 +947,7 @@ Section ListOps. Lemma rev_length : forall l, length (rev l) = length l. Proof. - induction l;simpl; auto. + intro l; induction l as [|? l IHl];simpl; auto. rewrite app_length. rewrite IHl. simpl. @@ -935,9 +957,9 @@ Section ListOps. Lemma rev_nth : forall l d n, n < length l -> nth n (rev l) d = nth (length l - S n) l d. Proof. - induction l. - intros; inversion H. - intros. + intro l; induction l as [|a l IHl]. + intros d n H; inversion H. + intros ? n H. simpl in H. simpl (rev (a :: l)). simpl (length (a :: l) - S n). @@ -967,7 +989,7 @@ Section ListOps. Lemma rev_append_rev : forall l l', rev_append l l' = rev l ++ l'. Proof. - induction l; simpl; auto; intros. + intro l; induction l; simpl; auto; intros. rewrite <- app_assoc; firstorder. Qed. @@ -989,20 +1011,20 @@ Section ListOps. (forall (a:A) (l:list A), P (rev l) -> P (rev (a :: l))) -> forall l:list A, P (rev l). Proof. - induction l; auto. + intros P ? ? l; induction l; auto. Qed. Theorem rev_ind : forall P:list A -> Prop, P [] -> (forall (x:A) (l:list A), P l -> P (l ++ [x])) -> forall l:list A, P l. Proof. - intros. + intros P H H0 l. generalize (rev_involutive l). intros E; rewrite <- E. apply (rev_list_ind P). - auto. - simpl. - intros. + intros a l0 ?. apply (H0 a (rev l0)). auto. Qed. @@ -1039,10 +1061,10 @@ Section ListOps. Lemma in_concat : forall l y, In y (concat l) <-> exists x, In x l /\ In y x. Proof. - induction l; simpl; split; intros. + intro l; induction l as [|a l IHl]; simpl; intro y; split; intros H. contradiction. destruct H as (x,(H,_)); contradiction. - destruct (in_app_or _ _ _ H). + destruct (in_app_or _ _ _ H) as [H0|H0]. exists a; auto. destruct (IHl y) as (H1,_); destruct (H1 H0) as (x,(H2,H3)). exists x; auto. @@ -1091,69 +1113,69 @@ Section Map. Lemma in_map : forall (l:list A) (x:A), In x l -> In (f x) (map l). Proof. - induction l; firstorder (subst; auto). + intro l; induction l; firstorder (subst; auto). Qed. Lemma in_map_iff : forall l y, In y (map l) <-> exists x, f x = y /\ In x l. Proof. - induction l; firstorder (subst; auto). + intro l; induction l; firstorder (subst; auto). Qed. Lemma map_length : forall l, length (map l) = length l. Proof. - induction l; simpl; auto. + intro l; induction l; simpl; auto. Qed. Lemma map_nth : forall l d n, nth n (map l) (f d) = f (nth n l d). Proof. - induction l; simpl map; destruct n; firstorder. + intro l; induction l; simpl map; intros d n; destruct n; firstorder. Qed. Lemma map_nth_error : forall n l d, nth_error l n = Some d -> nth_error (map l) n = Some (f d). Proof. - induction n; intros [ | ] ? Heq; simpl in *; inversion Heq; auto. + intro n; induction n; intros [ | ] ? Heq; simpl in *; inversion Heq; auto. Qed. Lemma map_app : forall l l', map (l++l') = (map l)++(map l'). Proof. - induction l; simpl; auto. + intro l; induction l as [|a l IHl]; simpl; auto. intros; rewrite IHl; auto. Qed. Lemma map_last : forall l a, map (l ++ [a]) = (map l) ++ [f a]. Proof. - induction l; intros; [ reflexivity | ]. + intro l; induction l as [|a l IHl]; intros; [ reflexivity | ]. simpl; rewrite IHl; reflexivity. Qed. Lemma map_rev : forall l, map (rev l) = rev (map l). Proof. - induction l; simpl; auto. + intro l; induction l as [|a l IHl]; simpl; auto. rewrite map_app. rewrite IHl; auto. Qed. Lemma map_eq_nil : forall l, map l = [] -> l = []. Proof. - destruct l; simpl; reflexivity || discriminate. + intro l; destruct l; simpl; reflexivity || discriminate. Qed. Lemma map_eq_cons : forall l l' b, map l = b :: l' -> exists a tl, l = a :: tl /\ f a = b /\ map tl = l'. Proof. intros l l' b Heq. - destruct l; inversion_clear Heq. + destruct l as [|a l]; inversion_clear Heq. exists a, l; repeat split. Qed. Lemma map_eq_app : forall l l1 l2, map l = l1 ++ l2 -> exists l1' l2', l = l1' ++ l2' /\ map l1' = l1 /\ map l2' = l2. Proof. - induction l; simpl; intros l1 l2 Heq. + intro l; induction l as [|a l IHl]; simpl; intros l1 l2 Heq. - symmetry in Heq; apply app_eq_nil in Heq; destruct Heq; subst. exists nil, nil; repeat split. - destruct l1; simpl in Heq; inversion Heq as [[Heq2 Htl]]. @@ -1194,7 +1216,7 @@ Section Map. flat_map f (l1 ++ l2) = flat_map f l1 ++ flat_map f l2. Proof. intros F l1 l2. - induction l1; [ reflexivity | simpl ]. + induction l1 as [|? ? IHl1]; [ reflexivity | simpl ]. rewrite IHl1, app_assoc; reflexivity. Qed. @@ -1202,10 +1224,10 @@ Section Map. In y (flat_map f l) <-> exists x, In x l /\ In y (f x). Proof. clear f Hfinjective. - induction l; simpl; split; intros. + intros f l; induction l as [|a l IHl]; simpl; intros y; split; intros H. contradiction. destruct H as (x,(H,_)); contradiction. - destruct (in_app_or _ _ _ H). + destruct (in_app_or _ _ _ H) as [H0|H0]. exists a; auto. destruct (IHl y) as (H1,_); destruct (H1 H0) as (x,(H2,H3)). exists x; auto. @@ -1236,33 +1258,33 @@ Qed. Lemma remove_concat A (eq_dec : forall x y : A, {x = y}+{x <> y}) : forall l x, remove eq_dec x (concat l) = flat_map (remove eq_dec x) l. Proof. - intros l x; induction l; [ reflexivity | simpl ]. + intros l x; induction l as [|? ? IHl]; [ reflexivity | simpl ]. rewrite remove_app, IHl; reflexivity. Qed. Lemma map_id : forall (A :Type) (l : list A), map (fun x => x) l = l. Proof. - induction l; simpl; auto; rewrite IHl; auto. + intros A l; induction l as [|? ? IHl]; simpl; auto; rewrite IHl; auto. Qed. Lemma map_map : forall (A B C:Type)(f:A->B)(g:B->C) l, map g (map f l) = map (fun x => g (f x)) l. Proof. - induction l; simpl; auto. + intros A B C f g l; induction l as [|? ? IHl]; simpl; auto. rewrite IHl; auto. Qed. Lemma map_ext_in : forall (A B : Type)(f g:A->B) l, (forall a, In a l -> f a = g a) -> map f l = map g l. Proof. - induction l; simpl; auto. - intros; rewrite H by intuition; rewrite IHl; auto. + intros A B f g l; induction l as [|? ? IHl]; simpl; auto. + intros H; rewrite H by intuition; rewrite IHl; auto. Qed. Lemma ext_in_map : forall (A B : Type)(f g:A->B) l, map f l = map g l -> forall a, In a l -> f a = g a. -Proof. induction l; intros [=] ? []; subst; auto. Qed. +Proof. intros A B f g l; induction l; intros [=] ? []; subst; auto. Qed. Arguments ext_in_map [A B f g l]. @@ -1283,13 +1305,13 @@ Lemma flat_map_ext : forall (A B : Type)(f g : A -> list B), Proof. intros A B f g Hext l. rewrite 2 flat_map_concat_map. - now rewrite map_ext with (g := g). + now rewrite (map_ext _ g). Qed. Lemma nth_nth_nth_map A : forall (l : list A) n d ln dn, n < length ln \/ length l <= dn -> nth (nth n ln dn) l d = nth n (map (fun x => nth x l d) ln) d. Proof. - intros l n d ln dn; revert n; induction ln; intros n Hlen. + intros l n d ln dn; revert n; induction ln as [|? ? IHln]; intros n Hlen. - destruct Hlen as [Hlen|Hlen]. + inversion Hlen. + now rewrite nth_overflow; destruct n. @@ -1315,7 +1337,7 @@ Section Fold_Left_Recursor. Lemma fold_left_app : forall (l l':list B)(i:A), fold_left (l++l') i = fold_left l' (fold_left l i). Proof. - induction l. + intro l; induction l. simpl; auto. intros. simpl. @@ -1329,7 +1351,7 @@ Lemma fold_left_length : Proof. intros A l. enough (H : forall n, fold_left (fun x _ => S x) l n = n + length l) by exact (H 0). - induction l; simpl; auto. + induction l as [|? ? IHl]; simpl; auto. intros; rewrite IHl. simpl; auto with arith. Qed. @@ -1354,7 +1376,7 @@ End Fold_Right_Recursor. Lemma fold_right_app : forall (A B:Type)(f:A->B->B) l l' i, fold_right f i (l++l') = fold_right f (fold_right f i l') l. Proof. - induction l. + intros A B f l; induction l. simpl; auto. simpl; intros. f_equal; auto. @@ -1363,7 +1385,7 @@ End Fold_Right_Recursor. Lemma fold_left_rev_right : forall (A B:Type)(f:A->B->B) l i, fold_right f i (rev l) = fold_left (fun x y => f y x) l i. Proof. - induction l. + intros A B f l; induction l. simpl; auto. intros. simpl. @@ -1377,8 +1399,9 @@ End Fold_Right_Recursor. forall (l : list A), fold_left f l a0 = fold_right f a0 l. Proof. intros A f assoc a0 comma0 l. - induction l as [ | a1 l ]; [ simpl; reflexivity | ]. - simpl. rewrite <- IHl. clear IHl. revert a1. induction l; [ auto | ]. + induction l as [ | a1 l IHl]; [ simpl; reflexivity | ]. + simpl. rewrite <- IHl. clear IHl. revert a1. + induction l as [|? ? IHl]; [ auto | ]. simpl. intro. rewrite <- assoc. rewrite IHl. rewrite IHl. auto. Qed. @@ -1415,7 +1438,7 @@ End Fold_Right_Recursor. Lemma existsb_exists : forall l, existsb l = true <-> exists x, In x l /\ f x = true. Proof. - induction l as [ | a m IH ]; split; simpl. + intro l; induction l as [ | a m IH ]; split; simpl. - easy. - intros [x [[]]]. - rewrite orb_true_iff; intros [ H | H ]. @@ -1430,9 +1453,9 @@ End Fold_Right_Recursor. Lemma existsb_nth : forall l n d, n < length l -> existsb l = false -> f (nth n l d) = false. Proof. - induction l. + intro l; induction l as [|? ? IHl]. inversion 1. - simpl; intros. + simpl; intros n ? ? H0. destruct (orb_false_elim _ _ H0); clear H0; auto. destruct n ; auto. rewrite IHl; auto with arith. @@ -1441,7 +1464,7 @@ End Fold_Right_Recursor. Lemma existsb_app : forall l1 l2, existsb (l1++l2) = existsb l1 || existsb l2. Proof. - induction l1; intros l2; simpl. + intro l1; induction l1 as [|a ? ?]; intros l2; simpl. solve[auto]. case (f a); simpl; solve[auto]. Qed. @@ -1458,19 +1481,19 @@ End Fold_Right_Recursor. Lemma forallb_forall : forall l, forallb l = true <-> (forall x, In x l -> f x = true). Proof. - induction l; simpl; intuition. - destruct (andb_prop _ _ H1). - congruence. - destruct (andb_prop _ _ H1); auto. - assert (forallb l = true). - apply H0; intuition. - rewrite H1; auto. + intro l; induction l as [|a l IHl]; simpl; [ tauto | split; intro H ]. + + destruct (andb_prop _ _ H); intros a' [?|?]. + - congruence. + - apply IHl; assumption. + + apply andb_true_intro; split. + - apply H; left; reflexivity. + - apply IHl; intros; apply H; right; assumption. Qed. Lemma forallb_app : forall l1 l2, forallb (l1++l2) = forallb l1 && forallb l2. Proof. - induction l1; simpl. + intro l1; induction l1 as [|a ? ?]; simpl. solve[auto]. case (f a); simpl; solve[auto]. Qed. @@ -1485,7 +1508,7 @@ End Fold_Right_Recursor. Lemma filter_In : forall x l, In x (filter l) <-> In x l /\ f x = true. Proof. - induction l; simpl. + intros x l; induction l as [|a ? ?]; simpl. intuition. intros. case_eq (f a); intros; simpl; intuition congruence. @@ -1501,7 +1524,7 @@ End Fold_Right_Recursor. Lemma concat_filter_map : forall (l : list (list A)), concat (map filter l) = filter (concat l). Proof. - induction l as [| v l IHl]; [auto|]. + intro l; induction l as [| v l IHl]; [auto|]. simpl. rewrite IHl. rewrite filter_app. reflexivity. Qed. @@ -1597,10 +1620,10 @@ End Fold_Right_Recursor. Lemma filter_map : forall (f g : A -> bool) (l : list A), filter f l = filter g l <-> map f l = map g l. Proof. - induction l as [| a l IHl]; [firstorder|]. + intros f g l; induction l as [| a l IHl]; [firstorder|]. simpl. destruct (f a) eqn:Hfa; destruct (g a) eqn:Hga; split; intros H. - - inversion H. apply IHl in H1. rewrite H1. reflexivity. - - inversion H. apply IHl in H1. rewrite H1. reflexivity. + - inversion H as [H1]. apply IHl in H1. rewrite H1. reflexivity. + - inversion H as [H1]. apply IHl in H1. rewrite H1. reflexivity. - assert (Ha : In a (filter g l)). { rewrite <- H. apply in_eq. } apply filter_In in Ha. destruct Ha as [_ Hga']. rewrite Hga in Hga'. inversion Hga'. - inversion H. @@ -1681,9 +1704,9 @@ End Fold_Right_Recursor. Lemma in_split_l : forall (l:list (A*B))(p:A*B), In p l -> In (fst p) (fst (split l)). Proof. - induction l; simpl; intros; auto. - destruct p; destruct a; destruct (split l); simpl in *. - destruct H. + intro l; induction l as [|a l IHl]; simpl; intros p H; auto. + destruct p as [a0 b]; destruct a; destruct (split l); simpl in *. + destruct H as [H|H]. injection H; auto. right; apply (IHl (a0,b) H). Qed. @@ -1691,9 +1714,9 @@ End Fold_Right_Recursor. Lemma in_split_r : forall (l:list (A*B))(p:A*B), In p l -> In (snd p) (snd (split l)). Proof. - induction l; simpl; intros; auto. - destruct p; destruct a; destruct (split l); simpl in *. - destruct H. + intro l; induction l as [|a l IHl]; simpl; intros p H; auto. + destruct p as [a0 b]; destruct a; destruct (split l); simpl in *. + destruct H as [H|H]. injection H; auto. right; apply (IHl (a0,b) H). Qed. @@ -1701,9 +1724,9 @@ End Fold_Right_Recursor. Lemma split_nth : forall (l:list (A*B))(n:nat)(d:A*B), nth n l d = (nth n (fst (split l)) (fst d), nth n (snd (split l)) (snd d)). Proof. - induction l. - destruct n; destruct d; simpl; auto. - destruct n; destruct d; simpl; auto. + intro l; induction l as [|a l IHl]. + intros n d; destruct n; destruct d; simpl; auto. + intros n d; destruct n; destruct d; simpl; auto. destruct a; destruct (split l); simpl; auto. destruct a; destruct (split l); simpl in *; auto. apply IHl. @@ -1712,14 +1735,14 @@ End Fold_Right_Recursor. Lemma split_length_l : forall (l:list (A*B)), length (fst (split l)) = length l. Proof. - induction l; simpl; auto. + intro l; induction l as [|a l IHl]; simpl; auto. destruct a; destruct (split l); simpl; auto. Qed. Lemma split_length_r : forall (l:list (A*B)), length (snd (split l)) = length l. Proof. - induction l; simpl; auto. + intro l; induction l as [|a l IHl]; simpl; auto. destruct a; destruct (split l); simpl; auto. Qed. @@ -1736,7 +1759,7 @@ End Fold_Right_Recursor. Lemma split_combine : forall (l: list (A*B)), let (l1,l2) := split l in combine l1 l2 = l. Proof. - induction l. + intro l; induction l as [|a l IHl]. simpl; auto. destruct a; simpl. destruct (split l); simpl in *. @@ -1746,18 +1769,19 @@ End Fold_Right_Recursor. Lemma combine_split : forall (l:list A)(l':list B), length l = length l' -> split (combine l l') = (l,l'). Proof. - induction l, l'; simpl; trivial; try discriminate. + intro l; induction l as [|a l IHl]; intro l'; destruct l'; + simpl; trivial; try discriminate. now intros [= ->%IHl]. Qed. Lemma in_combine_l : forall (l:list A)(l':list B)(x:A)(y:B), In (x,y) (combine l l') -> In x l. Proof. - induction l. + intro l; induction l as [|a l IHl]. simpl; auto. - destruct l'; simpl; auto; intros. + intro l'; destruct l' as [|a0 l']; simpl; auto; intros x y H. contradiction. - destruct H. + destruct H as [H|H]. injection H; auto. right; apply IHl with l' y; auto. Qed. @@ -1765,10 +1789,10 @@ End Fold_Right_Recursor. Lemma in_combine_r : forall (l:list A)(l':list B)(x:A)(y:B), In (x,y) (combine l l') -> In y l'. Proof. - induction l. + intro l; induction l as [|? ? IHl]. simpl; intros; contradiction. - destruct l'; simpl; auto; intros. - destruct H. + intro l'; destruct l'; simpl; auto; intros x y H. + destruct H as [H|H]. injection H; auto. right; apply IHl with x; auto. Qed. @@ -1776,16 +1800,16 @@ End Fold_Right_Recursor. Lemma combine_length : forall (l:list A)(l':list B), length (combine l l') = min (length l) (length l'). Proof. - induction l. + intro l; induction l. simpl; auto. - destruct l'; simpl; auto. + intro l'; destruct l'; simpl; auto. Qed. Lemma combine_nth : forall (l:list A)(l':list B)(n:nat)(x:A)(y:B), length l = length l' -> nth n (combine l l') (x,y) = (nth n l x, nth n l' y). Proof. - induction l; destruct l'; intros; try discriminate. + intro l; induction l; intro l'; destruct l'; intros n x y; try discriminate. destruct n; simpl; auto. destruct n; simpl in *; auto. Qed. @@ -1805,7 +1829,7 @@ End Fold_Right_Recursor. forall (x:A) (y:B) (l:list B), In y l -> In (x, y) (map (fun y0:B => (x, y0)) l). Proof. - induction l; + intros x y l; induction l; [ simpl; auto | simpl; destruct 1 as [H1| ]; [ left; rewrite H1; trivial | right; auto ] ]. @@ -1815,9 +1839,9 @@ End Fold_Right_Recursor. forall (l:list A) (l':list B) (x:A) (y:B), In x l -> In y l' -> In (x, y) (list_prod l l'). Proof. - induction l; + intro l; induction l; [ simpl; tauto - | simpl; intros; apply in_or_app; destruct H; + | simpl; intros l' x y H H0; apply in_or_app; destruct H as [H|H]; [ left; rewrite H; apply in_prod_aux; assumption | right; auto ] ]. Qed. @@ -1825,10 +1849,10 @@ End Fold_Right_Recursor. forall (l:list A)(l':list B)(x:A)(y:B), In (x,y) (list_prod l l') <-> In x l /\ In y l'. Proof. - split; [ | intros; apply in_prod; intuition ]. - induction l; simpl; intros. + intros l l' x y; split; [ | intros H; apply in_prod; intuition ]. + induction l as [|a l IHl]; simpl; intros H. intuition. - destruct (in_app_or _ _ _ H); clear H. + destruct (in_app_or _ _ _ H) as [H0|H0]; clear H. destruct (in_map_iff (fun y : B => (a, y)) l' (x,y)) as (H1,_). destruct (H1 H0) as (z,(H2,H3)); clear H0 H1. injection H2 as [= -> ->]; intuition. @@ -1838,7 +1862,7 @@ End Fold_Right_Recursor. Lemma prod_length : forall (l:list A)(l':list B), length (list_prod l l') = (length l) * (length l'). Proof. - induction l; simpl; auto. + intro l; induction l; simpl; auto. intros. rewrite app_length. rewrite map_length. @@ -1926,7 +1950,7 @@ Section SetIncl. Lemma incl_l_nil : forall l, incl l nil -> l = nil. Proof. - destruct l; intros Hincl. + intro l; destruct l as [|a l]; intros Hincl. - reflexivity. - exfalso; apply Hincl with a; simpl; auto. Qed. @@ -2000,7 +2024,7 @@ Section SetIncl. Lemma incl_app_inv : forall l1 l2 m : list A, incl (l1 ++ l2) m -> incl l1 m /\ incl l2 m. Proof. - induction l1; intros l2 m Hin; split; auto. + intro l1; induction l1 as [|a l1 IHl1]; intros l2 m Hin; split; auto. - apply incl_nil_l. - intros b Hb; inversion_clear Hb; subst; apply Hin. + now constructor. @@ -2062,9 +2086,9 @@ Section Cutting. Lemma firstn_all2 n: forall (l:list A), (length l) <= n -> firstn n l = l. Proof. induction n as [|k iHk]. - - intro. inversion 1 as [H1|?]. + - intro l. inversion 1 as [H1|?]. rewrite (length_zero_iff_nil l) in H1. subst. now simpl. - - destruct l as [|x xs]; simpl. + - intro l; destruct l as [|x xs]; simpl. * now reflexivity. * simpl. intro H. apply Peano.le_S_n in H. f_equal. apply iHk, H. Qed. @@ -2074,16 +2098,16 @@ Section Cutting. Lemma firstn_le_length n: forall l:list A, length (firstn n l) <= n. Proof. - induction n as [|k iHk]; simpl; [auto | destruct l as [|x xs]; simpl]. + induction n as [|k iHk]; simpl; [auto | intro l; destruct l as [|x xs]; simpl]. - auto with arith. - apply Peano.le_n_S, iHk. Qed. Lemma firstn_length_le: forall l:list A, forall n:nat, n <= length l -> length (firstn n l) = n. - Proof. induction l as [|x xs Hrec]. + Proof. intro l; induction l as [|x xs Hrec]. - simpl. intros n H. apply le_n_0_eq in H. rewrite <- H. now simpl. - - destruct n. + - intro n; destruct n as [|n]. * now simpl. * simpl. intro H. apply le_S_n in H. now rewrite (Hrec n H). Qed. @@ -2116,11 +2140,11 @@ Section Cutting. forall l:list A, forall i j : nat, firstn i (firstn j l) = firstn (min i j) l. - Proof. induction l as [|x xs Hl]. + Proof. intro l; induction l as [|x xs Hl]. - intros. simpl. now rewrite ?firstn_nil. - - destruct i. + - intro i; destruct i. * intro. now simpl. - * destruct j. + * intro j; destruct j. + now simpl. + simpl. f_equal. apply Hl. Qed. @@ -2136,11 +2160,11 @@ Section Cutting. Lemma firstn_skipn_comm : forall m n l, firstn m (skipn n l) = skipn n (firstn (n + m) l). - Proof. now intros m; induction n; intros []; simpl; destruct m. Qed. + Proof. now intros m n; induction n; intros []; simpl; destruct m. Qed. Lemma skipn_firstn_comm : forall m n l, skipn m (firstn n l) = firstn (n - m) (skipn m l). - Proof. now induction m; intros [] []; simpl; rewrite ?firstn_nil. Qed. + Proof. now intro m; induction m; intros [] []; simpl; rewrite ?firstn_nil. Qed. Lemma skipn_O : forall l, skipn 0 l = l. Proof. reflexivity. Qed. @@ -2152,7 +2176,7 @@ Section Cutting. Proof. reflexivity. Qed. Lemma skipn_all : forall l, skipn (length l) l = nil. - Proof. now induction l. Qed. + Proof. now intro l; induction l. Qed. #[deprecated(since="8.12",note="Use skipn_all instead.")] Notation skipn_none := skipn_all. @@ -2164,15 +2188,15 @@ Section Cutting. Lemma firstn_skipn : forall n l, firstn n l ++ skipn n l = l. Proof. - induction n. + intro n; induction n. simpl; auto. - destruct l; simpl; auto. + intro l; destruct l; simpl; auto. f_equal; auto. Qed. Lemma firstn_length : forall n l, length (firstn n l) = min n (length l). Proof. - induction n; destruct l; simpl; auto. + intro n; induction n; intro l; destruct l; simpl; auto. Qed. Lemma skipn_length n : @@ -2180,7 +2204,7 @@ Section Cutting. Proof. induction n. - intros l; simpl; rewrite Nat.sub_0_r; reflexivity. - - destruct l; simpl; auto. + - intro l; destruct l; simpl; auto. Qed. Lemma skipn_app n : forall l1 l2, @@ -2220,11 +2244,11 @@ Section Cutting. Lemma removelast_firstn : forall n l, n < length l -> removelast (firstn (S n) l) = firstn n l. Proof. - induction n; destruct l. + intro n; induction n as [|n IHn]; intro l; destruct l as [|a l]. simpl; auto. simpl; auto. simpl; auto. - intros. + intros H. simpl in H. change (firstn (S (S n)) (a::l)) with ((a::nil)++firstn (S n) l). change (firstn (S n) (a::l)) with (a::firstn n l). @@ -2232,30 +2256,30 @@ Section Cutting. rewrite IHn; auto with arith. clear IHn; destruct l; simpl in *; try discriminate. - inversion_clear H. - inversion_clear H0. + inversion_clear H as [|? H1]. + inversion_clear H1. Qed. Lemma removelast_firstn_len : forall l, removelast l = firstn (pred (length l)) l. Proof. - induction l; [ reflexivity | simpl ]. + intro l; induction l as [|a l IHl]; [ reflexivity | simpl ]. destruct l; [ | rewrite IHl ]; reflexivity. Qed. Lemma firstn_removelast : forall n l, n < length l -> firstn n (removelast l) = firstn n l. Proof. - induction n; destruct l. + intro n; induction n; intro l; destruct l as [|a l]. simpl; auto. simpl; auto. simpl; auto. - intros. + intros H. simpl in H. change (removelast (a :: l)) with (removelast ((a::nil)++l)). rewrite removelast_app. simpl; f_equal; auto with arith. - intro H0; rewrite H0 in H; inversion_clear H; inversion_clear H1. + intro H0; rewrite H0 in H; inversion_clear H as [|? H1]; inversion_clear H1. Qed. End Cutting. @@ -2279,9 +2303,9 @@ Section Combining. Lemma combine_firstn_l : forall (l : list A) (l' : list B), combine l l' = combine l (firstn (length l) l'). Proof. - induction l as [| x l IHl]; intros l'; [reflexivity|]. + intro l; induction l as [| x l IHl]; intros l'; [reflexivity|]. destruct l' as [| x' l']; [reflexivity|]. - simpl. specialize IHl with (l':=l'). rewrite <- IHl. + simpl. specialize IHl with l'. rewrite <- IHl. reflexivity. Qed. @@ -2292,14 +2316,14 @@ Section Combining. induction l' as [| x' l' IHl']; intros l. - simpl. apply combine_nil. - destruct l as [| x l]; [reflexivity|]. - simpl. specialize IHl' with (l:=l). rewrite <- IHl'. + simpl. specialize IHl' with l. rewrite <- IHl'. reflexivity. Qed. Lemma combine_firstn : forall (l : list A) (l' : list B) (n : nat), firstn n (combine l l') = combine (firstn n l) (firstn n l'). Proof. - induction l as [| x l IHl]; intros l' n. + intro l; induction l as [| x l IHl]; intros l' n. - simpl. repeat (rewrite firstn_nil). reflexivity. - destruct l' as [| x' l']. + simpl. repeat (rewrite firstn_nil). rewrite combine_nil. reflexivity. @@ -2332,7 +2356,7 @@ Section Add. Lemma Add_split a l l' : Add a l l' -> exists l1 l2, l = l1++l2 /\ l' = l1++a::l2. Proof. - induction 1. + induction 1 as [l|x ? ? ? IHAdd]. - exists nil; exists l; split; trivial. - destruct IHAdd as (l1 & l2 & Hl & Hl'). exists (x::l1); exists l2; split; simpl; f_equal; trivial. @@ -2341,7 +2365,7 @@ Section Add. Lemma Add_in a l l' : Add a l l' -> forall x, In x l' <-> In x (a::l). Proof. - induction 1; intros; simpl in *; rewrite ?IHAdd; tauto. + induction 1 as [|? ? ? ? IHAdd]; intros; simpl in *; rewrite ?IHAdd; tauto. Qed. Lemma Add_length a l l' : Add a l l' -> length l' = S (length l). @@ -2416,7 +2440,7 @@ Section ReDun. Lemma NoDup_rev l : NoDup l -> NoDup (rev l). Proof. - induction l; simpl; intros Hnd; [ constructor | ]. + induction l as [|a l IHl]; simpl; intros Hnd; [ constructor | ]. inversion_clear Hnd as [ | ? ? Hnin Hndl ]. assert (Add a (rev l) (rev l ++ a :: nil)) as Hadd by (rewrite <- (app_nil_r (rev l)) at 1; apply Add_app). @@ -2426,10 +2450,10 @@ Section ReDun. Lemma NoDup_filter f l : NoDup l -> NoDup (filter f l). Proof. - induction l; simpl; intros Hnd; auto. + induction l as [|a l IHl]; simpl; intros Hnd; auto. apply NoDup_cons_iff in Hnd. destruct (f a); [ | intuition ]. - apply NoDup_cons_iff; split; intuition. + apply NoDup_cons_iff; split; [intro H|]; intuition. apply filter_In in H; intuition. Qed. @@ -2443,7 +2467,7 @@ Section ReDun. | x::xs => if in_dec decA x xs then nodup xs else x::(nodup xs) end. - Lemma nodup_fixed_point : forall (l : list A), + Lemma nodup_fixed_point (l : list A) : NoDup l -> nodup l = l. Proof. induction l as [| x l IHl]; [auto|]. intros H. @@ -2491,7 +2515,7 @@ Section ReDun. - rewrite NoDup_cons_iff, Hrec, (count_occ_not_In decA). clear Hrec. split. + intros (Ha, H) x. simpl. destruct (decA a x); auto. subst; now rewrite Ha. - + split. + + intro H; split. * specialize (H a). rewrite count_occ_cons_eq in H; trivial. now inversion H. * intros x. specialize (H x). simpl in *. destruct (decA a x); auto. @@ -2526,7 +2550,7 @@ Section ReDun. * elim Hal. eapply nth_error_In; eauto. * elim Hal. eapply nth_error_In; eauto. * f_equal. apply IH; auto with arith. } - { induction l as [|a l]; intros H; constructor. + { induction l as [|a l IHl]; intros H; constructor. * intro Ha. apply In_nth_error in Ha. destruct Ha as (n,Hn). assert (n < length l) by (now rewrite <- nth_error_Some, Hn). specialize (H 0 (S n)). simpl in H. discriminate H; auto with arith. @@ -2546,7 +2570,7 @@ Section ReDun. * elim Hal. subst a. apply nth_In; auto with arith. * elim Hal. subst a. apply nth_In; auto with arith. * f_equal. apply IH; auto with arith. } - { induction l as [|a l]; intros H; constructor. + { induction l as [|a l IHl]; intros H; constructor. * intro Ha. eapply In_nth in Ha. destruct Ha as (n & Hn & Hn'). specialize (H 0 (S n)). simpl in H. discriminate H; eauto with arith. * apply IHl. @@ -2570,7 +2594,7 @@ Section ReDun. NoDup l -> length l' <= length l -> incl l l' -> incl l' l. Proof. intros N. revert l'. induction N as [|a l Hal N IH]. - - destruct l'; easy. + - intro l'; destruct l'; easy. - intros l' E H x Hx. destruct (Add_inv a l') as (l'', AD). { apply H; simpl; auto. } rewrite (Add_in AD) in Hx. simpl in Hx. @@ -2583,7 +2607,7 @@ Section ReDun. Lemma NoDup_incl_NoDup (l l' : list A) : NoDup l -> length l' <= length l -> incl l l' -> NoDup l'. Proof. - revert l'; induction l; simpl; intros l' Hnd Hlen Hincl. + revert l'; induction l as [|a l IHl]; simpl; intros l' Hnd Hlen Hincl. - now destruct l'; inversion Hlen. - assert (In a l') as Ha by now apply Hincl; left. apply in_split in Ha as [l1' [l2' ->]]. @@ -2593,7 +2617,7 @@ Section ReDun. * rewrite app_length. rewrite app_length in Hlen; simpl in Hlen; rewrite Nat.add_succ_r in Hlen. now apply Nat.succ_le_mono. - * apply incl_Add_inv with (u:= l1' ++ l2') in Hincl; auto. + * apply (incl_Add_inv (u:= l1' ++ l2')) in Hincl; auto. apply Add_app. + intros Hnin'. assert (incl (a :: l) (l1' ++ l2')) as Hincl''. @@ -2642,13 +2666,13 @@ Section NatSeq. Lemma seq_length : forall len start, length (seq start len) = len. Proof. - induction len; simpl; auto. + intro len; induction len; simpl; auto. Qed. Lemma seq_nth : forall len start n d, n < len -> nth n (seq start len) d = start+n. Proof. - induction len; intros. + intro len; induction len as [|len IHlen]; intros start n d H. inversion H. simpl seq. destruct n; simpl. @@ -2659,7 +2683,7 @@ Section NatSeq. Lemma seq_shift : forall len start, map S (seq start len) = seq (S start) len. Proof. - induction len; simpl; auto. + intro len; induction len as [|len IHlen]; simpl; auto. intros. rewrite IHlen. auto with arith. @@ -2668,7 +2692,7 @@ Section NatSeq. Lemma in_seq len start n : In n (seq start len) <-> start <= n < start+len. Proof. - revert start. induction len; simpl; intros. + revert start. induction len as [|len IHlen]; simpl; intros. - rewrite <- plus_n_O. split;[easy|]. intros (H,H'). apply (Lt.lt_irrefl _ (Lt.le_lt_trans _ _ _ H H')). - rewrite IHlen, <- plus_n_Sm; simpl; split. @@ -2685,7 +2709,7 @@ Section NatSeq. Lemma seq_app : forall len1 len2 start, seq start (len1 + len2) = seq start len1 ++ seq (start + len1) len2. Proof. - induction len1 as [|len1' IHlen]; intros; simpl in *. + intro len1; induction len1 as [|len1' IHlen]; intros; simpl in *. - now rewrite Nat.add_0_r. - now rewrite Nat.add_succ_r, IHlen. Qed. @@ -2730,7 +2754,7 @@ Section Exists_Forall. split. - intros HE; apply Exists_exists in HE. destruct HE as [a [Hin HP]]. - apply In_nth with (d := a) in Hin; destruct Hin as [i [Hl Heq]]. + apply (In_nth _ _ a) in Hin; destruct Hin as [i [Hl Heq]]. rewrite <- Heq in HP. now exists i; exists a. - intros [i [d [Hl HP]]]. @@ -2806,23 +2830,23 @@ Section Exists_Forall. Proof. split. - intros HF i d Hl. - apply Forall_forall with (x := nth i l d) in HF. + apply (Forall_forall l). assumption. apply nth_In; assumption. - intros HF. apply Forall_forall; intros a Hin. - apply In_nth with (d := a) in Hin; destruct Hin as [i [Hl Heq]]. + apply (In_nth _ _ a) in Hin; destruct Hin as [i [Hl Heq]]. rewrite <- Heq; intuition. Qed. Lemma Forall_inv : forall (a:A) l, Forall (a :: l) -> P a. Proof. - intros; inversion H; trivial. + intros a l H; inversion H; trivial. Qed. Theorem Forall_inv_tail : forall (a:A) l, Forall (a :: l) -> Forall l. Proof. - intros; inversion H; trivial. + intros a l H; inversion H; trivial. Qed. Lemma Forall_app l1 l2 : @@ -2847,14 +2871,14 @@ Section Exists_Forall. Lemma Forall_rect : forall (Q : list A -> Type), Q [] -> (forall b l, P b -> Q (b :: l)) -> forall l, Forall l -> Q l. Proof. - intros Q H H'; induction l; intro; [|eapply H', Forall_inv]; eassumption. + intros Q H H' l; induction l; intro; [|eapply H', Forall_inv]; eassumption. Qed. Lemma Forall_dec : (forall x:A, {P x} + { ~ P x }) -> forall l:list A, {Forall l} + {~ Forall l}. Proof. - intro Pdec. induction l as [|a l' Hrec]. + intros Pdec l. induction l as [|a l' Hrec]. - left. apply Forall_nil. - destruct Hrec as [Hl'|Hl']. + destruct (Pdec a) as [Ha|Ha]. @@ -2873,7 +2897,7 @@ Section Exists_Forall. Proof. intros Hincl HF. apply Forall_forall; intros a Ha. - apply Forall_forall with (x:=a) in HF; intuition. + apply (Forall_forall l1); intuition. Qed. End One_predicate. @@ -2888,7 +2912,7 @@ Section Exists_Forall. forall l, Exists P l -> Exists Q l. Proof. intros P Q H l H0. - induction H0. + induction H0 as [x l H0|x l H0 IHExists]. apply (Exists_cons_hd Q x l (H x H0)). apply (Exists_cons_tl x IHExists). Qed. @@ -2896,7 +2920,7 @@ Section Exists_Forall. Lemma Exists_or : forall (P Q : A -> Prop) l, Exists P l \/ Exists Q l -> Exists (fun x => P x \/ Q x) l. Proof. - induction l; intros [H | H]; inversion H; subst. + intros P Q l; induction l as [|a l IHl]; intros [H | H]; inversion H; subst. 1,3: apply Exists_cons_hd; auto. all: apply Exists_cons_tl, IHl; auto. Qed. @@ -2904,7 +2928,8 @@ Section Exists_Forall. Lemma Exists_or_inv : forall (P Q : A -> Prop) l, Exists (fun x => P x \/ Q x) l -> Exists P l \/ Exists Q l. Proof. - induction l; intro Hl; inversion Hl as [ ? ? H | ? ? H ]; subst. + intros P Q l; induction l as [|a l IHl]; + intro Hl; inversion Hl as [ ? ? H | ? ? H ]; subst. - inversion H; now repeat constructor. - destruct (IHl H); now repeat constructor. Qed. @@ -2918,13 +2943,13 @@ Section Exists_Forall. Lemma Forall_and : forall (P Q : A -> Prop) l, Forall P l -> Forall Q l -> Forall (fun x => P x /\ Q x) l. Proof. - induction l; intros HP HQ; constructor; inversion HP; inversion HQ; auto. + intros P Q l; induction l; intros HP HQ; constructor; inversion HP; inversion HQ; auto. Qed. Lemma Forall_and_inv : forall (P Q : A -> Prop) l, Forall (fun x => P x /\ Q x) l -> Forall P l /\ Forall Q l. Proof. - induction l; intro Hl; split; constructor; inversion Hl; firstorder. + intros P Q l; induction l; intro Hl; split; constructor; inversion Hl; firstorder. Qed. Lemma Forall_Exists_neg (P:A->Prop)(l:list A) : @@ -2954,7 +2979,7 @@ Section Exists_Forall. Exists (fun x => ~ P x) l. Proof. intro Dec. - apply Exists_Forall_neg; intros. + apply Exists_Forall_neg; intros x. destruct (Dec x); auto. Qed. @@ -2980,7 +3005,7 @@ Hint Constructors Forall : core. Lemma exists_Forall A B : forall (P : A -> B -> Prop) l, (exists k, Forall (P k) l) -> Forall (fun x => exists k, P k x) l. Proof. - induction l; intros [k HF]; constructor; inversion_clear HF. + intros P l; induction l as [|a l IHl]; intros [k HF]; constructor; inversion_clear HF. - now exists k. - now apply IHl; exists k. Qed. @@ -2988,7 +3013,7 @@ Qed. Lemma Forall_image A B : forall (f : A -> B) l, Forall (fun y => exists x, y = f x) l <-> exists l', l = map f l'. Proof. - induction l; split; intros HF. + intros f l; induction l as [|a l IHl]; split; intros HF. - exists nil; reflexivity. - constructor. - inversion_clear HF as [| ? ? [x Hx] HFtl]; subst. @@ -3005,7 +3030,7 @@ Qed. Lemma concat_nil_Forall A : forall (l : list (list A)), concat l = nil <-> Forall (fun x => x = nil) l. Proof. - induction l; simpl; split; intros Hc; auto. + intro l; induction l as [|a l IHl]; simpl; split; intros Hc; auto. - apply app_eq_nil in Hc. constructor; firstorder. - inversion Hc; subst; simpl. @@ -3048,9 +3073,9 @@ Section Forall2. Forall2 (l1 ++ l2) l' -> exists l1' l2', Forall2 l1 l1' /\ Forall2 l2 l2' /\ l' = l1' ++ l2'. Proof. - induction l1; intros. + intro l1; induction l1 as [|a l1 IHl1]; intros l2 l' H. exists [], l'; auto. - simpl in H; inversion H; subst; clear H. + simpl in H; inversion H as [|? y ? ? ? H4]; subst; clear H. apply IHl1 in H4 as (l1' & l2' & Hl1 & Hl2 & ->). exists (y::l1'), l2'; simpl; auto. Qed. @@ -3059,9 +3084,9 @@ Section Forall2. Forall2 l (l1' ++ l2') -> exists l1 l2, Forall2 l1 l1' /\ Forall2 l2 l2' /\ l = l1 ++ l2. Proof. - induction l1'; intros. + intro l1'; induction l1' as [|a l1' IHl1']; intros l2' l H. exists [], l; auto. - simpl in H; inversion H; subst; clear H. + simpl in H; inversion H as [|x ? ? ? ? H4]; subst; clear H. apply IHl1' in H4 as (l1 & l2 & Hl1 & Hl2 & ->). exists (x::l1), l2; simpl; auto. Qed. @@ -3069,7 +3094,7 @@ Section Forall2. Theorem Forall2_app : forall l1 l2 l1' l2', Forall2 l1 l1' -> Forall2 l2 l2' -> Forall2 (l1 ++ l2) (l1' ++ l2'). Proof. - intros. induction l1 in l1', H, H0 |- *; inversion H; subst; simpl; auto. + intros l1 l2 l1' l2' H H0. induction l1 in l1', H, H0 |- *; inversion H; subst; simpl; auto. Qed. End Forall2. @@ -3112,7 +3137,7 @@ Section ForallPairs. Lemma ForallPairs_ForallOrdPairs l: ForallPairs l -> ForallOrdPairs l. Proof. - induction l; auto. intros H. + induction l as [|a l IHl]; auto. intros H. constructor. apply <- Forall_forall. intros; apply H; simpl; auto. apply IHl. red; intros; apply H; simpl; auto. @@ -3152,17 +3177,55 @@ Section Repeat. Lemma repeat_cons n a : a :: repeat a n = repeat a n ++ (a :: nil). Proof. - induction n; simpl. + induction n as [|n IHn]; simpl. - reflexivity. - 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) : repeat a n = concat (repeat [a] n). Proof. - induction n; simpl. + induction n as [|n IHn]; simpl. - reflexivity. - f_equal; apply IHn. Qed. @@ -3175,7 +3238,7 @@ Definition list_sum l := fold_right plus 0 l. Lemma list_sum_app : forall l1 l2, list_sum (l1 ++ l2) = list_sum l1 + list_sum l2. Proof. -induction l1; intros l2; [ reflexivity | ]. +intro l1; induction l1 as [|a l1 IHl1]; intros l2; [ reflexivity | ]. simpl; rewrite IHl1. apply Nat.add_assoc. Qed. @@ -3187,14 +3250,14 @@ Definition list_max l := fold_right max 0 l. Lemma list_max_app : forall l1 l2, list_max (l1 ++ l2) = max (list_max l1) (list_max l2). Proof. -induction l1; intros l2; [ reflexivity | ]. +intro l1; induction l1 as [|a l1 IHl1]; intros l2; [ reflexivity | ]. now simpl; rewrite IHl1, Nat.max_assoc. Qed. Lemma list_max_le : forall l n, list_max l <= n <-> Forall (fun k => k <= n) l. Proof. -induction l; simpl; intros n; split; intros H; intuition. +intro l; induction l as [|a l IHl]; simpl; intros n; split; intros H; intuition. - apply Nat.max_lub_iff in H. now constructor; [ | apply IHl ]. - inversion_clear H as [ | ? ? Hle HF ]. @@ -3204,7 +3267,7 @@ Qed. Lemma list_max_lt : forall l n, l <> nil -> list_max l < n <-> Forall (fun k => k < n) l. Proof. -induction l; simpl; intros n Hnil; split; intros H; intuition. +intro l; induction l as [|a l IHl]; simpl; intros n Hnil; split; intros H; intuition. - destruct l. + repeat constructor. now simpl in H; rewrite Nat.max_0_r in H. diff --git a/theories/Logic/EqdepFacts.v b/theories/Logic/EqdepFacts.v index 23d486ff90..a918d1ecd7 100644 --- a/theories/Logic/EqdepFacts.v +++ b/theories/Logic/EqdepFacts.v @@ -104,7 +104,7 @@ Section Dependent_Equality. Lemma eq_dep_dep1 : forall (p q:U) (x:P p) (y:P q), eq_dep p x q y -> eq_dep1 p x q y. Proof. - destruct 1. + intros p; destruct 1. apply eq_dep1_intro with (eq_refl p). simpl; trivial. Qed. @@ -120,7 +120,7 @@ Lemma eq_sigT_eq_dep : forall (U:Type) (P:U -> Type) (p q:U) (x:P p) (y:P q), existT P p x = existT P q y -> eq_dep p x q y. Proof. - intros. + intros * H. dependent rewrite H. apply eq_dep_intro. Qed. @@ -145,7 +145,7 @@ Lemma eq_sig_eq_dep : forall (U:Type) (P:U -> Prop) (p q:U) (x:P p) (y:P q), exist P p x = exist P q y -> eq_dep p x q y. Proof. - intros. + intros * H. dependent rewrite H. apply eq_dep_intro. Qed. @@ -168,10 +168,10 @@ Qed. Set Implicit Arguments. -Lemma eq_sigT_sig_eq : forall X P (x1 x2:X) H1 H2, existT P x1 H1 = existT P x2 H2 <-> - {H:x1=x2 | rew H in H1 = H2}. +Lemma eq_sigT_sig_eq X P (x1 x2:X) H1 H2 : + existT P x1 H1 = existT P x2 H2 <-> {H:x1=x2 | rew H in H1 = H2}. Proof. - intros; split; intro H. + split; intro H. - change x2 with (projT1 (existT P x2 H2)). change H2 with (projT2 (existT P x2 H2)) at 5. destruct H. simpl. @@ -181,19 +181,17 @@ Proof. reflexivity. Defined. -Lemma eq_sigT_fst : - forall X P (x1 x2:X) H1 H2 (H:existT P x1 H1 = existT P x2 H2), x1 = x2. +Lemma eq_sigT_fst X P (x1 x2:X) H1 H2 (H:existT P x1 H1 = existT P x2 H2) : + x1 = x2. Proof. - intros. change x2 with (projT1 (existT P x2 H2)). destruct H. reflexivity. Defined. -Lemma eq_sigT_snd : - forall X P (x1 x2:X) H1 H2 (H:existT P x1 H1 = existT P x2 H2), rew (eq_sigT_fst H) in H1 = H2. +Lemma eq_sigT_snd X P (x1 x2:X) H1 H2 (H:existT P x1 H1 = existT P x2 H2) : + rew (eq_sigT_fst H) in H1 = H2. Proof. - intros. unfold eq_sigT_fst. change x2 with (projT1 (existT P x2 H2)). change H2 with (projT2 (existT P x2 H2)) at 3. @@ -201,19 +199,17 @@ Proof. reflexivity. Defined. -Lemma eq_sig_fst : - forall X P (x1 x2:X) H1 H2 (H:exist P x1 H1 = exist P x2 H2), x1 = x2. +Lemma eq_sig_fst X P (x1 x2:X) H1 H2 (H:exist P x1 H1 = exist P x2 H2) : + x1 = x2. Proof. - intros. change x2 with (proj1_sig (exist P x2 H2)). destruct H. reflexivity. Defined. -Lemma eq_sig_snd : - forall X P (x1 x2:X) H1 H2 (H:exist P x1 H1 = exist P x2 H2), rew (eq_sig_fst H) in H1 = H2. +Lemma eq_sig_snd X P (x1 x2:X) H1 H2 (H:exist P x1 H1 = exist P x2 H2) : + rew (eq_sig_fst H) in H1 = H2. Proof. - intros. unfold eq_sig_fst, eq_ind. change x2 with (proj1_sig (exist P x2 H2)). change H2 with (proj2_sig (exist P x2 H2)) at 3. @@ -283,7 +279,7 @@ Section Equivalences. Lemma eq_rect_eq_on__eq_dep_eq_on (p : U) (P : U -> Type) (x : P p) : Eq_rect_eq_on p P x -> Eq_dep_eq_on P p x. Proof. - intros eq_rect_eq; red; intros. + intros eq_rect_eq; red; intros y H. symmetry; apply (eq_rect_eq_on__eq_dep1_eq_on _ _ _ eq_rect_eq). apply eq_dep_sym in H; apply eq_dep_dep1; trivial. Qed. @@ -299,7 +295,7 @@ Section Equivalences. Proof. intro eq_dep_eq; red. elim p1 using eq_indd. - intros; apply eq_dep_eq. + intros p2; apply eq_dep_eq. elim p2 using eq_indd. apply eq_dep_intro. Qed. diff --git a/theories/Logic/Eqdep_dec.v b/theories/Logic/Eqdep_dec.v index 6ef5fa7d4c..4af90ae12d 100644 --- a/theories/Logic/Eqdep_dec.v +++ b/theories/Logic/Eqdep_dec.v @@ -46,9 +46,8 @@ Section EqdepDec. Let comp (x y y':A) (eq1:x = y) (eq2:x = y') : y = y' := eq_ind _ (fun a => a = y') eq2 _ eq1. - Remark trans_sym_eq : forall (x y:A) (u:x = y), comp u u = eq_refl y. + Remark trans_sym_eq (x y:A) (u:x = y) : comp u u = eq_refl y. Proof. - intros. case u; trivial. Qed. @@ -62,8 +61,7 @@ Section EqdepDec. | or_intror neqxy => False_ind _ (neqxy u) end. - Let nu_constant : forall (y:A) (u v:x = y), nu u = nu v. - intros. + Let nu_constant (y:A) (u v:x = y) : nu u = nu v. unfold nu. destruct (eq_dec y) as [Heq|Hneq]. - reflexivity. @@ -75,27 +73,23 @@ Section EqdepDec. Let nu_inv (y:A) (v:x = y) : x = y := comp (nu (eq_refl x)) v. - Remark nu_left_inv_on : forall (y:A) (u:x = y), nu_inv (nu u) = u. + Remark nu_left_inv_on (y:A) (u:x = y) : nu_inv (nu u) = u. Proof. - intros. case u; unfold nu_inv. apply trans_sym_eq. Qed. - Theorem eq_proofs_unicity_on : forall (y:A) (p1 p2:x = y), p1 = p2. + Theorem eq_proofs_unicity_on (y:A) (p1 p2:x = y) : p1 = p2. Proof. - intros. - elim nu_left_inv_on with (u := p1). - elim nu_left_inv_on with (u := p2). + elim (nu_left_inv_on p1). + elim (nu_left_inv_on p2). elim nu_constant with y p1 p2. reflexivity. Qed. - Theorem K_dec_on : - forall P:x = x -> Prop, P (eq_refl x) -> forall p:x = x, P p. + Theorem K_dec_on (P:x = x -> Prop) (H:P (eq_refl x)) (p:x = x) : P p. Proof. - intros. elim eq_proofs_unicity_on with x (eq_refl x) p. trivial. Qed. @@ -112,11 +106,10 @@ Section EqdepDec. end. - Theorem inj_right_pair_on : - forall (P:A -> Prop) (y y':P x), - ex_intro P x y = ex_intro P x y' -> y = y'. + Theorem inj_right_pair_on (P:A -> Prop) (y y':P x) : + ex_intro P x y = ex_intro P x y' -> y = y'. Proof. - intros. + intros H. cut (proj (ex_intro P x y) y = proj (ex_intro P x y') y). - simpl. destruct (eq_dec x) as [Heq|Hneq]. @@ -156,14 +149,11 @@ Proof (@inj_right_pair_on A x (eq_dec x)). Require Import EqdepFacts. (** We deduce axiom [K] for (decidable) types *) -Theorem K_dec_type : - forall A:Type, - (forall x y:A, {x = y} + {x <> y}) -> - forall (x:A) (P:x = x -> Prop), P (eq_refl x) -> forall p:x = x, P p. +Theorem K_dec_type (A:Type) (eq_dec:forall x y:A, {x = y} + {x <> y}) (x:A) + (P:x = x -> Prop) (H:P (eq_refl x)) (p:x = x) : P p. Proof. - intros A eq_dec x P H p. - elim p using K_dec; intros. - - case (eq_dec x0 y); [left|right]; assumption. + elim p using K_dec. + - intros x0 y; case (eq_dec x0 y); [left|right]; assumption. - trivial. Qed. @@ -259,7 +249,7 @@ Module DecidableEqDep (M:DecidableType). ex_intro P x p = ex_intro P x q -> p = q. Proof. intros. - apply inj_right_pair with (A:=U). + apply inj_right_pair. - intros x0 y0; case (eq_dec x0 y0); [left|right]; assumption. - assumption. Qed. @@ -377,7 +367,7 @@ Defined. Lemma UIP_refl_nat (n:nat) (x : n = n) : x = eq_refl. Proof. - induction n. + induction n as [|n IHn]. - change (match 0 as n return 0=n -> Prop with | 0 => fun x => x = eq_refl | _ => fun _ => True diff --git a/theories/NArith/BinNat.v b/theories/NArith/BinNat.v index 1881e387a2..039e920c29 100644 --- a/theories/NArith/BinNat.v +++ b/theories/NArith/BinNat.v @@ -94,7 +94,7 @@ Defined. Definition discr n : { p:positive | n = pos p } + { n = 0 }. Proof. - destruct n; auto. + destruct n as [|p]; auto. left; exists p; auto. Defined. @@ -486,7 +486,7 @@ Qed. Lemma size_le n : 2^(size n) <= succ_double n. Proof. - destruct n. discriminate. simpl. + destruct n as [|p]. discriminate. simpl. change (2^Pos.size p <= Pos.succ (p~0))%positive. apply Pos.lt_le_incl, Pos.lt_succ_r, Pos.size_le. Qed. @@ -512,10 +512,10 @@ Qed. Lemma even_spec n : even n = true <-> Even n. Proof. - destruct n. + destruct n as [|p]. split. now exists 0. trivial. - destruct p; simpl; split; try easy. + destruct p as [p|p|]; simpl; split; try easy. intros (m,H). now destruct m. now exists (pos p). intros (m,H). now destruct m. @@ -523,10 +523,10 @@ Qed. Lemma odd_spec n : odd n = true <-> Odd n. Proof. - destruct n. + destruct n as [|p]. split. discriminate. intros (m,H). now destruct m. - destruct p; simpl; split; try easy. + destruct p as [p|p|]; simpl; split; try easy. now exists (pos p). intros (m,H). now destruct m. now exists 0. @@ -537,7 +537,8 @@ Qed. Theorem pos_div_eucl_spec (a:positive)(b:N) : let (q,r) := pos_div_eucl a b in pos a = q * b + r. Proof. - induction a; cbv beta iota delta [pos_div_eucl]; fold pos_div_eucl; cbv zeta. + induction a as [a IHa|a IHa|]; + cbv beta iota delta [pos_div_eucl]; fold pos_div_eucl; cbv zeta. (* a~1 *) destruct pos_div_eucl as (q,r). change (pos a~1) with (succ_double (pos a)). @@ -579,7 +580,8 @@ Theorem pos_div_eucl_remainder (a:positive) (b:N) : b<>0 -> snd (pos_div_eucl a b) < b. Proof. intros Hb. - induction a; cbv beta iota delta [pos_div_eucl]; fold pos_div_eucl; cbv zeta. + induction a as [a IHa|a IHa|]; + cbv beta iota delta [pos_div_eucl]; fold pos_div_eucl; cbv zeta. (* a~1 *) destruct pos_div_eucl as (q,r); simpl in *. case leb_spec; intros H; simpl; trivial. @@ -612,7 +614,7 @@ Qed. Lemma sqrtrem_sqrt n : fst (sqrtrem n) = sqrt n. Proof. - destruct n. reflexivity. + destruct n as [|p]. reflexivity. unfold sqrtrem, sqrt, Pos.sqrt. destruct (Pos.sqrtrem p) as (s,r). now destruct r. Qed. @@ -620,7 +622,7 @@ Qed. Lemma sqrtrem_spec n : let (s,r) := sqrtrem n in n = s*s + r /\ r <= 2*s. Proof. - destruct n. now split. + destruct n as [|p]. now split. generalize (Pos.sqrtrem_spec p). simpl. destruct 1; simpl; subst; now split. Qed. @@ -628,7 +630,7 @@ Qed. Lemma sqrt_spec n : 0<=n -> let s := sqrt n in s*s <= n < (succ s)*(succ s). Proof. - intros _. destruct n. now split. apply (Pos.sqrt_spec p). + intros _. destruct n as [|p]. now split. apply (Pos.sqrt_spec p). Qed. Lemma sqrt_neg n : n<0 -> sqrt n = 0. @@ -749,7 +751,7 @@ Lemma shiftr_spec a n m : 0<=m -> testbit (shiftr a n) m = testbit a (m+n). Proof. intros _. revert a m. - induction n using peano_ind; intros a m. now rewrite add_0_r. + induction n as [|n IHn] using peano_ind; intros a m. now rewrite add_0_r. rewrite add_comm, add_succ_l, add_comm, <- add_succ_l. now rewrite <- IHn, testbit_succ_r_div2, shiftr_succ_r by apply le_0_l. Qed. @@ -771,10 +773,10 @@ Lemma shiftl_spec_low a n m : m<n -> testbit (shiftl a n) m = false. Proof. revert a m. - induction n using peano_ind; intros a m H. + induction n as [|n IHn] using peano_ind; intros a m H. elim (le_0_l m). now rewrite compare_antisym, H. rewrite shiftl_succ_r. - destruct m. now destruct (shiftl a n). + destruct m as [|p]. now destruct (shiftl a n). rewrite <- (succ_pos_pred p), testbit_succ_r_div2, div2_double by apply le_0_l. apply IHn. apply add_lt_mono_l with 1. rewrite 2 (add_succ_l 0). simpl. @@ -902,8 +904,8 @@ Qed. Lemma pos_pred_shiftl_low : forall p n m, m<n -> testbit (Pos.pred_N (Pos.shiftl p n)) m = true. Proof. - induction n using peano_ind. - now destruct m. + intros p n; induction n as [|n IHn] using peano_ind. + now intro m; destruct m. intros m H. unfold Pos.shiftl. destruct n as [|n]; simpl in *. destruct m. now destruct p. elim (Pos.nlt_1_r _ H). @@ -921,7 +923,7 @@ Lemma pos_pred_shiftl_high : forall p n m, n<=m -> testbit (Pos.pred_N (Pos.shiftl p n)) m = testbit (shiftl (Pos.pred_N p) n) m. Proof. - induction n using peano_ind; intros m H. + intros p n; induction n as [|n IHn] using peano_ind; intros m H. unfold shiftl. simpl. now destruct (Pos.pred_N p). rewrite shiftl_succ_r. destruct n as [|n]. @@ -945,11 +947,11 @@ Qed. (** ** Properties of [iter] *) -Lemma iter_swap_gen : forall A B (f:A -> B) (g:A -> A) (h:B -> B), +Lemma iter_swap_gen A B (f:A -> B) (g:A -> A) (h:B -> B) : (forall a, f (g a) = h (f a)) -> forall n a, f (iter n g a) = iter n h (f a). Proof. - destruct n; simpl; intros; rewrite ?H; trivial. + intros H n; destruct n; simpl; intros; rewrite ?H; trivial. now apply Pos.iter_swap_gen. Qed. @@ -964,7 +966,7 @@ Theorem iter_succ : forall n (A:Type) (f:A -> A) (x:A), iter (succ n) f x = f (iter n f x). Proof. - destruct n; intros; simpl; trivial. + intro n; destruct n; intros; simpl; trivial. now apply Pos.iter_succ. Qed. @@ -979,17 +981,16 @@ Theorem iter_add : forall p q (A:Type) (f:A -> A) (x:A), iter (p+q) f x = iter p f (iter q f x). Proof. - induction p using peano_ind; intros; trivial. + intro p; induction p as [|p IHp] using peano_ind; intros; trivial. now rewrite add_succ_l, !iter_succ, IHp. Qed. -Theorem iter_ind : - forall (A:Type) (f:A -> A) (a:A) (P:N -> A -> Prop), +Theorem iter_ind (A:Type) (f:A -> A) (a:A) (P:N -> A -> Prop) : P 0 a -> (forall n a', P n a' -> P (succ n) (f a')) -> forall n, P n (iter n f a). Proof. - induction n using peano_ind; trivial. + intros ? ? n; induction n using peano_ind; trivial. rewrite iter_succ; auto. Qed. @@ -998,7 +999,7 @@ Theorem iter_invariant : (forall x:A, Inv x -> Inv (f x)) -> forall x:A, Inv x -> Inv (iter n f x). Proof. - intros; apply iter_ind with (P := fun _ => Inv); trivial. + intros; apply iter_ind; trivial. Qed. End N. @@ -1007,7 +1008,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/NArith/Nnat.v b/theories/NArith/Nnat.v index 43fa8516d3..48df5fe884 100644 --- a/theories/NArith/Nnat.v +++ b/theories/NArith/Nnat.v @@ -70,7 +70,7 @@ Lemma inj_sub a a' : N.to_nat (a - a') = N.to_nat a - N.to_nat a'. Proof. destruct a as [|a], a' as [|a']; simpl; rewrite ?Nat.sub_0_r; trivial. - destruct (Pos.compare_spec a a'). + destruct (Pos.compare_spec a a') as [H|H|H]. - subst. now rewrite Pos.sub_mask_diag, Nat.sub_diag. - rewrite Pos.sub_mask_neg; trivial. apply Pos2Nat.inj_lt in H. simpl; symmetry; apply Nat.sub_0_le. now apply Nat.lt_le_incl. @@ -93,8 +93,8 @@ Qed. Lemma inj_compare a a' : (a ?= a')%N = (N.to_nat a ?= N.to_nat a'). Proof. - destruct a, a'; simpl; trivial. - - now destruct (Pos2Nat.is_succ p) as (n,->). + destruct a as [|p], a' as [|p']; simpl; trivial. + - now destruct (Pos2Nat.is_succ p') as (n,->). - now destruct (Pos2Nat.is_succ p) as (n,->). - apply Pos2Nat.inj_compare. Qed. 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/Numbers/Natural/Abstract/NAdd.v b/theories/Numbers/Natural/Abstract/NAdd.v index 8c4d072114..55c4b193a5 100644 --- a/theories/Numbers/Natural/Abstract/NAdd.v +++ b/theories/Numbers/Natural/Abstract/NAdd.v @@ -58,7 +58,7 @@ Qed. Theorem succ_add_discr : forall n m, m ~= S (n + m). Proof. -intro n; induct m. +intros n m; induct m. apply neq_sym. apply neq_succ_0. intros m IH H. apply succ_inj in H. rewrite add_succ_r in H. unfold not in IH; now apply IH. diff --git a/theories/Numbers/Natural/Abstract/NAddOrder.v b/theories/Numbers/Natural/Abstract/NAddOrder.v index 7c74de6364..d0ef94d1a4 100644 --- a/theories/Numbers/Natural/Abstract/NAddOrder.v +++ b/theories/Numbers/Natural/Abstract/NAddOrder.v @@ -19,7 +19,7 @@ Include NOrderProp N. Theorem le_add_r : forall n m, n <= n + m. Proof. -intro n; induct m. +intros n m; induct m. rewrite add_0_r; now apply eq_le_incl. intros m IH. rewrite add_succ_r; now apply le_le_succ_r. Qed. diff --git a/theories/Numbers/Natural/Abstract/NBase.v b/theories/Numbers/Natural/Abstract/NBase.v index a141cb7c0d..185a5974c2 100644 --- a/theories/Numbers/Natural/Abstract/NBase.v +++ b/theories/Numbers/Natural/Abstract/NBase.v @@ -39,7 +39,7 @@ Qed. Theorem le_0_l : forall n, 0 <= n. Proof. -nzinduct n. +intro n; nzinduct n. now apply eq_le_incl. intro n; split. apply le_le_succ_r. @@ -79,21 +79,21 @@ Proof. intro H; apply (neq_succ_0 0). apply H. Qed. -Theorem neq_0_r : forall n, n ~= 0 <-> exists m, n == S m. +Theorem neq_0_r n : n ~= 0 <-> exists m, n == S m. Proof. cases n. split; intro H; [now elim H | destruct H as [m H]; symmetry in H; false_hyp H neq_succ_0]. intro n; split; intro H; [now exists n | apply neq_succ_0]. Qed. -Theorem zero_or_succ : forall n, n == 0 \/ exists m, n == S m. +Theorem zero_or_succ n : n == 0 \/ exists m, n == S m. Proof. cases n. now left. intro n; right; now exists n. Qed. -Theorem eq_pred_0 : forall n, P n == 0 <-> n == 0 \/ n == 1. +Theorem eq_pred_0 n : P n == 0 <-> n == 0 \/ n == 1. Proof. cases n. rewrite pred_0. now split; [left|]. @@ -103,16 +103,16 @@ intros [H|H]. elim (neq_succ_0 _ H). apply succ_inj_wd. now rewrite <- one_succ. Qed. -Theorem succ_pred : forall n, n ~= 0 -> S (P n) == n. +Theorem succ_pred n : n ~= 0 -> S (P n) == n. Proof. cases n. intro H; exfalso; now apply H. intros; now rewrite pred_succ. Qed. -Theorem pred_inj : forall n m, n ~= 0 -> m ~= 0 -> P n == P m -> n == m. +Theorem pred_inj n m : n ~= 0 -> m ~= 0 -> P n == P m -> n == m. Proof. -intros n m; cases n. +cases n. intros H; exfalso; now apply H. intros n _; cases m. intros H; exfalso; now apply H. @@ -134,7 +134,7 @@ Proof. rewrite one_succ. intros until 3. assert (D : forall n, A n /\ A (S n)); [ |intro n; exact (proj1 (D n))]. -induct n; [ | intros n [IH1 IH2]]; auto. +intro n; induct n; [ | intros n [IH1 IH2]]; auto. Qed. End PairInduction. @@ -151,10 +151,10 @@ Theorem two_dim_induction : (forall n m, R n m -> R n (S m)) -> (forall n, (forall m, R n m) -> R (S n) 0) -> forall n m, R n m. Proof. -intros H1 H2 H3. induct n. -induct m. +intros H1 H2 H3. intro n; induct n. +intro m; induct m. exact H1. exact (H2 0). -intros n IH. induct m. +intros n IH. intro m; induct m. now apply H3. exact (H2 (S n)). Qed. @@ -171,8 +171,8 @@ Theorem double_induction : (forall n, R (S n) 0) -> (forall n m, R n m -> R (S n) (S m)) -> forall n m, R n m. Proof. -intros H1 H2 H3; induct n; auto. -intros n H; cases m; auto. +intros H1 H2 H3 n; induct n; auto. +intros n H m; cases m; auto. Qed. End DoubleInduction. diff --git a/theories/Numbers/Natural/Abstract/NBits.v b/theories/Numbers/Natural/Abstract/NBits.v index 6e557a567e..313b9adfd1 100644 --- a/theories/Numbers/Natural/Abstract/NBits.v +++ b/theories/Numbers/Natural/Abstract/NBits.v @@ -190,7 +190,7 @@ Qed. Lemma bit0_odd : forall a, a.[0] = odd a. Proof. - intros. symmetry. + intros a. symmetry. destruct (exists_div2 a) as (a' & b & EQ). rewrite EQ, testbit_0_r, add_comm, odd_add_mul_2. destruct b; simpl; apply odd_1 || apply odd_0. @@ -272,14 +272,14 @@ Qed. Lemma mul_pow2_bits_high : forall a n m, n<=m -> (a*2^n).[m] = a.[m-n]. Proof. - intros. + intros a n m ?. rewrite <- (sub_add n m) at 1 by order'. now rewrite mul_pow2_bits_add. Qed. Lemma mul_pow2_bits_low : forall a n m, m<n -> (a*2^n).[m] = false. Proof. - intros. apply testbit_false. + intros a n m H. apply testbit_false. rewrite <- (sub_add m n) by order'. rewrite pow_add_r, mul_assoc. rewrite div_mul by order_nz. rewrite <- (succ_pred (n-m)). rewrite pow_succ_r. @@ -370,7 +370,10 @@ Qed. Hint Rewrite lxor_spec lor_spec land_spec ldiff_spec bits_0 : bitwise. -Ltac bitwise := apply bits_inj; intros ?m; autorewrite with bitwise. +Tactic Notation "bitwise" "as" simple_intropattern(m) + := apply bits_inj; intros m; autorewrite with bitwise. + +Ltac bitwise := bitwise as ?m. (** The streams of bits that correspond to a natural numbers are exactly the ones that are always 0 after some point *) @@ -418,7 +421,7 @@ Qed. Lemma shiftl_mul_pow2 : forall a n, a << n == a * 2^n. Proof. - intros. bitwise. + intros a n. bitwise as m. destruct (le_gt_cases n m) as [H|H]. now rewrite shiftl_spec_high', mul_pow2_bits_high. now rewrite shiftl_spec_low, mul_pow2_bits_low. @@ -455,7 +458,7 @@ Qed. Lemma shiftr_shiftl_l : forall a n m, m<=n -> (a << n) >> m == a << (n-m). Proof. - intros. + intros a n m ?. rewrite shiftr_div_pow2, !shiftl_mul_pow2. rewrite <- (sub_add m n) at 1 by trivial. now rewrite pow_add_r, mul_assoc, div_mul by order_nz. @@ -464,7 +467,7 @@ Qed. Lemma shiftr_shiftl_r : forall a n m, n<=m -> (a << n) >> m == a >> (m-n). Proof. - intros. + intros a n m ?. rewrite !shiftr_div_pow2, shiftl_mul_pow2. rewrite <- (sub_add n m) at 1 by trivial. rewrite pow_add_r, (mul_comm (2^(m-n))). @@ -630,7 +633,7 @@ Qed. Lemma lor_eq_0_l : forall a b, lor a b == 0 -> a == 0. Proof. - intros a b H. bitwise. + intros a b H. bitwise as m. apply (orb_false_iff a.[m] b.[m]). now rewrite <- lor_spec, H, bits_0. Qed. @@ -638,7 +641,7 @@ Qed. Lemma lor_eq_0_iff : forall a b, lor a b == 0 <-> a == 0 /\ b == 0. Proof. intros a b. split. - split. now apply lor_eq_0_l in H. + intro H; split. now apply lor_eq_0_l in H. rewrite lor_comm in H. now apply lor_eq_0_l in H. intros (EQ,EQ'). now rewrite EQ, lor_0_l. Qed. @@ -751,13 +754,13 @@ Proof. unfold clearbit. solve_proper. Qed. Lemma pow2_bits_true : forall n, (2^n).[n] = true. Proof. - intros. rewrite <- (mul_1_l (2^n)). rewrite <- (add_0_l n) at 2. + intros n. rewrite <- (mul_1_l (2^n)). rewrite <- (add_0_l n) at 2. now rewrite mul_pow2_bits_add, bit0_odd, odd_1. Qed. Lemma pow2_bits_false : forall n m, n~=m -> (2^n).[m] = false. Proof. - intros. + intros n m ?. rewrite <- (mul_1_l (2^n)). destruct (le_gt_cases n m). rewrite mul_pow2_bits_high; trivial. @@ -768,7 +771,7 @@ Qed. Lemma pow2_bits_eqb : forall n m, (2^n).[m] = eqb n m. Proof. - intros. apply eq_true_iff_eq. rewrite eqb_eq. split. + intros n m. apply eq_true_iff_eq. rewrite eqb_eq. split. destruct (eq_decidable n m) as [H|H]. trivial. now rewrite (pow2_bits_false _ _ H). intros EQ. rewrite EQ. apply pow2_bits_true. @@ -813,7 +816,7 @@ Qed. Lemma clearbit_eq : forall a n, (clearbit a n).[n] = false. Proof. - intros. rewrite clearbit_eqb, (proj2 (eqb_eq _ _) (eq_refl n)). + intros a n. rewrite clearbit_eqb, (proj2 (eqb_eq _ _) (eq_refl n)). apply andb_false_r. Qed. @@ -830,7 +833,7 @@ Qed. Lemma shiftl_lxor : forall a b n, (lxor a b) << n == lxor (a << n) (b << n). Proof. - intros. bitwise. + intros a b n. bitwise as m. destruct (le_gt_cases n m). now rewrite !shiftl_spec_high', lxor_spec. now rewrite !shiftl_spec_low. @@ -845,7 +848,7 @@ Qed. Lemma shiftl_land : forall a b n, (land a b) << n == land (a << n) (b << n). Proof. - intros. bitwise. + intros a b n. bitwise as m. destruct (le_gt_cases n m). now rewrite !shiftl_spec_high', land_spec. now rewrite !shiftl_spec_low. @@ -860,7 +863,7 @@ Qed. Lemma shiftl_lor : forall a b n, (lor a b) << n == lor (a << n) (b << n). Proof. - intros. bitwise. + intros a b n. bitwise as m. destruct (le_gt_cases n m). now rewrite !shiftl_spec_high', lor_spec. now rewrite !shiftl_spec_low. @@ -875,7 +878,7 @@ Qed. Lemma shiftl_ldiff : forall a b n, (ldiff a b) << n == ldiff (a << n) (b << n). Proof. - intros. bitwise. + intros a b n. bitwise as m. destruct (le_gt_cases n m). now rewrite !shiftl_spec_high', ldiff_spec. now rewrite !shiftl_spec_low. @@ -944,7 +947,7 @@ Qed. Lemma ones_spec_high : forall n m, n<=m -> (ones n).[m] = false. Proof. - intros. + intros n m ?. destruct (eq_0_gt_0_cases n) as [EQ|LT]; rewrite ones_equiv. now rewrite EQ, pow_0_r, one_succ, pred_succ, bits_0. apply bits_above_log2. @@ -973,7 +976,7 @@ Qed. Lemma lnot_involutive : forall a n, lnot (lnot a n) n == a. Proof. - intros a n. bitwise. + intros a n. bitwise as m. destruct (le_gt_cases n m). now rewrite 2 lnot_spec_high. now rewrite 2 lnot_spec_low, negb_involutive. @@ -994,7 +997,7 @@ Qed. Lemma lor_ones_low : forall a n, log2 a < n -> lor a (ones n) == ones n. Proof. - intros a n H. bitwise. destruct (le_gt_cases n m). + intros a n H. bitwise as m. destruct (le_gt_cases n m). rewrite ones_spec_high, bits_above_log2; trivial. now apply lt_le_trans with n. now rewrite ones_spec_low, orb_true_r. @@ -1002,7 +1005,7 @@ Qed. Lemma land_ones : forall a n, land a (ones n) == a mod 2^n. Proof. - intros a n. bitwise. destruct (le_gt_cases n m). + intros a n. bitwise as m. destruct (le_gt_cases n m). now rewrite ones_spec_high, mod_pow2_bits_high, andb_false_r. now rewrite ones_spec_low, mod_pow2_bits_low, andb_true_r. Qed. @@ -1017,7 +1020,7 @@ Qed. Lemma ldiff_ones_r : forall a n, ldiff a (ones n) == (a >> n) << n. Proof. - intros a n. bitwise. destruct (le_gt_cases n m). + intros a n. bitwise as m. destruct (le_gt_cases n m). rewrite ones_spec_high, shiftl_spec_high', shiftr_spec'; trivial. rewrite sub_add; trivial. apply andb_true_r. now rewrite ones_spec_low, shiftl_spec_low, andb_false_r. @@ -1026,7 +1029,7 @@ Qed. Lemma ldiff_ones_r_low : forall a n, log2 a < n -> ldiff a (ones n) == 0. Proof. - intros a n H. bitwise. destruct (le_gt_cases n m). + intros a n H. bitwise as m. destruct (le_gt_cases n m). rewrite ones_spec_high, bits_above_log2; trivial. now apply lt_le_trans with n. now rewrite ones_spec_low, andb_false_r. @@ -1035,7 +1038,7 @@ Qed. Lemma ldiff_ones_l_low : forall a n, log2 a < n -> ldiff (ones n) a == lnot a n. Proof. - intros a n H. bitwise. destruct (le_gt_cases n m). + intros a n H. bitwise as m. destruct (le_gt_cases n m). rewrite ones_spec_high, lnot_spec_high, bits_above_log2; trivial. now apply lt_le_trans with n. now rewrite ones_spec_low, lnot_spec_low. @@ -1044,7 +1047,7 @@ Qed. Lemma lor_lnot_diag : forall a n, lor a (lnot a n) == lor a (ones n). Proof. - intros a n. bitwise. + intros a n. bitwise as m. destruct (le_gt_cases n m). rewrite lnot_spec_high, ones_spec_high; trivial. now destruct a.[m]. rewrite lnot_spec_low, ones_spec_low; trivial. now destruct a.[m]. @@ -1059,7 +1062,7 @@ Qed. Lemma land_lnot_diag : forall a n, land a (lnot a n) == ldiff a (ones n). Proof. - intros a n. bitwise. + intros a n. bitwise as m. destruct (le_gt_cases n m). rewrite lnot_spec_high, ones_spec_high; trivial. now destruct a.[m]. rewrite lnot_spec_low, ones_spec_low; trivial. now destruct a.[m]. @@ -1074,7 +1077,7 @@ Qed. Lemma lnot_lor_low : forall a b n, log2 a < n -> log2 b < n -> lnot (lor a b) n == land (lnot a n) (lnot b n). Proof. - intros a b n Ha Hb. bitwise. destruct (le_gt_cases n m). + intros a b n Ha Hb. bitwise as m. destruct (le_gt_cases n m). rewrite !lnot_spec_high, lor_spec, !bits_above_log2; trivial. now apply lt_le_trans with n. now apply lt_le_trans with n. @@ -1084,7 +1087,7 @@ Qed. Lemma lnot_land_low : forall a b n, log2 a < n -> log2 b < n -> lnot (land a b) n == lor (lnot a n) (lnot b n). Proof. - intros a b n Ha Hb. bitwise. destruct (le_gt_cases n m). + intros a b n Ha Hb. bitwise as m. destruct (le_gt_cases n m). rewrite !lnot_spec_high, land_spec, !bits_above_log2; trivial. now apply lt_le_trans with n. now apply lt_le_trans with n. @@ -1094,7 +1097,7 @@ Qed. Lemma ldiff_land_low : forall a b n, log2 a < n -> ldiff a b == land a (lnot b n). Proof. - intros a b n Ha. bitwise. destruct (le_gt_cases n m). + intros a b n Ha. bitwise as m. destruct (le_gt_cases n m). rewrite (bits_above_log2 a m). trivial. now apply lt_le_trans with n. rewrite !lnot_spec_low; trivial. @@ -1103,7 +1106,7 @@ Qed. Lemma lnot_ldiff_low : forall a b n, log2 a < n -> log2 b < n -> lnot (ldiff a b) n == lor (lnot a n) b. Proof. - intros a b n Ha Hb. bitwise. destruct (le_gt_cases n m). + intros a b n Ha Hb. bitwise as m. destruct (le_gt_cases n m). rewrite !lnot_spec_high, ldiff_spec, !bits_above_log2; trivial. now apply lt_le_trans with n. now apply lt_le_trans with n. @@ -1113,7 +1116,7 @@ Qed. Lemma lxor_lnot_lnot : forall a b n, lxor (lnot a n) (lnot b n) == lxor a b. Proof. - intros a b n. bitwise. destruct (le_gt_cases n m). + intros a b n. bitwise as m. destruct (le_gt_cases n m). rewrite !lnot_spec_high; trivial. rewrite !lnot_spec_low, xorb_negb_negb; trivial. Qed. @@ -1121,7 +1124,7 @@ Qed. Lemma lnot_lxor_l : forall a b n, lnot (lxor a b) n == lxor (lnot a n) b. Proof. - intros a b n. bitwise. destruct (le_gt_cases n m). + intros a b n. bitwise as m. destruct (le_gt_cases n m). rewrite !lnot_spec_high, lxor_spec; trivial. rewrite !lnot_spec_low, lxor_spec, negb_xorb_l; trivial. Qed. @@ -1129,7 +1132,7 @@ Qed. Lemma lnot_lxor_r : forall a b n, lnot (lxor a b) n == lxor a (lnot b n). Proof. - intros a b n. bitwise. destruct (le_gt_cases n m). + intros a b n. bitwise as m. destruct (le_gt_cases n m). rewrite !lnot_spec_high, lxor_spec; trivial. rewrite !lnot_spec_low, lxor_spec, negb_xorb_r; trivial. Qed. @@ -1137,7 +1140,7 @@ Qed. Lemma lxor_lor : forall a b, land a b == 0 -> lxor a b == lor a b. Proof. - intros a b H. bitwise. + intros a b H. bitwise as m. assert (a.[m] && b.[m] = false) by now rewrite <- land_spec, H, bits_0. now destruct a.[m], b.[m]. @@ -1264,7 +1267,7 @@ Qed. Lemma add_carry_div2 : forall a b (c0:bool), (a + b + c0)/2 == a/2 + b/2 + nextcarry a.[0] b.[0] c0. Proof. - intros. + intros a b c0. rewrite <- add3_bits_div2. rewrite (add_comm ((a/2)+_)). rewrite <- div_add by order'. @@ -1312,7 +1315,7 @@ Proof. apply div_lt_upper_bound; trivial. order'. now rewrite <- pow_succ_r'. exists (c0 + 2*c). repeat split. (* - add *) - bitwise. + bitwise as m. destruct (zero_or_succ m) as [EQ|[m' EQ]]; rewrite EQ; clear EQ. now rewrite add_b2n_double_bit0, add3_bit0, b2n_bit0. rewrite <- !div2_bits, <- 2 lxor_spec. @@ -1320,7 +1323,7 @@ Proof. rewrite add_b2n_double_div2, <- IH1. apply add_carry_div2. (* - carry *) rewrite add_b2n_double_div2. - bitwise. + bitwise as m. destruct (zero_or_succ m) as [EQ|[m' EQ]]; rewrite EQ; clear EQ. now rewrite add_b2n_double_bit0. rewrite <- !div2_bits, IH2. autorewrite with bitwise. @@ -1356,7 +1359,7 @@ Proof. symmetry in H. now apply lor_eq_0_l in H. intros EQ. rewrite EQ, lor_0_l in H. apply bits_inj_0. - induct n. trivial. + intro n; induct n. trivial. intros n IH. rewrite <- div2_bits, H. autorewrite with bitwise. @@ -1381,7 +1384,7 @@ Lemma ldiff_le : forall a b, ldiff a b == 0 -> a <= b. Proof. cut (forall n a b, a < 2^n -> ldiff a b == 0 -> a <= b). intros H a b. apply (H a), pow_gt_lin_r; order'. - induct n. + intro n; induct n. intros a b Ha _. rewrite pow_0_r, one_succ, lt_succ_r in Ha. assert (Ha' : a == 0) by (generalize (le_0_l a); order'). rewrite Ha'. apply le_0_l. @@ -1410,7 +1413,7 @@ Proof. rewrite sub_add. symmetry. rewrite add_nocarry_lxor. - bitwise. + bitwise as m. apply bits_inj_iff in H. specialize (H m). rewrite ldiff_spec, bits_0 in H. now destruct a.[m], b.[m]. @@ -1454,7 +1457,7 @@ Lemma add_nocarry_mod_lt_pow2 : forall a b n, land a b == 0 -> Proof. intros a b n H. apply add_nocarry_lt_pow2. - bitwise. + bitwise as m. destruct (le_gt_cases n m). now rewrite mod_pow2_bits_high. now rewrite !mod_pow2_bits_low, <- land_spec, H, bits_0. diff --git a/theories/Numbers/Natural/Abstract/NDiv.v b/theories/Numbers/Natural/Abstract/NDiv.v index 9c50d5ca58..bb2f32935f 100644 --- a/theories/Numbers/Natural/Abstract/NDiv.v +++ b/theories/Numbers/Natural/Abstract/NDiv.v @@ -39,15 +39,15 @@ Qed. Theorem div_mod_unique : forall b q1 q2 r1 r2, r1<b -> r2<b -> b*q1+r1 == b*q2+r2 -> q1 == q2 /\ r1 == r2. -Proof. intros. apply div_mod_unique with b; auto'. Qed. +Proof. intros b q1 q2 r1 r2 ? ? ?. apply div_mod_unique with b; auto'. Qed. Theorem div_unique: forall a b q r, r<b -> a == b*q + r -> q == a/b. -Proof. intros; apply div_unique with r; auto'. Qed. +Proof. intros a b q r ? ?; apply div_unique with r; auto'. Qed. Theorem mod_unique: forall a b q r, r<b -> a == b*q + r -> r == a mod b. -Proof. intros. apply mod_unique with q; auto'. Qed. +Proof. intros a b q r ? ?. apply mod_unique with q; auto'. Qed. Theorem div_unique_exact: forall a b q, b~=0 -> a == b*q -> q == a/b. Proof. intros. apply div_unique_exact; auto'. Qed. diff --git a/theories/Numbers/Natural/Abstract/NGcd.v b/theories/Numbers/Natural/Abstract/NGcd.v index a80ae8dc45..c1d8308e34 100644 --- a/theories/Numbers/Natural/Abstract/NGcd.v +++ b/theories/Numbers/Natural/Abstract/NGcd.v @@ -53,7 +53,7 @@ Definition divide_gcd_iff' n m := divide_gcd_iff n m (le_0_l n). Lemma gcd_add_mult_diag_r : forall n m p, gcd n (m+p*n) == gcd n m. Proof. - intros. apply gcd_unique_alt'. + intros n m p. apply gcd_unique_alt'. intros. rewrite gcd_divide_iff. split; intros (U,V); split; trivial. apply divide_add_r; trivial. now apply divide_mul_r. apply divide_add_cancel_r with (p*n); trivial. @@ -98,11 +98,11 @@ Lemma gcd_bezout_pos_pos : forall n, 0<n -> forall m, 0<m -> Bezout n m (gcd n m) /\ Bezout m n (gcd n m). Proof. intros n Hn. rewrite <- le_succ_l, <- one_succ in Hn. - pattern n. apply strong_right_induction with (z:=1); trivial. + pattern n. apply (fun H => strong_right_induction _ H 1); trivial. unfold Bezout. solve_proper. clear n Hn. intros n Hn IHn. intros m Hm. rewrite <- le_succ_l, <- one_succ in Hm. - pattern m. apply strong_right_induction with (z:=1); trivial. + pattern m. apply (fun H => strong_right_induction _ H 1); trivial. unfold Bezout. solve_proper. clear m Hm. intros m Hm IHm. destruct (lt_trichotomy n m) as [LT|[EQ|LT]]. @@ -156,7 +156,7 @@ Qed. Theorem bezout_comm : forall a b g, b ~= 0 -> Bezout a b g -> Bezout b a g. Proof. - intros * Hbz (u & v & Huv). + intros a b g Hbz (u & v & Huv). destruct (eq_0_gt_0_cases a) as [Haz| Haz]. -rewrite Haz in Huv |-*. rewrite mul_0_r in Huv; symmetry in Huv. @@ -260,7 +260,7 @@ Qed. Lemma gcd_mul_mono_r : forall n m p, gcd (n*p) (m*p) == gcd n m * p. Proof. - intros. rewrite !(mul_comm _ p). apply gcd_mul_mono_l. + intros n m p. rewrite !(mul_comm _ p). apply gcd_mul_mono_l. Qed. Lemma gauss : forall n m p, (n | m * p) -> gcd n m == 1 -> (n | p). diff --git a/theories/Numbers/Natural/Abstract/NLcm.v b/theories/Numbers/Natural/Abstract/NLcm.v index 3a9cf34b25..b75b4521df 100644 --- a/theories/Numbers/Natural/Abstract/NLcm.v +++ b/theories/Numbers/Natural/Abstract/NLcm.v @@ -169,7 +169,7 @@ Qed. Lemma lcm_divide_iff : forall n m p, (lcm n m | p) <-> (n | p) /\ (m | p). Proof. - intros. split. split. + intros n m p. split. split. transitivity (lcm n m); trivial using divide_lcm_l. transitivity (lcm n m); trivial using divide_lcm_r. intros (H,H'). now apply lcm_least. diff --git a/theories/Numbers/Natural/Abstract/NMaxMin.v b/theories/Numbers/Natural/Abstract/NMaxMin.v index ad6e2d65f0..3a41a2a560 100644 --- a/theories/Numbers/Natural/Abstract/NMaxMin.v +++ b/theories/Numbers/Natural/Abstract/NMaxMin.v @@ -42,95 +42,95 @@ Qed. (** Succ *) -Lemma succ_max_distr : forall n m, S (max n m) == max (S n) (S m). +Lemma succ_max_distr n m : S (max n m) == max (S n) (S m). Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?succ_le_mono. Qed. -Lemma succ_min_distr : forall n m, S (min n m) == min (S n) (S m). +Lemma succ_min_distr n m : S (min n m) == min (S n) (S m). Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?succ_le_mono. Qed. (** Add *) -Lemma add_max_distr_l : forall n m p, max (p + n) (p + m) == p + max n m. +Lemma add_max_distr_l n m p : max (p + n) (p + m) == p + max n m. Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?add_le_mono_l. Qed. -Lemma add_max_distr_r : forall n m p, max (n + p) (m + p) == max n m + p. +Lemma add_max_distr_r n m p : max (n + p) (m + p) == max n m + p. Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 max_r | rewrite 2 max_l]; now rewrite <- ?add_le_mono_r. Qed. -Lemma add_min_distr_l : forall n m p, min (p + n) (p + m) == p + min n m. +Lemma add_min_distr_l n m p : min (p + n) (p + m) == p + min n m. Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?add_le_mono_l. Qed. -Lemma add_min_distr_r : forall n m p, min (n + p) (m + p) == min n m + p. +Lemma add_min_distr_r n m p : min (n + p) (m + p) == min n m + p. Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 min_l | rewrite 2 min_r]; now rewrite <- ?add_le_mono_r. Qed. (** Mul *) -Lemma mul_max_distr_l : forall n m p, max (p * n) (p * m) == p * max n m. +Lemma mul_max_distr_l n m p : max (p * n) (p * m) == p * max n m. Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply mul_le_mono_l. Qed. -Lemma mul_max_distr_r : forall n m p, max (n * p) (m * p) == max n m * p. +Lemma mul_max_distr_r n m p : max (n * p) (m * p) == max n m * p. Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply mul_le_mono_r. Qed. -Lemma mul_min_distr_l : forall n m p, min (p * n) (p * m) == p * min n m. +Lemma mul_min_distr_l n m p : min (p * n) (p * m) == p * min n m. Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply mul_le_mono_l. Qed. -Lemma mul_min_distr_r : forall n m p, min (n * p) (m * p) == min n m * p. +Lemma mul_min_distr_r n m p : min (n * p) (m * p) == min n m * p. Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply mul_le_mono_r. Qed. (** Sub *) -Lemma sub_max_distr_l : forall n m p, max (p - n) (p - m) == p - min n m. +Lemma sub_max_distr_l n m p : max (p - n) (p - m) == p - min n m. Proof. - intros. destruct (le_ge_cases n m). + destruct (le_ge_cases n m). rewrite min_l by trivial. apply max_l. now apply sub_le_mono_l. rewrite min_r by trivial. apply max_r. now apply sub_le_mono_l. Qed. -Lemma sub_max_distr_r : forall n m p, max (n - p) (m - p) == max n m - p. +Lemma sub_max_distr_r n m p : max (n - p) (m - p) == max n m - p. Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 max_r | rewrite 2 max_l]; try order; now apply sub_le_mono_r. Qed. -Lemma sub_min_distr_l : forall n m p, min (p - n) (p - m) == p - max n m. +Lemma sub_min_distr_l n m p : min (p - n) (p - m) == p - max n m. Proof. - intros. destruct (le_ge_cases n m). + destruct (le_ge_cases n m). rewrite max_r by trivial. apply min_r. now apply sub_le_mono_l. rewrite max_l by trivial. apply min_l. now apply sub_le_mono_l. Qed. -Lemma sub_min_distr_r : forall n m p, min (n - p) (m - p) == min n m - p. +Lemma sub_min_distr_r n m p : min (n - p) (m - p) == min n m - p. Proof. - intros. destruct (le_ge_cases n m); + destruct (le_ge_cases n m); [rewrite 2 min_l | rewrite 2 min_r]; try order; now apply sub_le_mono_r. Qed. diff --git a/theories/Numbers/Natural/Abstract/NOrder.v b/theories/Numbers/Natural/Abstract/NOrder.v index 9a9a882239..ccdac104a3 100644 --- a/theories/Numbers/Natural/Abstract/NOrder.v +++ b/theories/Numbers/Natural/Abstract/NOrder.v @@ -46,19 +46,19 @@ Qed. Theorem lt_0_succ : forall n, 0 < S n. Proof. -induct n; [apply lt_succ_diag_r | intros n H; now apply lt_lt_succ_r]. +intro n; induct n; [apply lt_succ_diag_r | intros n H; now apply lt_lt_succ_r]. Qed. Theorem neq_0_lt_0 : forall n, n ~= 0 <-> 0 < n. Proof. -cases n. +intro n; cases n. split; intro H; [now elim H | intro; now apply lt_irrefl with 0]. intro n; split; intro H; [apply lt_0_succ | apply neq_succ_0]. Qed. Theorem eq_0_gt_0_cases : forall n, n == 0 \/ 0 < n. Proof. -cases n. +intro n; cases n. now left. intro; right; apply lt_0_succ. Qed. @@ -66,8 +66,8 @@ Qed. Theorem zero_one : forall n, n == 0 \/ n == 1 \/ 1 < n. Proof. setoid_rewrite one_succ. -induct n. now left. -cases n. intros; right; now left. +intro n; induct n. now left. +intro n; cases n. intros; right; now left. intros n IH. destruct IH as [H | [H | H]]. false_hyp H neq_succ_0. right; right. rewrite H. apply lt_succ_diag_r. @@ -77,7 +77,7 @@ Qed. Theorem lt_1_r : forall n, n < 1 <-> n == 0. Proof. setoid_rewrite one_succ. -cases n. +intro n; cases n. split; intro; [reflexivity | apply lt_succ_diag_r]. intros n. rewrite <- succ_lt_mono. split; intro H; [false_hyp H nlt_0_r | false_hyp H neq_succ_0]. @@ -86,7 +86,7 @@ Qed. Theorem le_1_r : forall n, n <= 1 <-> n == 0 \/ n == 1. Proof. setoid_rewrite one_succ. -cases n. +intro n; cases n. split; intro; [now left | apply le_succ_diag_r]. intro n. rewrite <- succ_le_mono, le_0_r, succ_inj_wd. split; [intro; now right | intros [H | H]; [false_hyp H neq_succ_0 | assumption]]. @@ -101,7 +101,7 @@ Qed. Theorem lt_1_l' : forall n m p, n < m -> m < p -> 1 < p. Proof. -intros. apply lt_1_l with m; auto. +intros n m p H H0. apply lt_1_l with m; auto. apply le_lt_trans with n; auto. now apply le_0_l. Qed. @@ -117,7 +117,7 @@ Theorem le_ind_rel : (forall n m, n <= m -> R n m -> R (S n) (S m)) -> forall n m, n <= m -> R n m. Proof. -intros Base Step; induct n. +intros Base Step n; induct n. intros; apply Base. intros n IH m H. elim H using le_ind. solve_proper. @@ -130,7 +130,7 @@ Theorem lt_ind_rel : (forall n m, n < m -> R n m -> R (S n) (S m)) -> forall n m, n < m -> R n m. Proof. -intros Base Step; induct n. +intros Base Step n; induct n. intros m H. apply lt_exists_pred in H; destruct H as [m' [H _]]. rewrite H; apply Base. intros n IH m H. elim H using lt_ind. @@ -151,14 +151,14 @@ Qed. Theorem le_pred_l : forall n, P n <= n. Proof. -cases n. +intro n; cases n. rewrite pred_0; now apply eq_le_incl. intros; rewrite pred_succ; apply le_succ_diag_r. Qed. Theorem lt_pred_l : forall n, n ~= 0 -> P n < n. Proof. -cases n. +intro n; cases n. intro H; exfalso; now apply H. intros; rewrite pred_succ; apply lt_succ_diag_r. Qed. @@ -176,7 +176,7 @@ Qed. Theorem lt_le_pred : forall n m, n < m -> n <= P m. (* Converse is false for n == m == 0 *) Proof. -intro n; cases m. +intros n m; cases m. intro H; false_hyp H nlt_0_r. intros m IH. rewrite pred_succ; now apply lt_succ_r. Qed. diff --git a/theories/Numbers/Natural/Abstract/NParity.v b/theories/Numbers/Natural/Abstract/NParity.v index 58bc1499e1..4bb465c93c 100644 --- a/theories/Numbers/Natural/Abstract/NParity.v +++ b/theories/Numbers/Natural/Abstract/NParity.v @@ -16,19 +16,19 @@ Module Type NParityProp (Import N : NAxiomsSig')(Import NP : NSubProp N). Include NZParityProp N N NP. -Lemma odd_pred : forall n, n~=0 -> odd (P n) = even n. +Lemma odd_pred n : n~=0 -> odd (P n) = even n. Proof. intros. rewrite <- (succ_pred n) at 2 by trivial. symmetry. apply even_succ. Qed. -Lemma even_pred : forall n, n~=0 -> even (P n) = odd n. +Lemma even_pred n : n~=0 -> even (P n) = odd n. Proof. intros. rewrite <- (succ_pred n) at 2 by trivial. symmetry. apply odd_succ. Qed. -Lemma even_sub : forall n m, m<=n -> even (n-m) = Bool.eqb (even n) (even m). +Lemma even_sub n m : m<=n -> even (n-m) = Bool.eqb (even n) (even m). Proof. intros. case_eq (even n); case_eq (even m); @@ -56,7 +56,7 @@ Proof. rewrite add_1_r in Hm,Hn. order. Qed. -Lemma odd_sub : forall n m, m<=n -> odd (n-m) = xorb (odd n) (odd m). +Lemma odd_sub n m : m<=n -> odd (n-m) = xorb (odd n) (odd m). Proof. intros. rewrite <- !negb_even. rewrite even_sub by trivial. now destruct (even n), (even m). diff --git a/theories/Numbers/Natural/Abstract/NPow.v b/theories/Numbers/Natural/Abstract/NPow.v index 0b7720fd57..b49b6bf03c 100644 --- a/theories/Numbers/Natural/Abstract/NPow.v +++ b/theories/Numbers/Natural/Abstract/NPow.v @@ -55,7 +55,7 @@ Proof. wrap pow_mul_r. Qed. (** Power and nullity *) Lemma pow_eq_0 : forall a b, b~=0 -> a^b == 0 -> a == 0. -Proof. intros. apply (pow_eq_0 a b); trivial. auto'. Qed. +Proof. intros a b ? ?. apply (pow_eq_0 a b); trivial. auto'. Qed. Lemma pow_nonzero : forall a b, a~=0 -> a^b ~= 0. Proof. wrap pow_nonzero. Qed. diff --git a/theories/Numbers/Natural/Abstract/NSub.v b/theories/Numbers/Natural/Abstract/NSub.v index e06604db53..b939352144 100644 --- a/theories/Numbers/Natural/Abstract/NSub.v +++ b/theories/Numbers/Natural/Abstract/NSub.v @@ -17,21 +17,21 @@ Include NMulOrderProp N. Theorem sub_0_l : forall n, 0 - n == 0. Proof. -induct n. +intro n; induct n. apply sub_0_r. intros n IH; rewrite sub_succ_r; rewrite IH. now apply pred_0. Qed. Theorem sub_succ : forall n m, S n - S m == n - m. Proof. -intro n; induct m. +intros n m; induct m. rewrite sub_succ_r. do 2 rewrite sub_0_r. now rewrite pred_succ. intros m IH. rewrite sub_succ_r. rewrite IH. now rewrite sub_succ_r. Qed. Theorem sub_diag : forall n, n - n == 0. Proof. -induct n. apply sub_0_r. intros n IH; rewrite sub_succ; now rewrite IH. +intro n; induct n. apply sub_0_r. intros n IH; rewrite sub_succ; now rewrite IH. Qed. Theorem sub_gt : forall n m, n > m -> n - m ~= 0. @@ -96,7 +96,7 @@ Qed. Theorem sub_add_distr : forall n m p, n - (m + p) == (n - m) - p. Proof. -intros n m; induct p. +intros n m p; induct p. rewrite add_0_r; now rewrite sub_0_r. intros p IH. rewrite add_succ_r; do 2 rewrite sub_succ_r. now rewrite IH. Qed. @@ -113,7 +113,7 @@ Qed. Theorem le_sub_l : forall n m, n - m <= n. Proof. -intro n; induct m. +intros n m; induct m. rewrite sub_0_r; now apply eq_le_incl. intros m IH. rewrite sub_succ_r. apply le_trans with (n - m); [apply le_pred_l | assumption]. @@ -121,7 +121,7 @@ Qed. Theorem sub_0_le : forall n m, n - m == 0 <-> n <= m. Proof. -double_induct n m. +intros n m; double_induct n m. intro m; split; intro; [apply le_0_l | apply sub_0_l]. intro m; rewrite sub_0_r; split; intro H; [false_hyp H neq_succ_0 | false_hyp H nle_succ_0]. @@ -130,7 +130,7 @@ Qed. Theorem sub_add_le : forall n m, n <= n - m + m. Proof. -intros. +intros n m. destruct (le_ge_cases n m) as [LE|GE]. rewrite <- sub_0_le in LE. rewrite LE; nzsimpl. now rewrite <- sub_0_le. @@ -216,12 +216,13 @@ Qed. Lemma sub_le_mono_r : forall n m p, n <= m -> n-p <= m-p. Proof. - intros. rewrite le_sub_le_add_r. transitivity m. assumption. apply sub_add_le. + intros n m p. rewrite le_sub_le_add_r. + transitivity m. assumption. apply sub_add_le. Qed. Lemma sub_le_mono_l : forall n m p, n <= m -> p-m <= p-n. Proof. - intros. rewrite le_sub_le_add_r. + intros n m p. rewrite le_sub_le_add_r. transitivity (p-n+n); [ apply sub_add_le | now apply add_le_mono_l]. Qed. @@ -264,14 +265,14 @@ Definition lt_alt n m := exists p, S p + n == m. Lemma le_equiv : forall n m, le_alt n m <-> n <= m. Proof. -split. +intros n m; split. intros (p,H). rewrite <- H, add_comm. apply le_add_r. intro H. exists (m-n). now apply sub_add. Qed. Lemma lt_equiv : forall n m, lt_alt n m <-> n < m. Proof. -split. +intros n m; split. intros (p,H). rewrite <- H, add_succ_l, lt_succ_r, add_comm. apply le_add_r. intro H. exists (m-S n). rewrite add_succ_l, <- add_succ_r. apply sub_add. now rewrite le_succ_l. diff --git a/theories/PArith/BinPos.v b/theories/PArith/BinPos.v index c8414c241d..e97f2dc748 100644 --- a/theories/PArith/BinPos.v +++ b/theories/PArith/BinPos.v @@ -145,7 +145,7 @@ Qed. Lemma succ_inj p q : succ p = succ q -> p = q. Proof. revert q. - induction p; intros [q|q| ] H; simpl in H; destr_eq H; f_equal; auto. + induction p as [p|p|]; intros [q|q| ] H; simpl in H; destr_eq H; f_equal; auto. elim (succ_not_1 p); auto. elim (succ_not_1 q); auto. Qed. @@ -177,14 +177,14 @@ Qed. Theorem add_carry_spec p q : add_carry p q = succ (p + q). Proof. - revert q. induction p; destruct q; simpl; now f_equal. + revert q. induction p; intro q; destruct q; simpl; now f_equal. Qed. (** ** Commutativity *) Theorem add_comm p q : p + q = q + p. Proof. - revert q. induction p; destruct q; simpl; f_equal; trivial. + revert q. induction p; intro q; destruct q; simpl; f_equal; trivial. rewrite 2 add_carry_spec; now f_equal. Qed. @@ -193,7 +193,7 @@ Qed. Theorem add_succ_r p q : p + succ q = succ (p + q). Proof. revert q. - induction p; destruct q; simpl; f_equal; + induction p; intro q; destruct q; simpl; f_equal; auto using add_1_r; rewrite add_carry_spec; auto. Qed. @@ -247,13 +247,13 @@ Qed. Lemma add_carry_reg_r p q r : add_carry p r = add_carry q r -> p = q. Proof. - intros H. apply add_reg_r with (r:=r); now apply add_carry_add. + intros H. apply (add_reg_r _ _ r); now apply add_carry_add. Qed. Lemma add_carry_reg_l p q r : add_carry p q = add_carry p r -> q = r. Proof. - intros H; apply add_reg_r with (r:=p); + intros H; apply (add_reg_r _ _ p); rewrite (add_comm r), (add_comm q); now apply add_carry_add. Qed. @@ -288,7 +288,7 @@ Qed. Lemma add_xO_pred_double p q : pred_double (p + q) = p~0 + pred_double q. Proof. - revert q. induction p as [p IHp| p IHp| ]; destruct q; simpl; + revert q. induction p as [p IHp| p IHp| ]; intro q; destruct q; simpl; rewrite ?add_carry_spec, ?pred_double_succ, ?add_xI_pred_double; try reflexivity. rewrite IHp; auto. @@ -323,7 +323,7 @@ Theorem peano_rect_succ (P:positive->Type) (a:P 1) (f:forall p, P p -> P (succ p)) (p:positive) : peano_rect P a f (succ p) = f _ (peano_rect P a f p). Proof. - revert P a f. induction p; trivial. + revert P a f. induction p as [p IHp|p IHp|]; trivial. intros. simpl. now rewrite IHp. Qed. @@ -393,17 +393,17 @@ Qed. Theorem PeanoViewUnique : forall p (q q':PeanoView p), q = q'. Proof. - intros. + intros p q q'. induction q as [ | p q IHq ]. apply eq_dep_eq_positive. - cut (1=1). pattern 1 at 1 2 5, q'. destruct q'. trivial. + cut (1=1). pattern 1 at 1 2 5, q'. destruct q' as [|p ?]. trivial. destruct p; intros; discriminate. trivial. apply eq_dep_eq_positive. - cut (succ p=succ p). pattern (succ p) at 1 2 5, q'. destruct q'. + cut (succ p=succ p). pattern (succ p) at 1 2 5, q'. destruct q' as [|? q']. intro. destruct p; discriminate. - intro. apply succ_inj in H. - generalize q'. rewrite H. intro. + intro H. apply succ_inj in H. + generalize q'. rewrite H. intro q'0. rewrite (IHq q'0). trivial. trivial. @@ -412,7 +412,7 @@ Qed. Lemma peano_equiv (P:positive->Type) (a:P 1) (f:forall p, P p -> P (succ p)) p : PeanoView_iter P a f p (peanoView p) = peano_rect P a f p. Proof. - revert P a f. induction p using peano_rect. + revert P a f. induction p as [|p IHp] using peano_rect. trivial. intros; simpl. rewrite peano_rect_succ. rewrite (PeanoViewUnique _ (peanoView (succ p)) (PeanoSucc _ (peanoView p))). @@ -575,11 +575,11 @@ Qed. (** ** Properties of [iter] *) -Lemma iter_swap_gen : forall A B (f:A->B)(g:A->A)(h:B->B), +Lemma iter_swap_gen A B (f:A->B)(g:A->A)(h:B->B) : (forall a, f (g a) = h (f a)) -> forall p a, f (iter g a p) = iter h (f a) p. Proof. - induction p; simpl; intros; now rewrite ?H, ?IHp. + intros H p; induction p as [p IHp|p IHp|]; simpl; intros; now rewrite ?H, ?IHp. Qed. Theorem iter_swap : @@ -593,7 +593,7 @@ Theorem iter_succ : forall p (A:Type) (f:A -> A) (x:A), iter f x (succ p) = f (iter f x p). Proof. - induction p as [p IHp|p IHp|]; intros; simpl; trivial. + intro p; induction p as [p IHp|p IHp|]; intros; simpl; trivial. now rewrite !IHp, iter_swap. Qed. @@ -608,18 +608,17 @@ Theorem iter_add : forall p q (A:Type) (f:A -> A) (x:A), iter f x (p+q) = iter f (iter f x q) p. Proof. - induction p using peano_ind; intros. + intro p; induction p as [|p IHp] using peano_ind; intros. now rewrite add_1_l, iter_succ. now rewrite add_succ_l, !iter_succ, IHp. Qed. -Theorem iter_ind : - forall (A:Type) (f:A -> A) (a:A) (P:positive -> A -> Prop), +Theorem iter_ind (A:Type) (f:A -> A) (a:A) (P:positive -> A -> Prop) : P 1 (f a) -> (forall p a', P p a' -> P (succ p) (f a')) -> forall p, P p (iter f a p). Proof. - induction p using peano_ind; trivial. + intros ? ? p; induction p as [|p IHp] using peano_ind; trivial. rewrite iter_succ; auto. Qed. @@ -628,7 +627,7 @@ Theorem iter_invariant : (forall x:A, Inv x -> Inv (f x)) -> forall x:A, Inv x -> Inv (iter f x p). Proof. - intros; apply iter_ind with (P := fun _ => Inv); auto. + intros; apply iter_ind; auto. Qed. (** ** Properties of power *) @@ -647,7 +646,7 @@ Qed. Lemma square_spec p : square p = p * p. Proof. - induction p. + induction p as [p IHp|p IHp|]. - rewrite square_xI. simpl. now rewrite IHp. - rewrite square_xO. simpl. now rewrite IHp. - trivial. @@ -658,13 +657,14 @@ Qed. Lemma sub_mask_succ_r p q : sub_mask p (succ q) = sub_mask_carry p q. Proof. - revert q. induction p; destruct q; simpl; f_equal; trivial; now destruct p. + revert q. induction p as [p ?|p ?|]; intro q; destruct q; + simpl; f_equal; trivial; now destruct p. Qed. Theorem sub_mask_carry_spec p q : sub_mask_carry p q = pred_mask (sub_mask p q). Proof. - revert q. induction p as [p IHp|p IHp| ]; destruct q; simpl; + revert q. induction p as [p IHp|p IHp|]; intro q; destruct q as [q|q|]; simpl; try reflexivity; rewrite ?IHp; destruct (sub_mask p q) as [|[r|r| ]|] || destruct p; auto. Qed. @@ -676,16 +676,17 @@ Inductive SubMaskSpec (p q : positive) : mask -> Prop := Theorem sub_mask_spec p q : SubMaskSpec p q (sub_mask p q). Proof. - revert q. induction p; destruct q; simpl; try constructor; trivial. + revert q. induction p as [p IHp|p IHp|]; intro q; destruct q as [q|q|]; + simpl; try constructor; trivial. (* p~1 q~1 *) - destruct (IHp q); subst; try now constructor. + destruct (IHp q) as [|r|r]; subst; try now constructor. now apply SubIsNeg with r~0. (* p~1 q~0 *) - destruct (IHp q); subst; try now constructor. + destruct (IHp q) as [|r|r]; subst; try now constructor. apply SubIsNeg with (pred_double r). symmetry. apply add_xI_pred_double. (* p~0 q~1 *) rewrite sub_mask_carry_spec. - destruct (IHp q); subst; try constructor. + destruct (IHp q) as [|r|r]; subst; try constructor. now apply SubIsNeg with 1. destruct r; simpl; try constructor; simpl. now rewrite add_carry_spec, <- add_succ_r. @@ -693,7 +694,7 @@ Proof. now rewrite add_1_r. now apply SubIsNeg with r~1. (* p~0 q~0 *) - destruct (IHp q); subst; try now constructor. + destruct (IHp q) as [|r|r]; subst; try now constructor. now apply SubIsNeg with r~0. (* p~0 1 *) now rewrite add_1_l, succ_pred_double. @@ -707,7 +708,7 @@ Theorem sub_mask_nul_iff p q : sub_mask p q = IsNul <-> p = q. Proof. split. now case sub_mask_spec. - intros <-. induction p; simpl; now rewrite ?IHp. + intros <-. induction p as [p IHp|p IHp|]; simpl; now rewrite ?IHp. Qed. Theorem sub_mask_diag p : sub_mask p p = IsNul. @@ -752,7 +753,8 @@ Qed. Theorem eqb_eq p q : (p =? q) = true <-> p=q. Proof. - revert q. induction p; destruct q; simpl; rewrite ?IHp; split; congruence. + revert q. induction p as [p IHp|p IHp|]; intro q; destruct q; + simpl; rewrite ?IHp; split; congruence. Qed. Theorem ltb_lt p q : (p <? q) = true <-> p < q. @@ -786,7 +788,7 @@ Lemma compare_cont_spec p q c : Proof. unfold compare. revert q c. - induction p; destruct q; simpl; trivial. + induction p as [p IHp|p IHp|]; intro q; destruct q as [q|q|]; simpl; trivial. intros c. rewrite 2 IHp. now destruct (compare_cont Eq p q). intros c. @@ -1026,7 +1028,8 @@ Qed. Lemma compare_succ_succ p q : (succ p ?= succ q) = (p ?= q). Proof. revert q. - induction p; destruct q; simpl; simpl_compare; trivial; + induction p as [p|p|]; intro q; destruct q as [q|q|]; + simpl; simpl_compare; trivial; apply compare_succ_l || apply compare_succ_r || (now destruct p) || (now destruct q). Qed. @@ -1159,7 +1162,7 @@ Qed. Lemma add_compare_mono_l p q r : (p+q ?= p+r) = (q ?= r). Proof. - revert p q r. induction p using peano_ind; intros q r. + revert q r. induction p using peano_ind; intros q r. rewrite 2 add_1_l. apply compare_succ_succ. now rewrite 2 add_succ_l, compare_succ_succ. Qed. @@ -1214,7 +1217,7 @@ Qed. Lemma mul_compare_mono_l p q r : (p*q ?= p*r) = (q ?= r). Proof. - revert q r. induction p; simpl; trivial. + revert q r. induction p as [p IHp|p IHp|]; simpl; trivial. intros q r. specialize (IHp q r). destruct (compare_spec q r). subst. apply compare_refl. @@ -1265,7 +1268,7 @@ Qed. Lemma lt_add_r p q : p < p+q. Proof. - induction q using peano_ind. + induction q as [|q] using peano_ind. rewrite add_1_r. apply lt_succ_diag_r. apply lt_trans with (p+q); auto. apply add_lt_mono_l, lt_succ_diag_r. @@ -1476,10 +1479,11 @@ Qed. Lemma size_nat_monotone p q : p<q -> (size_nat p <= size_nat q)%nat. Proof. - assert (le0 : forall n, (0<=n)%nat) by (induction n; auto). + assert (le0 : forall n, (0<=n)%nat) by (intro n; induction n; auto). assert (leS : forall n m, (n<=m -> S n <= S m)%nat) by (induction 1; auto). revert q. - induction p; destruct q; simpl; intros; auto; easy || apply leS; + induction p as [p IHp|p IHp|]; intro q; destruct q as [q|q|]; + simpl; intros H; auto; easy || apply leS; red in H; simpl_compare_in H. apply IHp. red. now destruct (p?=q). destruct (compare_spec p q); subst; now auto. @@ -1487,13 +1491,13 @@ Qed. Lemma size_gt p : p < 2^(size p). Proof. - induction p; simpl; try rewrite pow_succ_r; try easy. + induction p as [p IHp|p IHp|]; simpl; try rewrite pow_succ_r; try easy. apply le_succ_l in IHp. now apply le_succ_l. Qed. Lemma size_le p : 2^(size p) <= p~0. Proof. - induction p; simpl; try rewrite pow_succ_r; try easy. + induction p as [p IHp|p IHp|]; simpl; try rewrite pow_succ_r; try easy. apply mul_le_mono_l. apply le_lteq; left. rewrite xI_succ_xO. apply lt_succ_r, IHp. Qed. @@ -1612,7 +1616,7 @@ Lemma iter_op_succ : forall A (op:A->A->A), forall p a, iter_op op (succ p) a = op a (iter_op op p a). Proof. - induction p; simpl; intros; trivial. + intros A op H p; induction p as [p IHp|p IHp|]; simpl; intros; trivial. rewrite H. apply IHp. Qed. @@ -1620,7 +1624,7 @@ Qed. Lemma of_nat_succ (n:nat) : of_succ_nat n = of_nat (S n). Proof. - induction n. trivial. simpl. f_equal. now rewrite IHn. + induction n as [|n IHn]. trivial. simpl. f_equal. now rewrite IHn. Qed. Lemma pred_of_succ_nat (n:nat) : pred (of_succ_nat n) = of_nat n. @@ -1671,7 +1675,7 @@ Qed. Lemma sqrtrem_spec p : SqrtSpec (sqrtrem p) p. Proof. revert p. fix sqrtrem_spec 1. - destruct p; try destruct p; try (constructor; easy); + intro p; destruct p as [p|p|]; try destruct p; try (constructor; easy); apply sqrtrem_step_spec; auto. Qed. @@ -1688,7 +1692,7 @@ Proof. split. apply lt_le_incl, lt_add_r. rewrite <- add_1_l, mul_add_distr_r, !mul_add_distr_l, !mul_1_r, !mul_1_l. - rewrite add_assoc, (add_comm _ r). apply add_lt_mono_r. + rewrite add_assoc, (add_comm _ _). apply add_lt_mono_r. now rewrite <- add_assoc, add_diag, add_1_l, lt_succ_r. Qed. @@ -1710,7 +1714,7 @@ Lemma divide_xO_xI p q r : (p | q~0) -> (p | r~1) -> (p | q). Proof. intros (s,Hs) (t,Ht). destruct p. - destruct s; try easy. simpl in Hs. destr_eq Hs. now exists s. + destruct s as [s|s|]; try easy. simpl in Hs. destr_eq Hs. now exists s. rewrite mul_xO_r in Ht; discriminate. exists q; now rewrite mul_1_r. Qed. @@ -1738,9 +1742,9 @@ Qed. Lemma ggcdn_gcdn : forall n a b, fst (ggcdn n a b) = gcdn n a b. Proof. - induction n. + intro n; induction n as [|n IHn]. simpl; auto. - destruct a, b; simpl; auto; try case compare_spec; simpl; trivial; + intros a b; destruct a, b; simpl; auto; try case compare_spec; simpl; trivial; rewrite <- IHn; destruct ggcdn as (g,(u,v)); simpl; auto. Qed. @@ -1760,9 +1764,10 @@ Lemma ggcdn_correct_divisors : forall n a b, let '(g,(aa,bb)) := ggcdn n a b in a = g*aa /\ b = g*bb. Proof. - induction n. + intro n; induction n as [|n IHn]. simpl; auto. - destruct a, b; simpl; auto; try case compare_spec; try destr_pggcdn IHn. + intros a b; destruct a, b; + simpl; auto; try case compare_spec; try destr_pggcdn IHn. (* Eq *) intros ->. now rewrite mul_comm. (* Lt *) @@ -1809,9 +1814,9 @@ Qed. Lemma gcdn_greatest : forall n a b, (size_nat a + size_nat b <= n)%nat -> forall p, (p|a) -> (p|b) -> (p|gcdn n a b). Proof. - induction n. + intro n; induction n as [|n IHn]; intros a b. destruct a, b; simpl; inversion 1. - destruct a, b; simpl; try case compare_spec; simpl; auto. + destruct a as [a|a|], b as [b|b|]; simpl; try case compare_spec; simpl; auto. (* Lt *) intros LT LE p Hp1 Hp2. apply IHn; clear IHn; trivial. apply le_S_n in LE. eapply Le.le_trans; [|eapply LE]. @@ -1839,7 +1844,7 @@ Proof. apply divide_xO_xI with b; trivial. (* a~0 b~0 *) intros LE p Hp1 Hp2. - destruct p. + destruct p as [p|p|]. change (gcdn n a b)~0 with (2*(gcdn n a b)). apply divide_mul_r. apply IHn; clear IHn. @@ -1865,7 +1870,7 @@ Lemma ggcd_greatest : forall a b, let (aa,bb) := snd (ggcd a b) in forall p, (p|aa) -> (p|bb) -> p=1. Proof. - intros. generalize (gcd_greatest a b) (ggcd_correct_divisors a b). + intros a b **. generalize (gcd_greatest a b) (ggcd_correct_divisors a b). rewrite <- ggcd_gcd. destruct ggcd as (g,(aa,bb)); simpl. intros H (EQa,EQb) p Hp1 Hp2; subst. assert (H' : (g*p | g)). @@ -1886,7 +1891,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. @@ -2126,7 +2131,7 @@ Qed. Lemma Dcompare : forall r:comparison, r = Eq \/ r = Lt \/ r = Gt. Proof. - destruct r; auto. + intro r; destruct r; auto. Qed. (** Incompatibilities : 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/PArith/Pnat.v b/theories/PArith/Pnat.v index abb33d462d..09c65f848f 100644 --- a/theories/PArith/Pnat.v +++ b/theories/PArith/Pnat.v @@ -32,14 +32,14 @@ Qed. Theorem inj_add p q : to_nat (p + q) = to_nat p + to_nat q. Proof. - revert q. induction p using peano_ind; intros q. + revert q. induction p as [|p IHp] using peano_ind; intros q. now rewrite add_1_l, inj_succ. now rewrite add_succ_l, !inj_succ, IHp. Qed. Theorem inj_mul p q : to_nat (p * q) = to_nat p * to_nat q. Proof. - revert q. induction p using peano_ind; simpl; intros; trivial. + revert q. induction p as [|p IHp] using peano_ind; simpl; intros; trivial. now rewrite mul_succ_l, inj_add, IHp, inj_succ. Qed. @@ -62,9 +62,9 @@ Qed. (** [Pos.to_nat] maps to the strictly positive subset of [nat] *) -Lemma is_succ : forall p, exists n, to_nat p = S n. +Lemma is_succ p : exists n, to_nat p = S n. Proof. - induction p using peano_ind. + induction p as [|p IHp] using peano_ind. now exists 0. destruct IHp as (n,Hn). exists (S n). now rewrite inj_succ, Hn. Qed. @@ -82,7 +82,7 @@ Qed. Theorem id p : of_nat (to_nat p) = p. Proof. - induction p using peano_ind. trivial. + induction p as [|p IHp] using peano_ind. trivial. rewrite inj_succ. rewrite <- IHp at 2. now destruct (is_succ p) as (n,->). Qed. @@ -149,7 +149,7 @@ Qed. Theorem inj_sub_max p q : to_nat (p - q) = Nat.max 1 (to_nat p - to_nat q). Proof. - destruct (ltb_spec q p). + destruct (ltb_spec q p) as [H|H]. - (* q < p *) rewrite <- inj_sub by trivial. now destruct (is_succ (p - q)) as (m,->). @@ -192,11 +192,10 @@ Proof. - now apply Nat.max_l, Nat.lt_le_incl. Qed. -Theorem inj_iter : - forall p {A} (f:A->A) (x:A), +Theorem inj_iter p {A} (f:A->A) (x:A) : Pos.iter f x p = nat_rect _ x (fun _ => f) (to_nat p). Proof. - induction p using peano_ind. + induction p as [|p IHp] using peano_ind. - trivial. - intros. rewrite inj_succ, iter_succ. simpl. f_equal. apply IHp. @@ -443,7 +442,7 @@ Section ObsoletePmultNat. Lemma Pmult_nat_mult : forall p n, Pmult_nat p n = Pos.to_nat p * n. Proof. - induction p; intros n; unfold Pos.to_nat; simpl. + intro p; induction p as [p IHp|p IHp|]; intros n; unfold Pos.to_nat; simpl. f_equal. rewrite 2 IHp. rewrite <- Nat.mul_assoc. f_equal. simpl. now rewrite Nat.add_0_r. rewrite 2 IHp. rewrite <- Nat.mul_assoc. @@ -482,7 +481,7 @@ Qed. Lemma le_Pmult_nat : forall p n, n <= Pmult_nat p n. Proof. - intros. rewrite Pmult_nat_mult. + intros p n. rewrite Pmult_nat_mult. apply Nat.le_trans with (1*n). now rewrite Nat.mul_1_l. apply Nat.mul_le_mono_r. apply Pos2Nat.is_pos. Qed. 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/Reals/Rseries.v b/theories/Reals/Rseries.v index 015eb8e2ac..7238ec0068 100644 --- a/theories/Reals/Rseries.v +++ b/theories/Reals/Rseries.v @@ -78,25 +78,12 @@ Section sequence. Lemma growing_prop : forall n m:nat, Un_growing -> (n >= m)%nat -> Un n >= Un m. Proof. - double induction n m; intros. - unfold Rge; right; trivial. - exfalso; unfold ge in H1; generalize (le_Sn_O n0); intro; auto. - cut (n0 >= 0)%nat. - generalize H0; intros; unfold Un_growing in H0; - apply - (Rge_trans (Un (S n0)) (Un n0) (Un 0) (Rle_ge (Un n0) (Un (S n0)) (H0 n0)) - (H 0%nat H2 H3)). - elim n0; auto. - elim (lt_eq_lt_dec n1 n0); intro y. - elim y; clear y; intro y. - unfold ge in H2; generalize (le_not_lt n0 n1 (le_S_n n0 n1 H2)); intro; - exfalso; auto. - rewrite y; unfold Rge; right; trivial. - unfold ge in H0; generalize (H0 (S n0) H1 (lt_le_S n0 n1 y)); intro; - unfold Un_growing in H1; - apply - (Rge_trans (Un (S n1)) (Un n1) (Un (S n0)) - (Rle_ge (Un n1) (Un (S n1)) (H1 n1)) H3). + intros * Hgrowing Hle. + induction Hle as [|p]. + - apply Rge_refl. + - apply Rge_trans with (Un p). + + apply Rle_ge, Hgrowing. + + apply IHHle. Qed. (*********) 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..547d180d95 100644 --- a/theories/Setoids/Setoid.v +++ b/theories/Setoids/Setoid.v @@ -19,7 +19,7 @@ Require Coq.ssr.ssrsetoid. Definition Setoid_Theory := @Equivalence. Definition Build_Setoid_Theory := @Build_Equivalence. -Register Build_Setoid_Theory as plugins.setoid_ring.Build_Setoid_Theory. +Register Build_Setoid_Theory as plugins.ring.Build_Setoid_Theory. Definition Seq_refl A Aeq (s : Setoid_Theory A Aeq) : forall x:A, Aeq x x. Proof. @@ -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/dune b/theories/dune index de8dcdc5b1..c2d8197ee4 100644 --- a/theories/dune +++ b/theories/dune @@ -23,7 +23,7 @@ coq.plugins.btauto coq.plugins.rtauto - coq.plugins.setoid_ring + coq.plugins.ring coq.plugins.nsatz coq.plugins.omega 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/setoid_ring/BinList.v b/theories/setoid_ring/BinList.v index b6b8b45e1a..892909fd40 100644 --- a/theories/setoid_ring/BinList.v +++ b/theories/setoid_ring/BinList.v @@ -33,13 +33,13 @@ Section MakeBinList. Lemma jump_tl : forall j l, tl (jump j l) = jump j (tl l). Proof. - induction j;simpl;intros; now rewrite ?IHj. + intro j;induction j as [j IHj|j IHj|];simpl;intros; now rewrite ?IHj. Qed. Lemma jump_succ : forall j l, jump (Pos.succ j) l = jump 1 (jump j l). Proof. - induction j;simpl;intros. + intro j;induction j as [j IHj|j IHj|];simpl;intros. - rewrite !IHj; simpl; now rewrite !jump_tl. - now rewrite !jump_tl. - trivial. @@ -48,7 +48,7 @@ Section MakeBinList. Lemma jump_add : forall i j l, jump (i + j) l = jump i (jump j l). Proof. - induction i using Pos.peano_ind; intros. + intro i; induction i as [|i IHi] using Pos.peano_ind; intros. - now rewrite Pos.add_1_l, jump_succ. - now rewrite Pos.add_succ_l, !jump_succ, IHi. Qed. @@ -56,7 +56,7 @@ Section MakeBinList. Lemma jump_pred_double : forall i l, jump (Pos.pred_double i) (tl l) = jump i (jump i l). Proof. - induction i;intros;simpl. + intro i;induction i as [i IHi|i IHi|];intros;simpl. - now rewrite !jump_tl. - now rewrite IHi, <- 2 jump_tl, IHi. - trivial. @@ -64,7 +64,7 @@ Section MakeBinList. Lemma nth_jump : forall p l, nth p (tl l) = hd default (jump p l). Proof. - induction p;simpl;intros. + intro p;induction p as [p IHp|p IHp|];simpl;intros. - now rewrite <-jump_tl, IHp. - now rewrite <-jump_tl, IHp. - trivial. @@ -73,7 +73,7 @@ Section MakeBinList. Lemma nth_pred_double : forall p l, nth (Pos.pred_double p) (tl l) = nth p (jump p l). Proof. - induction p;simpl;intros. + intro p;induction p as [p IHp|p IHp|];simpl;intros. - now rewrite !jump_tl. - now rewrite jump_pred_double, <- !jump_tl, IHp. - trivial. diff --git a/theories/setoid_ring/Ring_base.v b/theories/setoid_ring/Ring_base.v index 04c7a3a83b..4986661ad1 100644 --- a/theories/setoid_ring/Ring_base.v +++ b/theories/setoid_ring/Ring_base.v @@ -12,7 +12,7 @@ ring tactic. Abstract rings need more theory, depending on ZArith_base. *) -Declare ML Module "newring_plugin". +Declare ML Module "ring_plugin". Require Export Ring_theory. Require Export Ring_tac. Require Import InitialRing. diff --git a/theories/setoid_ring/Ring_polynom.v b/theories/setoid_ring/Ring_polynom.v index e0a3d5a3bf..a13b1fc738 100644 --- a/theories/setoid_ring/Ring_polynom.v +++ b/theories/setoid_ring/Ring_polynom.v @@ -919,14 +919,14 @@ Section MakeRingPol. | PEopp : PExpr -> PExpr | PEpow : PExpr -> N -> PExpr. - Register PExpr as plugins.setoid_ring.pexpr. - Register PEc as plugins.setoid_ring.const. - Register PEX as plugins.setoid_ring.var. - Register PEadd as plugins.setoid_ring.add. - Register PEsub as plugins.setoid_ring.sub. - Register PEmul as plugins.setoid_ring.mul. - Register PEopp as plugins.setoid_ring.opp. - Register PEpow as plugins.setoid_ring.pow. + Register PExpr as plugins.ring.pexpr. + Register PEc as plugins.ring.const. + Register PEX as plugins.ring.var. + Register PEadd as plugins.ring.add. + Register PEsub as plugins.ring.sub. + Register PEmul as plugins.ring.mul. + Register PEopp as plugins.ring.opp. + Register PEpow as plugins.ring.pow. (** evaluation of polynomial expressions towards R *) Definition mk_X j := mkPinj_pred j mkX. diff --git a/theories/setoid_ring/Ring_tac.v b/theories/setoid_ring/Ring_tac.v index df54989169..76e9b1e947 100644 --- a/theories/setoid_ring/Ring_tac.v +++ b/theories/setoid_ring/Ring_tac.v @@ -15,7 +15,7 @@ Require Import Ring_polynom. Require Import BinList. Require Export ListTactics. Require Import InitialRing. -Declare ML Module "newring_plugin". +Declare ML Module "ring_plugin". (* adds a definition t' on the normal form of t and an hypothesis id diff --git a/theories/setoid_ring/Ring_theory.v b/theories/setoid_ring/Ring_theory.v index 230e789e21..32f21e2737 100644 --- a/theories/setoid_ring/Ring_theory.v +++ b/theories/setoid_ring/Ring_theory.v @@ -53,7 +53,7 @@ Section Power. Lemma pow_pos_swap x j : pow_pos x j * x == x * pow_pos x j. Proof. - induction j; simpl; rewrite <- ?mul_assoc. + induction j as [j IHj|j IHj|]; simpl; rewrite <- ?mul_assoc. - f_equiv. now do 2 (rewrite IHj, mul_assoc). - now do 2 (rewrite IHj, mul_assoc). - reflexivity. @@ -62,7 +62,7 @@ Section Power. Lemma pow_pos_succ x j : pow_pos x (Pos.succ j) == x * pow_pos x j. Proof. - induction j; simpl; try reflexivity. + induction j as [j IHj|j IHj|]; simpl; try reflexivity. rewrite IHj, <- mul_assoc; f_equiv. now rewrite mul_assoc, pow_pos_swap, mul_assoc. Qed. @@ -70,7 +70,7 @@ Section Power. Lemma pow_pos_add x i j : pow_pos x (i + j) == pow_pos x i * pow_pos x j. Proof. - induction i using Pos.peano_ind. + induction i as [|i IHi] using Pos.peano_ind. - now rewrite Pos.add_1_l, pow_pos_succ. - now rewrite Pos.add_succ_l, !pow_pos_succ, IHi, mul_assoc. Qed. diff --git a/theories/ssr/ssrbool.v b/theories/ssr/ssrbool.v index be84e217a5..e8a036bbb0 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. @@ -1368,8 +1401,8 @@ Definition mem T (pT : predType T) : pT -> mem_pred T := let: PredType toP := pT in fun A => Mem [eta toP A]. Arguments mem {T pT} A : rename, simpl never. -Notation "x \in A" := (in_mem x (mem A)) : bool_scope. -Notation "x \in A" := (in_mem x (mem A)) : bool_scope. +Notation "x \in A" := (in_mem x (mem A)) (only parsing) : bool_scope. +Notation "x \in A" := (in_mem x (mem A)) (only printing) : bool_scope. Notation "x \notin A" := (~~ (x \in A)) : bool_scope. Notation "A =i B" := (eq_mem (mem A) (mem B)) : type_scope. Notation "{ 'subset' A <= B }" := (sub_mem (mem A) (mem B)) : type_scope. @@ -1540,9 +1573,12 @@ Arguments has_quality n {T}. Lemma qualifE n T p x : (x \in @Qualifier n T p) = p x. Proof. by []. Qed. -Notation "x \is A" := (x \in has_quality 0 A) : bool_scope. -Notation "x \is 'a' A" := (x \in has_quality 1 A) : bool_scope. -Notation "x \is 'an' A" := (x \in has_quality 2 A) : bool_scope. +Notation "x \is A" := (x \in has_quality 0 A) (only parsing) : bool_scope. +Notation "x \is A" := (x \in has_quality 0 A) (only printing) : bool_scope. +Notation "x \is 'a' A" := (x \in has_quality 1 A) (only parsing) : bool_scope. +Notation "x \is 'a' A" := (x \in has_quality 1 A) (only printing) : bool_scope. +Notation "x \is 'an' A" := (x \in has_quality 2 A) (only parsing) : bool_scope. +Notation "x \is 'an' A" := (x \in has_quality 2 A) (only printing) : bool_scope. Notation "x \isn't A" := (x \notin has_quality 0 A) : bool_scope. Notation "x \isn't 'a' A" := (x \notin has_quality 1 A) : bool_scope. Notation "x \isn't 'an' A" := (x \notin has_quality 2 A) : bool_scope. @@ -1980,12 +2016,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 +2030,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 +2049,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..0ebb97d0bf 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,zarith # OCaml binaries CAMLC ?= "$(OCAMLFIND)" ocamlc -c diff --git a/tools/TimeFileMaker.py b/tools/TimeFileMaker.py index 12462726e5..72c7465b13 100644 --- a/tools/TimeFileMaker.py +++ b/tools/TimeFileMaker.py @@ -101,7 +101,12 @@ def add_output_file_name(parser): return add_file_name_gen(parser, 'OUTPUT_', 'f def reformat_time_string(time): - seconds, milliseconds = time.split('.') + try: + seconds, milliseconds = time.split('.') + except ValueError: + print('WARNING: Invalid time string: not the right number of dots (.); expected one: %s' % repr(time), file=sys.stderr) + seconds, milliseconds = (time + '.').split('.')[:2] + if seconds == '': seconds = 0 seconds = int(seconds) minutes, seconds = divmod(seconds, 60) return '%dm%02d.%ss' % (minutes, seconds, milliseconds) 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/topbin/coqtacticworker_bin.ml b/topbin/coqtacticworker_bin.ml index 252c8faa05..706554e025 100644 --- a/topbin/coqtacticworker_bin.ml +++ b/topbin/coqtacticworker_bin.ml @@ -8,6 +8,6 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -module W = AsyncTaskQueue.MakeWorker(Stm.TacTask) () +module W = AsyncTaskQueue.MakeWorker(Partac.TacTask) () let () = WorkerLoop.start ~init:W.init_stdout ~loop:W.main_loop "coqtacticworker" diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index a94c1aea66..6460378edc 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..98f4ba2edf 100644 --- a/toplevel/dune +++ b/toplevel/dune @@ -3,8 +3,8 @@ (public_name coq.toplevel) (synopsis "Coq's Interactive Shell [terminal-based]") (wrapped false) - (libraries num coq.stm)) -; Coqlevel provides the `Num` library to plugins, we could also use + (libraries coq.stm)) +; 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..5ae8f4ae6e 100644 --- a/user-contrib/Ltac2/g_ltac2.mlg +++ b/user-contrib/Ltac2/g_ltac2.mlg @@ -72,13 +72,13 @@ let test_ltac1_env = end let tac2expr = Tac2entries.Pltac.tac2expr -let tac2type = Entry.create "tactic:tac2type" -let tac2def_val = Entry.create "tactic:tac2def_val" -let tac2def_typ = Entry.create "tactic:tac2def_typ" -let tac2def_ext = Entry.create "tactic:tac2def_ext" -let tac2def_syn = Entry.create "tactic:tac2def_syn" -let tac2def_mut = Entry.create "tactic:tac2def_mut" -let tac2mode = Entry.create "vernac:ltac2_command" +let tac2type = Entry.create "tac2type" +let tac2def_val = Entry.create "tac2def_val" +let tac2def_typ = Entry.create "tac2def_typ" +let tac2def_ext = Entry.create "tac2def_ext" +let tac2def_syn = Entry.create "tac2def_syn" +let tac2def_mut = Entry.create "tac2def_mut" +let tac2mode = Entry.create "ltac2_command" let ltac1_expr = Pltac.tactic_expr let tac2expr_in_env = Tac2entries.Pltac.tac2expr_in_env @@ -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/user-contrib/Ltac2/tac2core.ml b/user-contrib/Ltac2/tac2core.ml index cdbcc24484..3ce50865c0 100644 --- a/user-contrib/Ltac2/tac2core.ml +++ b/user-contrib/Ltac2/tac2core.ml @@ -1362,7 +1362,7 @@ let () = let () = let e = Tac2entries.Pltac.tac2expr_in_env in - let inject (loc, v) = Ltac_plugin.Tacexpr.TacGeneric (in_gen (rawwit wit_ltac2) v) in + let inject (loc, v) = Ltac_plugin.Tacexpr.TacGeneric (Some "ltac2", in_gen (rawwit wit_ltac2) v) in Ltac_plugin.Tacentries.create_ltac_quotation "ltac2" inject (e, None) (* Ltac1 runtime representation of Ltac2 closure quotations *) diff --git a/user-contrib/Ltac2/tac2entries.ml b/user-contrib/Ltac2/tac2entries.ml index 0a6e976db8..30340cd632 100644 --- a/user-contrib/Ltac2/tac2entries.ml +++ b/user-contrib/Ltac2/tac2entries.ml @@ -24,29 +24,29 @@ open Tac2intern module Pltac = struct -let tac2expr = Pcoq.Entry.create "tactic:tac2expr" -let tac2expr_in_env = Pcoq.Entry.create "tactic:tac2expr_in_env" - -let q_ident = Pcoq.Entry.create "tactic:q_ident" -let q_bindings = Pcoq.Entry.create "tactic:q_bindings" -let q_with_bindings = Pcoq.Entry.create "tactic:q_with_bindings" -let q_intropattern = Pcoq.Entry.create "tactic:q_intropattern" -let q_intropatterns = Pcoq.Entry.create "tactic:q_intropatterns" -let q_destruction_arg = Pcoq.Entry.create "tactic:q_destruction_arg" -let q_induction_clause = Pcoq.Entry.create "tactic:q_induction_clause" -let q_conversion = Pcoq.Entry.create "tactic:q_conversion" -let q_rewriting = Pcoq.Entry.create "tactic:q_rewriting" -let q_clause = Pcoq.Entry.create "tactic:q_clause" -let q_dispatch = Pcoq.Entry.create "tactic:q_dispatch" -let q_occurrences = Pcoq.Entry.create "tactic:q_occurrences" -let q_reference = Pcoq.Entry.create "tactic:q_reference" -let q_strategy_flag = Pcoq.Entry.create "tactic:q_strategy_flag" -let q_constr_matching = Pcoq.Entry.create "tactic:q_constr_matching" -let q_goal_matching = Pcoq.Entry.create "tactic:q_goal_matching" -let q_hintdb = Pcoq.Entry.create "tactic:q_hintdb" -let q_move_location = Pcoq.Entry.create "tactic:q_move_location" -let q_pose = Pcoq.Entry.create "tactic:q_pose" -let q_assert = Pcoq.Entry.create "tactic:q_assert" +let tac2expr = Pcoq.Entry.create "tac2expr" +let tac2expr_in_env = Pcoq.Entry.create "tac2expr_in_env" + +let q_ident = Pcoq.Entry.create "q_ident" +let q_bindings = Pcoq.Entry.create "q_bindings" +let q_with_bindings = Pcoq.Entry.create "q_with_bindings" +let q_intropattern = Pcoq.Entry.create "q_intropattern" +let q_intropatterns = Pcoq.Entry.create "q_intropatterns" +let q_destruction_arg = Pcoq.Entry.create "q_destruction_arg" +let q_induction_clause = Pcoq.Entry.create "q_induction_clause" +let q_conversion = Pcoq.Entry.create "q_conversion" +let q_rewriting = Pcoq.Entry.create "q_rewriting" +let q_clause = Pcoq.Entry.create "q_clause" +let q_dispatch = Pcoq.Entry.create "q_dispatch" +let q_occurrences = Pcoq.Entry.create "q_occurrences" +let q_reference = Pcoq.Entry.create "q_reference" +let q_strategy_flag = Pcoq.Entry.create "q_strategy_flag" +let q_constr_matching = Pcoq.Entry.create "q_constr_matching" +let q_goal_matching = Pcoq.Entry.create "q_goal_matching" +let q_hintdb = Pcoq.Entry.create "q_hintdb" +let q_move_location = Pcoq.Entry.create "q_move_location" +let q_pose = Pcoq.Entry.create "q_pose" +let q_assert = Pcoq.Entry.create "q_assert" end (** Tactic definition *) 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..a464eab127 100644 --- a/vernac/classes.ml +++ b/vernac/classes.ml @@ -41,11 +41,11 @@ let classes_transparent_state () = let () = Hook.set Typeclasses.classes_transparent_state_hook classes_transparent_state -let add_instance_hint inst path ~locality info poly = +let add_instance_hint inst path ~locality info = Flags.silently (fun () -> Hints.add_hints ~locality [typeclasses_db] (Hints.HintsResolveEntry - [info, poly, false, Hints.PathHints path, inst])) () + [info, false, Hints.PathHints path, inst])) () let is_local_for_hint i = match i.is_global with @@ -56,16 +56,9 @@ let is_local_for_hint i = itself *) let add_instance_base inst = - let poly = Global.is_polymorphic inst.is_impl in let locality = if is_local_for_hint inst then Goptions.OptLocal else Goptions.OptGlobal in add_instance_hint (Hints.IsGlobRef inst.is_impl) [inst.is_impl] ~locality - inst.is_info poly; - List.iter (fun (path, pri, c) -> - let h = Hints.IsConstr (EConstr.of_constr c, Univ.ContextSet.empty) [@ocaml.warning "-3"] in - add_instance_hint h path - ~locality pri poly) - (build_subclasses ~check:(not (isVarRef inst.is_impl)) - (Global.env ()) (Evd.from_env (Global.env ())) inst.is_impl inst.is_info) + inst.is_info let mk_instance cl info glob impl = let global = @@ -162,8 +155,17 @@ let subst_class (subst,cl) = let do_subst_context (grs,ctx) = List.Smart.map (Option.Smart.map do_subst_gr) grs, do_subst_ctx ctx in - let do_subst_projs projs = List.Smart.map (fun (x, y, z) -> - (x, y, Option.Smart.map do_subst_con z)) projs in + let do_subst_meth m = + let c = Option.Smart.map do_subst_con m.meth_const in + if c == m.meth_const then m + else + { + meth_name = m.meth_name; + meth_info = m.meth_info; + meth_const = c; + } + in + let do_subst_projs projs = List.Smart.map do_subst_meth projs in { cl_univs = cl.cl_univs; cl_impl = do_subst_gr cl.cl_impl; cl_context = do_subst_context cl.cl_context; @@ -248,10 +250,10 @@ let add_class cl = let add_class env sigma cl = add_class cl; - List.iter (fun (n, inst, body) -> - match inst with - | Some (Backward, info) -> - (match body with + List.iter (fun m -> + match m.meth_info with + | Some info -> + (match m.meth_const with | None -> CErrors.user_err Pp.(str "Non-definable projection can not be declared as a subinstance") | Some b -> declare_instance ~warn:true env sigma (Some info) false (GlobRef.ConstRef b)) | _ -> ()) @@ -358,8 +360,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 @@ -430,9 +433,9 @@ let do_instance_type_ctx_instance props k env' ctx' sigma ~program_mode subst = let rest' = List.filter (fun v -> not (is_id v)) rest in let {CAst.loc;v=mid} = get_id loc_mid in - List.iter (fun (n, _, x) -> - if Name.equal n (Name mid) then - Option.iter (fun x -> Dumpglob.add_glob ?loc (GlobRef.ConstRef x)) x) k.cl_projs; + List.iter (fun m -> + if Name.equal m.meth_name (Name mid) then + Option.iter (fun x -> Dumpglob.add_glob ?loc (GlobRef.ConstRef x)) m.meth_const) k.cl_projs; c :: props, rest' with Not_found -> ((CAst.make @@ CHole (None(* Some Evar_kinds.GoalEvar *), Namegen.IntroAnonymous, None)) :: props), rest 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..78572c6aa6 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -110,7 +110,7 @@ let interp_fix_context ~program_mode ~cofix env sigma fix = else [], fix.Vernacexpr.binders in let sigma, (impl_env, ((env', ctx), imps)) = interp_context_evars ~program_mode env sigma before in let sigma, (impl_env', ((env'', ctx'), imps')) = - interp_context_evars ~program_mode ~impl_env ~shift:(Context.Rel.nhyps ctx) env' sigma after + interp_context_evars ~program_mode ~impl_env env' sigma after in let annot = Option.map (fun _ -> List.length (Termops.assums_of_rel_context ctx)) fix.Vernacexpr.rec_order in sigma, ((env'', ctx' @ ctx), (impl_env',imps @ imps'), annot) @@ -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/comHints.ml b/vernac/comHints.ml index 051560fb63..9eac558908 100644 --- a/vernac/comHints.ml +++ b/vernac/comHints.ml @@ -62,7 +62,7 @@ let project_hint ~poly pri l2r r = cb in let info = {Typeclasses.hint_priority = pri; hint_pattern = None} in - (info, false, true, Hints.PathAny, Hints.IsGlobRef (GlobRef.ConstRef c)) + (info, true, Hints.PathAny, Hints.IsGlobRef (GlobRef.ConstRef c)) let warn_deprecated_hint_constr = CWarnings.create ~name:"fragile-hint-constr" ~category:"automation" @@ -89,10 +89,10 @@ let interp_hints ~poly h = let env = Global.env () in let sigma = Evd.from_env env in let c, diff = Hints.prepare_hint true env sigma (evd, c) in - if poly then (Hints.IsConstr (c, diff) [@ocaml.warning "-3"]) + if poly then (Hints.IsConstr (c, Some diff) [@ocaml.warning "-3"]) else let () = DeclareUctx.declare_universe_context ~poly:false diff in - (Hints.IsConstr (c, Univ.ContextSet.empty) [@ocaml.warning "-3"]) + (Hints.IsConstr (c, None) [@ocaml.warning "-3"]) in let fref r = let gr = Smartlocate.global_with_alias r in @@ -106,20 +106,20 @@ let interp_hints ~poly h = match c with | HintsReference c -> let gr = Smartlocate.global_with_alias c in - (PathHints [gr], poly, IsGlobRef gr) + (PathHints [gr], IsGlobRef gr) | HintsConstr c -> let () = warn_deprecated_hint_constr () in - (PathAny, poly, f poly c) + (PathAny, f poly c) in let fp = Constrintern.intern_constr_pattern env sigma in let fres (info, b, r) = - let path, poly, gr = fi r in + let path, gr = fi r in let info = { info with Typeclasses.hint_pattern = Option.map fp info.Typeclasses.hint_pattern } in - (info, poly, b, path, gr) + (info, b, path, gr) in let open Hints in let open Vernacexpr in @@ -140,7 +140,6 @@ let interp_hints ~poly h = | HintsConstructors lqid -> let constr_hints_of_ind qid = let ind = Smartlocate.global_inductive_with_alias qid in - let mib, _ = Global.lookup_inductive ind in Dumpglob.dump_reference ?loc:qid.CAst.loc "<>" (Libnames.string_of_qualid qid) "ind"; @@ -148,7 +147,6 @@ let interp_hints ~poly h = let c = (ind, i + 1) in let gr = GlobRef.ConstructRef c in ( empty_hint_info - , Declareops.inductive_is_polymorphic mib , true , PathHints [gr] , IsGlobRef gr )) diff --git a/vernac/comInductive.ml b/vernac/comInductive.ml index 673124296d..bb26ce652e 100644 --- a/vernac/comInductive.ml +++ b/vernac/comInductive.ml @@ -16,7 +16,6 @@ open Context open Environ open Names open Libnames -open Nameops open Constrexpr open Constrexpr_ops open Constrintern @@ -139,7 +138,7 @@ let model_conclusion env sigma ind_rel params n arity_indices = let sigma,model_indices = List.fold_right (fun (_,t) (sigma, subst) -> - let t = EConstr.Vars.substl subst (EConstr.Vars.liftn n (List.length subst + 1) (EConstr.Vars.liftn 1 (List.length params + List.length subst + 1) t)) in + let t = EConstr.Vars.substl subst (EConstr.Vars.liftn n (List.length subst + 1) t) in let sigma, c = Evarutil.new_evar env sigma t in sigma, c::subst) arity_indices (sigma, []) in @@ -443,15 +442,14 @@ let interp_params env udecl uparamsl paramsl = interp_context_evars ~program_mode:false ~impl_env:uimpls env_uparams sigma paramsl in (* Names of parameters as arguments of the inductive type (defs removed) *) - let assums = List.filter is_local_assum ctx_params in sigma, env_params, (ctx_params, env_uparams, ctx_uparams, - List.map (RelDecl.get_name %> Name.get_id) assums, userimpls, useruimpls, impls, udecl) + userimpls, useruimpls, impls, udecl) (* When a hole remains for a param, pretend the param is uniform and 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 +460,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; @@ -478,11 +480,12 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not then user_err (str "Inductives with uniform parameters may not have attached notations."); let indnames = List.map (fun ind -> ind.ind_name) indl in + let ninds = List.length indl in (* In case of template polymorphism, we need to compute more constraints *) let env0 = if poly then env0 else Environ.set_universes_lbound env0 UGraph.Bound.Prop in - let sigma, env_params, (ctx_params, env_uparams, ctx_uparams, params, userimpls, useruimpls, impls, udecl) = + let sigma, env_params, (ctx_params, env_uparams, ctx_uparams, userimpls, useruimpls, impls, udecl) = interp_params env0 udecl uparamsl paramsl in @@ -492,16 +495,17 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not let sigma, arities = List.fold_left_map (pretype_ind_arity env_params) sigma arities in let arities, relevances, arityconcl, indimpls = List.split4 arities in - let lift1_ctx ctx = + let lift_ctx n ctx = let t = EConstr.it_mkProd_or_LetIn EConstr.mkProp ctx in - let t = EConstr.Vars.lift 1 t in + let t = EConstr.Vars.lift n t in let ctx, _ = EConstr.decompose_prod_assum sigma t in ctx in - let ctx_params_lifted, fullarities = CList.fold_left_map - (fun ctx_params c -> lift1_ctx ctx_params, EConstr.it_mkProd_or_LetIn c ctx_params) - ctx_params - arities + let ctx_params_lifted, fullarities = + lift_ctx ninds ctx_params, + CList.map_i + (fun i c -> EConstr.Vars.lift i (EConstr.it_mkProd_or_LetIn c ctx_params)) + 0 arities in let env_ar = push_types env_uparams indnames relevances fullarities in let env_ar_params = EConstr.push_rel_context ctx_params_lifted env_ar in @@ -511,14 +515,15 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not let impls = compute_internalization_env env_uparams sigma ~impls Inductive indnames fullarities indimpls in let ntn_impls = compute_internalization_env env_uparams sigma Inductive indnames fullarities indimpls in - let ninds = List.length indl in let (sigma, _), constructors = Metasyntax.with_syntax_protection (fun () -> (* Temporary declaration of notations and scopes *) List.iter (Metasyntax.set_notation_for_interpretation env_params ntn_impls) notations; (* Interpret the constructor types *) List.fold_left2_map - (fun (sigma, ind_rel) -> interp_cstrs env_ar_params (sigma, ind_rel) impls ctx_params) + (fun (sigma, ind_rel) ind arity -> + interp_cstrs env_ar_params (sigma, ind_rel) impls ctx_params_lifted + ind (EConstr.Vars.liftn ninds (Rel.length ctx_params + 1) arity)) (sigma, ninds) indl arities) () in @@ -527,7 +532,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 @@ -536,7 +541,7 @@ let interp_mutual_inductive_gen env0 ~template udecl (uparamsl,paramsl,indl) not let nuparams = Context.Rel.length ctx_uparams in let uargs = Context.Rel.to_extended_vect EConstr.mkRel 0 ctx_uparams in let uparam_subst = - List.init (List.length indl) EConstr.(fun i -> mkApp (mkRel (i + 1 + nuparams), uargs)) + List.init ninds EConstr.(fun i -> mkApp (mkRel (i + 1 + nuparams), uargs)) @ List.init nuparams EConstr.(fun i -> mkRel (i + 1)) in let generalize_constructor c = EConstr.Unsafe.to_constr (EConstr.Vars.substnl uparam_subst nparams c) in let cimpls = List.map pi3 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/comTactic.ml b/vernac/comTactic.ml new file mode 100644 index 0000000000..8a9a412362 --- /dev/null +++ b/vernac/comTactic.ml @@ -0,0 +1,82 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * Copyright INRIA, CNRS and contributors *) +(* <O___,, * (see version control and CREDITS file for authors & dates) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Goptions + +module Dyn = Dyn.Make() + +module DMap = Dyn.Map(struct type 'a t = 'a -> unit Proofview.tactic end) + +let interp_map = ref DMap.empty + +type 'a tactic_interpreter = 'a Dyn.tag +type interpretable = I : 'a tactic_interpreter * 'a -> interpretable + +let register_tactic_interpreter na f = + let t = Dyn.create na in + interp_map := DMap.add t f !interp_map; + t + +let interp_tac (I (tag,t)) = + let f = DMap.find tag !interp_map in + f t + +type parallel_solver = + pstate:Declare.Proof.t -> + info:int option -> + interpretable -> + abstract:bool -> + with_end_tac:bool -> + Declare.Proof.t + +let print_info_trace = + declare_intopt_option_and_ref ~depr:false ~key:["Info" ; "Level"] + +let solve_core ~pstate n ~info t ~with_end_tac:b = + let pstate, status = Declare.Proof.map_fold_endline ~f:(fun etac p -> + let with_end_tac = if b then Some etac else None in + let info = Option.append info (print_info_trace ()) in + let (p,status) = Proof.solve n info t ?with_end_tac p in + (* in case a strict subtree was completed, + go back to the top of the prooftree *) + let p = Proof.maximal_unfocus Vernacentries.command_focus p in + p,status) pstate in + if not status then Feedback.feedback Feedback.AddedAxiom; + pstate + +let solve ~pstate n ~info t ~with_end_tac = + let t = interp_tac t in + solve_core ~pstate n ~info t ~with_end_tac + +let check_par_applicable pstate = + Declare.Proof.fold pstate ~f:(fun p -> + (Proof.data p).Proof.goals |> List.iter (fun goal -> + let is_ground = + let { Proof.sigma = sigma0 } = Declare.Proof.fold pstate ~f:Proof.data in + let g = Evd.find sigma0 goal in + let concl, hyps = Evd.evar_concl g, Evd.evar_context g in + Evarutil.is_ground_term sigma0 concl && + List.for_all (Context.Named.Declaration.for_all (Evarutil.is_ground_term sigma0)) hyps in + if not is_ground then + CErrors.user_err + Pp.(strbrk("The par: goal selector does not support goals with existential variables")))) + +let par_implementation = ref (fun ~pstate ~info t ~abstract ~with_end_tac -> + let t = interp_tac t in + let t = Proofview.Goal.enter (fun _ -> + if abstract then Abstract.tclABSTRACT None ~opaque:true t else t) + in + solve_core ~pstate Goal_select.SelectAll ~info t ~with_end_tac) + +let set_par_implementation f = par_implementation := f + +let solve_parallel ~pstate ~info t ~abstract ~with_end_tac = + check_par_applicable pstate; + !par_implementation ~pstate ~info t ~abstract ~with_end_tac diff --git a/vernac/comTactic.mli b/vernac/comTactic.mli new file mode 100644 index 0000000000..f1a75e1b6a --- /dev/null +++ b/vernac/comTactic.mli @@ -0,0 +1,47 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(** Tactic interpreters have to register their interpretation function *) +type 'a tactic_interpreter +type interpretable = I : 'a tactic_interpreter * 'a -> interpretable + +(** ['a] should be marshallable if ever used with [par:] *) +val register_tactic_interpreter : + string -> ('a -> unit Proofview.tactic) -> 'a tactic_interpreter + +(** Entry point for toplevel tactic expression execution. It calls Proof.solve + after having interpreted the tactic, and after the tactic runs it + unfocus as much as needed to put a goal under focus. *) +val solve : + pstate:Declare.Proof.t -> + Goal_select.t -> + info:int option -> + interpretable -> + with_end_tac:bool -> + Declare.Proof.t + +(** [par: tac] runs tac on all goals, possibly in parallel using a worker pool. + If tac is [abstract tac1], then [abstract] is passed + explicitly to the solver and [tac1] passed to worker since it is up to + master to opacify the sub proofs produced by the workers. *) +type parallel_solver = + pstate:Declare.Proof.t -> + info:int option -> + interpretable -> + abstract:bool -> (* the tactic result has to be opacified as per abstract *) + with_end_tac:bool -> + Declare.Proof.t + +(** Entry point when the goal selector is par: *) +val solve_parallel : parallel_solver + +(** By default par: is implemented with all: (sequential). + The STM and LSP document manager provide "more parallel" implementations *) +val set_par_implementation : parallel_solver -> unit diff --git a/vernac/declare.ml b/vernac/declare.ml index eedbee852b..ae7878b615 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 @@ -707,7 +725,6 @@ module Obligation = struct ; obl_tac : unit Proofview.tactic option } let set_type ~typ obl = {obl with obl_type = typ} - let set_body ~body obl = {obl with obl_body = Some body} end type obligations = {obls : Obligation.t array; remaining : int} @@ -1535,11 +1552,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 +1733,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 +2013,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 +2250,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 +2291,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 @@ -2450,32 +2463,25 @@ let add_mutual_definitions l ~pm ~info ?obl_hook ~uctx in pm -let admit_prog ~pm prg = - let {obls; remaining} = Internal.get_obligations prg in - let obls = Array.copy obls in - Array.iteri - (fun i x -> - match x.obl_body with - | None -> - let x = subst_deps_obl obls x in - let uctx = Internal.get_uctx prg in - let univs = UState.univ_entry ~poly:false uctx in - let kn = declare_constant ~name:x.obl_name ~local:Locality.ImportNeedQualified - (ParameterEntry (None, (x.obl_type, univs), None)) ~kind:Decls.(IsAssumption Conjectural) - in - assumption_message x.obl_name; - obls.(i) <- Obligation.set_body ~body:(DefinedObl (kn, Univ.Instance.empty)) x - | Some _ -> ()) - obls; - Obls_.update_obls ~pm prg obls 0 - -(* get_any_prog *) +let rec admit_prog ~pm prg = + let {obls} = Internal.get_obligations prg in + let is_open _ x = Option.is_empty x.obl_body && List.is_empty (deps_remaining obls x.obl_deps) in + let i = match Array.findi is_open obls with + | Some i -> i + | None -> CErrors.anomaly (Pp.str "Could not find a solvable obligation.") + in + let proof = solve_obligation prg i None in + let pm = Proof.save_admitted ~pm ~proof in + match ProgMap.find_opt (Internal.get_name prg) pm with + | Some prg -> admit_prog ~pm (CEphemeron.get prg) + | None -> pm + let rec admit_all_obligations ~pm = let prg = State.first_pending pm in match prg with | None -> pm | Some prg -> - let pm, _prog = admit_prog ~pm prg in + let pm = admit_prog ~pm prg in admit_all_obligations ~pm let admit_obligations ~pm n = @@ -2483,7 +2489,7 @@ let admit_obligations ~pm n = | None -> admit_all_obligations ~pm | Some _ -> let prg = get_unique_prog ~pm n in - let pm, _ = admit_prog ~pm prg in + let pm = admit_prog ~pm prg in pm let next_obligation ~pm n tac = 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/egramcoq.ml b/vernac/egramcoq.ml index cbd83e88b6..b134f7b82b 100644 --- a/vernac/egramcoq.ml +++ b/vernac/egramcoq.ml @@ -268,16 +268,16 @@ let custom_entry_locality = Summary.ref ~name:"LOCAL-CUSTOM-ENTRY" String.Set.em let create_custom_entry ~local s = if List.mem s ["constr";"pattern";"ident";"global";"binder";"bigint"] then user_err Pp.(quote (str s) ++ str " is a reserved entry name."); - let sc = "constr:"^s in - let sp = "pattern:"^s in + let sc = "custom:"^s in + let sp = "custom_pattern:"^s in let _ = extend_entry_command constr_custom_entry sc in let _ = extend_entry_command pattern_custom_entry sp in let () = if local then custom_entry_locality := String.Set.add s !custom_entry_locality in () let find_custom_entry s = - let sc = "constr:"^s in - let sp = "pattern:"^s in + let sc = "custom:"^s in + let sp = "custom_pattern:"^s in try (find_custom_entry constr_custom_entry sc, find_custom_entry pattern_custom_entry sp) with Not_found -> user_err Pp.(str "Undeclared custom entry: " ++ str s ++ str ".") diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index e0550fd744..49d4847fde 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -33,26 +33,26 @@ open Attributes (* Rem: do not join the different GEXTEND into one, it breaks native *) (* compilation on PowerPC and Sun architectures *) -let query_command = Entry.create "vernac:query_command" - -let search_query = Entry.create "vernac:search_query" -let search_queries = Entry.create "vernac:search_queries" - -let subprf = Entry.create "vernac:subprf" - -let quoted_attributes = Entry.create "vernac:quoted_attributes" -let class_rawexpr = Entry.create "vernac:class_rawexpr" -let thm_token = Entry.create "vernac:thm_token" -let def_token = Entry.create "vernac:def_token" -let assumption_token = Entry.create "vernac:assumption_token" -let def_body = Entry.create "vernac:def_body" -let decl_notations = Entry.create "vernac:decl_notations" -let record_field = Entry.create "vernac:record_field" -let of_type_with_opt_coercion = Entry.create "vernac:of_type_with_opt_coercion" -let section_subset_expr = Entry.create "vernac:section_subset_expr" -let scope_delimiter = Entry.create "vernac:scope_delimiter" -let syntax_modifiers = Entry.create "vernac:syntax_modifiers" -let only_parsing = Entry.create "vernac:only_parsing" +let query_command = Entry.create "query_command" + +let search_query = Entry.create "search_query" +let search_queries = Entry.create "search_queries" + +let subprf = Entry.create "subprf" + +let quoted_attributes = Entry.create "quoted_attributes" +let class_rawexpr = Entry.create "class_rawexpr" +let thm_token = Entry.create "thm_token" +let def_token = Entry.create "def_token" +let assumption_token = Entry.create "assumption_token" +let def_body = Entry.create "def_body" +let decl_notations = Entry.create "decl_notations" +let record_field = Entry.create "record_field" +let of_type_with_opt_coercion = Entry.create "of_type_with_opt_coercion" +let section_subset_expr = Entry.create "section_subset_expr" +let scope_delimiter = Entry.create "scope_delimiter" +let syntax_modifiers = Entry.create "syntax_modifiers" +let only_parsing = Entry.create "only_parsing" let make_bullet s = let open Proof_bullet in @@ -436,12 +436,12 @@ GRAMMAR EXTEND Gram | l = binders; ":="; b = lconstr -> { fun id -> match b.CAst.v with | CCast(b', (CastConv t|CastVM t|CastNative t)) -> - (None,DefExpr(id,mkLambdaCN ~loc l b',Some (mkProdCN ~loc l t))) + (NoInstance,DefExpr(id,mkLambdaCN ~loc l b',Some (mkProdCN ~loc l t))) | _ -> - (None,DefExpr(id,mkLambdaCN ~loc l b,None)) } ] ] + (NoInstance,DefExpr(id,mkLambdaCN ~loc l b,None)) } ] ] ; record_binder: - [ [ id = name -> { (None,AssumExpr(id, CAst.make ~loc @@ CHole (None, IntroAnonymous, None))) } + [ [ id = name -> { (NoInstance,AssumExpr(id, CAst.make ~loc @@ CHole (None, IntroAnonymous, None))) } | id = name; f = record_binder_body -> { f id } ] ] ; assum_list: @@ -452,13 +452,13 @@ GRAMMAR EXTEND Gram ; simple_assum_coe: [ [ idl = LIST1 ident_decl; oc = of_type_with_opt_coercion; c = lconstr -> - { (not (Option.is_empty oc),(idl,c)) } ] ] + { (oc <> NoInstance,(idl,c)) } ] ] ; constructor_type: [[ l = binders; t= [ coe = of_type_with_opt_coercion; c = lconstr -> - { fun l id -> (not (Option.is_empty coe),(id,mkProdCN ~loc l c)) } + { fun l id -> (coe <> NoInstance,(id,mkProdCN ~loc l c)) } | -> { fun l id -> (false,(id,mkProdCN ~loc l (CAst.make ~loc @@ CHole (None, IntroAnonymous, None)))) } ] -> { t l } @@ -469,12 +469,9 @@ GRAMMAR EXTEND Gram [ [ id = identref; c=constructor_type -> { c id } ] ] ; of_type_with_opt_coercion: - [ [ ":>>" -> { Some false } - | ":>"; ">" -> { Some false } - | ":>" -> { Some true } - | ":"; ">"; ">" -> { Some false } - | ":"; ">" -> { Some true } - | ":" -> { None } ] ] + [ [ ":>" -> { BackInstance } + | ":"; ">" -> { BackInstance } + | ":" -> { NoInstance } ] ] ; END diff --git a/vernac/himsg.ml b/vernac/himsg.ml index 762c95fffe..a9de01bfd0 100644 --- a/vernac/himsg.ml +++ b/vernac/himsg.ml @@ -71,6 +71,9 @@ let rec contract3' env sigma a b c = function | ConversionFailed (env',t1,t2) -> let (env',t1,t2) = contract2 env' sigma t1 t2 in contract3 env sigma a b c, ConversionFailed (env',t1,t2) + | IncompatibleInstances (env',ev,t1,t2) -> + let (env',ev,t1,t2) = contract3 env' sigma (EConstr.mkEvar ev) t1 t2 in + contract3 env sigma a b c, IncompatibleInstances (env',EConstr.destEvar sigma ev,t1,t2) | NotSameArgSize | NotSameHead | NoCanonicalStructure | MetaOccurInBody _ | InstanceNotSameType _ | ProblemBeyondCapabilities | UnifUnivInconsistency _ as x -> contract3 env sigma a b c, x @@ -313,6 +316,13 @@ let explain_unification_error env sigma p1 p2 = function let t1, t2 = pr_explicit env sigma t1 t2 in [str "cannot unify " ++ t1 ++ strbrk " and " ++ t2] else [] + | IncompatibleInstances (env,ev,t1,t2) -> + let env = make_all_name_different env sigma in + let ev = pr_leconstr_env env sigma (EConstr.mkEvar ev) in + let t1 = Reductionops.nf_betaiota env sigma t1 in + let t2 = Reductionops.nf_betaiota env sigma t2 in + let t1, t2 = pr_explicit env sigma t1 t2 in + [ev ++ strbrk " has otherwise to unify with " ++ t1 ++ str " which is incompatible with " ++ t2] | MetaOccurInBody evk -> [str "instance for " ++ quote (pr_existential_key sigma evk) ++ strbrk " refers to a metavariable - please report your example" ++ @@ -689,34 +699,29 @@ let explain_cannot_unify_binding_type env sigma m n = str "which should be unifiable with" ++ brk(1,1) ++ pn ++ str "." let explain_cannot_find_well_typed_abstraction env sigma p l e = - let p = EConstr.to_constr sigma p in str "Abstracting over the " ++ str (String.plural (List.length l) "term") ++ spc () ++ - hov 0 (pr_enum (fun c -> pr_lconstr_env env sigma (EConstr.to_constr sigma c)) l) ++ spc () ++ - str "leads to a term" ++ spc () ++ pr_ltype_env ~goal_concl_style:true env sigma p ++ + hov 0 (pr_enum (fun c -> pr_leconstr_env env sigma c) l) ++ spc () ++ + str "leads to a term" ++ spc () ++ pr_letype_env ~goal_concl_style:true env sigma p ++ spc () ++ str "which is ill-typed." ++ (match e with None -> mt () | Some e -> fnl () ++ str "Reason is: " ++ e) let explain_wrong_abstraction_type env sigma na abs expected result = - let abs = EConstr.to_constr sigma abs in - let expected = EConstr.to_constr sigma expected in - let result = EConstr.to_constr sigma result in let ppname = match na with Name id -> Id.print id ++ spc () | _ -> mt () in str "Cannot instantiate metavariable " ++ ppname ++ strbrk "of type " ++ - pr_lconstr_env env sigma expected ++ strbrk " with abstraction " ++ - pr_lconstr_env env sigma abs ++ strbrk " of incompatible type " ++ - pr_lconstr_env env sigma result ++ str "." + pr_leconstr_env env sigma expected ++ strbrk " with abstraction " ++ + pr_leconstr_env env sigma abs ++ strbrk " of incompatible type " ++ + pr_leconstr_env env sigma result ++ str "." let explain_abstraction_over_meta _ m n = strbrk "Too complex unification problem: cannot find a solution for both " ++ Name.print m ++ spc () ++ str "and " ++ Name.print n ++ str "." let explain_non_linear_unification env sigma m t = - let t = EConstr.to_constr sigma t in strbrk "Cannot unambiguously instantiate " ++ Name.print m ++ str ":" ++ strbrk " which would require to abstract twice on " ++ - pr_lconstr_env env sigma t ++ str "." + pr_leconstr_env env sigma t ++ str "." let explain_unsatisfied_constraints env sigma cst = strbrk "Unsatisfied constraints: " ++ @@ -803,10 +808,10 @@ let explain_cannot_unify_occurrences env sigma nested ((cl2,pos2),t2) ((cl1,pos1 explain_unification_error env sigma c1 c2 (Some e) in str "Found incompatible occurrences of the pattern" ++ str ":" ++ - spc () ++ str "Matched term " ++ pr_lconstr_env env sigma (EConstr.to_constr sigma t2) ++ + spc () ++ str "Matched term " ++ pr_leconstr_env env sigma t2 ++ strbrk " at position " ++ pr_position (cl2,pos2) ++ strbrk " is not compatible with matched term " ++ - pr_lconstr_env env sigma (EConstr.to_constr sigma t1) ++ strbrk " at position " ++ + pr_leconstr_env env sigma t1 ++ strbrk " at position " ++ pr_position (cl1,pos1) ++ ppreason ++ str "." let pr_constraints printenv env sigma evars cstrs = @@ -826,7 +831,7 @@ let pr_constraints printenv env sigma evars cstrs = (fun (ev, evi) -> fnl () ++ pr_existential_key sigma ev ++ str " : " ++ pr_leconstr_env env' sigma evi.evar_concl ++ fnl ()) l in - h 0 (pe ++ evs ++ pr_evar_constraints sigma cstrs) + h (pe ++ evs ++ pr_evar_constraints sigma cstrs) else let filter evk _ = Evar.Map.mem evk evars in pr_evar_map_filter ~with_univs:false filter env sigma @@ -968,8 +973,8 @@ let explain_not_match_error = function (UContext.instance uctx) (UContext.constraints uctx) in - str "incompatible polymorphic binders: got" ++ spc () ++ h 0 (pr_auctx got) ++ spc() ++ - str "but expected" ++ spc() ++ h 0 (pr_auctx expect) ++ + str "incompatible polymorphic binders: got" ++ spc () ++ h (pr_auctx got) ++ spc() ++ + str "but expected" ++ spc() ++ h (pr_auctx expect) ++ (if not (Int.equal (AUContext.size got) (AUContext.size expect)) then mt() else fnl() ++ str "(incompatible constraints)") | IncompatibleVariance -> @@ -1287,9 +1292,8 @@ let explain_recursion_scheme_error env = function (* Pattern-matching errors *) let explain_bad_pattern env sigma cstr ty = - let ty = EConstr.to_constr sigma ty in let env = make_all_name_different env sigma in - let pt = pr_lconstr_env env sigma ty in + let pt = pr_leconstr_env env sigma ty in let pc = pr_constructor env cstr in str "Found the constructor " ++ pc ++ brk(1,1) ++ str "while matching a term of type " ++ pt ++ brk(1,1) ++ @@ -1326,12 +1330,11 @@ let explain_non_exhaustive env pats = spc () ++ hov 0 (prlist_with_sep pr_comma pr_cases_pattern pats) let explain_cannot_infer_predicate env sigma typs = - let inj c = EConstr.to_constr sigma c in - let typs = Array.map_to_list (fun (c1, c2) -> (inj c1, inj c2)) typs in + let typs = Array.to_list typs in let env = make_all_name_different env sigma in let pr_branch (cstr,typ) = - let cstr,_ = decompose_app cstr in - str "For " ++ pr_lconstr_env env sigma cstr ++ str ": " ++ pr_lconstr_env env sigma typ + let cstr,_ = EConstr.decompose_app sigma cstr in + str "For " ++ pr_leconstr_env env sigma cstr ++ str ": " ++ pr_leconstr_env env sigma typ in str "Unable to unify the types found in the branches:" ++ spc () ++ hov 0 (prlist_with_sep fnl pr_branch typs) diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml index 6cc48d0e48..8ce59c40c3 100644 --- a/vernac/metasyntax.ml +++ b/vernac/metasyntax.ml @@ -85,7 +85,7 @@ let pr_grammar = function pr_entry Pvernac.Vernac_.gallina_ext | name -> pr_registered_grammar name -let pr_custom_grammar name = pr_registered_grammar ("constr:"^name) +let pr_custom_grammar name = pr_registered_grammar ("custom:"^name) (**********************************************************************) (* Parse a format (every terminal starting with a letter or a single @@ -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; @@ -1101,8 +1107,14 @@ let make_interpretation_type isrec isonlybinding default_if_binding = function if isrec then NtnTypeBinderList else anomaly Pp.(str "Type binder is only for use in recursive notations for binders.") -let subentry_of_constr_prod_entry = function - | ETConstr (InCustomEntry s,_,(NumLevel n,_)) -> InCustomEntryLevel (s,n) +let subentry_of_constr_prod_entry from_level = function + (* Specific 8.2 approximation *) + | ETConstr (InCustomEntry s,_,x) -> + let n = match fst (precedence_of_position_and_level from_level x) with + | LevelLt n -> n-1 + | LevelLe n -> n + | LevelSome -> max_int in + InCustomEntryLevel (s,n) (* level and use of parentheses for coercion is hard-wired for "constr"; we don't remember the level *) | ETConstr (InConstrEntry,_,_) -> InConstrEntrySomeLevel @@ -1110,7 +1122,7 @@ let subentry_of_constr_prod_entry = function let make_interpretation_vars (* For binders, default is to parse only as an ident *) ?(default_if_binding=AsIdent) - recvars allvars typs = + recvars level allvars typs = let eq_subscope (sc1, l1) (sc2, l2) = Option.equal String.equal sc1 sc2 && List.equal String.equal l1 l2 @@ -1126,7 +1138,7 @@ let make_interpretation_vars Id.Map.filter (fun x _ -> not (Id.List.mem x useless_recvars)) allvars in Id.Map.mapi (fun x (isonlybinding, sc) -> let typ = Id.List.assoc x typs in - ((subentry_of_constr_prod_entry typ,sc), + ((subentry_of_constr_prod_entry level typ,sc), make_interpretation_type (Id.List.mem_assoc x recvars) isonlybinding default_if_binding typ)) mainvars let check_rule_productivity l = @@ -1153,18 +1165,13 @@ let warn_non_reversible_notation = str " not occur in the right-hand side." ++ spc() ++ strbrk "The notation will not be used for printing as it is not reversible.") -type entry_coercion_kind = - | IsEntryCoercion of notation_entry_level - | IsEntryGlobal of string * int - | IsEntryIdent of string * int - let is_coercion level typs = match level, typs with | Some (custom,n,_), [e] -> (match e, custom with | ETConstr _, _ -> let customkey = make_notation_entry_level custom n in - let subentry = subentry_of_constr_prod_entry e in + let subentry = subentry_of_constr_prod_entry n e in if notation_entry_level_eq subentry customkey then None else Some (IsEntryCoercion subentry) | ETGlobal, InCustomEntry s -> Some (IsEntryGlobal (s,n)) @@ -1405,8 +1412,7 @@ type notation_obj = { notobj_scope : scope_name option; notobj_interp : interpretation; notobj_coercion : entry_coercion_kind option; - notobj_onlyparse : bool; - notobj_onlyprint : bool; + notobj_use : notation_use option; notobj_deprecation : Deprecation.t option; notobj_notation : notation * notation_location; notobj_specific_pp_rules : syntax_printing_extension option; @@ -1430,37 +1436,19 @@ let open_notation i (_, nobj) = let scope = nobj.notobj_scope in let (ntn, df) = nobj.notobj_notation in let pat = nobj.notobj_interp in - let onlyprint = nobj.notobj_onlyprint in let deprecation = nobj.notobj_deprecation in - let specific = match scope with None -> LastLonelyNotation | Some sc -> NotationInScope sc in - let specific_ntn = (specific,ntn) in - let fresh = not (Notation.exists_notation_in_scope scope ntn onlyprint pat) in - if fresh then begin - (* Declare the interpretation *) - let () = Notation.declare_notation_interpretation ntn scope pat df ~onlyprint deprecation in - (* Declare the uninterpretation *) - if not nobj.notobj_onlyparse then - Notation.declare_uninterpretation (NotationRule specific_ntn) pat; - (* Declare a possible coercion *) - (match nobj.notobj_coercion with - | Some (IsEntryCoercion entry) -> - let (_,level,_) = Notation.level_of_notation ntn in - let level = match fst ntn with - | InConstrEntry -> None - | InCustomEntry _ -> Some level - in - Notation.declare_entry_coercion specific_ntn level entry - | Some (IsEntryGlobal (entry,n)) -> Notation.declare_custom_entry_has_global entry n - | Some (IsEntryIdent (entry,n)) -> Notation.declare_custom_entry_has_ident entry n - | None -> ()) - end; + let scope = match scope with None -> LastLonelyNotation | Some sc -> NotationInScope sc in + (* Declare the notation *) + (match nobj.notobj_use with + | Some use -> Notation.declare_notation (scope,ntn) pat df ~use nobj.notobj_coercion deprecation + | None -> ()); (* Declare specific format if any *) - match nobj.notobj_specific_pp_rules with + (match nobj.notobj_specific_pp_rules with | Some pp_sy -> - if specific_format_to_declare specific_ntn pp_sy then + if specific_format_to_declare (scope,ntn) pp_sy then Ppextend.declare_specific_notation_printing_rules - specific_ntn ~extra:pp_sy.synext_extra pp_sy.synext_unparsing - | None -> () + (scope,ntn) ~extra:pp_sy.synext_extra pp_sy.synext_unparsing + | None -> ()) end let cache_notation o = @@ -1590,6 +1578,20 @@ let make_printing_rules reserved (sd : SynData.syn_data) = let open SynData in synext_extra = sd.extra; } +let warn_unused_interpretation = + CWarnings.create ~name:"unused-notation" ~category:"parsing" + (fun b -> + strbrk "interpretation is used neither for printing nor for parsing, " ++ + (if b then strbrk "the declaration could be replaced by \"Reserved Notation\"." + else strbrk "the declaration could be removed.")) + +let make_use reserved onlyparse onlyprint = + match onlyparse, onlyprint with + | false, false -> Some ParsingAndPrinting + | true, false -> Some OnlyParsing + | false, true -> Some OnlyPrinting + | true, true -> warn_unused_interpretation reserved; None + (**********************************************************************) (* Main functions about notations *) @@ -1602,7 +1604,14 @@ let add_notation_in_scope ~local deprecation df env c mods scope = let sd = compute_syntax_data ~local deprecation df mods in (* Prepare the parsing and printing rules *) let sy_pa_rules = make_parsing_rules sd in - let sy_pp_rules = make_printing_rules false sd in + let sy_pp_rules, gen_sy_pp_rules = + match sd.only_parsing, Ppextend.has_generic_notation_printing_rule (fst sd.info) with + | true, true -> None, None + | onlyparse, has_generic -> + let rules = make_printing_rules false sd in + let _ = check_reserved_format (fst sd.info) rules in + (if onlyparse then None else rules), + (if has_generic then None else (* We use the format of this notation as the default *) rules) in (* Prepare the interpretation *) let i_vars = make_internalization_vars sd.recvars sd.mainvars sd.intern_typs in let nenv = { @@ -1610,26 +1619,22 @@ let add_notation_in_scope ~local deprecation df env c mods scope = ninterp_rec_vars = to_map sd.recvars; } in let (acvars, ac, reversibility) = interp_notation_constr env nenv c in - let interp = make_interpretation_vars sd.recvars acvars (fst sd.pa_syntax_data) in + let interp = make_interpretation_vars sd.recvars (pi2 sd.level) acvars (fst sd.pa_syntax_data) in let map (x, _) = try Some (x, Id.Map.find x interp) with Not_found -> None in let onlyparse,coe = printability (Some sd.level) sd.subentries sd.only_parsing reversibility ac in let notation, location = sd.info in + let use = make_use true onlyparse sd.only_printing in let notation = { notobj_local = local; notobj_scope = scope; notobj_interp = (List.map_filter map i_vars, ac); (* Order is important here! *) - notobj_onlyparse = onlyparse; + notobj_use = use; notobj_coercion = coe; - notobj_onlyprint = sd.only_printing; notobj_deprecation = sd.deprecation; notobj_notation = (notation, location); notobj_specific_pp_rules = sy_pp_rules; } in - let gen_sy_pp_rules = - if Ppextend.has_generic_notation_printing_rule (fst sd.info) then None - else sy_pp_rules (* We use the format of this notation as the default *) in - let _ = check_reserved_format (fst sd.info) sy_pp_rules in (* Ready to change the global state *) List.iter (fun f -> f ()) sd.msgs; Lib.add_anonymous_leaf (inSyntaxExtension (local, (sy_pa_rules,gen_sy_pp_rules))); @@ -1657,17 +1662,18 @@ let add_notation_interpretation_core ~local df env ?(impls=empty_internalization ninterp_rec_vars = to_map recvars; } in let (acvars, ac, reversibility) = interp_notation_constr env ~impls nenv c in - let interp = make_interpretation_vars recvars acvars (List.combine mainvars i_typs) in + let plevel = match level with Some (from,level,l) -> level | None (* numeral: irrelevant )*) -> 0 in + let interp = make_interpretation_vars recvars plevel acvars (List.combine mainvars i_typs) in let map (x, _) = try Some (x, Id.Map.find x interp) with Not_found -> None in let onlyparse,coe = printability level i_typs onlyparse reversibility ac in + let use = make_use false onlyparse onlyprint in let notation = { notobj_local = local; notobj_scope = scope; notobj_interp = (List.map_filter map i_vars, ac); (* Order is important here! *) - notobj_onlyparse = onlyparse; + notobj_use = use; notobj_coercion = coe; - notobj_onlyprint = onlyprint; notobj_deprecation = deprecation; notobj_notation = df'; notobj_specific_pp_rules = pp_sy; @@ -1841,8 +1847,8 @@ let add_syntactic_definition ~local deprecation env ident (vars,c) { onlyparsing } in interp_notation_constr env nenv c in - let in_pat id = (id,ETConstr (Constrexpr.InConstrEntry,None,(NextLevel,0))) in - let interp = make_interpretation_vars ~default_if_binding:AsIdentOrPattern [] acvars (List.map in_pat vars) in + let in_pat id = (id,ETConstr (Constrexpr.InConstrEntry,None,(NextLevel,InternalProd))) in + let interp = make_interpretation_vars ~default_if_binding:AsIdentOrPattern [] 0 acvars (List.map in_pat vars) in let vars = List.map (fun x -> (x, Id.Map.find x interp)) vars in let onlyparsing = onlyparsing || fst (printability None [] false reversibility pat) in Syntax_def.declare_syntactic_definition ~local deprecation ident ~onlyparsing (vars,pat) diff --git a/vernac/ppvernac.ml b/vernac/ppvernac.ml index b73e7c7515..f972e05d3b 100644 --- a/vernac/ppvernac.ml +++ b/vernac/ppvernac.ml @@ -503,9 +503,8 @@ let pr_lconstrarg c = let pr_intarg n = spc () ++ int n let pr_oc = function - | None -> str" :" - | Some true -> str" :>" - | Some false -> str" :>>" + | NoInstance -> str" :" + | BackInstance -> str" :>" let pr_record_field (x, { rf_subclass = oc ; rf_priority = pri ; rf_notation = ntn }) = let prx = match x with diff --git a/vernac/prettyp.ml b/vernac/prettyp.ml index 2b46542287..06f7c32cdc 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) (********************************) @@ -216,7 +216,7 @@ let print_polymorphism ref = (if poly then str "universe polymorphic" else if template_poly then str "template universe polymorphic " - ++ h 0 (pr_template_variables template_variables) + ++ h (pr_template_variables template_variables) else str "not universe polymorphic") ] let print_type_in_type ref = @@ -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/pvernac.ml b/vernac/pvernac.ml index f4cb1adfe8..c9f68eed57 100644 --- a/vernac/pvernac.ml +++ b/vernac/pvernac.ml @@ -10,7 +10,9 @@ open Pcoq -let uvernac = create_universe "vernac" +[@@@ocaml.warning "-3"] +let uvernac = create_universe "vernac" [@@deprecated "Deprecated in 8.13"] +[@@@ocaml.warning "+3"] type proof_mode = string @@ -35,20 +37,18 @@ let command_entry_ref = ref None module Vernac_ = struct - let gec_vernac s = Entry.create ("vernac:" ^ s) - (* The different kinds of vernacular commands *) - let gallina = gec_vernac "gallina" - let gallina_ext = gec_vernac "gallina_ext" - let command = gec_vernac "command" - let syntax = gec_vernac "syntax_command" - let vernac_control = gec_vernac "Vernac.vernac_control" - let rec_definition = gec_vernac "Vernac.rec_definition" - let red_expr = new_entry utactic "red_expr" - let hint_info = gec_vernac "hint_info" + let gallina = Entry.create "gallina" + let gallina_ext = Entry.create "gallina_ext" + let command = Entry.create "command" + let syntax = Entry.create "syntax_command" + let vernac_control = Entry.create "Vernac.vernac_control" + let rec_definition = Entry.create "Vernac.rec_definition" + let red_expr = Entry.create "red_expr" + let hint_info = Entry.create "hint_info" (* Main vernac entry *) let main_entry = Entry.create "vernac" - let noedit_mode = gec_vernac "noedit_command" + let noedit_mode = Entry.create "noedit_command" let () = let act_vernac v loc = Some v in diff --git a/vernac/pvernac.mli b/vernac/pvernac.mli index 1718024edd..8ab4af7d48 100644 --- a/vernac/pvernac.mli +++ b/vernac/pvernac.mli @@ -12,7 +12,9 @@ open Pcoq open Genredexpr open Vernacexpr -val uvernac : gram_universe +[@@@ocaml.warning "-3"] +val uvernac : gram_universe [@@deprecated "Deprecated in 8.13"] +[@@@ocaml.warning "+3"] type proof_mode diff --git a/vernac/record.ml b/vernac/record.ml index d0036e40f9..e362cb052a 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) @@ -518,7 +518,7 @@ let implicits_of_context ctx = (List.rev (Anonymous :: (List.map RelDecl.get_name ctx))) let declare_class def cumulative ubinders univs id idbuild paramimpls params univ arity - template fieldimpls fields ?(kind=Decls.StructureComponent) coers priorities = + template fieldimpls fields ?(kind=Decls.StructureComponent) coers = let fieldimpls = (* Make the class implicit in the projections, and the params if applicable. *) let impls = implicits_of_context params in @@ -556,26 +556,27 @@ let declare_class def cumulative ubinders univs id idbuild paramimpls params uni Impargs.declare_manual_implicits false cref paramimpls; Impargs.declare_manual_implicits false (GlobRef.ConstRef proj_cst) (List.hd fieldimpls); Classes.set_typeclass_transparency (EvalConstRef cst) false false; - let sub = match List.hd coers with - | Some b -> Some ((if b then Backward else Forward), List.hd priorities) - | None -> None - in - [cref, [Name proj_name, sub, Some proj_cst]] + let sub = List.hd coers in + let m = { + meth_name = Name proj_name; + meth_info = sub; + meth_const = Some proj_cst; + } in + [cref, [m]] | _ -> let record_data = [id, idbuild, univ, arity, fieldimpls, fields, false, List.map (fun _ -> { pf_subclass = false ; pf_canonical = true }) fields] in let inds = declare_structure ~cumulative Declarations.BiFinite ubinders univs paramimpls params template ~kind:Decls.Method ~name:[|binder_name|] record_data in - let coers = List.map2 (fun coe pri -> - Option.map (fun b -> - if b then Backward, pri else Forward, pri) coe) - coers priorities - in let map ind = - let l = List.map3 (fun decl b y -> RelDecl.get_name decl, b, y) - (List.rev fields) coers (Recordops.lookup_projections ind) - in GlobRef.IndRef ind, l + let map decl b y = { + meth_name = RelDecl.get_name decl; + meth_info = b; + meth_const = y; + } in + let l = List.map3 map (List.rev fields) coers (Recordops.lookup_projections ind) in + GlobRef.IndRef ind, l in List.map map inds in @@ -731,16 +732,21 @@ let definition_structure udecl kind ~template ~cumulative ~poly finite records = | [r], [d] -> r, d | _, _ -> CErrors.user_err (str "Mutual definitional classes are not handled") in - let priorities = List.map (fun (_, { rf_priority }) -> {hint_priority = rf_priority ; hint_pattern = None}) cfs in - let coers = List.map (fun (_, { rf_subclass }) -> rf_subclass) cfs in + let coers = List.map (fun (_, { rf_subclass=coe; rf_priority=pri }) -> + match coe with + | Vernacexpr.BackInstance -> Some {hint_priority = pri ; hint_pattern = None} + | Vernacexpr.NoInstance -> None) + cfs + in declare_class def cumulative ubinders univs id.CAst.v idbuild - implpars params univ arity template implfs fields coers priorities + implpars params univ arity template implfs fields coers | _ -> let map impls = implpars @ [CAst.make None] @ impls in let data = List.map (fun (univ, arity, implfs, fields) -> (univ, arity, List.map map implfs, fields)) data in let map (univ, arity, implfs, fields) (is_coe, id, _, cfs, idbuild, _) = let coe = List.map (fun (_, { rf_subclass ; rf_canonical }) -> - { pf_subclass = not (Option.is_empty rf_subclass); + { pf_subclass = + (match rf_subclass with Vernacexpr.BackInstance -> true | Vernacexpr.NoInstance -> false); pf_canonical = rf_canonical }) cfs in diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index 994592a88a..cd0dd5e9a6 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -43,4 +43,5 @@ Topfmt Loadpath ComArguments Vernacentries +ComTactic Vernacinterp diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index d540e7f93d..0d3f38d139 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 = @@ -770,7 +776,7 @@ let vernac_inductive ~atts kind indl = | _ -> CErrors.user_err Pp.(str "Definitional classes do not support the \"|\" syntax.") in let (coe, (lid, ce)) = l in - let coe' = if coe then Some true else None in + let coe' = if coe then BackInstance else NoInstance in let f = AssumExpr ((make ?loc:lid.loc @@ Name lid.v), ce), { rf_subclass = coe' ; rf_priority = None ; rf_notation = [] ; rf_canonical = true } in vernac_record ~template udecl ~cumulative (Class true) ~poly finite [id, bl, c, None, [f]] @@ -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 @@ -1640,7 +1646,7 @@ let query_command_selector ?loc = function | _ -> user_err ?loc ~hdr:"query_command_selector" (str "Query commands only support the single numbered goal selector.") -let vernac_check_may_eval ~pstate ~atts redexp glopt rc = +let vernac_check_may_eval ~pstate redexp glopt rc = let glopt = query_command_selector glopt in let sigma, env = get_current_context_of_args ~pstate glopt in let sigma, c = Constrintern.interp_open_constr ~expected_type:Pretyping.UnknownIfTermOrType env sigma rc in @@ -1740,7 +1746,7 @@ let print_about_hyp_globs ~pstate ?loc ref_or_by_not udecl glopt = let sigma, env = get_current_or_global_context ~pstate in Prettyp.print_about env sigma ref_or_by_not udecl -let vernac_print ~pstate ~atts = +let vernac_print ~pstate = let sigma, env = get_current_or_global_context ~pstate in function | PrintTypingFlags -> pr_typing_flags (Environ.typing_flags (Global.env ())) @@ -1784,11 +1790,11 @@ let vernac_print ~pstate ~atts = | PrintHintDbName s -> Hints.pr_hint_db_by_name env sigma s | PrintHintDb -> Hints.pr_searchtable env sigma | PrintScopes -> - Notation.pr_scopes (Constrextern.without_symbols (pr_lglob_constr_env env)) + Notation.pr_scopes (Constrextern.without_symbols (pr_glob_constr_env env)) | PrintScope s -> - Notation.pr_scope (Constrextern.without_symbols (pr_lglob_constr_env env)) s + Notation.pr_scope (Constrextern.without_symbols (pr_glob_constr_env env)) s | PrintVisibility s -> - Notation.pr_visibility (Constrextern.without_symbols (pr_lglob_constr_env env)) s + Notation.pr_visibility (Constrextern.without_symbols (pr_glob_constr_env env)) s | PrintAbout (ref_or_by_not,udecl,glnumopt) -> print_about_hyp_globs ~pstate ref_or_by_not udecl glnumopt | PrintImplicit qid -> @@ -1824,7 +1830,7 @@ let vernac_locate ~pstate = let open Constrexpr in function | LocateTerm {v=ByNotation (ntn, sc)} -> let _, env = get_current_or_global_context ~pstate in Notation.locate_notation - (Constrextern.without_symbols (pr_lglob_constr_env env)) ntn sc + (Constrextern.without_symbols (pr_glob_constr_env env)) ntn sc | LocateLibrary qid -> print_located_library qid | LocateModule qid -> Prettyp.print_located_module qid | LocateOther (s, qid) -> Prettyp.print_located_other s qid @@ -2201,8 +2207,9 @@ let translate_vernac ~atts v = let open Vernacextend in match v with vernac_print_option key) | VernacCheckMayEval (r,g,c) -> VtReadProofOpt(fun ~pstate -> + unsupported_attributes atts; Feedback.msg_notice @@ - vernac_check_may_eval ~pstate ~atts r g c) + vernac_check_may_eval ~pstate r g c) | VernacDeclareReduction (s,r) -> VtDefault(fun () -> with_locality ~atts vernac_declare_reduction s r) @@ -2212,13 +2219,15 @@ let translate_vernac ~atts v = let open Vernacextend in match v with Feedback.msg_notice @@ vernac_global_check c) | VernacPrint p -> VtReadProofOpt(fun ~pstate -> - Feedback.msg_notice @@ vernac_print ~pstate ~atts p) + unsupported_attributes atts; + Feedback.msg_notice @@ vernac_print ~pstate p) | VernacSearch (s,g,r) -> VtReadProofOpt( unsupported_attributes atts; vernac_search ~atts s g r) - | VernacLocate l -> unsupported_attributes atts; + | VernacLocate l -> VtReadProofOpt(fun ~pstate -> + unsupported_attributes atts; Feedback.msg_notice @@ vernac_locate ~pstate l) | VernacRegister (qid, r) -> VtNoProof(fun () -> diff --git a/vernac/vernacexpr.ml b/vernac/vernacexpr.ml index d8e17d00e3..eeebb43114 100644 --- a/vernac/vernacexpr.ml +++ b/vernac/vernacexpr.ml @@ -106,8 +106,7 @@ type search_restriction = type verbose_flag = bool (* true = Verbose; false = Silent *) type coercion_flag = bool (* true = AddCoercion false = NoCoercion *) -type instance_flag = bool option - (* Some true = Backward instance; Some false = Forward instance, None = NoInstance *) +type instance_flag = BackInstance | NoInstance type export_flag = bool (* true = Export; false = Import *) diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index 496b1a43d1..ed63332861 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -30,7 +30,6 @@ type vernac_classification = | VtQed of vernac_qed_type (* A proof step *) | VtProofStep of { - parallel : [ `Yes of solving_tac * anon_abstracting_tac | `No ]; proof_block_detection : proof_block_name option } (* Queries are commands assumed to be "pure", that is to say, they @@ -124,7 +123,7 @@ let declare_vernac_classifier name f = let classify_as_query = VtQuery let classify_as_sideeff = VtSideff ([], VtLater) -let classify_as_proofstep = VtProofStep { parallel = `No; proof_block_detection = None} +let classify_as_proofstep = VtProofStep { proof_block_detection = None} type (_, _) ty_sig = | TyNil : (vernac_command, vernac_classification) ty_sig @@ -247,7 +246,7 @@ let vernac_argument_extend ~name arg = let () = Pcoq.register_grammar wit e in e | Arg_rules rules -> - let e = Pcoq.create_generic_entry Pcoq.utactic name (Genarg.rawwit wit) in + let e = Pcoq.create_generic_entry2 name (Genarg.rawwit wit) in let () = Pcoq.grammar_extend e {Pcoq.pos=None; data=[(None, None, rules)]} in e in diff --git a/vernac/vernacextend.mli b/vernac/vernacextend.mli index 5ef137cfc0..e1e3b4cfe5 100644 --- a/vernac/vernacextend.mli +++ b/vernac/vernacextend.mli @@ -46,7 +46,6 @@ type vernac_classification = | VtQed of vernac_qed_type (* A proof step *) | VtProofStep of { - parallel : [ `Yes of solving_tac * anon_abstracting_tac | `No ]; proof_block_detection : proof_block_name option } (* Queries are commands assumed to be "pure", that is to say, they 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 |