diff options
391 files changed, 6598 insertions, 3959 deletions
diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index 56f48aaa4f..9e2af04e28 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -14,7 +14,7 @@ /configure* @coq/legacy-build-maintainers @coq/build-maintainers -/META.coq.in @coq/legacy-build-maintainers +/META.coq-core.in @coq/legacy-build-maintainers ########## CI infrastructure ########## diff --git a/.github/PULL_REQUEST_TEMPLATE.md b/.github/PULL_REQUEST_TEMPLATE.md index 3bd3342329..df9e14b178 100644 --- a/.github/PULL_REQUEST_TEMPLATE.md +++ b/.github/PULL_REQUEST_TEMPLATE.md @@ -17,3 +17,5 @@ Fixes / closes #???? <!-- (Otherwise, remove these lines.) --> - [ ] Corresponding documentation was added / updated (including any warning and error messages added / removed / modified). - [ ] Entry added in the changelog (see https://github.com/coq/coq/tree/master/doc/changelog#unreleased-changelog for details). +- [ ] Overlay pull requests (if this breaks 3rd party developments in CI, see +https://github.com/coq/coq/blob/master/dev/ci/user-overlays/README.md for details) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index f5527192e0..7ec3ba1bd7 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -63,18 +63,18 @@ jobs: MACOSX_DEPLOYMENT_TARGET: "10.11" NJOBS: "2" + - name: Install Coq + run: | + make install install-byte + - name: Run Coq Test Suite run: | eval $(opam env) - export OCAMLPATH=$(pwd):"$OCAMLPATH" + export OCAMLPATH="$(pwd)/_install_ci/lib":"$OCAMLPATH" make -j "$NJOBS" test-suite PRINT_LOGS=1 env: NJOBS: "2" - - name: Install Coq - run: | - make install - - name: Create the dmg bundle run: | eval $(opam env) diff --git a/.gitignore b/.gitignore index aab1d1ede7..bf7430cc2e 100644 --- a/.gitignore +++ b/.gitignore @@ -152,6 +152,7 @@ plugins/ssr/ssrvernac.ml kernel/byterun/coq_instruct.h kernel/byterun/coq_jumptbl.h +kernel/byterun/coq_arity.h kernel/genOpcodeFiles.exe kernel/vmopcodes.ml kernel/uint63.ml @@ -183,6 +184,7 @@ plugins/ssr/ssrvernac.ml # ocaml dev files .merlin META.coq +META.coq-core # Files automatically generated by Dune. *.install diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 754c09776e..ce6be777f3 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -20,7 +20,7 @@ variables: # Format: $IMAGE-V$DATE-$hash # The $hash is the first 10 characters of the md5 of the Dockerfile. e.g. # echo $(md5sum dev/ci/docker/bionic_coq/Dockerfile | head -c 10) - CACHEKEY: "bionic_coq-V2020-12-25-95a34df128" + CACHEKEY: "bionic_coq-V2021-02-11-b601de5a7b" IMAGE: "$CI_REGISTRY_IMAGE:$CACHEKEY" # By default, jobs run in the base switch; override to select another switch OPAM_SWITCH: "base" @@ -260,7 +260,7 @@ before_script: stage: stage-1 interruptible: true variables: - PLATFORM: "https://github.com/coq/platform/archive/master.zip" + PLATFORM: "https://github.com/coq/platform/archive/dev-ci.zip" artifacts: name: "$CI_JOB_NAME" paths: @@ -351,6 +351,9 @@ windows64: - call dev/ci/platform-windows.bat tags: - windows-inria + only: + variables: + - $WINDOWS =~ /enabled/ lint: stage: stage-1 @@ -372,7 +375,8 @@ pkg:opam: # OPAM will build out-of-tree so no point in importing artifacts script: - set -e - - opam pin add --kind=path coq.dev . + - opam pin add --kind=path coq-core.dev . + - opam pin add --kind=path coq-stdlib.dev . - opam pin add --kind=path coqide-server.dev . - opam pin add --kind=path coqide.dev . - set +e @@ -702,7 +706,11 @@ library:ci-engine_bench: extends: .ci-template library:ci-fcsl_pcm: - extends: .ci-template + extends: .ci-template-flambda + stage: stage-3 + needs: + - build:edge+flambda + - library:ci-mathcomp library:ci-fiat_crypto: extends: .ci-template-flambda @@ -777,6 +785,10 @@ plugin:ci-gappa: library:ci-geocoq: extends: .ci-template-flambda + stage: stage-3 + needs: + - build:edge+flambda + - library:ci-mathcomp library:ci-hott: extends: .ci-template @@ -816,6 +828,13 @@ library:ci-vst: - build:edge+flambda - library:ci-flocq +library:ci-deriving: + extends: .ci-template-flambda + stage: stage-3 + needs: + - build:edge+flambda + - library:ci-mathcomp + # Plugins are by definition the projects that depend on Coq's ML API plugin:ci-aac_tactics: @@ -828,7 +847,7 @@ plugin:ci-coq_dpdgraph: extends: .ci-template plugin:ci-coqhammer: - extends: .ci-template + extends: .ci-template-flambda plugin:ci-elpi: extends: .ci-template @@ -867,6 +886,10 @@ plugin:plugin-tutorial: plugin:ci-quickchick: extends: .ci-template-flambda + stage: stage-3 + needs: + - build:edge+flambda + - library:ci-mathcomp plugin:ci-reduction_effects: extends: .ci-template @@ -22,6 +22,7 @@ Yves Bertot <yves.bertot@inria.fr> Yves Bertot <bertot@inria.fr> Yves Bertot <yves.bertot@inria.fr> Yves Bertot <Yves.Bertot@inria.fr> Yves Bertot <yves.bertot@inria.fr> Yves Bertot <bertot@nardis.inria.fr> Frédéric Besson <frederic.besson@inria.fr> fbesson <fbesson@85f007b7-540e-0410-9357-904b9bb8a0f7> +Frédéric Besson <frederic.besson@inria.fr> BESSON Frederic <frederic.besson@inria.fr> Siddharth Bhat <siddu.druid@gmail.com> Siddharth <siddu.druid@gmail.com> Lasse Blaauwbroek <lasse@blaauwbroek.eu> Lasse Blaauwbroek <lasse@lasse-work.localdomain> Simon Boulier <simon.boulier@ens-rennes.fr> SimonBoulier <simon.boulier@ens-rennes.fr> @@ -72,6 +73,7 @@ Vincent Gross <vgross@gforge> vgross <vgross@85f007b7-540e- Huang Guan-Shieng <huang@gforge> huang <huang@85f007b7-540e-0410-9357-904b9bb8a0f7> Hugo Herbelin <Hugo.Herbelin@inria.fr> herbelin <herbelin@85f007b7-540e-0410-9357-904b9bb8a0f7> Hugo Herbelin <Hugo.Herbelin@inria.fr> Hugo Herbelin <herbelin@users.noreply.github.com> +Wolf Honore <wolfhonore@gmail.com> whonore <wolfhonore@gmail.com> Jasper Hugunin <jasperh@cs.washington.edu> Jasper Hugunin <jasper@hashplex.com> Tom Hutchinson <thutchin@gforge> thutchin <thutchin@85f007b7-540e-0410-9357-904b9bb8a0f7> Cezary Kaliszyk <cek@gforge> cek <cek@85f007b7-540e-0410-9357-904b9bb8a0f7> @@ -91,7 +93,6 @@ Larry Darryl Lee Jr. <llee454@gmail.com> llee454@gmail.com <llee454@gm Xavier Leroy <xavier.leroy@college-de-france.fr> Xavier Leroy <xavier.leroy@inria.fr> Pierre Letouzey <pierre.letouzey@inria.fr> letouzey <letouzey@85f007b7-540e-0410-9357-904b9bb8a0f7> Pierre Letouzey <pierre.letouzey@inria.fr> letouzey <pierre.letouzey@inria.fr> -Xia Li-yao <lysxia@gmail.com> Lysxia <lysxia@gmail.com> Yishuai Li <yishuai@cis.upenn.edu> Yishuai Li <yishuai@upenn.edu> Assia Mahboubi <assia.mahboubi@inria.fr> amahboub <amahboub@85f007b7-540e-0410-9357-904b9bb8a0f7> Kenji Maillard <kenji.maillard@inria.fr> Kenji Maillard <kenji@maillard.blue> @@ -154,6 +155,9 @@ Laurent Théry <laurent.thery@inria.fr> Laurent Théry <thery@sophia Laurent Théry <laurent.thery@inria.fr> thery <Laurent.Thery@inria.fr> Anton Trunov <anton.a.trunov@gmail.com> Anton Trunov <anton.trunov@imdea.org> Benjamin Werner <werner@gforge> werner <werner@85f007b7-540e-0410-9357-904b9bb8a0f7> +Li-yao Xia <lysxia@gmail.com> Lysxia <lysxia@gmail.com> +Li-yao Xia <lysxia@gmail.com> Xia Li-yao <lysxia@gmail.com> +Li-yao Xia <lysxia@gmail.com> Xia Li-yao <Lysxia@users.noreply.github.com> Wang Zhuyang <hawnzug@gmail.com> hawnzug <hawnzug@gmail.com> Beta Ziliani <beta@mpi-sws.org> Beta Ziliani <bziliani@famaf.unc.edu.ar> Beta Ziliani <beta@mpi-sws.org> beta <beta@mpi-sws.org> diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index a96b93154c..361270ff32 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -643,7 +643,7 @@ reviewers, with specific requests. - [needs: benchmarking][needs-benchmarking] and [needs: testing][needs-testing] indicate the PR needs testing beyond what the test suite can handle. For example, performance benchmarking is currently performed with a different - infrastructure ([documented in the wiki][jenkins-doc]). Unless some followup + infrastructure ([documented in the wiki][Benchmarking]). Unless some followup is specifically requested, you aren't expected to do this additional testing. More generally, such labels should come with a description that should @@ -1007,7 +1007,7 @@ to prepare overlays, and propose a simplified and documented procedure. We also have a benchmarking infrastructure, which is documented [on -the wiki][jenkins-doc]. +the wiki][Benchmarking]. ##### Restarting failed jobs ##### @@ -1225,6 +1225,7 @@ can be found [on the wiki][wiki-CUDW]. [add-contributor]: https://github.com/orgs/coq/teams/contributors/members?add=true [api-doc]: https://coq.github.io/doc/master/api/ +[Benchmarking]: https://github.com/coq/coq/wiki/Benchmarking [CEP]: https://github.com/coq/ceps [check-owners]: dev/tools/check-owners-pr.sh [CI-README-developers]: dev/ci/README-developers.md @@ -1272,7 +1273,6 @@ can be found [on the wiki][wiki-CUDW]. [GitLab-coq]: https://gitlab.com/coq [GitLab-doc]: https://docs.gitlab.com/ [JasonGross-coq-tools]: https://github.com/JasonGross/coq-tools -[jenkins-doc]: https://github.com/coq/coq/wiki/Jenkins-(automated-benchmarking) [kind-documentation]: https://github.com/coq/coq/issues?q=is%3Aopen+is%3Aissue+label%3A%22kind%3A+documentation%22 [master-doc]: https://coq.github.io/doc/master/refman/ [merge-pr]: dev/tools/merge-pr.sh diff --git a/META.coq.in b/META.coq-core.in index 7a9818da08..c58513979d 100644 --- a/META.coq.in +++ b/META.coq-core.in @@ -35,7 +35,7 @@ package "lib" ( directory = "lib" - requires = "coq.clib, coq.config, dynlink" + requires = "coq-core.clib, coq-core.config, dynlink" archive(byte) = "lib.cma" archive(native) = "lib.cmxa" @@ -68,7 +68,7 @@ package "kernel" ( directory = "kernel" - requires = "coq.lib, coq.vm" + requires = "coq-core.lib, coq-core.vm" archive(byte) = "kernel.cma" archive(native) = "kernel.cmxa" @@ -80,7 +80,7 @@ package "library" ( description = "Coq Libraries (vo) support" version = "8.14" - requires = "coq.kernel" + requires = "coq-core.kernel" directory = "library" @@ -94,7 +94,7 @@ package "engine" ( description = "Coq Tactic Engine" version = "8.14" - requires = "coq.library" + requires = "coq-core.library" directory = "engine" archive(byte) = "engine.cma" @@ -107,7 +107,7 @@ package "pretyping" ( description = "Coq Pretyper" version = "8.14" - requires = "coq.engine" + requires = "coq-core.engine" directory = "pretyping" archive(byte) = "pretyping.cma" @@ -120,7 +120,7 @@ package "interp" ( description = "Coq Term Interpretation" version = "8.14" - requires = "zarith, coq.pretyping" + requires = "zarith, coq-core.pretyping" directory = "interp" archive(byte) = "interp.cma" @@ -133,7 +133,7 @@ package "proofs" ( description = "Coq Proof Engine" version = "8.14" - requires = "coq.interp" + requires = "coq-core.interp" directory = "proofs" archive(byte) = "proofs.cma" @@ -146,7 +146,7 @@ package "gramlib" ( description = "Coq Grammar Engine" version = "8.14" - requires = "coq.lib" + requires = "coq-core.lib" directory = "gramlib/.pack" archive(byte) = "gramlib.cma" @@ -158,7 +158,7 @@ package "parsing" ( description = "Coq Parsing Engine" version = "8.14" - requires = "coq.gramlib, coq.proofs" + requires = "coq-core.gramlib, coq-core.proofs" directory = "parsing" archive(byte) = "parsing.cma" @@ -171,7 +171,7 @@ package "printing" ( description = "Coq Printing Engine" version = "8.14" - requires = "coq.parsing" + requires = "coq-core.parsing" directory = "printing" archive(byte) = "printing.cma" @@ -184,7 +184,7 @@ package "tactics" ( description = "Coq Basic Tactics" version = "8.14" - requires = "coq.printing" + requires = "coq-core.printing" directory = "tactics" archive(byte) = "tactics.cma" @@ -197,7 +197,7 @@ package "vernac" ( description = "Coq Vernacular Interpreter" version = "8.14" - requires = "coq.tactics" + requires = "coq-core.tactics" directory = "vernac" archive(byte) = "vernac.cma" @@ -210,7 +210,7 @@ package "stm" ( description = "Coq State Transaction Machine" version = "8.14" - requires = "coq.sysinit" + requires = "coq-core.sysinit" directory = "stm" archive(byte) = "stm.cma" @@ -223,7 +223,7 @@ package "sysinit" ( description = "Coq initialization" version = "8.14" - requires = "coq.vernac" + requires = "coq-core.vernac" directory = "sysinit" archive(byte) = "sysinit.cma" @@ -236,7 +236,7 @@ package "toplevel" ( description = "Coq Toplevel" version = "8.14" - requires = "coq.stm" + requires = "coq-core.stm" directory = "toplevel" archive(byte) = "toplevel.cma" @@ -249,7 +249,7 @@ package "idetop" ( description = "Coq IDE Libraries" version = "8.14" - requires = "coq.toplevel" + requires = "coq-core.toplevel" directory = "ide" archive(byte) = "coqidetop.cma" @@ -262,7 +262,7 @@ package "ide" ( description = "Coq IDE Libraries" version = "8.14" - requires = "coq.lib, coq.ideprotocol, lablgtk3, lablgtk3-sourceview3" + requires = "coq-core.lib, coq-core.ideprotocol, lablgtk3, lablgtk3-sourceview3" directory = "ide" archive(byte) = "ide.cma" @@ -275,7 +275,7 @@ package "ideprotocol" ( description = "Coq IDE protocol" version = "8.14" - requires = "coq.toplevel" + requires = "coq-core.toplevel" directory = "ide/protocol" archive(byte) = "ideprotocol.cma" @@ -295,7 +295,7 @@ package "plugins" ( description = "Coq LTAC Plugin" version = "8.14" - requires = "coq.stm" + requires = "coq-core.stm" directory = "ltac" archive(byte) = "ltac_plugin.cmo" @@ -310,7 +310,7 @@ package "plugins" ( description = "Coq tauto plugin" version = "8.14" - requires = "coq.plugins.ltac" + requires = "coq-core.plugins.ltac" directory = "ltac" archive(byte) = "tauto_plugin.cmo" @@ -325,7 +325,7 @@ package "plugins" ( description = "Coq omega plugin" version = "8.14" - requires = "coq.plugins.ltac" + requires = "coq-core.plugins.ltac" directory = "omega" archive(byte) = "omega_plugin.cmo" @@ -340,7 +340,7 @@ package "plugins" ( description = "Coq micromega plugin" version = "8.14" - requires = "coq.plugins.ltac" + requires = "coq-core.plugins.ltac" directory = "micromega" archive(byte) = "micromega_plugin.cmo" @@ -355,7 +355,7 @@ package "plugins" ( description = "Coq Zify plugin" version = "8.14" - requires = "coq.plugins.ltac" + requires = "coq-core.plugins.ltac" directory = "micromega" archive(byte) = "zify_plugin.cmo" @@ -385,7 +385,7 @@ package "plugins" ( description = "Coq extraction plugin" version = "8.14" - requires = "coq.plugins.ltac" + requires = "coq-core.plugins.ltac" directory = "extraction" archive(byte) = "extraction_plugin.cmo" @@ -400,7 +400,7 @@ package "plugins" ( description = "Coq cc plugin" version = "8.14" - requires = "coq.plugins.ltac" + requires = "coq-core.plugins.ltac" directory = "cc" archive(byte) = "cc_plugin.cmo" @@ -415,7 +415,7 @@ package "plugins" ( description = "Coq ground plugin" version = "8.14" - requires = "coq.plugins.ltac" + requires = "coq-core.plugins.ltac" directory = "firstorder" archive(byte) = "ground_plugin.cmo" @@ -430,7 +430,7 @@ package "plugins" ( description = "Coq rtauto plugin" version = "8.14" - requires = "coq.plugins.ltac" + requires = "coq-core.plugins.ltac" directory = "rtauto" archive(byte) = "rtauto_plugin.cmo" @@ -445,7 +445,7 @@ package "plugins" ( description = "Coq btauto plugin" version = "8.14" - requires = "coq.plugins.ltac" + requires = "coq-core.plugins.ltac" directory = "btauto" archive(byte) = "btauto_plugin.cmo" @@ -460,7 +460,7 @@ package "plugins" ( description = "Coq recdef plugin" version = "8.14" - requires = "coq.plugins.extraction" + requires = "coq-core.plugins.extraction" directory = "funind" archive(byte) = "recdef_plugin.cmo" @@ -475,7 +475,7 @@ package "plugins" ( description = "Coq nsatz plugin" version = "8.14" - requires = "zarith, coq.plugins.ltac" + requires = "zarith, coq-core.plugins.ltac" directory = "nsatz" archive(byte) = "nsatz_plugin.cmo" @@ -500,27 +500,12 @@ package "plugins" ( plugin(native) = "r_syntax_plugin.cmxs" ) - package "int63syntax" ( - - description = "Coq int63syntax plugin" - version = "8.14" - - requires = "" - directory = "syntax" - - archive(byte) = "int63_syntax_plugin.cmo" - archive(native) = "int63_syntax_plugin.cmx" - - plugin(byte) = "int63_syntax_plugin.cmo" - plugin(native) = "int63_syntax_plugin.cmxs" - ) - package "string_notation" ( description = "Coq string_notation plugin" version = "8.14" - requires = "coq.vernac" + requires = "coq-core.vernac" directory = "syntax" archive(byte) = "string_notation_plugin.cmo" @@ -534,7 +519,7 @@ package "plugins" ( description = "Coq numeral notation plugin" version = "8.14" - requires = "coq.vernac" + requires = "coq-core.vernac" directory = "numeral_notation" archive(byte) = "numeral_notation_plugin.cmo" @@ -564,7 +549,7 @@ package "plugins" ( description = "Coq ssrmatching plugin" version = "8.14" - requires = "coq.plugins.ltac" + requires = "coq-core.plugins.ltac" directory = "ssrmatching" archive(byte) = "ssrmatching_plugin.cmo" @@ -579,7 +564,7 @@ package "plugins" ( description = "Coq ssreflect plugin" version = "8.14" - requires = "coq.plugins.ssrmatching" + requires = "coq-core.plugins.ssrmatching" directory = "ssr" archive(byte) = "ssreflect_plugin.cmo" @@ -594,7 +579,7 @@ package "plugins" ( description = "Coq Ltac2 Plugin" version = "8.14" - requires = "coq.plugins.ltac" + requires = "coq-core.plugins.ltac" directory = "../user-contrib/Ltac2" archive(byte) = "ltac2_plugin.cmo" diff --git a/Makefile.build b/Makefile.build index b307bde5df..d619fd3c85 100644 --- a/Makefile.build +++ b/Makefile.build @@ -367,6 +367,10 @@ kernel/byterun/coq_jumptbl.h: kernel/genOpcodeFiles.exe $(SHOW)'WRITE $@' $(HIDE)$< jump > $@ +kernel/byterun/coq_arity.h: kernel/genOpcodeFiles.exe + $(SHOW)'WRITE $@' + $(HIDE)$< arity > $@ + kernel/vmopcodes.ml: kernel/genOpcodeFiles.exe $(SHOW)'WRITE $@' $(HIDE)$< copml > $@ diff --git a/Makefile.ci b/Makefile.ci index d549ed1b39..f7c2943cc2 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -24,6 +24,7 @@ CI_TARGETS= \ ci-coq_performance_tests \ ci-coq_tools \ ci-coqprime \ + ci-deriving \ ci-elpi \ ci-engine_bench \ ci-ext_lib \ @@ -74,6 +75,7 @@ ci-color: ci-bignums ci-coqprime: ci-bignums ci-coquelicot: ci-mathcomp +ci-deriving: ci-mathcomp ci-math_classes: ci-bignums ci-corn: ci-math_classes @@ -86,9 +88,12 @@ ci-fiat_crypto_ocaml: ci-fiat_crypto ci-interval: ci-mathcomp ci-flocq ci-coquelicot ci-bignums ci-fourcolor: ci-mathcomp ci-oddorder: ci-mathcomp +ci-fcsl_pcm: ci-mathcomp + +ci-geocoq: ci-mathcomp ci-simple_io: ci-ext_lib -ci-quickchick: ci-ext_lib ci-simple_io +ci-quickchick: ci-ext_lib ci-simple_io ci-mathcomp ci-metacoq: ci-equations diff --git a/Makefile.common b/Makefile.common index 415454df79..dc40413078 100644 --- a/Makefile.common +++ b/Makefile.common @@ -149,7 +149,6 @@ CCCMO:=plugins/cc/cc_plugin.cmo BTAUTOCMO:=plugins/btauto/btauto_plugin.cmo RTAUTOCMO:=plugins/rtauto/rtauto_plugin.cmo SYNTAXCMO:=$(addprefix plugins/syntax/, \ - int63_syntax_plugin.cmo \ float_syntax_plugin.cmo \ number_string_notation_plugin.cmo) DERIVECMO:=plugins/derive/derive_plugin.cmo diff --git a/Makefile.dune b/Makefile.dune index c2899dcaba..c338405f2c 100644 --- a/Makefile.dune +++ b/Makefile.dune @@ -56,7 +56,8 @@ help-install: @echo "" @echo " Provided opam/dune packages are:" @echo "" - @echo " - coq: base Coq package, toplevel compilers, tools, stdlib, no GTK" + @echo " - coq-core: base Coq package, toplevel compilers, plugins, tools, no stdlib, no GTK" + @echo " - coq-stdlib: Coq's standard library" @echo " - coqide-server: XML protocol language server" @echo " - coqide: CoqIDE gtk application" @echo "" @@ -82,7 +83,7 @@ voboot: states: dune build $(DUNEOPT) dev/shim/coqtop-prelude -NONDOC_INSTALL_TARGETS:=coq.install coqide-server.install coqide.install +NONDOC_INSTALL_TARGETS:=coq-core.install coq-stdlib.install coqide-server.install coqide.install world: dune build $(DUNEOPT) $(NONDOC_INSTALL_TARGETS) diff --git a/Makefile.install b/Makefile.install index 4977bb38e1..0dd4c1bc24 100644 --- a/Makefile.install +++ b/Makefile.install @@ -162,8 +162,9 @@ install-latex: $(INSTALLLIB) tools/coqdoc/coqdoc.sty $(FULLCOQDOCDIR) # -$(UPDATETEX) -install-meta: META.coq - $(INSTALLLIB) META.coq $(FULLCOQLIB)/META +install-meta: META.coq-core + $(INSTALLLIB) META.coq-core $(FULLCOQLIB)/META + cd $(FULLCOQLIB)/.. && rm -f coq-core && ln -s coq coq-core # For emacs: # Local Variables: diff --git a/Makefile.make b/Makefile.make index 2f6781439c..9f0e06dffc 100644 --- a/Makefile.make +++ b/Makefile.make @@ -109,7 +109,7 @@ GENGRAMMLFILES := $(GRAMMLFILES) gramlib/.pack/gramlib.ml # why is gramlib.ml no GENMLGFILES:= $(MLGFILES:.mlg=.ml) GENMLFILES:=$(LEXFILES:.mll=.ml) $(YACCFILES:.mly=.ml) $(GENMLGFILES) $(GENGRAMMLFILES) ide/coqide/coqide_os_specific.ml kernel/vmopcodes.ml kernel/uint63.ml kernel/float64.ml GENMLIFILES:=$(GRAMMLIFILES) -GENHFILES:=kernel/byterun/coq_instruct.h kernel/byterun/coq_jumptbl.h +GENHFILES:=$(addprefix kernel/byterun/, coq_instruct.h coq_jumptbl.h coq_arity.h) GENFILES:=$(GENMLFILES) $(GENMLIFILES) $(GENHFILES) kernel/genOpcodeFiles.exe COQ_EXPORTED += GRAMFILES GRAMMLFILES GRAMMLIFILES GENMLFILES GENHFILES GENFILES @@ -187,10 +187,10 @@ Makefile $(wildcard Makefile.*) config/Makefile : ; ########################################################################### # OCaml dev files ########################################################################### -camldevfiles: $(MERLINFILES) META.coq +camldevfiles: $(MERLINFILES) META.coq-core # prevent submake dependency -META.coq.in $(MERLININFILES): ; +META.coq-core.in $(MERLININFILES): ; .merlin: .merlin.in cp -a "$<" "$@" @@ -198,7 +198,7 @@ META.coq.in $(MERLININFILES): ; %/.merlin: %/.merlin.in cp -a "$<" "$@" -META.coq: META.coq.in +META.coq-core: META.coq-core.in cp -a "$<" "$@" ########################################################################### @@ -222,7 +222,7 @@ cruftclean: mlgclean rm -f gmon.out core camldevfilesclean: - rm -f $(MERLINFILES) META.coq + rm -f $(MERLINFILES) META.coq-core indepclean: rm -f $(GENFILES) @@ -274,7 +274,7 @@ depclean: find . $(FIND_SKIP_DIRS) '(' -name '*.d' ')' -exec rm -f {} + cacheclean: - find theories test-suite -name '.*.aux' -exec rm -f {} + + find theories user-contrib test-suite -name '.*.aux' -exec rm -f {} + cleanconfig: rm -f config/Makefile config/coq_config.ml dev/ocamldebug-coq config/Info-*.plist @@ -282,12 +282,12 @@ cleanconfig: distclean: clean cleanconfig cacheclean timingclean voclean: - find theories plugins test-suite \( -name '*.vo' -o -name '*.vio' -o -name '*.vos' -o -name '*.vok' -o -name '*.glob' -o -name "*.cmxs" \ + find theories plugins user-contrib test-suite \( -name '*.vo' -o -name '*.vio' -o -name '*.vos' -o -name '*.vok' -o -name '*.glob' -o -name "*.cmxs" \ -o -name "*.native" -o -name "*.cmx" -o -name "*.cmi" -o -name "*.o" \) -exec rm -f {} + - find theories plugins test-suite -name .coq-native -empty -exec rm -rf {} + + find theories plugins user-contrib test-suite -name .coq-native -empty -exec rm -rf {} + timingclean: - find theories plugins test-suite \( -name '*.v.timing' -o -name '*.v.before-timing' \ + find theories plugins user-contrib test-suite \( -name '*.v.timing' -o -name '*.v.before-timing' \ -o -name "*.v.after-timing" -o -name "*.v.timing.diff" -o -name "time-of-build.log" \ -o -name "time-of-build-before.log" -o -name "time-of-build-after.log" \ -o -name "time-of-build-pretty.log" -o -name "time-of-build-both.log" \) -exec rm -f {} + @@ -65,12 +65,9 @@ environment for semi-interactive development of machine-checked proofs. [coqorg-badge]: https://images.microbadger.com/badges/version/coqorg/coq.svg [coqorg-link]: https://github.com/coq-community/docker-coq/wiki#docker-coq-images "coqorg/coq:latest" -Download the pre-built packages of the [latest release][] for Windows and macOS; -read the [help page][opam-using] on how to install Coq with OPAM; -or refer to the [`INSTALL.md`](INSTALL.md) file for the procedure to install from source. - -[latest release]: https://github.com/coq/coq/releases/latest -[opam-using]: https://coq.inria.fr/opam/www/using.html +Please see https://coq.inria.fr/download. +Information on how to build and install from sources can be found in +[`INSTALL.md`](INSTALL.md). ## Documentation diff --git a/checker/check.ml b/checker/check.ml index 1ff1425dea..587bb90d43 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -149,7 +149,7 @@ let remove_load_path dir = load_paths := List.filter2 (fun p d -> p <> dir) physical logical let add_load_path (phys_path,coq_path) = - if !Flags.debug then + if CDebug.(get_flag misc) then Feedback.msg_notice (str "path: " ++ pr_dirpath coq_path ++ str " ->" ++ spc() ++ str phys_path); let phys_path = CUnix.canonical_path_name phys_path in diff --git a/checker/checker.ml b/checker/checker.ml index bdfc5f07be..f55ed9e8d6 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -48,19 +48,17 @@ let path_of_string s = let ( / ) = Filename.concat -let get_version_date () = +let get_version () = try let ch = open_in (Envars.coqlib () / "revision") in let ver = input_line ch in let rev = input_line ch in let () = close_in ch in - (ver,rev) - with _ -> (Coq_config.version,Coq_config.date) + Printf.sprintf "%s (%s)" ver rev + with _ -> Coq_config.version let print_header () = - let (ver,rev) = (get_version_date ()) in - Printf.printf "Welcome to Chicken %s (%s)\n" ver rev; - flush stdout + Printf.printf "Welcome to Chicken %s\n%!" (get_version ()) (* Adding files to Coq loadpath *) @@ -109,7 +107,15 @@ let init_load_path () = let user_contrib = coqlib/"user-contrib" in let xdg_dirs = Envars.xdg_dirs in let coqpath = Envars.coqpath in - let plugins = coqlib/"plugins" in + let plugins = + CPath.choose_existing + [ CPath.make [ coqlib ; "plugins" ] + ; CPath.make [ coqlib ; ".."; "coq-core"; "plugins" ] + ] |> function + | None -> + CErrors.user_err (Pp.str "Cannot find plugins directory") + | Some f -> (f :> string) + in (* NOTE: These directories are searched from last to first *) (* first standard library *) add_rec_path ~unix_path:(coqlib/"theories") ~coq_root:(Names.DirPath.make[coq_root]); @@ -132,8 +138,6 @@ let init_load_path () = includes := [] -let set_debug () = Flags.debug := true - let impredicative_set = ref Declarations.PredicativeSet let set_impredicative_set () = impredicative_set := Declarations.ImpredicativeSet @@ -170,9 +174,7 @@ let compile_files senv = ~check:(List.rev !compile_list) let version () = - Printf.printf "The Coq Proof Checker, version %s (%s)\n" - Coq_config.version Coq_config.date; - Printf.printf "compiled on %s\n" Coq_config.compile_date; + Printf.printf "The Coq Proof Checker, version %s\n" Coq_config.version; exit 0 (* print the usage of coqtop (or coqc) on channel co *) @@ -222,7 +224,7 @@ let guill s = str "\"" ++ str s ++ str "\"" let where = function | None -> mt () | Some s -> - if !Flags.debug then (str"in " ++ str s ++ str":" ++ spc ()) else (mt ()) + if CDebug.(get_flag misc) then (str"in " ++ str s ++ str":" ++ spc ()) else (mt ()) let explain_exn = function | Stream.Failure -> @@ -251,7 +253,7 @@ let explain_exn = function hov 0 (fnl () ++ str "User interrupt.") | Univ.UniverseInconsistency i -> let msg = - if !Flags.debug then + if CDebug.(get_flag misc) then str "." ++ spc() ++ Univ.explain_universe_inconsistency Univ.Level.pr i else @@ -339,7 +341,7 @@ let parse_args argv = | ("-Q"|"-R") :: d :: p :: rem -> set_include d p;parse rem | ("-Q"|"-R") :: ([] | [_]) -> usage () - | "-debug" :: rem -> set_debug (); parse rem + | "-debug" :: rem -> CDebug.set_debug_all true; parse rem | "-where" :: _ -> Envars.set_coqlib ~fail:(fun x -> CErrors.user_err Pp.(str x)); @@ -377,7 +379,7 @@ let init_with_argv argv = try parse_args argv; CWarnings.set_flags ("+"^Typeops.warn_bad_relevance_name); - if !Flags.debug then Printexc.record_backtrace true; + if CDebug.(get_flag misc) then Printexc.record_backtrace true; Envars.set_coqlib ~fail:(fun x -> CErrors.user_err Pp.(str x)); Flags.if_verbose print_header (); init_load_path (); @@ -392,7 +394,7 @@ let run senv = let senv = compile_files senv in flush_all(); senv with e -> - if !Flags.debug then Printexc.print_backtrace stderr; + if CDebug.(get_flag misc) then Printexc.print_backtrace stderr; fatal_error (explain_exn e) (is_anomaly e) let start () = diff --git a/checker/dune b/checker/dune index af7d4f2923..78b4032141 100644 --- a/checker/dune +++ b/checker/dune @@ -7,13 +7,14 @@ (synopsis "Coq's Standalone Proof Checker") (modules :standard \ coqchk votour) (wrapped true) - (libraries coq.kernel)) + (libraries coq-core.kernel)) (executable (name coqchk) (public_name coqchk) (modes exe byte) - (package coq) + ; Move to coq-checker? + (package coq-core) (modules coqchk) (flags :standard -open Coq_checklib) (libraries coq_checklib)) @@ -21,7 +22,7 @@ (executable (name votour) (public_name votour) - (package coq) + (package coq-core) (modules votour) (flags :standard -open Coq_checklib) (libraries coq_checklib)) diff --git a/checker/values.ml b/checker/values.ml index 907f9f7e32..f7a367b986 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -240,7 +240,7 @@ let v_template_universes = v_tuple "template_universes" [|List(Opt v_level);v_context_set|] let v_primitive = - v_enum "primitive" 50 (* Number of "Primitive" in Int63.v and PrimFloat.v *) + v_enum "primitive" 54 (* Number of constructors of the CPrimitives.t type *) let v_cst_def = v_sum "constant_def" 0 diff --git a/clib/cPath.ml b/clib/cPath.ml new file mode 100644 index 0000000000..66d03078dc --- /dev/null +++ b/clib/cPath.ml @@ -0,0 +1,27 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* This API is loosely inspired by [Stdune.Path], for now we keep it + minimal, but at some point we may extend it, see developer notes in + the implementation file. *) + +type t = string + +(* Note that in general, make is not safe, due to its type, however + relative is as you can enforce a particular root. So we eventually + should remove [make] *) +let make = List.fold_left Filename.concat "" + +let relative = Filename.concat + +let rec choose_existing = function + | [] -> None + | f :: fs -> + if Sys.file_exists f then Some f else choose_existing fs diff --git a/clib/cPath.mli b/clib/cPath.mli new file mode 100644 index 0000000000..762279a218 --- /dev/null +++ b/clib/cPath.mli @@ -0,0 +1,31 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +(* This API is loosely inspired by [Stdune.Path], for now we keep it + minimal, but at some point we may extend it, see developer notes in + the implementation file. *) + +(* To be made opaque one day, for now we force users to go thru the + constructor *) +type t = private string + +(** [make path_components] build a path from its components *) +val make : string list -> t + +(** [relative path string] build a path relative to an existing one *) +val relative : t -> string -> t + +(** [choose_existing paths] will return [Some f] for the first file + [f] in [paths] that exists, [None] otherwise. *) +val choose_existing : t list -> t option + +(* We should gradually add some more functions to handle common dirs + here such the theories directories or share files. Abstracting it + here does allow to use system-specific functionalities *) diff --git a/clib/clib.mllib b/clib/clib.mllib index be3b5971be..02f2ec8e56 100644 --- a/clib/clib.mllib +++ b/clib/clib.mllib @@ -37,3 +37,5 @@ Terminal Monad Diff2 + +CPath @@ -1,8 +1,7 @@ (library (name clib) (synopsis "Coq's Utility Library [general purpose]") - (public_name coq.clib) + (public_name coq-core.clib) (wrapped false) (modules_without_implementation cSig) (libraries str unix threads)) - diff --git a/config/coq_config.mli b/config/coq_config.mli index 809fa3d758..035574475d 100644 --- a/config/coq_config.mli +++ b/config/coq_config.mli @@ -33,8 +33,6 @@ val arch_is_win32 : bool val version : string (* version number of Coq *) val caml_version : string (* OCaml version used to compile Coq *) val caml_version_nums : int list (* OCaml version used to compile Coq by components *) -val date : string (* release date *) -val compile_date : string (* compile date *) val vo_version : int32 val state_magic_number : int diff --git a/config/dune b/config/dune index 83d1364b0c..777201f29f 100644 --- a/config/dune +++ b/config/dune @@ -1,7 +1,7 @@ (library (name config) (synopsis "Coq Configuration Variables") - (public_name coq.config) + (public_name coq-core.config) (modules :standard \ list_plugins) (wrapped false)) diff --git a/configure.ml b/configure.ml index 40d77ed109..abea59bd60 100644 --- a/configure.ml +++ b/configure.ml @@ -196,31 +196,6 @@ let which prog = let program_in_path prog = try let _ = which prog in true with Not_found -> false -let build_date = - try - float_of_string (Sys.getenv "SOURCE_DATE_EPOCH") - with - Not_found -> Unix.time () - -(** * Date *) - -(** The short one is displayed when starting coqtop, - The long one is used as compile date *) - -let months = - [| "January";"February";"March";"April";"May";"June"; - "July";"August";"September";"October";"November";"December" |] - -let get_date () = - let now = Unix.gmtime build_date in - let year = 1900+now.Unix.tm_year in - let month = months.(now.Unix.tm_mon) in - sprintf "%s %d" month year, - sprintf "%s %d %d %d:%02d:%02d" (String.sub month 0 3) now.Unix.tm_mday year - now.Unix.tm_hour now.Unix.tm_min now.Unix.tm_sec - -let short_date, full_date = get_date () - (** * Command-line parsing *) type ide = Opt | Byte | No @@ -361,9 +336,16 @@ let arg_profile = Arg.String (fun s -> prefs := Profiles.get s !prefs) (* TODO : earlier any option -foo was also available as --foo *) +let check_absolute = function + | None -> () + | Some path -> + if Filename.is_relative path then + die "argument to -prefix must be an absolute path" + else () + let args_options = Arg.align [ - "-prefix", arg_string_option (fun p prefix -> { p with prefix }), - "<dir> Set installation directory to <dir>"; + "-prefix", arg_string_option (fun p prefix -> check_absolute prefix; { p with prefix }), + "<dir> Set installation directory to <dir> (absolute path required)"; "-local", arg_set (fun p local -> { p with local }), " Set installation directory to the current source tree"; "-no-ask", arg_clear (fun p interactive -> { p with interactive }), @@ -1096,8 +1078,6 @@ let write_configml f = pr_s "version" coq_version; pr_s "caml_version" caml_version; pr_li "caml_version_nums" caml_version_nums; - pr_s "date" short_date; - pr_s "compile_date" full_date; pr_s "arch" arch; pr_b "arch_is_win32" arch_is_win32; pr_s "exec_extension" exe; diff --git a/coq-core.opam b/coq-core.opam new file mode 100644 index 0000000000..8b8c43f66e --- /dev/null +++ b/coq-core.opam @@ -0,0 +1,54 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +version: "dev" +synopsis: "The Coq Proof Assistant -- Core Binaries and Tools" +description: """ +Coq is a formal proof management system. It provides +a formal language to write mathematical definitions, executable +algorithms and theorems together with an environment for +semi-interactive development of machine-checked proofs. + +Typical applications include the certification of properties of +programming languages (e.g. the CompCert compiler certification +project, or the Bedrock verified low-level programming library), the +formalization of mathematics (e.g. the full formalization of the +Feit-Thompson theorem or homotopy type theory) and teaching. + +This package includes the Coq core binaries, plugins, and tools, but +not the vernacular standard library. + +Note that in this setup, Coq needs to be started with the -boot and +-noinit options, as will otherwise fail to find the regular Coq +prelude, now living in the coq-stdlib package.""" +maintainer: ["The Coq development team <coqdev@inria.fr>"] +authors: ["The Coq development team, INRIA, CNRS, and contributors"] +license: "LGPL-2.1-only" +homepage: "https://coq.inria.fr/" +doc: "https://coq.github.io/doc/" +bug-reports: "https://github.com/coq/coq/issues" +depends: [ + "dune" {>= "2.5"} + "ocaml" {>= "4.05.0"} + "ocamlfind" {>= "1.8.1"} + "zarith" {>= "1.10"} + "ounit2" {with-test} +] +build: [ + # Requires dune 2.8 due to https://github.com/ocaml/dune/issues/3219 + # ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/coq/coq.git" +build-env: [ + [ COQ_CONFIGURE_PREFIX = "%{prefix}" ] +] diff --git a/coq.opam.template b/coq-core.opam.template index c0efccdc0f..c0efccdc0f 100644 --- a/coq.opam.template +++ b/coq-core.opam.template diff --git a/coq-doc.opam b/coq-doc.opam index 3a872db33d..37bf1e95fe 100644 --- a/coq-doc.opam +++ b/coq-doc.opam @@ -17,11 +17,12 @@ doc: "https://coq.github.io/doc/" bug-reports: "https://github.com/coq/coq/issues" depends: [ "dune" {build & >= "2.5.0"} + "conf-python-3" {build} "coq" {build & = version} ] build: [ -# Disabled until Dune 2.8 is available -# ["dune" "subst"] {pinned} + # Requires dune 2.8 due to https://github.com/ocaml/dune/issues/3219 + # ["dune" "subst"] {pinned} [ "dune" "build" diff --git a/coq-stdlib.opam b/coq-stdlib.opam new file mode 100644 index 0000000000..20d994abcb --- /dev/null +++ b/coq-stdlib.opam @@ -0,0 +1,44 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +version: "dev" +synopsis: "The Coq Proof Assistant -- Standard Library" +description: """ +Coq is a formal proof management system. It provides +a formal language to write mathematical definitions, executable +algorithms and theorems together with an environment for +semi-interactive development of machine-checked proofs. + +Typical applications include the certification of properties of +programming languages (e.g. the CompCert compiler certification +project, or the Bedrock verified low-level programming library), the +formalization of mathematics (e.g. the full formalization of the +Feit-Thompson theorem or homotopy type theory) and teaching. + +This package includes the Coq Standard Library, that is to say, the +set of modules usually bound to the Coq.* namespace.""" +maintainer: ["The Coq development team <coqdev@inria.fr>"] +authors: ["The Coq development team, INRIA, CNRS, and contributors"] +license: "LGPL-2.1-only" +homepage: "https://coq.inria.fr/" +doc: "https://coq.github.io/doc/" +bug-reports: "https://github.com/coq/coq/issues" +depends: [ + "dune" {>= "2.5"} + "coq-core" {= version} +] +build: [ + # Requires dune 2.8 due to https://github.com/ocaml/dune/issues/3219 + # ["dune" "subst"] {pinned} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/coq/coq.git" @@ -20,14 +20,12 @@ homepage: "https://coq.inria.fr/" doc: "https://coq.github.io/doc/" bug-reports: "https://github.com/coq/coq/issues" depends: [ - "ocaml" {>= "4.05.0"} - "dune" {>= "2.5.0"} - "ocamlfind" {>= "1.8.1"} - "zarith" {>= "1.10"} + "dune" {>= "2.5"} + "coq-core" {= version} + "coq-stdlib" {= version} ] build: [ -# Disabled until Dune 2.8 is available -# ["dune" "subst"] {pinned} + ["dune" "subst"] {pinned} [ "dune" "build" @@ -41,6 +39,3 @@ build: [ ] ] dev-repo: "git+https://github.com/coq/coq.git" -build-env: [ - [ COQ_CONFIGURE_PREFIX = "%{prefix}" ] -] diff --git a/coqide-server.opam b/coqide-server.opam index cbb0db2893..8359b5f04e 100644 --- a/coqide-server.opam +++ b/coqide-server.opam @@ -19,12 +19,12 @@ homepage: "https://coq.inria.fr/" doc: "https://coq.github.io/doc/" bug-reports: "https://github.com/coq/coq/issues" depends: [ - "dune" {>= "2.5.0"} - "coq" {= version} + "dune" {>= "2.5"} + "coq-core" {= version} ] build: [ -# Disabled until Dune 2.8 is available -# ["dune" "subst"] {pinned} + # Requires dune 2.8 due to https://github.com/ocaml/dune/issues/3219 + # ["dune" "subst"] {pinned} [ "dune" "build" diff --git a/coqide.opam b/coqide.opam index 9e4fb05701..3c59f7fd9c 100644 --- a/coqide.opam +++ b/coqide.opam @@ -17,12 +17,12 @@ homepage: "https://coq.inria.fr/" doc: "https://coq.github.io/doc/" bug-reports: "https://github.com/coq/coq/issues" depends: [ - "dune" {>= "2.5.0"} + "dune" {>= "2.5"} "coqide-server" {= version} ] build: [ -# Disabled until Dune 2.8 is available -# ["dune" "subst"] {pinned} + # Requires dune 2.8 due to https://github.com/ocaml/dune/issues/3219 + # ["dune" "subst"] {pinned} [ "dune" "build" diff --git a/coqpp/coqpp_main.ml b/coqpp/coqpp_main.ml index 8affe58824..2de103a2ff 100644 --- a/coqpp/coqpp_main.ml +++ b/coqpp/coqpp_main.ml @@ -360,7 +360,7 @@ let print_body_fun state fmt r = print_binders r.vernac_toks print_atts_left r.vernac_atts (print_body_state state) r let print_body state fmt r = - fprintf fmt "@[(%afun %a~atts@ -> coqpp_body %a%a)@]" + fprintf fmt "@[(%afun %a?loc ~atts@ -> coqpp_body %a%a)@]" (print_body_fun state) r print_binders r.vernac_toks print_binders r.vernac_toks print_atts_right r.vernac_atts diff --git a/coqpp/dune b/coqpp/dune index d4b49301fb..e4cdc33b3d 100644 --- a/coqpp/dune +++ b/coqpp/dune @@ -10,6 +10,6 @@ (executable (name coqpp_main) (public_name coqpp) - (package coq) + (package coq-core) (libraries coqpp) (modules coqpp_main)) diff --git a/default.nix b/default.nix index 0b23bdb48c..4700a6ed64 100644 --- a/default.nix +++ b/default.nix @@ -33,7 +33,7 @@ }: with pkgs; -with stdenv.lib; +with pkgs.lib; stdenv.mkDerivation rec { @@ -98,7 +98,7 @@ stdenv.mkDerivation rec { createFindlibDestdir = !shell; - postInstall = "ln -s $out/lib/coq $OCAMLFIND_DESTDIR/coq"; + postInstall = "ln -s $out/lib/coq-core $OCAMLFIND_DESTDIR/coq-core"; inherit doInstallCheck; diff --git a/dev/base_include b/dev/base_include index f375a867bc..061bf1f3e1 100644 --- a/dev/base_include +++ b/dev/base_include @@ -16,7 +16,6 @@ #install_printer (* kernel_name *) ppkn;; #install_printer (* constant *) ppcon;; #install_printer (* projection *) ppproj;; -#install_printer (* cl_index *) ppclindex;; #install_printer (* recarg Rtree.t *) ppwf_paths;; #install_printer (* constr *) print_pure_constr;; #install_printer (* patch *) ppripos;; diff --git a/dev/bench/gitlab-bench.yml b/dev/bench/gitlab-bench.yml index 25545cf565..69136ee773 100644 --- a/dev/bench/gitlab-bench.yml +++ b/dev/bench/gitlab-bench.yml @@ -4,9 +4,7 @@ bench: when: manual before_script: - printenv -0 | sort -z | tr '\0' '\n' - script: - - . ~/.opam/opam-init/init.sh - - ./dev/bench/gitlab.sh + script: dev/bench/gitlab.sh tags: - timing variables: diff --git a/dev/bench/gitlab.sh b/dev/bench/gitlab.sh index b616371ef8..49c8099e8b 100755 --- a/dev/bench/gitlab.sh +++ b/dev/bench/gitlab.sh @@ -52,7 +52,7 @@ check_variable "CI_JOB_URL" : "${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 coq-perennial}" +: "${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-coquelicot coq-lambda-rust coq-verdi coq-verdi-raft coq-fourcolor coq-rewriter-perf-SuperFast coq-perennial coq-vst}" new_coq_commit=$(git rev-parse HEAD^2) old_coq_commit=$(git merge-base HEAD^1 $new_coq_commit) @@ -283,25 +283,27 @@ create_opam() { 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.log 1>&3 \ - 4>$log_dir/coq.$RUNNER.opam_install.1.stderr.log 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 + for package in coq-core coq-stdlib coq; do + _RES=0 + /usr/bin/time -o "$log_dir/$package.$RUNNER.1.time" --format="%U %M %F" \ + perf stat -e instructions:u,cycles:u -o "$log_dir/$package.$RUNNER.1.perf" \ + opam pin add -y -b -j "$number_of_processors" --kind=path $package.dev . \ + 3>$log_dir/$package.$RUNNER.opam_install.1.stdout.log 1>&3 \ + 4>$log_dir/$package.$RUNNER.opam_install.1.stderr.log 2>&4 || \ + _RES=$? + if [ $_RES = 0 ]; then + echo "$package ($RUNNER) installed successfully" + else + echo "ERROR: \"opam install $package.$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" + # 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/$package.$RUNNER.1.time" "$log_dir/$package.$RUNNER.$it.time" + cp "$log_dir/$package.$RUNNER.1.perf" "$log_dir/$package.$RUNNER.$it.perf" + done done } @@ -327,7 +329,7 @@ fi export TIMING=1 # The following variable will be set in the following cycle: -installable_coq_opam_packages=coq +installable_coq_opam_packages="coq-core coq-stdlib coq" for coq_opam_package in $sorted_coq_opam_packages; do diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 8bcbd90f0b..4799755b15 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -308,3 +308,8 @@ project sf "https://github.com/DeepSpec/sf" "master" # Coqtail ######################################################################## project coqtail "https://github.com/whonore/Coqtail" "master" + +######################################################################## +# Deriving +######################################################################## +project deriving "https://github.com/arthuraa/deriving" "master" diff --git a/dev/ci/ci-common.sh b/dev/ci/ci-common.sh index 8d8f78e10c..006565df5c 100644 --- a/dev/ci/ci-common.sh +++ b/dev/ci/ci-common.sh @@ -143,33 +143,3 @@ make() command make --output-sync "$@" fi } - -# this installs just the ssreflect library of math-comp -install_ssreflect() -{ - echo 'Installing ssreflect' - - git_download mathcomp - - ( cd "${CI_BUILD_DIR}/mathcomp/mathcomp/ssreflect" && \ - make && \ - make install ) - -} - -# this installs just the ssreflect + algebra library of math-comp -install_ssralg() -{ - echo 'Installing ssralg' - - git_download mathcomp - - ( cd "${CI_BUILD_DIR}/mathcomp/mathcomp" && \ - make -C ssreflect && \ - make -C ssreflect install && \ - make -C fingroup && \ - make -C fingroup install && \ - make -C algebra && \ - make -C algebra install ) - -} diff --git a/dev/ci/ci-deriving.sh b/dev/ci/ci-deriving.sh new file mode 100755 index 0000000000..c34fc44f69 --- /dev/null +++ b/dev/ci/ci-deriving.sh @@ -0,0 +1,8 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +. "${ci_dir}/ci-common.sh" + +git_download deriving + +( cd "${CI_BUILD_DIR}/deriving" && make && make tests && make install ) diff --git a/dev/ci/ci-fcsl_pcm.sh b/dev/ci/ci-fcsl_pcm.sh index cb951630c8..e1248c6627 100755 --- a/dev/ci/ci-fcsl_pcm.sh +++ b/dev/ci/ci-fcsl_pcm.sh @@ -3,8 +3,6 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" -install_ssreflect - git_download fcsl_pcm ( cd "${CI_BUILD_DIR}/fcsl_pcm" && make ) diff --git a/dev/ci/ci-geocoq.sh b/dev/ci/ci-geocoq.sh index e4fc983e68..0ad9ac0cbb 100755 --- a/dev/ci/ci-geocoq.sh +++ b/dev/ci/ci-geocoq.sh @@ -3,8 +3,6 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" -install_ssralg - git_download geocoq ( cd "${CI_BUILD_DIR}/geocoq" && ./configure.sh && make ) diff --git a/dev/ci/ci-quickchick.sh b/dev/ci/ci-quickchick.sh index 08686d7ced..2bc2a18849 100755 --- a/dev/ci/ci-quickchick.sh +++ b/dev/ci/ci-quickchick.sh @@ -3,8 +3,6 @@ ci_dir="$(dirname "$0")" . "${ci_dir}/ci-common.sh" -install_ssreflect - git_download quickchick ( cd "${CI_BUILD_DIR}/quickchick" && make && make install) diff --git a/dev/ci/docker/bionic_coq/Dockerfile b/dev/ci/docker/bionic_coq/Dockerfile index b4b6411d28..8f14625c63 100644 --- a/dev/ci/docker/bionic_coq/Dockerfile +++ b/dev/ci/docker/bionic_coq/Dockerfile @@ -44,7 +44,7 @@ ENV COMPILER="4.05.0" # Common OPAM packages ENV BASE_OPAM="zarith.1.10 ocamlfind.1.8.1 ounit2.2.2.3 odoc.1.5.1" \ CI_OPAM="ocamlgraph.1.8.8" \ - BASE_ONLY_OPAM="elpi.1.12.0" + BASE_ONLY_OPAM="elpi.1.13.0" # BASE switch; CI_OPAM contains Coq's CI dependencies. ENV COQIDE_OPAM="cairo2.0.6.1 lablgtk3-sourceview3.3.1.0" diff --git a/dev/ci/user-overlays/13202-SkySkimmer-debug-infra.sh b/dev/ci/user-overlays/13202-SkySkimmer-debug-infra.sh new file mode 100644 index 0000000000..d80363c49f --- /dev/null +++ b/dev/ci/user-overlays/13202-SkySkimmer-debug-infra.sh @@ -0,0 +1 @@ +overlay elpi https://github.com/SkySkimmer/coq-elpi debug-infra 13202 diff --git a/dev/ci/user-overlays/13842-proux01-remove-decimal.sh b/dev/ci/user-overlays/13842-proux01-remove-decimal.sh new file mode 100644 index 0000000000..5ede8221ce --- /dev/null +++ b/dev/ci/user-overlays/13842-proux01-remove-decimal.sh @@ -0,0 +1 @@ +overlay hott https://github.com/proux01/HoTT coq-13842 13842 diff --git a/dev/ci/user-overlays/13844-gares-command-loc.sh b/dev/ci/user-overlays/13844-gares-command-loc.sh new file mode 100644 index 0000000000..d9a1736532 --- /dev/null +++ b/dev/ci/user-overlays/13844-gares-command-loc.sh @@ -0,0 +1 @@ +overlay elpi https://github.com/LPCIC/coq-elpi command-loc 13844 diff --git a/dev/ci/user-overlays/13847-gares-elpi-1.13-coq-elpi-1.9.0.sh b/dev/ci/user-overlays/13847-gares-elpi-1.13-coq-elpi-1.9.0.sh new file mode 100644 index 0000000000..6847bde6d8 --- /dev/null +++ b/dev/ci/user-overlays/13847-gares-elpi-1.13-coq-elpi-1.9.0.sh @@ -0,0 +1 @@ +overlay elpi https://github.com/LPCIC/coq-elpi coq-master+1.9.0 13847 diff --git a/dev/ci/user-overlays/13912-pi8027-remove-bijint.sh b/dev/ci/user-overlays/13912-pi8027-remove-bijint.sh new file mode 100644 index 0000000000..d860cfec01 --- /dev/null +++ b/dev/ci/user-overlays/13912-pi8027-remove-bijint.sh @@ -0,0 +1 @@ +overlay elpi https://github.com/pi8027/coq-elpi coq-overlay-13912 13912 diff --git a/dev/doc/critical-bugs b/dev/doc/critical-bugs index 79c2155823..4452baf513 100644 --- a/dev/doc/critical-bugs +++ b/dev/doc/critical-bugs @@ -332,6 +332,18 @@ Conversion machines GH issue number: ocaml/ocaml#6385, #11170 risk: unlikely to be activated by chance, might happen for autogenerated code + component: "virtual machine" (compilation to bytecode ran by a C-interpreter) + summary: buffer overflow, arbitrary code execution on floating-point operations + introduced: 8.13 + impacted released versions: 8.13.0 + impacted coqchk versions: none (no virtual machine in coqchk) + fixed in: 8.13.1 + found by: Melquiond + GH issue number: #13867 + risk: none, unless using floating-point operations; high otherwise; + noticeable if activated by chance, since it usually breaks + control-flow integrity + Side-effects component: side-effects diff --git a/dev/doc/release-process.md b/dev/doc/release-process.md index 894244044a..1697a19668 100644 --- a/dev/doc/release-process.md +++ b/dev/doc/release-process.md @@ -1,177 +1,167 @@ -# Release process # - -## As soon as the previous version branched off master ## - -In principle, these steps should be undertaken by the RM of the next -release. Unfortunately, we have not yet been able to nominate RMs -early enough in the process for this person to be known at that point -in time. - -- [ ] Create a new issue to track the release process where you can copy-paste - the present checklist from `dev/doc/release-process.md`. -- [ ] Change the version name to the next major version and the magic - numbers (see [#7008](https://github.com/coq/coq/pull/7008/files)). +# Release checklist # + +## When the release managers for version `X.X` get nominated ## + +- [ ] Create a new issue to track the release process where you can + copy-paste the present checklist from `dev/doc/release-process.md`. +- [ ] Decide the release calendar with the team (date of branching, + preview and final release). +- [ ] Create a wiki page that you link to from + https://github.com/coq/coq/wiki/Release-Plan with this information + and the link to the issue. + +## About one month before the branching date ## + +- [ ] Create both the upcoming final release (`X.X.0`) and the + following major release (`Y.Y+rc1`) milestones if they do not + already exist. +- [ ] Send an announcement of the upcoming branching date on Coqdev + + the Coq development category on Discourse (coqdev@inria.fr + + coq+coq-development@discoursemail.com) and ask people to remove from + the `X.X+rc1` milestone any feature and clean up PRs that they + already know won't be ready on time. +- [ ] In a PR on `master`, call + [`dev/tools/update-compat.py`](../tools/update-compat.py) with the + `--release` flag; this sets up Coq to support three `-compat` flag + arguments including the upcoming one (instead of four). To ensure + that CI passes, you will have to decide what to do about all + test-suite files which mention `-compat U.U` or `Coq.Comapt.CoqUU` + (which is no longer valid, since we only keep compatibility against + the two previous versions), and you may have to ping maintainers of + projects that are still relying on the old compatibility flag so + that they fix this. +- [ ] Make sure that this change is merged in time for the branching + date. + +## On the branching date ## + +- [ ] In a PR on `master`, change the version name to the next major + version and the magic numbers (see + [#7008](https://github.com/coq/coq/pull/7008/files)). Additionally, in the same commit, update the compatibility infrastructure, which consists of invoking [`dev/tools/update-compat.py`](../tools/update-compat.py) with the `--master` flag. - Note that the `update-compat.py` script must be run twice: once - *immediately after* branching with the `--master` flag (which sets - up Coq to support four `-compat` flag arguments), *in the same - commit* as the one that updates `coq_version` in - [`configure.ml`](../../configure.ml), and once again later on before - the next branch point with the `--release` flag (see next section). -- [ ] Put the corresponding alpha tag using `git tag -s`. - The `VX.X+alpha` tag marks the first commit to be in `master` and not in the - branch of the previous version. Note that this commit is the first commit + Note that the `update-compat.py` script must be run twice: once in + preparation of the release with the `--release` flag (see previous + section) and once on the branching date with the `--master` flag to + mark the start of the next version. +- [ ] Merge the above PR and create the `vX.X` branch from the last + merge commit before this one (using this name will ensure that the + branch will be automatically protected). +- [ ] Set the next major version alpha tag using `git tag -s`. The + `VY.Y+alpha` tag marks the first commit to be in `master` and not in + the `vX.X` release branch. Note that this commit is the first commit in the first PR merged in master, not the merge commit for that PR. - After tagging double check that `git describe` picks up - the tag you just made (if not, you tagged the wrong commit). -- [ ] Create the `X.X+beta1` milestone if it did not already exist. -- [ ] Decide the release calendar with the team (freeze date, beta date, final - release date) and put this information in the milestone (using the - description and due date fields). - -## Anytime after the previous version is branched off master ## - -- [ ] Update the compatibility infrastructure to the next release, - which consists of invoking - [`dev/tools/update-compat.py`](../tools/update-compat.py) with the - `--release` flag; this sets up Coq to support three `-compat` flag - arguments. To ensure that CI passes, you will have to decide what - to do about all test-suite files which mention `-compat U.U` or - `Coq.Comapt.CoqUU` (which is no longer valid, since we only keep - compatibility against the two previous versions on releases), and - you may have to prepare overlays for projects using the - compatibility flags. - -## About one month before the beta ## - -- [ ] Create the `X.X.0` milestone and set its due date. -- [ ] Send an announcement of the upcoming freeze on Coqdev and ask people to - remove from the beta milestone what they already know won't be ready on time - (possibly postponing to the `X.X.0` milestone for minor bug fixes, - infrastructure and documentation updates). -- [ ] Determine which issues should / must be fixed before the beta, add them - to the beta milestone, possibly with a - ["priority: blocker"](https://github.com/coq/coq/labels/priority%3A%20blocker) - label. Make sure that all these issues are assigned (and that the assignee - provides an ETA). -- [ ] Ping the development coordinator (**@mattam82**) to get him started on - the update to the Credits chapter of the reference manual. - See also [#7058](https://github.com/coq/coq/issues/7058). - - The command that was used in the previous versions to get the list - of contributors for this version is `git shortlog -s -n - VX.X+alpha..master | cut -f2 | sort -k 2`. Note that the ordering is - approximative as it will misplace people with middle names. It is - also probably not correctly handling `Co-authored-by` info that we - have been using more lately, so should probably be updated to - account for this. - -## On the date of the feature freeze ## - -- [ ] Create the new version branch `vX.X` (using this name will ensure that - the branch will be automatically protected). -- [ ] Pin the versions of libraries and plugins in - `dev/ci/ci-basic-overlays.sh` to use commit hashes or tag (or, if it - exists, a branch dedicated to compatibility with the corresponding - Coq branch). You can use the `dev/tools/pin-ci.sh` script to do this - semi-automatically. - - [ ] Notify upstream authors about the pinning, see - `dev/tools/notify-upstream-pins.sh`. As of today there is no automated - way to track these issues. -- [ ] Remove all remaining unmerged feature PRs from the beta milestone. + Therefore, if you proceeded as described above, this should be the + commit updating the version, magic numbers and compatibility + infrastructure. After tagging, double-check that `git describe` + picks up the tag you just made (if not, you tagged the wrong + commit). +- [ ] Push the new tag with `git push upstream VY.Y+alpha --dry-run` + (remove the `--dry-run` and redo if everything looks OK). - [ ] Start a new project to track PR backporting. The project should - have a "Request X.X+beta1 inclusion" column for the PRs that were + have a `Request X.X+rc1 inclusion` column for the PRs that were merged in `master` that are to be considered for backporting, and a - "Shipped in X.X+beta1" columns to put what was backported. A message - to **@coqbot** in the milestone description tells it to - automatically add merged PRs to the "Request ... inclusion" column - and backported PRs to the "Shipped in ..." column. See previous - milestones for examples. When moving to the next milestone - (e.g. X.X.0), you can clear and remove the "Request X.X+beta1 - inclusion" column and create new "Request X.X.0 inclusion" and - "Shipped in X.X.0" columns. + `Shipped in X.X+rc1` columns to put what was backported. A message + to `@coqbot` in the milestone description tells it to automatically + add merged PRs to the `Request ... inclusion` column and backported + PRs to the `Shipped in ...` column. See previous milestones for + examples. When moving to the next milestone (e.g. `X.X.0`), you can + clear and remove the `Request X.X+rc1 inclusion` column and create + new `Request X.X.0 inclusion` and `Shipped in X.X.0` columns. The release manager is the person responsible for merging PRs that - target the version branch and backporting appropriate PRs that are - merged into `master`. -- [ ] Delay non-blocking issues to the appropriate milestone and ensure - blocking issues are solved. If required to solve some blocking issues, - it is possible to revert some feature PRs in the version branch only. -- [ ] Add a new link to the ``'versions'`` list of the refman (in - ``html_context`` in ``doc/sphinx/conf.py``). - -## Before the beta release date ## - -- [ ] Ensure the Credits chapter has been updated. -- [ ] Prepare the release notes (see e.g., - [#10833](https://github.com/coq/coq/pull/10833)): in a PR against the `master` - branch, move the contents from all files of `doc/changelog/` that appear in - the release branch into the manual `doc/sphinx/changes.rst`. Merge that PR - into the `master` branch and backport it to the version branch. -- [ ] Ensure that an appropriate version of the plugins we will distribute with - Coq has been tagged. -- [ ] Have some people test the recently auto-generated Windows and MacOS - packages. + target the release branch and backporting appropriate PRs (mostly + safe bug fixes, user message improvements and documentation updates) + that are merged into `master`. +- [ ] Pin the versions of libraries and plugins in + [`dev/ci/ci-basic-overlay.sh`](../ci/ci-basic-overlay.sh) to use + commit hashes. You can use the + [`dev/tools/pin-ci.sh`](../tools/pin-ci.sh) script to do this + semi-automatically. +- [ ] In a PR on `master` to be backported, add a new link to the + `'versions'` list of the refman (in `html_context` in + [`doc/sphinx/conf.py`](../../doc/sphinx/conf.py)). + +## In the days following the branching ## + +- [ ] Make sure that all the last feature PRs that you want to include + in the release are finished and backported quickly and clean up the + milestone. We recommend backporting as few feature PRs as possible + after branching. In particular, any PR with overlays will require + manually bumping the pinned commits when backporting. +- [ ] Delay non-blocking issues to the appropriate milestone and + ensure blocking issues are solved. If required to solve some + blocking issues, it is possible to revert some feature PRs in the + release branch only (but in this case, the blocking issue should be + postponed to the next major release instead of being closed). +- [ ] Once the final list of features is known, in a PR on `master` to + be backported, generate the release changelog by calling + [`dev/tools/generate-release-changelog.sh`](../tools/generate-release-changelog.sh) + and include it in a new section in + [`doc/sphinx/changes.rst`](../../doc/sphinx/changes.rst). + + At the moment, the script doesn't do it automatically, but we + recommend reordering the entries to show first the **Changed**, then + the **Removed**, **Deprecated**, **Added** and last the **Fixed**. +- [ ] Ping the development coordinator (`@mattam82`) to get him + started on writing the release summary. + + The `dev/tools/list-contributors.sh` script computes the number and + list of contributors between Coq revisions. Typically used with + `VX.X+alpha..vX.X` to check the contributors of version `VX.X`. + + Note that this script relies on `.mailmap` to merge multiple + identities. If you notice anything incorrect while using it, use + the opportunity to fix the `.mailmap` file. Same thing if you want + to have the full name of a contributor shown instead of a pseudonym. + +## For each release (preview, final, patch-level) ## + +- [ ] Ensure that there exists a milestone for the following version. +- [ ] Ensure the release changelog has been merged (the release + summary is required for the final release). - [ ] In a PR against `vX.X` (for testing): - - Change the version name from alpha to beta1 (see - [#7009](https://github.com/coq/coq/pull/7009/files)). - - We generally do not update the magic numbers at this point. + - Update the version number. + - Only update the magic numbers for the final release (see + [#7271](https://github.com/coq/coq/pull/7271/files)). - Set `is_a_released_version` to `true` in `configure.ml`. -- [ ] Put the `VX.X+beta1` tag using `git tag -s`. -- [ ] Push the new tag with `git push upstream VX.X+beta1 --dry-run` - (remove the `--dry-run` and redo if all looks OK). -- [ ] Set `is_a_released_version` to `false` in `configure.ml` - (if you forget about it, you'll be reminded whenever you try to - backport a PR with a changelog entry). - -### These steps are the same for all releases (beta, final, patch-level) ### - -- [ ] Send an e-mail on Coqdev announcing that the tag has been put so that - package managers can start preparing package updates (including a - `coq-bignums` compatible version). -- [ ] When opening the corresponding PR for `coq` in the opam repository ([`coq/opam-coq-archive`](https://github.com/coq/opam-coq-archive) or [`ocaml/opam-repository`](https://github.com/ocaml/opam-repository)), - the package managers can Cc `@erikmd` to request that he prepare the necessary configuration for the Docker release in [`coqorg/coq`](https://hub.docker.com/r/coqorg/coq) - (namely, he'll need to make sure a `coq-bignums` opam package is available in [`extra-dev`](https://github.com/coq/opam-coq-archive/tree/master/extra-dev), respectively [`released`](https://github.com/coq/opam-coq-archive/tree/master/released), so the Docker image gathering `coq` and `coq-bignums` can be built). -- [ ] Draft a release on GitHub. -- [ ] Sign the Windows and MacOS packages and upload them on GitHub. - + The Windows packages must be signed by the Inria IT security service. They - should be sent as a link to the binary (via [filesender](https://filesender.renater.fr) for example) - together with its SHA256 hash in a signed e-mail to `dsi.securite` @ `inria.fr` - putting `@maximedenes` in carbon copy. - + The MacOS packages should be signed with our own certificate. A detailed step-by-step guide can be found [on the wiki](https://github.com/coq/coq/wiki/SigningReleases). -- [ ] Upload the PDF version of the reference manual to the GitHub release. (*TODO:* automate this.) -- [ ] Prepare a page of news on the website with the link to the GitHub release - (see [coq/www#63](https://github.com/coq/www/pull/63)). -- [ ] Merge the website update, publish the release - and send announcement e-mails, typically on - the `coq-club@inria.fr` mailing list and the discourse forum - ([posting by mail](https://github.com/coq/coq/wiki/Discourse)) +- [ ] Set the tag `VX.X...` using `git tag -s`. +- [ ] Push the new tag with `git push upstream VX.X... --dry-run` + (remove the `--dry-run` and redo if everything looks OK). +- [ ] Set `is_a_released_version` to `false` in `configure.ml` (if you + forget about it, you'll be reminded by the test-suite failing + whenever you try to backport a PR with a changelog entry). - [ ] Close the milestone - -## At the final release time ## - -- [ ] Prepare the release notes (see above) -- [ ] In a PR against `vX.X` (for testing): - - Change the version name from X.X.0 and the magic numbers (see - [#7271](https://github.com/coq/coq/pull/7271/files)). - - Set `is_a_released_version` to `true` in `configure.ml`. -- [ ] Put the `VX.X.0` tag. -- [ ] Push the new tag with `git push upstream VX.X.0 --dry-run` - (remove the `--dry-run` and redo if all looks OK). -- [ ] Set `is_a_released_version` to `false` in `configure.ml` - (if you forget about it, you'll be reminded whenever you try to - backport a PR with a changelog entry). - -Repeat the generic process documented above for all releases. - -Ping `@Zimmi48` to: - -- [ ] Switch the default version of the reference manual on the website. +- [ ] Send an e-mail on Coqdev + the Coq development category on + Discourse (coqdev@inria.fr + coq+coq-development@discoursemail.com) + announcing that the tag has been set so that package managers can + start preparing package updates (including a `coq-bignums` + compatible version). +- [ ] In particular, ensure that someone is working on providing an + opam package (either in the main + [ocaml/opam-repository](https://github.com/ocaml/opam-repository) + for standard releases or in the `core-dev` category of the + [coq/opam-coq-archive](https://github.com/coq/opam-coq-archive) + for preview releases. +- [ ] Make sure to cc `@erikmd` to request that he prepare the + necessary configuration for the Docker release in + [`coqorg/coq`](https://hub.docker.com/r/coqorg/coq) (namely, he'll + need to make sure a `coq-bignums` opam package is available in + [`extra-dev`](https://github.com/coq/opam-coq-archive/tree/master/extra-dev), + respectively + [`released`](https://github.com/coq/opam-coq-archive/tree/master/released), + so the Docker image gathering `coq` and `coq-bignums` can be built). +- [ ] Publish a release on GitHub with the PDF version of the + reference manual attached. + +## For each non-preview release ## + +- [ ] Ping `@Zimmi48` to switch the default version of the reference + manual on the website. This is done by logging into the server (`vps697916.ovh.net`), editing two `ProxyPass` lines (one for the refman and one for the @@ -182,11 +172,30 @@ Ping `@Zimmi48` to: repository. See [coq/www#111](https://github.com/coq/www/issues/111) and [coq/www#131](https://github.com/coq/www/issues/131). -- [ ] Publish a new version on Zenodo (only once per major version). +## Only for the final release of each major version ## + +- [ ] Ping `@Zimmi48` to publish a new version on Zenodo. *TODO:* automate this with coqbot. -## At the patch-level release time ## +## This is now delegated to the platform maintainers ## -We generally do not update the magic numbers at this point (see -[`2881a18`](https://github.com/coq/coq/commit/2881a18)). +- [ ] Sign the Windows and MacOS packages and upload them on GitHub. + + The Windows packages must be signed by the Inria IT security + service. They should be sent as a link to the binary (via + [filesender](https://filesender.renater.fr) for example) together + with its SHA256 hash in a signed e-mail to `dsi.securite` @ + `inria.fr` putting `@maximedenes` in carbon copy. + + The MacOS packages should be signed with our own certificate. A + detailed step-by-step guide can be found [on the + wiki](https://github.com/coq/coq/wiki/SigningReleases). + + The Snap package has to be built and uploaded to the snap store by + running a [platform CI job + manually](https://github.com/coq/platform/tree/v8.13/linux/snap/github_actions). + Then ask `@gares` to publish the upload or give you the password + for the `coq-team` account on the store so that you can do it + yourself. +- [ ] Prepare a PR on [coq/www](https://github.com/coq/www) adding a + page of news on the website. +- [ ] Announce the release to Coq-Club and Discourse + (coq-club@inria.fr + coq+announcements@discoursemail.com). @@ -1,11 +1,11 @@ (library (name top_printers) - (public_name coq.top_printers) + (public_name coq-core.top_printers) (synopsis "Coq's Debug Printers") (wrapped false) (modules top_printers) (optional) - (libraries coq.toplevel coq.plugins.ltac)) + (libraries coq-core.toplevel coq-core.plugins.ltac)) (rule (targets dune-dbg) @@ -17,27 +17,27 @@ ; We require all the OCaml libs to be in place and searchable ; by OCamlfind, this is a bit of a hack but until Dune gets ; proper ocamldebug support we have to live with that. - %{lib:coq.config:config.cma} - %{lib:coq.clib:clib.cma} - %{lib:coq.lib:lib.cma} - %{lib:coq.kernel:kernel.cma} - %{lib:coq.vm:byterun.cma} - %{lib:coq.vm:../../stublibs/dllbyterun_stubs.so} - %{lib:coq.library:library.cma} - %{lib:coq.engine:engine.cma} - %{lib:coq.pretyping:pretyping.cma} - %{lib:coq.gramlib:gramlib.cma} - %{lib:coq.interp:interp.cma} - %{lib:coq.proofs:proofs.cma} - %{lib:coq.parsing:parsing.cma} - %{lib:coq.printing:printing.cma} - %{lib:coq.tactics:tactics.cma} - %{lib:coq.vernac:vernac.cma} - %{lib:coq.stm:stm.cma} - %{lib:coq.sysinit:sysinit.cma} - %{lib:coq.toplevel:toplevel.cma} - %{lib:coq.plugins.ltac:ltac_plugin.cma} - %{lib:coq.top_printers:top_printers.cmi} - %{lib:coq.top_printers:top_printers.cma} - %{lib:coq.top_printers:../META}) + %{lib:coq-core.config:config.cma} + %{lib:coq-core.clib:clib.cma} + %{lib:coq-core.lib:lib.cma} + %{lib:coq-core.kernel:kernel.cma} + %{lib:coq-core.vm:byterun.cma} + %{lib:coq-core.vm:../../stublibs/dllbyterun_stubs.so} + %{lib:coq-core.library:library.cma} + %{lib:coq-core.engine:engine.cma} + %{lib:coq-core.pretyping:pretyping.cma} + %{lib:coq-core.gramlib:gramlib.cma} + %{lib:coq-core.interp:interp.cma} + %{lib:coq-core.proofs:proofs.cma} + %{lib:coq-core.parsing:parsing.cma} + %{lib:coq-core.printing:printing.cma} + %{lib:coq-core.tactics:tactics.cma} + %{lib:coq-core.vernac:vernac.cma} + %{lib:coq-core.stm:stm.cma} + %{lib:coq-core.sysinit:sysinit.cma} + %{lib:coq-core.toplevel:toplevel.cma} + %{lib:coq-core.plugins.ltac:ltac_plugin.cma} + %{lib:coq-core.top_printers:top_printers.cmi} + %{lib:coq-core.top_printers:top_printers.cma} + %{lib:coq-core.top_printers:../META}) (action (copy dune-dbg.in dune-dbg))) diff --git a/dev/nixpkgs.nix b/dev/nixpkgs.nix index a582a70e0a..37e39a99a9 100644 --- a/dev/nixpkgs.nix +++ b/dev/nixpkgs.nix @@ -1,4 +1,4 @@ import (fetchTarball { - url = "https://github.com/NixOS/nixpkgs/archive/0bbeca2ff952e6a171534793ddd0fa97c8f9546a.tar.gz"; - sha256 = "0h1y4ffvyvkqs6k2pak02pby25va7c6c1y4p8xkwlzqwswxqxvfl"; + url = "https://github.com/NixOS/nixpkgs/archive/5c7a370a208d93d458193fc05ed84ced0ba7f387.tar.gz"; + sha256 = "1jkn71xscsk4rb0agbp5saf06hy36qvy512zzh3881pkkn67i9js"; }) diff --git a/dev/shim/dune b/dev/shim/dune index 8006c629ed..e4cc7699f0 100644 --- a/dev/shim/dune +++ b/dev/shim/dune @@ -26,7 +26,7 @@ (targets coqbyte-prelude) (deps %{bin:coqtop.byte} - %{lib:coq.kernel:../../stublibs/dllbyterun_stubs.so} + %{lib:coq-core.kernel:../../stublibs/dllbyterun_stubs.so} %{project_root}/theories/Init/Prelude.vo) (action (with-stdout-to %{targets} diff --git a/dev/tools/coqdev.el b/dev/tools/coqdev.el index 5f9f326750..d4f599484f 100644 --- a/dev/tools/coqdev.el +++ b/dev/tools/coqdev.el @@ -33,7 +33,7 @@ (defun coqdev-default-directory () "Return the Coq repository containing `default-directory'." - (let ((dir (locate-dominating-file default-directory "META.coq.in"))) + (let ((dir (locate-dominating-file default-directory "META.coq-core.in"))) (when dir (expand-file-name dir)))) (defun coqdev-setup-compile-command () diff --git a/dev/tools/list-contributors.sh b/dev/tools/list-contributors.sh new file mode 100755 index 0000000000..0b0d01c7e2 --- /dev/null +++ b/dev/tools/list-contributors.sh @@ -0,0 +1,15 @@ +#!/usr/bin/env bash +# For compat with OSX which has a non-gnu sed which doesn't support -z +SED=`(which gsed || which sed) 2> /dev/null` + +if [ $# != 1 ]; then + echo "usage: $0 rev0..rev1" + exit 1 +fi + +git shortlog -s -n --group=author --group=trailer:Co-authored-by $1 | cut -f2 | sort -k 2 | grep -v -e "coqbot" -e "^$" > contributors.tmp + +cat contributors.tmp | wc -l | xargs echo "Contributors:" +cat contributors.tmp | $SED -z "s/\n/, /g" +echo +rm contributors.tmp diff --git a/dev/top_printers.ml b/dev/top_printers.ml index f3d6239c6f..67fe7b980b 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -52,7 +52,6 @@ let ppmind kn = pp(MutInd.debug_print kn) let ppind (kn,i) = pp(MutInd.debug_print kn ++ str"," ++int i) let ppsp sp = pp(pr_path sp) let ppqualid qid = pp(pr_qualid qid) -let ppclindex cl = pp(Coercionops.pr_cl_index cl) let ppscheme k = pp (Ind_tables.pr_scheme_kind k) let prrecarg = Declareops.pp_recarg @@ -576,7 +575,7 @@ let _ = let open Vernacextend in let ty_constr = Extend.TUentry (get_arg_tag Stdarg.wit_constr) in let cmd_sig = TyTerminal("PrintConstr", TyNonTerminal(ty_constr, TyNil)) in - let cmd_fn c ~atts = VtDefault (fun () -> in_current_context econstr_display c) in + let cmd_fn c ?loc:_ ~atts = VtDefault (fun () -> in_current_context econstr_display c) in let cmd_class _ = VtQuery in let cmd : ty_ml = TyML (false, cmd_sig, cmd_fn, Some cmd_class) in vernac_extend ~command:"PrintConstr" [cmd] @@ -585,7 +584,7 @@ let _ = let open Vernacextend in let ty_constr = Extend.TUentry (get_arg_tag Stdarg.wit_constr) in let cmd_sig = TyTerminal("PrintPureConstr", TyNonTerminal(ty_constr, TyNil)) in - let cmd_fn c ~atts = VtDefault (fun () -> in_current_context print_pure_econstr c) in + let cmd_fn c ?loc:_ ~atts = VtDefault (fun () -> in_current_context print_pure_econstr c) in let cmd_class _ = VtQuery in let cmd : ty_ml = TyML (false, cmd_sig, cmd_fn, Some cmd_class) in vernac_extend ~command:"PrintPureConstr" [cmd] diff --git a/dev/top_printers.mli b/dev/top_printers.mli index e8ed6c709e..ba7d92f907 100644 --- a/dev/top_printers.mli +++ b/dev/top_printers.mli @@ -29,8 +29,6 @@ val ppind : Names.inductive -> unit val ppsp : Libnames.full_path -> unit val ppqualid : Libnames.qualid -> unit -val ppclindex : Coercionops.cl_index -> unit - val ppscheme : 'a Ind_tables.scheme_kind -> unit val prrecarg : Declarations.recarg -> Pp.t @@ -165,6 +163,7 @@ val ppobj : Libobject.obj -> unit (* Some super raw printers *) val cast_kind_display : Constr.cast_kind -> string val constr_display : Constr.constr -> unit +val econstr_display : EConstr.constr -> unit val print_pure_constr : Constr.types -> unit val print_pure_econstr : EConstr.types -> unit diff --git a/doc/changelog/01-kernel/13853-delay-native.rst b/doc/changelog/01-kernel/13853-delay-native.rst new file mode 100644 index 0000000000..59bf960a0f --- /dev/null +++ b/doc/changelog/01-kernel/13853-delay-native.rst @@ -0,0 +1,6 @@ +- **Changed:** + Native-code libraries used by :tacn:`native_compute` are now delayed + until an actual call to the :tacn:`native_compute` machinery is + performed. This should make Coq more responsive on some systems + (`#13853 <https://github.com/coq/coq/pull/13853>`_, fixes `#13849 + <https://github.com/coq/coq/issues/13849>`_, by Guillaume Melquiond). diff --git a/doc/changelog/03-notations/13840-print-prim.rst b/doc/changelog/03-notations/13840-print-prim.rst new file mode 100644 index 0000000000..d6e3184662 --- /dev/null +++ b/doc/changelog/03-notations/13840-print-prim.rst @@ -0,0 +1,11 @@ +- **Changed:** + Flag :flag:`Printing Notations` no longer controls + whether strings and numbers are printed raw + (`#13840 <https://github.com/coq/coq/pull/13840>`_, + by Enrico Tassi). + +- **Added:** + Flag :flag:`Printing Raw Literals` to control whether + strings and numbers are printed raw. + (`#13840 <https://github.com/coq/coq/pull/13840>`_, + by Enrico Tassi). diff --git a/doc/changelog/03-notations/13842-remove-decimal.rst b/doc/changelog/03-notations/13842-remove-decimal.rst new file mode 100644 index 0000000000..4bc26ef6a8 --- /dev/null +++ b/doc/changelog/03-notations/13842-remove-decimal.rst @@ -0,0 +1,3 @@ +- **Removed:** + Remove decimal-only number notations which were deprecated in 8.12. + (`#13842 <https://github.com/coq/coq/pull/13842>`_, by Pierre Roux). diff --git a/doc/changelog/04-tactics/13882-fix-ssr-setoidrw-in-hyp.rst b/doc/changelog/04-tactics/13882-fix-ssr-setoidrw-in-hyp.rst new file mode 100644 index 0000000000..31b331f0ff --- /dev/null +++ b/doc/changelog/04-tactics/13882-fix-ssr-setoidrw-in-hyp.rst @@ -0,0 +1,6 @@ +- **Fixed:** + Setoid rewriting now remembers the (invisible) binder names of non-dependent product types. SSReflect's rewrite tactic expects these names to be retained when using ``rewrite foo in H``. + This also fixes SSR ``rewrite foo in H *`` erroneously reverting ``H``. + (`#13882 <https://github.com/coq/coq/pull/13882>`_, + fixes `#12011 <https://github.com/coq/coq/issues/12011>`_, + by Gaëtan Gilbert). diff --git a/doc/changelog/05-tactic-language/13236-ltac2-printf.rst b/doc/changelog/05-tactic-language/13236-ltac2-printf.rst new file mode 100644 index 0000000000..02213f22e5 --- /dev/null +++ b/doc/changelog/05-tactic-language/13236-ltac2-printf.rst @@ -0,0 +1,7 @@ +- **Added:** + Added a ``printf`` macro to Ltac2. It can be made accessible by + importing the ``Ltac2.Printf`` module. See the documentation + there for more information + (`#13236 <https://github.com/coq/coq/pull/13236>`_, + fixes `#10108 <https://github.com/coq/coq/issues/10108>`_, + by Pierre-Marie Pédrot). diff --git a/doc/changelog/05-tactic-language/13920-ltac2-ind-api.rst b/doc/changelog/05-tactic-language/13920-ltac2-ind-api.rst new file mode 100644 index 0000000000..32499957be --- /dev/null +++ b/doc/changelog/05-tactic-language/13920-ltac2-ind-api.rst @@ -0,0 +1,5 @@ +- **Added:** + Added the Ltac2 API `Ltac2.Ind` for manipulating inductive types + (`#13920 <https://github.com/coq/coq/pull/13920>`_, + fixes `#10095 <https://github.com/coq/coq/issues/10095>`_, + by Pierre-Marie Pédrot). diff --git a/doc/changelog/07-vernac-commands-and-options/13202-debug-infra.rst b/doc/changelog/07-vernac-commands-and-options/13202-debug-infra.rst new file mode 100644 index 0000000000..cd1ac3a35a --- /dev/null +++ b/doc/changelog/07-vernac-commands-and-options/13202-debug-infra.rst @@ -0,0 +1,19 @@ +- **Added:** + :opt:`Debug` to control debug messages, functioning similarly to the warning system + (`#13202 <https://github.com/coq/coq/pull/13202>`_, + by Maxime Dénès and Gaëtan Gilbert). + The following flags have been converted (such that ``Set Flag`` becomes ``Set Debug "flag"``): + + - ``Debug Unification`` to ``unification`` + + - ``Debug HO Unification`` to ``ho-unification`` + + - ``Debug Tactic Unification`` to ``tactic-unification`` + + - ``Congruence Verbose`` to ``congruence`` + + - ``Debug Cbv`` to ``cbv`` + + - ``Debug RAKAM`` to ``RAKAM`` + + - ``Debug Ssreflect`` to ``ssreflect`` diff --git a/doc/changelog/07-vernac-commands-and-options/13912-remove-bijint.rst b/doc/changelog/07-vernac-commands-and-options/13912-remove-bijint.rst new file mode 100644 index 0000000000..99efda3a5b --- /dev/null +++ b/doc/changelog/07-vernac-commands-and-options/13912-remove-bijint.rst @@ -0,0 +1,5 @@ +- **Changed:** + The printing order of :cmd:`Print Classes` and :cmd:`Print Graph`, due to the + changes for the internal tables of coercion classes and coercion paths. + (`#13912 <https://github.com/coq/coq/pull/13912>`_, + by Kazuhiko Sakaguchi). diff --git a/doc/changelog/08-cli-tools/13822-rm-depr-cmdline.rst b/doc/changelog/08-cli-tools/13822-rm-depr-cmdline.rst new file mode 100644 index 0000000000..e3333f8a9a --- /dev/null +++ b/doc/changelog/08-cli-tools/13822-rm-depr-cmdline.rst @@ -0,0 +1,4 @@ +- **Removed:** previously deprecated command line options + ``-sprop-cumulative`` and ``-input-state`` and its alias ``-is`` + (`#13822 <https://github.com/coq/coq/pull/13822>`_, + by Gaëtan Gilbert). diff --git a/doc/changelog/08-cli-tools/13876-coqc+no_multiple_files.rst b/doc/changelog/08-cli-tools/13876-coqc+no_multiple_files.rst new file mode 100644 index 0000000000..e48b772f01 --- /dev/null +++ b/doc/changelog/08-cli-tools/13876-coqc+no_multiple_files.rst @@ -0,0 +1,6 @@ +- **Changed:** + `coqc` now enforces that at most a single `.v` file can be passed in + the command line. Support for multiple `.v` files in the form of + `coqc f1.v f2.v` didn't properly work in 8.13, tho it was accepted. + (`#13876 <https://github.com/coq/coq/pull/13876>`_, + by Emilio Jesus Gallego Arias). diff --git a/doc/changelog/09-coqide/13810-shift-return-search-backwards.rst b/doc/changelog/09-coqide/13810-shift-return-search-backwards.rst new file mode 100644 index 0000000000..e78280d91d --- /dev/null +++ b/doc/changelog/09-coqide/13810-shift-return-search-backwards.rst @@ -0,0 +1,3 @@ +- **Added:** + Shift-return in the Find dialog now searches backwards (`#13810 <https://github.com/coq/coq/pull/13810>`_, + by slrnsc). diff --git a/doc/changelog/10-standard-library/13080-ascii.rst b/doc/changelog/10-standard-library/13080-ascii.rst new file mode 100644 index 0000000000..167002283e --- /dev/null +++ b/doc/changelog/10-standard-library/13080-ascii.rst @@ -0,0 +1,4 @@ +- **Added:** + ``leb`` and ``ltb`` functions for ``ascii`` + (`#13080 <https://github.com/coq/coq/pull/13080>`_, + by Yishuai Li). diff --git a/doc/changelog/10-standard-library/13559-primitive_integers.rst b/doc/changelog/10-standard-library/13559-primitive_integers.rst new file mode 100644 index 0000000000..c3cad79bd2 --- /dev/null +++ b/doc/changelog/10-standard-library/13559-primitive_integers.rst @@ -0,0 +1,5 @@ +- **Added:** + Library for signed primitive integers, Sint63. The following operations were added to the kernel: division, remainder, comparison functions, and arithmetic shift right. Everything else works the same for signed and unsigned ints. + (`#13559 <https://github.com/coq/coq/pull/13559>`_, + fixes `#12109 <https://github.com/coq/coq/issues/12109>`_, + by Ana Borges, Guillaume Melquiond and Pierre Roux). diff --git a/doc/changelog/11-infrastructure-and-dependencies/12567-dune+split_stdlib.rst b/doc/changelog/11-infrastructure-and-dependencies/12567-dune+split_stdlib.rst new file mode 100644 index 0000000000..6fe6f62faa --- /dev/null +++ b/doc/changelog/11-infrastructure-and-dependencies/12567-dune+split_stdlib.rst @@ -0,0 +1,14 @@ +- **Changed:** + Coq's configure script now requires absolute paths for the `-prefix` + option. + (`#12567 <https://github.com/coq/coq/pull/12567>`_, + by Emilio Jesus Gallego Arias). + +- **Changed:** + The regular Coq package has been split in two: coq-core, with + OCaml-based libraries and tools; and coq-stdlib, which contains the + Gallina-based standard library. The package Coq now depends on both + for compatiblity. + (`#12567 <https://github.com/coq/coq/pull/12567>`_, + by Emilio Jesus Gallego Arias, review by Vincent Laporte, Guillaume + Melquiond, Enrico Tassi, and Théo Zimmerman). diff --git a/doc/changelog/12-misc/13586-nested-timeout.rst b/doc/changelog/12-misc/13586-nested-timeout.rst new file mode 100644 index 0000000000..2c31dc210a --- /dev/null +++ b/doc/changelog/12-misc/13586-nested-timeout.rst @@ -0,0 +1,7 @@ +- **Fixed:** + Fix the timeout facility on Unix to allow for nested timeouts. + Previous behavior on nested timeouts was that an "inner" timeout would replace an "outer" + timeout, so that the outer timeout would no longer fire. With the new behavior, Unix and Windows + implementations should be (approximately) equivalent. + (`#13586 <https://github.com/coq/coq/pull/13586>`_, + by Lasse Blaauwbroek). @@ -13,7 +13,8 @@ ; + %{bin:coqdoc} etc... ; + config/coq_config.py ; + tools/coqdoc/coqdoc.css - (package coq) + (package coq-core) + (package coq-stdlib) (source_tree sphinx) (source_tree tools/coqrst) unreleased.rst @@ -26,7 +27,8 @@ ; Cannot use this deps alias because of ocaml/dune#3415 ; (deps (alias refman-deps)) (deps - (package coq) + (package coq-core) + (package coq-stdlib) (source_tree sphinx) (source_tree tools/coqrst) unreleased.rst @@ -41,7 +43,8 @@ ; Cannot use this deps alias because of ocaml/dune#3415 ; (deps (alias refman-deps)) (deps - (package coq) + (package coq-core) + (package coq-stdlib) (source_tree sphinx) (source_tree tools/coqrst) unreleased.rst diff --git a/doc/plugin_tutorial/tuto0/src/dune b/doc/plugin_tutorial/tuto0/src/dune index ab9b4dd531..c7ed997221 100644 --- a/doc/plugin_tutorial/tuto0/src/dune +++ b/doc/plugin_tutorial/tuto0/src/dune @@ -1,6 +1,6 @@ (library (name tuto0_plugin) - (public_name coq.plugins.tutorial.p0) - (libraries coq.plugins.ltac)) + (public_name coq-core.plugins.tutorial.p0) + (libraries coq-core.plugins.ltac)) (coq.pp (modules g_tuto0)) diff --git a/doc/plugin_tutorial/tuto1/src/dune b/doc/plugin_tutorial/tuto1/src/dune index 054d5ecd26..bf87222e16 100644 --- a/doc/plugin_tutorial/tuto1/src/dune +++ b/doc/plugin_tutorial/tuto1/src/dune @@ -1,6 +1,6 @@ (library (name tuto1_plugin) - (public_name coq.plugins.tutorial.p1) - (libraries coq.plugins.ltac)) + (public_name coq-core.plugins.tutorial.p1) + (libraries coq-core.plugins.ltac)) (coq.pp (modules g_tuto1)) diff --git a/doc/plugin_tutorial/tuto2/src/dune b/doc/plugin_tutorial/tuto2/src/dune index 8c4b04b1ae..0797debccf 100644 --- a/doc/plugin_tutorial/tuto2/src/dune +++ b/doc/plugin_tutorial/tuto2/src/dune @@ -1,6 +1,6 @@ (library (name tuto2_plugin) - (public_name coq.plugins.tutorial.p2) - (libraries coq.plugins.ltac)) + (public_name coq-core.plugins.tutorial.p2) + (libraries coq-core.plugins.ltac)) (coq.pp (modules g_tuto2)) diff --git a/doc/plugin_tutorial/tuto3/src/dune b/doc/plugin_tutorial/tuto3/src/dune index 678dd71328..dcecf0852e 100644 --- a/doc/plugin_tutorial/tuto3/src/dune +++ b/doc/plugin_tutorial/tuto3/src/dune @@ -1,7 +1,7 @@ (library (name tuto3_plugin) - (public_name coq.plugins.tutorial.p3) + (public_name coq-core.plugins.tutorial.p3) (flags :standard -warn-error -3) - (libraries coq.plugins.ltac)) + (libraries coq-core.plugins.ltac)) (coq.pp (modules g_tuto3)) diff --git a/doc/sphinx/addendum/extraction.rst b/doc/sphinx/addendum/extraction.rst index 8e72bb4ffd..3c7449ee69 100644 --- a/doc/sphinx/addendum/extraction.rst +++ b/doc/sphinx/addendum/extraction.rst @@ -29,7 +29,7 @@ Generating ML Code .. note:: In the following, a qualified identifier :token:`qualid` - can be used to refer to any kind of Coq global "object" : constant, + can be used to refer to any kind of Coq global "object" : :term:`constant`, inductive type, inductive constructor or module name. The next two commands are meant to be used for rapid preview of @@ -128,7 +128,7 @@ wants to generate an OCaml program. The optimizations can be split in two groups: the type-preserving ones (essentially constant inlining and reductions) and the non type-preserving ones (some function abstractions of dummy types are removed when it is deemed safe in order -to have more elegant types). Therefore some constants may not appear in the +to have more elegant types). Therefore some :term:`constants <constant>` may not appear in the resulting monolithic OCaml program. In the case of modular extraction, even if some inlining is done, the inlined constants are nevertheless printed, to ensure session-independent programs. @@ -166,15 +166,15 @@ and commands: .. flag:: Extraction AutoInline - Default is on. The extraction mechanism inlines the bodies of - some defined constants, according to some heuristics + Default is on. The extraction mechanism inlines the :term:`bodies <body>` of + some defined :term:`constants <constant>`, according to some heuristics like size of bodies, uselessness of some arguments, etc. Those heuristics are not always perfect; if you want to disable this feature, turn this flag off. .. cmd:: Extraction Inline {+ @qualid } - In addition to the automatic inline feature, the constants + In addition to the automatic inline feature, the :term:`constants <constant>` mentioned by this command will always be inlined during extraction. .. cmd:: Extraction NoInline {+ @qualid } @@ -194,24 +194,24 @@ and commands: **Inlining and printing of a constant declaration:** -The user can explicitly ask for a constant to be extracted by two means: +The user can explicitly ask for a :term:`constant` to be extracted by two means: * by mentioning it on the extraction command line - * by extracting the whole Coq module of this constant. + * by extracting the whole Coq module of this :term:`constant`. -In both cases, the declaration of this constant will be present in the -produced file. But this same constant may or may not be inlined in +In both cases, the declaration of this :term:`constant` will be present in the +produced file. But this same :term:`constant` may or may not be inlined in the following terms, depending on the automatic/custom inlining mechanism. -For the constants non-explicitly required but needed for dependency +For the :term:`constants <constant>` non-explicitly required but needed for dependency reasons, there are two cases: * If an inlining decision is taken, whether automatically or not, - all occurrences of this constant are replaced by its extracted body, - and this constant is not declared in the generated file. + all occurrences of this :term:`constant` are replaced by its extracted :term:`body`, + and this :term:`constant` is not declared in the generated file. - * If no inlining decision is taken, the constant is normally + * If no inlining decision is taken, the :term:`constant` is normally declared in the produced file. Extra elimination of useless arguments @@ -264,7 +264,7 @@ what ML term corresponds to a given axiom. .. cmd:: Extract Constant @qualid {* @string__tv } => {| @ident | @string } - Give an ML extraction for the given constant. + Give an ML extraction for the given :term:`constant`. :n:`@string__tv` If the type scheme axiom is an arity (a sequence of products followed diff --git a/doc/sphinx/addendum/generalized-rewriting.rst b/doc/sphinx/addendum/generalized-rewriting.rst index 9ac05fab2e..930d286010 100644 --- a/doc/sphinx/addendum/generalized-rewriting.rst +++ b/doc/sphinx/addendum/generalized-rewriting.rst @@ -699,7 +699,7 @@ other. If a signature mentions a relation ``R`` on the left of an arrow ``==>``, then the signature also applies for any relation ``S`` that is smaller than ``R``, and the inverse applies on the right of an arrow. One can then declare only a few morphisms instances that generate the -complete set of signatures for a particular constant. By default, the +complete set of signatures for a particular :term:`constant`. By default, the only declared subrelation is ``iff``, which is a subrelation of ``impl`` and ``inverse impl`` (the dual of implication). That’s why we can declare only two morphisms for conjunction: ``Proper (impl ==> impl ==> impl) and`` and @@ -714,8 +714,8 @@ example of a mostly user-space extension of the algorithm. Constant unfolding ~~~~~~~~~~~~~~~~~~ -The resolution tactic is based on typeclasses and hence regards user- -defined constants as transparent by default. This may slow down the +The resolution tactic is based on typeclasses and hence regards user-defined +:term:`constants <constant>` as transparent by default. This may slow down the resolution due to a lot of unifications (all the declared ``Proper`` instances are tried at each node of the search tree). To speed it up, declare your constant as rigid for proof search using the command @@ -901,7 +901,7 @@ Hint databases created for :tacn:`autorewrite` can also be used by :tacn:`rewrite_strat` using the ``hints`` strategy that applies any of the lemmas at the current subterm. The ``terms`` strategy takes the lemma names directly as arguments. The ``eval`` strategy expects a reduction -expression (see :ref:`performingcomputations`) and succeeds +expression (see :ref:`applyingconversionrules`) and succeeds if it reduces the subterm under consideration. The ``fold`` strategy takes a :token:`term` and tries to *unify* it to the current subterm, converting it to :token:`term` on success. It is stronger than the tactic ``fold``. diff --git a/doc/sphinx/addendum/implicit-coercions.rst b/doc/sphinx/addendum/implicit-coercions.rst index 09b2bb003a..c1b2200741 100644 --- a/doc/sphinx/addendum/implicit-coercions.rst +++ b/doc/sphinx/addendum/implicit-coercions.rst @@ -190,7 +190,7 @@ Use :n:`:>` instead of :n:`:` before the .. cmd:: Identity Coercion @ident : @class >-> @class If ``C`` is the source `class` and ``D`` the destination, we check - that ``C`` is a constant with a body of the form + that ``C`` is a :term:`constant` with a :term:`body` of the form :g:`fun (x₁:T₁)..(xₙ:Tₙ) => D t₁..tₘ` where `m` is the number of parameters of ``D``. Then we define an identity function with type :g:`forall (x₁:T₁)..(xₙ:Tₙ)(y:C x₁..xₙ),D t₁..tₘ`, diff --git a/doc/sphinx/addendum/miscellaneous-extensions.rst b/doc/sphinx/addendum/miscellaneous-extensions.rst index 7d30cae525..8d70ffec01 100644 --- a/doc/sphinx/addendum/miscellaneous-extensions.rst +++ b/doc/sphinx/addendum/miscellaneous-extensions.rst @@ -15,12 +15,12 @@ it provides the following command: standing for the existential variables but they are shelved, as described in :tacn:`shelve`). - When the proof ends two constants are defined: + When the proof ends two :term:`constants <constant>` are defined: + The first one is named :n:`@ident__1` and is defined as the proof of the shelved goal (which is also the value of :g:`?x`). It is always transparent. - + The second one is named :n:`@ident__2`. It has type :n:`@type`, and its body is + + The second one is named :n:`@ident__2`. It has type :n:`@type`, and its :term:`body` is the proof of the initially visible goal. It is opaque if the proof ends with :cmd:`Qed`, and transparent if the proof ends with :cmd:`Defined`. diff --git a/doc/sphinx/addendum/omega.rst b/doc/sphinx/addendum/omega.rst index 0997c5e868..86bb0502c6 100644 --- a/doc/sphinx/addendum/omega.rst +++ b/doc/sphinx/addendum/omega.rst @@ -147,7 +147,7 @@ Options .. flag:: Omega UseLocalDefs - This flag (on by default) allows :tacn:`omega` to use the bodies of local + This flag (on by default) allows :tacn:`omega` to use the :term:`bodies <body>` of local variables. .. flag:: Omega System diff --git a/doc/sphinx/addendum/program.rst b/doc/sphinx/addendum/program.rst index 8f2b51ccce..a011c81f15 100644 --- a/doc/sphinx/addendum/program.rst +++ b/doc/sphinx/addendum/program.rst @@ -149,7 +149,7 @@ when reasoning with equality on the subset types themselves. The next two commands are similar to their standard counterparts :cmd:`Definition` and :cmd:`Fixpoint` -in that they define constants. However, they may require the user to +in that they define :term:`constants <constant>`. However, they may require the user to prove some goals to construct the final definitions. @@ -173,7 +173,7 @@ term :n:`@term__0`, checking that the type of :n:`@term__0` is coercible to set of obligations generated during the interpretation of :n:`@term__0` and the aforementioned coercion derivation are solved. -.. seealso:: Sections :ref:`vernac-controlling-the-reduction-strategies`, :tacn:`unfold` +.. seealso:: Sections :ref:`controlling-the-reduction-strategies`, :tacn:`unfold` .. _program_fixpoint: diff --git a/doc/sphinx/addendum/ring.rst b/doc/sphinx/addendum/ring.rst index 954c2c1446..6b7b588137 100644 --- a/doc/sphinx/addendum/ring.rst +++ b/doc/sphinx/addendum/ring.rst @@ -1,4 +1,4 @@ -.. |bdi| replace:: :math:`\beta\delta\iota` +.. |bdi| replace:: βδι .. |ra| replace:: :math:`\rightarrow_{\beta\delta\iota}` .. |la| replace:: :math:`\leftarrow_{\beta\delta\iota}` .. |eq| replace:: `=`:sub:`(by the main correctness theorem)` diff --git a/doc/sphinx/addendum/sprop.rst b/doc/sphinx/addendum/sprop.rst index 8c20e08154..281473231d 100644 --- a/doc/sphinx/addendum/sprop.rst +++ b/doc/sphinx/addendum/sprop.rst @@ -44,7 +44,7 @@ are convertible: exact Hx. Qed. -Since we have definitional :ref:`eta-expansion` for +Since we have definitional :ref:`eta-expansion-sect` for functions, the property of being a type of definitionally irrelevant values is impredicative, and so is :math:`\SProp`: diff --git a/doc/sphinx/addendum/type-classes.rst b/doc/sphinx/addendum/type-classes.rst index 8dc0030115..45741b4bb8 100644 --- a/doc/sphinx/addendum/type-classes.rst +++ b/doc/sphinx/addendum/type-classes.rst @@ -315,7 +315,7 @@ Summary of the commands inside records, and the trivial projection of an instance of such a class is convertible to the instance itself. This can be useful to make instances of existing objects easily and to reduce proof size by - not inserting useless projections. The class constant itself is + not inserting useless projections. The class :term:`constant` itself is declared rigid during resolution so that the class abstraction is maintained. @@ -326,7 +326,7 @@ Summary of the commands .. cmd:: Existing Class @qualid - This variant declares a class from a previously declared constant or + This variant declares a class from a previously declared :term:`constant` or inductive definition. No methods or instances are defined. .. warn:: @ident is already declared as a typeclass @@ -363,7 +363,7 @@ Summary of the commands This attribute can be used to leave holes or not provide all fields in the definition of an instance and open the tactic mode - to fill them. It works exactly as if no body had been given and + to fill them. It works exactly as if no :term:`body` had been given and the :tacn:`refine` tactic has been used first. .. cmd:: Declare Instance @ident_decl {* @binder } : @term {? @hint_info } @@ -377,7 +377,7 @@ Summary of the commands .. cmd:: Existing Instance @qualid {? @hint_info } Existing Instances {+ @qualid } {? %| @natural } - Adds a constant whose type ends with + Adds a :term:`constant` whose type ends with an applied typeclass to the instance database with an optional priority :token:`natural`. It can be used for redeclaring instances at the end of sections, or declaring structure projections as instances. This is @@ -418,7 +418,7 @@ Summary of the commands unifier. When considering local hypotheses, we use the transparent state of the first hint database given. Using an empty database (created with :cmd:`Create HintDb` for example) with unfoldable variables and - constants as the first argument of ``typeclasses eauto`` hence makes + :term:`constants <constant>` as the first argument of ``typeclasses eauto`` hence makes resolution with the local hypotheses use full conversion during unification. @@ -494,7 +494,7 @@ Typeclasses Transparent, Typeclasses Opaque Make :token:`qualid` opaque for typeclass search. A shortcut for :cmd:`Hint Opaque` :n:`{+ @qualid } : typeclass_instances`. - It is useful when some constants prevent some unifications and make + It is useful when some :term:`constants <constant>` prevent some unifications and make resolution fail. It is also useful to declare constants which should never be unfolded during proof search, like fixpoints or anything which does not look like an abbreviation. This can @@ -502,7 +502,7 @@ Typeclasses Transparent, Typeclasses Opaque indexed by such rigid constants (see :ref:`thehintsdatabasesforautoandeauto`). -By default, all constants and local variables are considered transparent. One +By default, all :term:`constants <constant>` and local variables are considered transparent. One should take care not to make opaque any constant that is used to abbreviate a type, like: @@ -531,7 +531,7 @@ Settings *unify* the goal with the conclusion of the hint. This can drastically improve performance by calling unification less often, matching syntactic patterns being very quick. This also provides more control - on the triggering of instances. For example, forcing a constant to + on the triggering of instances. For example, forcing a :term:`constant` to explicitly appear in the pattern will make it never apply on a goal where there is a hole in that place. diff --git a/doc/sphinx/addendum/universe-polymorphism.rst b/doc/sphinx/addendum/universe-polymorphism.rst index d0b05a03f9..773567b803 100644 --- a/doc/sphinx/addendum/universe-polymorphism.rst +++ b/doc/sphinx/addendum/universe-polymorphism.rst @@ -24,7 +24,7 @@ and *monomorphic* definitions is given by the identity function: Definition identity {A : Type} (a : A) := a. -By default, constant declarations are monomorphic, hence the identity +By default, :term:`constant` declarations are monomorphic, hence the identity function declares a global universe (say ``Top.1``) for its domain. Subsequently, if we try to self-apply the identity, we will get an error: @@ -150,7 +150,7 @@ Polymorphic, Monomorphic attribute is used to override the default. Many other commands can be used to declare universe polymorphic or -monomorphic constants depending on whether the :flag:`Universe +monomorphic :term:`constants <constant>` depending on whether the :flag:`Universe Polymorphism` flag is on or the :attr:`universes(polymorphic)` attribute is used: @@ -341,13 +341,13 @@ Conversion and unification The semantics of conversion and unification have to be modified a little to account for the new universe instance arguments to polymorphic references. The semantics respect the fact that -definitions are transparent, so indistinguishable from their bodies +definitions are transparent, so indistinguishable from their :term:`bodies <body>` during conversion. This is accomplished by changing one rule of unification, the first- order approximation rule, which applies when two applicative terms with the same head are compared. It tries to short-cut unfolding by -comparing the arguments directly. In case the constant is universe +comparing the arguments directly. In case the :term:`constant` is universe polymorphic, we allow this rule to fire only when unifying the universes results in instantiating a so-called flexible universe variables (not given by the user). Similarly for conversion, if such @@ -362,7 +362,7 @@ Minimization Universe polymorphism with cumulativity tends to generate many useless inclusion constraints in general. Typically at each application of a -polymorphic constant :g:`f`, if an argument has expected type :g:`Type@{i}` +polymorphic :term:`constant` :g:`f`, if an argument has expected type :g:`Type@{i}` and is given a term of type :g:`Type@{j}`, a :math:`j ≤ i` constraint will be generated. It is however often the case that an equation :math:`j = i` would be more appropriate, when :g:`f`\'s universes are fresh for example. @@ -550,7 +550,7 @@ underscore or by omitting the annotation to a polymorphic definition. .. flag:: Private Polymorphic Universes This flag, on by default, removes universes which appear only in - the body of an opaque polymorphic definition from the definition's + the :term:`body` of an opaque polymorphic definition from the definition's universe arguments. As such, no value needs to be provided for these universes when instantiating the definition. Universe constraints are automatically adjusted. @@ -563,18 +563,18 @@ underscore or by omitting the annotation to a polymorphic definition. Proof. exact Type. Qed. Print foo. - The universe :g:`Top.xxx` for the :g:`Type` in the body cannot be accessed, we + The universe :g:`Top.xxx` for the :g:`Type` in the :term:`body` cannot be accessed, we only care that one exists for any instantiation of the universes appearing in the type of :g:`foo`. This is guaranteed when the transitive constraint ``Set <= Top.xxx < i`` is verified. Then when - using the constant we don't need to put a value for the inner + using the :term:`constant` we don't need to put a value for the inner universe: .. coqtop:: all Check foo@{_}. - and when not looking at the body we don't mention the private + and when not looking at the :term:`body` we don't mention the private universe: .. coqtop:: all @@ -643,11 +643,11 @@ sections, except in the following ways: (in the above example the anonymous :g:`Type` constrains polymorphic universe :g:`i` to be strictly smaller.) -- no monomorphic constant or inductive may be declared if polymorphic +- no monomorphic :term:`constant` or inductive may be declared if polymorphic universes or universe constraints are present. These restrictions are required in order to produce a sensible result -when closing the section (the requirement on constants and inductives +when closing the section (the requirement on :term:`constants <constant>` and inductive types is stricter than the one on constraints, because constants and inductives are abstracted by *all* the section's polymorphic universes and constraints). diff --git a/doc/sphinx/changes.rst b/doc/sphinx/changes.rst index 4769636ae8..4f3ee2dcaf 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -82,13 +82,13 @@ Kazuhiko Sakaguchi, Vincent Semeria, Michael Soegtrop, Arnaud Spiwack, Matthieu Sozeau, Enrico Tassi, Laurent Théry, Anton Trunov, Li-yao Xia and Théo Zimmermann. -The 52 contributors to this version are Reynald Affeldt, Tanaka Akira, Frédéric +The 51 contributors to this version are Reynald Affeldt, Tanaka Akira, Frédéric Besson, Lasse Blaauwbroek, Clément Blaudeau, Martin Bodin, Ali Caglayan, Tej Chajed, Cyril Cohen, Julien Coolen, Matthew Dempsky, Maxime Dénès, Andres Erbsen, Jim Fehrle, Emilio Jesús Gallego Arias, Paolo G. Giarrusso, Attila Gáspár, Gaëtan Gilbert, Jason Gross, Benjamin Grégoire, Hugo Herbelin, Wolf Honore, Jasper Hugunin, Ignat Insarov, Ralf Jung, Fabian Kunze, Vincent Laporte, Olivier Laurent, Larry D. Lee Jr, -Thomas Letan, Yishuai Li, Xia Li-yao, James Lottes, Jean-Christophe Léchenet, +Thomas Letan, Yishuai Li, James Lottes, Jean-Christophe Léchenet, Kenji Maillard, Erik Martin-Dorel, Yusuke Matsushita, Guillaume Melquiond, Carl Patenaude-Poulin, Clément Pit-Claudel, Pierre-Marie Pédrot, Pierre Roux, Kazuhiko Sakaguchi, Vincent Semeria, Michael Soegtrop, Matthieu Sozeau, @@ -701,6 +701,27 @@ Commands and options (`#13556 <https://github.com/coq/coq/pull/13556>`_, by Simon Friis Vindum). +Changes in 8.13.1 +~~~~~~~~~~~~~~~~~ + +Kernel +^^^^^^ + +- **Fixed:** + Fix arities of VM opcodes for some floating-point operations + that could cause memory corruption + (`#13867 <https://github.com/coq/coq/pull/13867>`_, + by Guillaume Melquiond). + +CoqIDE +^^^^^^ + +- **Added:** + Option ``-v`` and ``--version`` to CoqIDE + (`#13870 <https://github.com/coq/coq/pull/13870>`_, + by Guillaume Melquiond). + + Version 8.12 ------------ @@ -1912,7 +1933,7 @@ Changes in 8.12.1 **Kernel** - **Fixed:** Incompleteness of conversion checking on problems - involving :ref:`eta-expansion` and :ref:`cumulative universe + involving :ref:`eta-expansion-sect` 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). @@ -5068,7 +5089,7 @@ Coq version 8.5 contains the result of five specific long-term projects: Matthieu Sozeau. - An implementation of primitive projections with - :math:`\eta`\-conversion bringing significant performance improvements + η-conversion bringing significant performance improvements when using records by Matthieu Sozeau. The full integration of the proof engine, by Arnaud Spiwack and @@ -5119,10 +5140,10 @@ messages in case of inconsistencies and allowing higher-level algorithms like unification to be entirely type safe. The internal representation of universes has been modified but this is invisible to the user. -The underlying logic has been extended with :math:`\eta`\-conversion for +The underlying logic has been extended with η-conversion for records defined with primitive projections by Matthieu Sozeau. This -additional form of :math:`\eta`\-conversion is justified using the same -principle than the previously added :math:`\eta`\-conversion for function +additional form of η-conversion is justified using the same +principle than the previously added η-conversion for function types, based on formulations of the Calculus of Inductive Constructions with typed equality. Primitive projections, which do not carry the parameters of the record and are rigid names (not defined as a @@ -6139,9 +6160,9 @@ contributed many various refinements of CoqIDE. Coq 8.4 also comes with a bunch of various smaller-scale changes and improvements regarding the different components of the system. -The underlying logic has been extended with :math:`\eta`-conversion +The underlying logic has been extended with η-conversion thanks to Hugo Herbelin, Stéphane Glondu and Benjamin Grégoire. The -addition of :math:`\eta`-conversion is justified by the confidence that +addition of η-conversion is justified by the confidence that the formulation of the Calculus of Inductive Constructions based on typed equality (such as the one considered in Lee and Werner to build a set-theoretic model of CIC :cite:`LeeWerner11`) is @@ -6150,7 +6171,7 @@ applicable to the concrete implementation of Coq. The underlying logic benefited also from a refinement of the guard condition for fixpoints by Pierre Boutillier, the point being that it is safe to propagate the information about structurally smaller arguments -through :math:`\beta`-redexes that are blocked by the “match” +through β-redexes that are blocked by the “match” construction (blocked commutative cuts). Relying on the added permissiveness of the guard condition, Hugo diff --git a/doc/sphinx/language/cic.rst b/doc/sphinx/language/cic.rst index 1cfd8dac50..9f097b4fe9 100644 --- a/doc/sphinx/language/cic.rst +++ b/doc/sphinx/language/cic.rst @@ -1,8 +1,9 @@ Typing rules ==================================== -The underlying formal language of Coq is a *Calculus of Inductive -Constructions* (|Cic|) whose inference rules are presented in this +The underlying formal language of Coq is a +:gdef:`Calculus of Inductive Constructions` (|Cic|) whose inference rules +are presented in this chapter. The history of this formalism as well as pointers to related work are provided in a separate chapter; see *Credits*. @@ -146,7 +147,7 @@ In the global environment, :math:`(c:T)`, indicating that :math:`c` is of the type :math:`T`. *Definitions* are written as :math:`c:=t:T`, indicating that :math:`c` has the value :math:`t` and type :math:`T`. We shall call -such names *constants*. For the rest of the chapter, the :math:`E;~c:T` denotes +such names :term:`constants <constant>`. For the rest of the chapter, the :math:`E;~c:T` denotes the global environment :math:`E` enriched with the assumption :math:`c:T`. Similarly, :math:`E;~c:=t:T` denotes the global environment :math:`E` enriched with the definition :math:`(c:=t:T)`. diff --git a/doc/sphinx/language/core/basic.rst b/doc/sphinx/language/core/basic.rst index 0a61c4ce22..2b50d4c420 100644 --- a/doc/sphinx/language/core/basic.rst +++ b/doc/sphinx/language/core/basic.rst @@ -523,31 +523,20 @@ they appear after a boldface label. They are listed in the Locality attributes supported by :cmd:`Set` and :cmd:`Unset` ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -The :cmd:`Set` and :cmd:`Unset` commands support the :attr:`local`, -:attr:`global` and :attr:`export` locality attributes: - -* no attribute: the original setting is *not* restored at the end of - the current module or section. -* :attr:`local` (or alternatively, the ``Local`` prefix): the setting - is applied within the current module or section. The original value - of the setting is restored at the end of the current module or - section. -* :attr:`export` (or alternatively, the ``Export`` prefix): similar to - :attr:`local`, the original value of the setting is restored at the - end of the current module or section. In addition, if the value is - set in a module, then :cmd:`Import`\-ing the module sets the option - or flag. -* :attr:`global` (or alternatively, the ``Global`` prefix): the - original setting is *not* restored at the end of the current module - or section. In addition, if the value is set in a file, then - :cmd:`Require`\-ing the file sets the option. +The :cmd:`Set` and :cmd:`Unset` commands support the mutually +exclusive :attr:`local`, :attr:`export` and :attr:`global` locality +attributes (or the ``Local``, ``Export`` or ``Global`` prefixes). + +If no attribute is specified, the original value of the flag or option +is restored at the end of the current module but it is *not* restored +at the end of the current section. Newly opened modules and sections inherit the current settings. .. note:: - We discourage using the :attr:`global` attribute with the :cmd:`Set` and - :cmd:`Unset` commands. If your goal is to define + We discourage using the :attr:`global` locality attribute with the + :cmd:`Set` and :cmd:`Unset` commands. If your goal is to define project-wide settings, you should rather use the command-line arguments ``-set`` and ``-unset`` for setting flags and options (see :ref:`command-line-options`). diff --git a/doc/sphinx/language/core/coinductive.rst b/doc/sphinx/language/core/coinductive.rst index e742139134..61952c1570 100644 --- a/doc/sphinx/language/core/coinductive.rst +++ b/doc/sphinx/language/core/coinductive.rst @@ -196,5 +196,5 @@ Top-level definitions of co-recursive functions If :n:`@term` is omitted, :n:`@type` is required and Coq enters proof mode. This can be used to define a term incrementally, in particular by relying on the :tacn:`refine` tactic. - In this case, the proof should be terminated with :cmd:`Defined` in order to define a constant + In this case, the proof should be terminated with :cmd:`Defined` in order to define a :term:`constant` for which the computational behavior is relevant. See :ref:`proof-editing-mode`. diff --git a/doc/sphinx/language/core/conversion.rst b/doc/sphinx/language/core/conversion.rst index 09c619338b..06b6c61ea9 100644 --- a/doc/sphinx/language/core/conversion.rst +++ b/doc/sphinx/language/core/conversion.rst @@ -1,11 +1,13 @@ .. _Conversion-rules: Conversion rules --------------------- +---------------- -In |Cic|, there is an internal reduction mechanism. In particular, it -can decide if two programs are *intentionally* equal (one says -:term:`convertible`). Convertibility is described in this section. +Coq has conversion rules that can be used to determine if two +terms are equal by definition, or :term:`convertible`. +Conversion rules consist of reduction rules and expansion rules. +See :ref:`applyingconversionrules`, +which describes tactics that apply these conversion rules. α-conversion ~~~~~~~~~~~~ @@ -14,56 +16,44 @@ Two terms are :gdef:`α-convertible <alpha-convertible>` if they are syntactical 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: - β-reduction ~~~~~~~~~~~ -We want to be able to identify some terms as we can identify the -application of a function to a given argument with its result. For -instance the identity function over a given type :math:`T` can be written -:math:`λx:T.~x`. In any global environment :math:`E` and local context -:math:`Γ`, we want to identify any object :math:`a` (of type -:math:`T`) with the application :math:`((λ x:T.~x)~a)`. We define for -this a *reduction* (or a *conversion*) rule we call :math:`β`: +:gdef:`β-reduction <beta-reduction>` reduces a :gdef:`beta-redex`, which is +a term in the form `(fun x => t) u`. (Beta-redex +is short for "beta-reducible expression", a term from lambda calculus. +See `Beta reduction <https://en.wikipedia.org/wiki/Beta_normal_form#Beta_reduction>`_ +for more background.) -.. math:: +Formally, in any :term:`global environment` :math:`E` and :term:`local context` +:math:`Γ`, the beta-reduction rule is: - E[Γ] ⊢ ((λx:T.~t)~u)~\triangleright_β~\subst{t}{x}{u} +.. inference:: Beta + + -------------- + E[Γ] ⊢ ((λx:T.~t)~u)~\triangleright_β~\subst{t}{x}{u} We say that :math:`\subst{t}{x}{u}` is the *β-contraction* of :math:`((λx:T.~t)~u)` and, conversely, that :math:`((λ x:T.~t)~u)` is the *β-expansion* of :math:`\subst{t}{x}{u}`. -According to β-reduction, terms of the *Calculus of Inductive -Constructions* enjoy some fundamental properties such as confluence, +.. todo: :term:`Calculus of Inductive Constructions` fails to build in CI for some reason :-() + +Terms of the *Calculus of Inductive Constructions* +enjoy some fundamental properties such as confluence, strong normalization, subject reduction. These results are theoretically of great importance but we will not detail them here and refer the interested reader to :cite:`Coq85`. - -.. _iota-reduction: - -ι-reduction -~~~~~~~~~~~ - -A specific conversion rule is associated with the inductive objects in -the global environment. We shall give later on (see Section -:ref:`Well-formed-inductive-definitions`) the precise rules but it -just says that a destructor applied to an object built from a -constructor behaves as expected. This reduction is called ι-reduction -and is more precisely studied in :cite:`Moh93,Wer94`. - - -.. _delta-reduction: +.. _delta-reduction-sect: δ-reduction ~~~~~~~~~~~ -We may have variables defined in local contexts or constants defined -in the global environment. It is legal to identify such a reference -with its value, that is to expand (or unfold) it into its value. This -reduction is called δ-reduction and shows as follows. +:gdef:`δ-reduction <delta-reduction>` replaces variables defined in +:term:`local contexts <local context>` +or :term:`constants <constant>` defined in the :term:`global environment` with their values. +:gdef:`Unfolding <unfold>` means to replace a constant by its definition. Formally, this is: .. inference:: Delta-Local @@ -79,16 +69,29 @@ reduction is called δ-reduction and shows as follows. -------------- E[Γ] ⊢ c~\triangleright_δ~t +:term:`Delta-reduction <delta-reduction>` only unfolds :term:`constants <constant>` that are +marked :gdef:`transparent`. :gdef:`Opaque <opaque>` is the opposite of +transparent; :term:`delta-reduction` doesn't unfold opaque constants. + +ι-reduction +~~~~~~~~~~~ -.. _zeta-reduction: +A specific conversion rule is associated with the inductive objects in +the global environment. We shall give later on (see Section +:ref:`Well-formed-inductive-definitions`) the precise rules but it +just says that a destructor applied to an object built from a +constructor behaves as expected. This reduction is called +:gdef:`ι-reduction <iota-reduction>` +and is more precisely studied in :cite:`Moh93,Wer94`. ζ-reduction ~~~~~~~~~~~ -Coq allows also to remove local definitions occurring in terms by -replacing the defined variable by its value. The declaration being -destroyed, this reduction differs from δ-reduction. It is called -ζ-reduction and shows as follows. +:gdef:`ζ-reduction <zeta-reduction>` removes :ref:`let-in definitions <let-in>` +in terms by +replacing the defined variable by its value. One way this reduction differs from +δ-reduction is that the declaration is removed from the term entirely. +Formally, this is: .. inference:: Zeta @@ -99,12 +102,12 @@ destroyed, this reduction differs from δ-reduction. It is called E[Γ] ⊢ \letin{x}{u:U}{t}~\triangleright_ζ~\subst{t}{x}{u} -.. _eta-expansion: +.. _eta-expansion-sect: η-expansion ~~~~~~~~~~~ -Another important concept is η-expansion. It is legal to identify any +Another important concept is :gdef:`η-expansion <eta-expansion>`. It is legal to identify any term :math:`t` of functional type :math:`∀ x:T,~U` with its so-called η-expansion .. math:: diff --git a/doc/sphinx/language/core/definitions.rst b/doc/sphinx/language/core/definitions.rst index 7196c082ed..fcf61a5bf4 100644 --- a/doc/sphinx/language/core/definitions.rst +++ b/doc/sphinx/language/core/definitions.rst @@ -31,43 +31,48 @@ for :n:`let @ident := fun {+ @binder} => @term__1 in @term__2`. single: ... <: ... single: ... <<: ... +.. _type-cast: + Type cast --------- .. insertprodn term_cast term_cast .. prodn:: - term_cast ::= @term10 <: @type + term_cast ::= @term10 : @type + | @term10 <: @type | @term10 <<: @type - | @term10 : @type | @term10 :> The expression :n:`@term10 : @type` is a type cast expression. It enforces the type of :n:`@term10` to be :n:`@type`. -:n:`@term10 <: @type` locally sets up the virtual machine for checking that -:n:`@term10` has type :n:`@type`. +:n:`@term10 <: @type` specifies that the virtual machine will be used +to type check that :n:`@term10` has type :n:`@type` (see :tacn:`vm_compute`). + +:n:`@term10 <<: @type` specifies that compilation to OCaml will be used +to type check that :n:`@term10` has type :n:`@type` (see :tacn:`native_compute`). -:n:`@term10 <<: @type` uses native compilation for checking that :n:`@term10` -has type :n:`@type`. +:n:`@term10 :>` casts to the support type in Program mode. +See :ref:`syntactic_control`. .. _gallina-definitions: Top-level definitions --------------------- -Definitions extend the global environment with associations of names to terms. +Definitions extend the global environment by associating names to terms. A definition can be seen as a way to give a meaning to a name or as a way to abbreviate a term. In any case, the name can later be replaced at any time by its definition. The operation of unfolding a name into its definition is called -:math:`\delta`-conversion (see Section :ref:`delta-reduction`). A -definition is accepted by the system if and only if the defined term is +:term:`delta-reduction`. +A definition is accepted by the system if and only if the defined term is well-typed in the current context of the definition and if the name is not already used. The name defined by the definition is called a -*constant* and the term it refers to is its *body*. A definition has a -type which is the type of its body. +:gdef:`constant` and the term it refers to is its :gdef:`body`. A definition has +a type, which is the type of its :term:`body`. A formal presentation of constants and environments is given in Section :ref:`typing-rules`. @@ -96,7 +101,7 @@ Section :ref:`typing-rules`. If :n:`@term` is omitted, :n:`@type` is required and Coq enters proof mode. This can be used to define a term incrementally, in particular by relying on the :tacn:`refine` tactic. - In this case, the proof should be terminated with :cmd:`Defined` in order to define a constant + In this case, the proof should be terminated with :cmd:`Defined` in order to define a :term:`constant` for which the computational behavior is relevant. See :ref:`proof-editing-mode`. The form :n:`Definition @ident : @type := @term` checks that the type of :n:`@term` @@ -151,7 +156,7 @@ The basic assertion command is: over a mutually inductive assumption, or that assert mutually dependent statements in some mutual co-inductive type. It is equivalent to :cmd:`Fixpoint` or :cmd:`CoFixpoint` but using tactics to build the proof of - the statements (or the body of the specification, depending on the point of + the statements (or the :term:`body` of the specification, depending on the point of view). The inductive or co-inductive types on which the induction or coinduction has to be done is assumed to be non ambiguous and is guessed by the system. @@ -202,10 +207,10 @@ the proof and adds it to the global environment. statements still to be proved. Nonetheless, this practice is discouraged and may stop working in future versions. - #. Proofs ended by :cmd:`Qed` are declared opaque. Their content cannot be - unfolded (see :ref:`performingcomputations`), thus - realizing some form of *proof-irrelevance*. To be able to unfold a - proof, the proof should be ended by :cmd:`Defined`. + #. Proofs ended by :cmd:`Qed` are declared :term:`opaque`. Their content cannot be + unfolded (see :ref:`applyingconversionrules`), thus + realizing some form of *proof-irrelevance*. + Proofs that end with :cmd:`Defined` can be unfolded. #. :cmd:`Proof` is recommended but can currently be omitted. On the opposite side, :cmd:`Qed` (or :cmd:`Defined`) is mandatory to validate a proof. diff --git a/doc/sphinx/language/core/inductive.rst b/doc/sphinx/language/core/inductive.rst index 4e892f709d..971a856899 100644 --- a/doc/sphinx/language/core/inductive.rst +++ b/doc/sphinx/language/core/inductive.rst @@ -25,7 +25,7 @@ Inductive types respectively correspond to elimination principles on :g:`Type`, :g:`Prop`, :g:`Set` and :g:`SProp`. The type of the destructors expresses structural induction/recursion principles over objects of - type :n:`@ident`. The constant :n:`@ident`\ ``_ind`` is always + type :n:`@ident`. The :term:`constant` :n:`@ident`\ ``_ind`` is always generated, whereas :n:`@ident`\ ``_rec`` and :n:`@ident`\ ``_rect`` may be impossible to derive (for example, when :n:`@ident` is a proposition). @@ -415,7 +415,7 @@ constructions. If :n:`@term` is omitted, :n:`@type` is required and Coq enters proof mode. This can be used to define a term incrementally, in particular by relying on the :tacn:`refine` tactic. - In this case, the proof should be terminated with :cmd:`Defined` in order to define a constant + In this case, the proof should be terminated with :cmd:`Defined` in order to define a :term:`constant` for which the computational behavior is relevant. See :ref:`proof-editing-mode`. This command accepts the :attr:`using` attribute. diff --git a/doc/sphinx/language/core/modules.rst b/doc/sphinx/language/core/modules.rst index 93d70c773f..c42d444089 100644 --- a/doc/sphinx/language/core/modules.rst +++ b/doc/sphinx/language/core/modules.rst @@ -17,7 +17,7 @@ and :math:`id` an identifier, then :math:`p′.id` is an access path. **Structure element.** A structure element is denoted by :math:`e` and -is either a definition of a constant, an assumption, a definition of +is either a definition of a :term:`constant`, an assumption, a definition of an inductive, a definition of a module, an alias of a module or a module type abbreviation. @@ -134,7 +134,7 @@ is also used to terminate :ref:`Sections<section-mechanism>`. :n:`End @ident` closes the interactive module or module type :token:`ident`. If the module type was given, the command verifies that the content of the module matches the module type. If the module is not a -functor, its components (constants, inductive types, submodules etc.) +functor, its components (:term:`constants <constant>`, inductive types, submodules etc.) are now available through the dot notation. .. exn:: No such label @ident. @@ -170,7 +170,7 @@ are now available through the dot notation. hints and the like valid for :n:`@ident__1` are the ones defined in :n:`@module_type` rather then those defined in :n:`@ident__2` (or the module body). #. Within an interactive module type definition, the :cmd:`Parameter` command declares a - constant instead of definining a new axiom (which it does when not in a module type definition). + :term:`constant` instead of definining a new axiom (which it does when not in a module type definition). #. Assumptions such as :cmd:`Axiom` that include the :n:`Inline` clause will be automatically expanded when the functor is applied, except when the function application is prefixed by ``!``. @@ -250,14 +250,14 @@ are now available through the dot notation. make only those names available with short names, not other names defined in the module nor will it activate other features. - The names to import may be constants, inductive types and + The names to import may be :term:`constants <constant>`, inductive types and constructors, and notation aliases (for instance, Ltac definitions cannot be selectively imported). If they are from an inner module to the one being imported, they must be prefixed by the inner path. The name of an inductive type may also be followed by ``(..)`` to import it, its constructors and its eliminators if they exist. For - this purpose "eliminator" means a constant in the same module whose + this purpose "eliminator" means a :term:`constant` in the same module whose name is the inductive type's name suffixed by one of ``_sind``, ``_ind``, ``_rec`` or ``_rect``. @@ -332,7 +332,7 @@ Examples Defined. End M. -Inside a module one can define constants, prove theorems and do anything +Inside a module one can define :term:`constants <constant>`, prove theorems and do anything else that can be done in the toplevel. Components of a closed module can be accessed using the dot notation: @@ -455,9 +455,9 @@ Typing Modules In order to introduce the typing system we first slightly extend the syntactic class of terms and environments given in section :ref:`The-terms`. The -environments, apart from definitions of constants and inductive types now also -hold any other structure elements. Terms, apart from variables, constants and -complex terms, include also access paths. +environments, apart from definitions of :term:`constants <constant>` and inductive types now also +hold any other structure elements. Terms, apart from variables, :term:`constants <constant>` and +complex terms, also include access paths. We also need additional typing judgments: @@ -880,7 +880,7 @@ started, unless option ``-top`` or ``-notop`` is set (see :ref:`command-line-opt .. _qualified-names: Qualified identifiers ---------------------- +~~~~~~~~~~~~~~~~~~~~~ .. insertprodn qualid field_ident @@ -1010,3 +1010,73 @@ subdirectories of path). See the command :cmd:`Declare ML Module` in See :ref:`command-line-options` for a more general view over the Coq command line options. + +.. _controlling-locality-of-commands: + +Controlling the scope of commands with locality attributes +---------------------------------------------------------- + +Many commands have effects that apply only within a specific scope, +typically the section or the module in which the command was +called. Locality :term:`attributes <attribute>` can alter the scope of +the effect. Below, we give the semantics of each locality attribute +while noting a few exceptional commands for which :attr:`local` and +:attr:`global` attributes are interpreted differently. + +.. attr:: local + + The :attr:`local` attribute limits the effect of the command to the + current scope (section or module). + + The ``Local`` prefix is an alternative syntax for the :attr:`local` + attribute (see :n:`@legacy_attr`). + + .. note:: + + - For some commands, this is the only locality supported within + sections (e.g., for :cmd:`Notation`, :cmd:`Ltac` and + :ref:`Hint <creating_hints>` commands). + + - For some commands, this is the default locality within + sections even though other locality attributes are supported + as well (e.g., for the :cmd:`Arguments` command). + + .. warning:: + + **Exception:** when :attr:`local` is applied to + :cmd:`Definition`, :cmd:`Theorem` or their variants, its + semantics are different: it makes the defined objects available + only through their fully-qualified names rather than their + unqualified names after an :cmd:`Import`. + +.. attr:: export + + The :attr:`export` attribute makes the effect of the command + persist when the section is closed and applies the effect when the + module containing the command is imported. + + Commands supporting this attribute include :cmd:`Set`, :cmd:`Unset` + and the :ref:`Hint <creating_hints>` commands, although the latter + don't support it within sections. + +.. attr:: global + + The :attr:`global` attribute makes the effect of the command + persist even when the current section or module is closed. Loading + the file containing the command (possibly transitively) applies the + effect of the command. + + The ``Global`` prefix is an alternative syntax for the + :attr:`global` attribute (see :n:`@legacy_attr`). + + .. warning:: + + **Exception:** for a few commands (like :cmd:`Notation` and + :cmd:`Ltac`), this attribute behaves like :attr:`export`. + + .. warning:: + + We strongly discourage using the :attr:`global` locality + attribute because the transitive nature of file loading gives + the user little control. We recommend using the :attr:`export` + locality attribute where it is supported. diff --git a/doc/sphinx/language/core/primitive.rst b/doc/sphinx/language/core/primitive.rst index 4505fc4b4d..7211d00dd0 100644 --- a/doc/sphinx/language/core/primitive.rst +++ b/doc/sphinx/language/core/primitive.rst @@ -8,15 +8,20 @@ Primitive Integers The language of terms features 63-bit machine integers as values. The type of such a value is *axiomatized*; it is declared through the following sentence -(excerpt from the :g:`Int63` module): +(excerpt from the :g:`PrimInt63` module): .. coqdoc:: Primitive int := #int63_type. -This type is equipped with a few operators, that must be similarly declared. -For instance, equality of two primitive integers can be decided using the :g:`Int63.eqb` function, -declared and specified as follows: +This type can be understood as representing either unsigned or signed integers, +depending on which module is imported or, more generally, which scope is open. +:g:`Int63` and :g:`int63_scope` refer to the unsigned version, while :g:`Sint63` +and :g:`sint63_scope` refer to the signed one. + +The :g:`PrimInt63` module declares the available operators for this type. +For instance, equality of two unsigned primitive integers can be determined using +the :g:`Int63.eqb` function, declared and specified as follows: .. coqdoc:: @@ -25,7 +30,9 @@ declared and specified as follows: Axiom eqb_correct : forall i j, (i == j)%int63 = true -> i = j. -The complete set of such operators can be obtained looking at the :g:`Int63` module. +The complete set of such operators can be found in the :g:`PrimInt63` module. +The specifications and notations are in the :g:`Int63` and :g:`Sint63` +modules. These primitive declarations are regular axioms. As such, they must be trusted and are listed by the :g:`Print Assumptions` command, as in the following example. diff --git a/doc/sphinx/language/core/records.rst b/doc/sphinx/language/core/records.rst index 6671c67fb2..871bc0770c 100644 --- a/doc/sphinx/language/core/records.rst +++ b/doc/sphinx/language/core/records.rst @@ -207,7 +207,7 @@ other arguments are the parameters of the inductive type. There may be three reasons: #. The name :token:`ident` already exists in the global environment (see :cmd:`Axiom`). - #. The body of :token:`ident` uses an incorrect elimination for + #. The :term:`body` of :token:`ident` uses an incorrect elimination for :token:`ident` (see :cmd:`Fixpoint` and :ref:`Destructors`). #. The type of the projections :token:`ident` depends on previous projections which themselves could not be defined. @@ -278,7 +278,7 @@ There are currently two ways to introduce primitive records types: `r` ``= Build_``\ `R` ``(``\ `r`\ ``.(``\ |p_1|\ ``) …`` `r`\ ``.(``\ |p_n|\ ``))``. Eta-conversion allows to define dependent elimination for these types as well. #. Through the ``Inductive`` and ``CoInductive`` commands, when - the body of the definition is a record declaration of the form + the :term:`body` of the definition is a record declaration of the form ``Build_``\ `R` ``{`` |p_1| ``:`` |t_1|\ ``; … ;`` |p_n| ``:`` |t_n| ``}``. In this case the types can be recursive and eta-conversion is disallowed. These kind of record types differ from their traditional versions in the sense that dependent @@ -290,11 +290,11 @@ Reduction The basic reduction rule of a primitive projection is |p_i| ``(Build_``\ `R` |t_1| … |t_n|\ ``)`` :math:`{\rightarrow_{\iota}}` |t_i|. -However, to take the :math:`{\delta}` flag into +However, to take the δ flag into account, projections can be in two states: folded or unfolded. An unfolded primitive projection application obeys the rule above, while the folded version delta-reduces to the unfolded version. This allows to -precisely mimic the usual unfolding rules of constants. Projections +precisely mimic the usual unfolding rules of :term:`constants <constant>`. Projections obey the usual ``simpl`` flags of the ``Arguments`` command in particular. There is currently no way to input unfolded primitive projections at the user-level, and there is no way to display unfolded projections differently @@ -305,8 +305,8 @@ Compatibility Projections and :g:`match` ++++++++++++++++++++++++++++++++++++++++ To ease compatibility with ordinary record types, each primitive -projection is also defined as a ordinary constant taking parameters and -an object of the record type as arguments, and whose body is an +projection is also defined as an ordinary :term:`constant` taking parameters and +an object of the record type as arguments, and whose :term:`body` is an application of the unfolded primitive projection of the same name. These constants are used when elaborating partial applications of the projection. One can distinguish them from applications of the primitive diff --git a/doc/sphinx/language/core/sections.rst b/doc/sphinx/language/core/sections.rst index c16152ff4f..4c41ce8a89 100644 --- a/doc/sphinx/language/core/sections.rst +++ b/doc/sphinx/language/core/sections.rst @@ -55,7 +55,7 @@ usable outside the section as shown in this :ref:`example <section_local_declara :name: Let; Let Fixpoint; Let CoFixpoint These are similar to :cmd:`Definition`, :cmd:`Fixpoint` and :cmd:`CoFixpoint`, except that - the declared constant is local to the current section. + the declared :term:`constant` is local to the current section. When the section is closed, all persistent definitions and theorems within it that depend on the constant will be wrapped with a :n:`@term_let` with the same declaration. diff --git a/doc/sphinx/language/extensions/arguments-command.rst b/doc/sphinx/language/extensions/arguments-command.rst index 214541570c..87001251c2 100644 --- a/doc/sphinx/language/extensions/arguments-command.rst +++ b/doc/sphinx/language/extensions/arguments-command.rst @@ -226,10 +226,10 @@ Automatic declaration of implicit arguments Print Implicit nil. The computation of implicit arguments takes account of the unfolding -of constants. For instance, the variable ``p`` below has type +of :term:`constants <constant>`. For instance, the variable ``p`` below has type ``(Transitivity R)`` which is reducible to ``forall x,y:U, R x y -> forall z:U, R y z -> R x z``. As the variables ``x``, ``y`` and ``z`` -appear strictly in the body of the type, they are implicit. +appear strictly in the :term:`body` of the type, they are implicit. .. coqtop:: all @@ -318,7 +318,7 @@ Binding arguments to a scope Effects of :cmd:`Arguments` on unfolding ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -+ `simpl never` indicates that a constant should never be unfolded by :tacn:`cbn`, ++ `simpl never` indicates that a :term:`constant` should never be unfolded by :tacn:`cbn`, :tacn:`simpl` or :tacn:`hnf`: .. example:: @@ -330,7 +330,7 @@ Effects of :cmd:`Arguments` on unfolding After that command an expression like :g:`(minus (S x) y)` is left untouched by the tactics :tacn:`cbn` and :tacn:`simpl`. -+ A constant can be marked to be unfolded only if it's applied to at least ++ A :term:`constant` can be marked to be unfolded only if it's applied to at least the arguments appearing before the `/` in a :cmd:`Arguments` command. .. example:: @@ -343,7 +343,7 @@ Effects of :cmd:`Arguments` on unfolding After that command the expression :g:`(f \o g)` is left untouched by :tacn:`simpl` while :g:`((f \o g) t)` is reduced to :g:`(f (g t))`. - The same mechanism can be used to make a constant volatile, i.e. + The same mechanism can be used to make a :term:`constant` volatile, i.e. always unfolded. .. example:: @@ -353,7 +353,7 @@ Effects of :cmd:`Arguments` on unfolding Definition volatile := fun x : nat => x. Arguments volatile / x. -+ A constant can be marked to be unfolded only if an entire set of ++ A :term:`constant` can be marked to be unfolded only if an entire set of arguments evaluates to a constructor. The ``!`` symbol can be used to mark such arguments. @@ -366,7 +366,7 @@ Effects of :cmd:`Arguments` on unfolding After that command, the expression :g:`(minus (S x) y)` is left untouched by :tacn:`simpl`, while :g:`(minus (S x) (S y))` is reduced to :g:`(minus x y)`. -+ `simpl nomatch` indicates that a constant should not be unfolded if it would expose ++ `simpl nomatch` indicates that a :term:`constant` should not be unfolded if it would expose a `match` construct in the head position. This affects the :tacn:`cbn`, :tacn:`simpl` and :tacn:`hnf` tactics. @@ -379,10 +379,10 @@ Effects of :cmd:`Arguments` on unfolding In this case, :g:`(minus (S (S x)) (S y))` is simplified to :g:`(minus (S x) y)` even if an extra simplification is possible. - In detail: the tactic :tacn:`simpl` first applies :math:`\beta`:math:`\iota`-reduction. Then, it - expands transparent constants and tries to reduce further using :math:`\beta`:math:`\iota`-reduction. - But, when no :math:`\iota` rule is applied after unfolding then - :math:`\delta`-reductions are not applied. For instance trying to use :tacn:`simpl` on + In detail: the tactic :tacn:`simpl` first applies βι-reduction. Then, it + expands transparent :term:`constants <constant>` and tries to reduce further using βι-reduction. + But, when no ι rule is applied after unfolding then + δ-reductions are not applied. For instance trying to use :tacn:`simpl` on :g:`(plus n O) = n` changes nothing. diff --git a/doc/sphinx/language/extensions/canonical.rst b/doc/sphinx/language/extensions/canonical.rst index 4cc35794cc..fbba6c30b8 100644 --- a/doc/sphinx/language/extensions/canonical.rst +++ b/doc/sphinx/language/extensions/canonical.rst @@ -34,7 +34,7 @@ in :ref:`canonicalstructures`; here only a simple example is given. The first form of this command declares an existing :n:`@reference` as a canonical instance of a structure (a record). - The second form defines a new constant as if the :cmd:`Definition` command + The second form defines a new :term:`constant` as if the :cmd:`Definition` command had been used, then declares it as a canonical instance as if the first form had been used on the defined object. @@ -113,7 +113,7 @@ in :ref:`canonicalstructures`; here only a simple example is given. This displays the list of global names that are components of some canonical structure. For each of them, the canonical structure of - which it is a projection is indicated. If constants are given as + which it is a projection is indicated. If :term:`constants <constant>` are given as its arguments, only the unification rules that involve or are synthesized from simultaneously all given constants will be shown. diff --git a/doc/sphinx/language/extensions/implicit-arguments.rst b/doc/sphinx/language/extensions/implicit-arguments.rst index 765d04ec88..76a4d4a6ff 100644 --- a/doc/sphinx/language/extensions/implicit-arguments.rst +++ b/doc/sphinx/language/extensions/implicit-arguments.rst @@ -238,7 +238,7 @@ Here is an example: This is triggered when setting an argument implicit in an expression which does not correspond to the type of an assumption - or to the body of a definition. Here is an example: + or to the :term:`body` of a definition. Here is an example: .. coqtop:: all warn @@ -448,7 +448,7 @@ function. Turning this flag on (it is off by default) deactivates the use of implicit arguments. - In this case, all arguments of constants, inductive types, + In this case, all arguments of :term:`constants <constant>`, inductive types, constructors, etc, including the arguments declared as implicit, have to be given as if no arguments were implicit. By symmetry, this also affects printing. diff --git a/doc/sphinx/language/extensions/match.rst b/doc/sphinx/language/extensions/match.rst index 1c022448b0..818d130042 100644 --- a/doc/sphinx/language/extensions/match.rst +++ b/doc/sphinx/language/extensions/match.rst @@ -300,7 +300,7 @@ Conventions about unused pattern-matching variables Pattern-matching variables that are not used on the right-hand side of ``=>`` are considered the sign of a potential error. For instance, it could -result from an undetected mispelled constant constructor. By default, +result from an undetected misspelled constant constructor. By default, a warning is issued in such situations. .. warn:: Unused variable @ident catches more than one case. @@ -366,7 +366,7 @@ only simple patterns remain. The original nesting of the ``match`` expressions is recovered at printing time. An easy way to see the result of the expansion is to toggle off the nesting performed at printing (use here :flag:`Printing Matching`), then by printing the term with :cmd:`Print` -if the term is a constant, or using the command :cmd:`Check`. +if the term is a :term:`constant`, or using the command :cmd:`Check`. The extended ``match`` still accepts an optional *elimination predicate* given after the keyword ``return``. Given a pattern matching expression, diff --git a/doc/sphinx/practical-tools/coq-commands.rst b/doc/sphinx/practical-tools/coq-commands.rst index a10312972e..464af37fde 100644 --- a/doc/sphinx/practical-tools/coq-commands.rst +++ b/doc/sphinx/practical-tools/coq-commands.rst @@ -499,7 +499,7 @@ wrong. In the current version, it does not modify the compiled libraries to mark them as successfully checked. Note that non-logical information is not checked. By logical -information, we mean the type and optional body associated with names. +information, we mean the type and optional :term:`body` associated with names. It excludes for instance anything related to the concrete syntax of objects (customized syntax rules, association between short and long names), implicit arguments, etc. @@ -521,7 +521,7 @@ relative paths in object files ``-Q`` and ``-R`` have exactly the same meaning. :-admit *module*: Do not check *module* and any of its dependencies, unless explicitly required. :-o: At exit, print a summary about the context. List the names of all - assumptions and variables (constants without body). + assumptions and variables (constants without a :term:`body`). :-silent: Do not write progress information to the standard output. Environment variable ``$COQLIB`` can be set to override the location of diff --git a/doc/sphinx/practical-tools/coqide.rst b/doc/sphinx/practical-tools/coqide.rst index dcc60195ed..e7237cf7eb 100644 --- a/doc/sphinx/practical-tools/coqide.rst +++ b/doc/sphinx/practical-tools/coqide.rst @@ -248,7 +248,7 @@ right arrow, or ``\>=`` for a greater than or equal sign. A larger number of latex tokens are supported by default. The full list is available here: -https://github.com/coq/coq/blob/master/ide/default_bindings_src.ml +https://github.com/coq/coq/blob/master/ide/coqide/default_bindings_src.ml Custom bindings may be added, as explained further on. diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index 013ff0a83f..b1759bf71b 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -1564,9 +1564,9 @@ Computing in a term: eval Evaluation of a term can be performed with: -.. tacn:: eval @red_expr in @term +:n:`eval @red_expr in @term` - :tacn:`eval` is a :token:`value_tactic`. +See :tacn:`eval`. :tacn:`eval` is a :token:`value_tactic`. Getting the type of a term ~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/doc/sphinx/proof-engine/ltac2.rst b/doc/sphinx/proof-engine/ltac2.rst index 1bb4216e4f..9f3f0ef3d5 100644 --- a/doc/sphinx/proof-engine/ltac2.rst +++ b/doc/sphinx/proof-engine/ltac2.rst @@ -1299,7 +1299,7 @@ Two examples of syntax differences: 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 + definition for :token:`delta_reductions`; compare it to :token:`ltac2_delta_reductions`. This also affects :tacn:`compute`. Ltac1 tactics are not automatically available in Ltac2. (Note that some of the tactics described @@ -1461,9 +1461,9 @@ Other nonterminals that have syntactic classes are listed here. - :token:`ltac2_bindings` - :token:`bindings` - * - :n:`strategy` - - :token:`ltac2_strategy_flag` - - :token:`strategy_flag` + * - :n:`reductions` + - :token:`ltac2_reductions` + - :token:`reductions` * - :n:`reference` - :token:`refglobal` @@ -1571,19 +1571,19 @@ Here is the syntax for the :n:`q_*` nonterminals: | @natural | @lident -.. insertprodn ltac2_strategy_flag ltac2_delta_flag +.. insertprodn ltac2_reductions ltac2_delta_reductions .. prodn:: - ltac2_strategy_flag ::= {+ @ltac2_red_flag } - | {? @ltac2_delta_flag } + ltac2_reductions ::= {+ @ltac2_red_flag } + | {? @ltac2_delta_reductions } ltac2_red_flag ::= beta | iota | match | fix | cofix | zeta - | delta {? @ltac2_delta_flag } - ltac2_delta_flag ::= {? - } [ {+ @refglobal } ] + | delta {? @ltac2_delta_reductions } + ltac2_delta_reductions ::= {? - } [ {+ @refglobal } ] .. insertprodn refglobal refglobal diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index 665bae7077..fad02b2645 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -479,6 +479,7 @@ one or more of its hypotheses. .. prodn:: occurrences ::= at @occs_nums | in @goal_occurrences + simple_occurrences ::= @occurrences occs_nums ::= {? - } {+ @nat_or_var } nat_or_var ::= {| @natural | @ident } goal_occurrences ::= {+, @hyp_occs } {? %|- {? @concl_occs } } @@ -496,6 +497,10 @@ one or more of its hypotheses. the conclusion of the goal. The second form can select occurrences in the goal conclusion and in one or more hypotheses. + :n:`@simple_occurrences` + A semantically restricted form of :n:`@occurrences` that doesn't allow the + `at` clause anywhere within it. + :n:`{? - } {+ @nat_or_var }` Selects the specified occurrences within a single goal or hypothesis. Occurrences are numbered starting with 1 following a depth-first traversal @@ -675,10 +680,10 @@ Applying theorems :tacn:`notypeclasses refine`: it performs type checking without resolution of typeclasses, does not perform beta reductions or shelve the subgoals. - .. flag:: Debug Unification - - Enables printing traces of unification steps used during - elaboration/typechecking and the :tacn:`refine` tactic. + :opt:`Debug` ``"unification"`` enables printing traces of + unification steps used during elaboration/typechecking and the + :tacn:`refine` tactic. ``"ho-unification"`` prints information + about higher order heuristics. .. tacn:: apply @term :name: apply @@ -1040,10 +1045,9 @@ Applying theorems when the instantiation of a variable cannot be found (cf. :tacn:`eapply` and :tacn:`apply`). -.. flag:: Debug Tactic Unification - - Enables printing traces of unification steps in tactic unification. - Tactic unification is used in tactics such as :tacn:`apply` and :tacn:`rewrite`. +:opt:`Debug` ``"tactic-unification"`` enables printing traces of +unification steps in tactic unification. Tactic unification is used in +tactics such as :tacn:`apply` and :tacn:`rewrite`. .. _managingthelocalcontext: diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index 8d1817b61f..22e4350c38 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -65,6 +65,9 @@ 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`). +:cmd:`Eval` and :cmd:`Compute` are also :token:`query_command`\s, which are +described elsewhere + .. cmd:: About @reference {? @univ_name_list } Displays information about the :n:`@reference` object, which, @@ -80,22 +83,6 @@ to accessible objects. (see Section :ref:`invocation-of-tactics`). Displays the type of :n:`@term`. When called in proof mode, the term is checked in the local context of the selected goal. -.. cmd:: Eval @red_expr in @term - - Performs the specified reduction on :n:`@term` and displays - the resulting term with its type. If a proof is open, :n:`@term` - may reference hypotheses of the selected goal. - - .. seealso:: Section :ref:`performingcomputations`. - - -.. cmd:: Compute @term - - Evaluates :n:`@term` using the bytecode-based virtual machine. - It is a shortcut for :cmd:`Eval` :n:`vm_compute in @term`. - - .. seealso:: Section :ref:`performingcomputations`. - .. cmd:: Search {+ @search_query } {? {| inside | outside } {+ @qualid } } This command can be used to filter the goal and the global context @@ -865,6 +852,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:: Debug "{+, {? - } @ident }" + + Configures the display of debug messages. Each :n:`@ident` enables debug messages + for that component, while :n:`-@ident` disables messages for the component. + ``all`` activates or deactivates all other components. ``backtrace`` controls printing of + error backtraces. + + :cmd:`Test` `Debug` displays the list of components and their enabled/disabled state. .. opt:: Printing Width @natural This command sets which left-aligned part of the width of the screen is used @@ -928,187 +923,6 @@ Printing constructions in full .. see a contrived example here: https://github.com/coq/coq/pull/11718#discussion_r415481854 -.. _vernac-controlling-the-reduction-strategies: - -Controlling the reduction strategies and the conversion algorithm ----------------------------------------------------------------------- - - -Coq provides reduction strategies that the tactics can invoke and two -different algorithms to check the convertibility of types. The first -conversion algorithm lazily compares applicative terms while the other -is a brute-force but efficient algorithm that first normalizes the -terms before comparing them. The second algorithm is based on a -bytecode representation of terms similar to the bytecode -representation used in the ZINC virtual machine :cite:`Leroy90`. It is -especially useful for intensive computation of algebraic values, such -as numbers, and for reflection-based tactics. The commands to fine- -tune the reduction strategies and the lazy conversion algorithm are -described first. - -.. cmd:: Opaque {+ @reference } - - This command accepts the :attr:`global` attribute. By default, the scope - of :cmd:`Opaque` is limited to the current section or module. - - This command has an effect on unfoldable constants, i.e. on constants - defined by :cmd:`Definition` or :cmd:`Let` (with an explicit body), or by a command - associated with a definition such as :cmd:`Fixpoint`, etc, - or by a proof ended by :cmd:`Defined`. The command tells not to unfold the - constants in the :n:`@reference` sequence in tactics using δ-conversion (unfolding - a constant is replacing it by its definition). - - :cmd:`Opaque` has also an effect on the conversion algorithm of Coq, telling - it to delay the unfolding of a constant as much as possible when Coq - has to check the conversion (see Section :ref:`conversion-rules`) of two distinct - applied constants. - -.. cmd:: Transparent {+ @reference } - - This command accepts the :attr:`global` attribute. By default, the scope - of :cmd:`Transparent` is limited to the current section or module. - - This command is the converse of :cmd:`Opaque` and it applies on unfoldable - constants to restore their unfoldability after an Opaque command. - - Note in particular that constants defined by a proof ended by Qed are - not unfoldable and Transparent has no effect on them. This is to keep - with the usual mathematical practice of *proof irrelevance*: what - matters in a mathematical development is the sequence of lemma - statements, not their actual proofs. This distinguishes lemmas from - the usual defined constants, whose actual values are of course - relevant in general. - - .. exn:: The reference @qualid was not found in the current environment. - - There is no constant named :n:`@qualid` in the environment. - -.. seealso:: :ref:`performingcomputations` and :ref:`proof-editing-mode` - -.. _vernac-strategy: - -.. cmd:: Strategy {+ @strategy_level [ {+ @reference } ] } - - .. insertprodn strategy_level strategy_level_or_var - - .. prodn:: - strategy_level ::= opaque - | @integer - | expand - | transparent - strategy_level_or_var ::= @strategy_level - | @ident - - This command accepts the :attr:`local` attribute, which limits its effect - to the current section or module, in which case the section and module - behavior is the same as :cmd:`Opaque` and :cmd:`Transparent` (without :attr:`global`). - - This command generalizes the behavior of the :cmd:`Opaque` and :cmd:`Transparent` - commands. It is used to fine-tune the strategy for unfolding - constants, both at the tactic level and at the kernel level. This - command associates a :n:`@strategy_level` with the qualified names in the :n:`@reference` - sequence. Whenever two - expressions with two distinct head constants are compared (for - instance, this comparison can be triggered by a type cast), the one - with lower level is expanded first. In case of a tie, the second one - (appearing in the cast type) is expanded. - - Levels can be one of the following (higher to lower): - - + ``opaque`` : level of opaque constants. They cannot be expanded by - tactics (behaves like +∞, see next item). - + :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 - constants, while positive levels correspond to constants to be - expanded after normal transparent constants. - + ``expand`` : level of constants that should be expanded first (behaves - like −∞) - + ``transparent`` : Equivalent to level 0 - -.. cmd:: Print Strategy @reference - - This command prints the strategy currently associated with :n:`@reference`. It - fails if :n:`@reference` is not an unfoldable reference, that is, neither a - variable nor a constant. - - .. exn:: The reference is not unfoldable. - :undocumented: - -.. cmd:: Print Strategies - - Print all the currently non-transparent strategies. - - -.. cmd:: Declare Reduction @ident := @red_expr - - Declares a short name for the reduction expression :n:`@red_expr`, for - instance ``lazy beta delta [foo bar]``. This short name can then be used - in :n:`Eval @ident in` or ``eval`` constructs. This command - accepts the :attr:`local` attribute, which indicates that the reduction - will be discarded at the end of the - file or module. The name is not qualified. In - particular declaring the same name in several modules or in several - functor applications will be rejected if these declarations are not - local. The name :n:`@ident` cannot be used directly as an Ltac tactic, but - nothing prevents the user from also performing a - :n:`Ltac @ident := @red_expr`. - - .. seealso:: :ref:`performingcomputations` - - -.. _controlling-locality-of-commands: - -Controlling the locality of commands ------------------------------------------ - -.. attr:: global - local - - Some commands support a :attr:`local` or :attr:`global` attribute - to control the scope of their effect. There is also a legacy (and - much more commonly used) syntax using the ``Local`` or ``Global`` - prefixes (see :n:`@legacy_attr`). There are four kinds of - commands: - - + Commands whose default is to extend their effect both outside the - section and the module or library file they occur in. For these - commands, the :attr:`local` attribute limits the effect of the command to the - current section or module it occurs in. As an example, the :cmd:`Coercion` - and :cmd:`Strategy` commands belong to this category. - + Commands whose default behavior is to stop their effect at the end - of the section they occur in but to extend their effect outside the module or - library file they occur in. For these commands, the :attr:`local` attribute limits the - effect of the command to the current module if the command does not occur in a - section and the :attr:`global` attribute extends the effect outside the current - sections and current module if the command occurs in a section. As an example, - the :cmd:`Arguments`, :cmd:`Ltac` or :cmd:`Notation` commands belong - to this category. Notice that a subclass of these commands do not support - extension of their scope outside sections at all and the :attr:`global` attribute is not - applicable to them. - + Commands whose default behavior is to stop their effect at the end - of the section or module they occur in. For these commands, the :attr:`global` - attribute extends their effect outside the sections and modules they - occur in. The :cmd:`Transparent` and :cmd:`Opaque` commands - belong to this category. - + Commands whose default behavior is to extend their effect outside - sections but not outside modules when they occur in a section and to - extend their effect outside the module or library file they occur in - when no section contains them. For these commands, the :attr:`local` attribute - limits the effect to the current section or module while the :attr:`global` - attribute extends the effect outside the module even when the command - occurs in a section. The :cmd:`Set` and :cmd:`Unset` commands belong to this - category. - -.. attr:: export - - Some commands support an :attr:`export` attribute. The effect of - the attribute is to make the effect of the command available when - the module containing it is imported. It is supported in - particular by the :ref:`Hint <creating_hints>`, :cmd:`Set` and :cmd:`Unset` - commands. - .. _controlling-typing-flags: Controlling Typing Flags diff --git a/doc/sphinx/proofs/automatic-tactics/auto.rst b/doc/sphinx/proofs/automatic-tactics/auto.rst index 30f7be5f13..d9945dd920 100644 --- a/doc/sphinx/proofs/automatic-tactics/auto.rst +++ b/doc/sphinx/proofs/automatic-tactics/auto.rst @@ -139,14 +139,13 @@ Programmable proof search Like :tacn:`eauto`, but uses a `breadth-first search <https://en.wikipedia.org/wiki/Breadth-first_search>`_. -.. tacn:: autounfold {? @hintbases } {? @occurrences } +.. tacn:: autounfold {? @hintbases } {? @simple_occurrences } Unfolds constants that were declared through a :cmd:`Hint Unfold` in the given databases. - :n:`@occurrences` - Performs the unfolding in the specified occurrences. The :n:`at @occs_nums` - clause of :n:`@occurrences` is not supported. + :n:`@simple_occurrences` + Performs the unfolding in the specified occurrences. .. tacn:: autorewrite {? * } with {+ @ident } {? @occurrences } {? using @ltac_expr } @@ -376,6 +375,9 @@ Creating Hints discrimination network to relax or constrain it in the case of discriminated databases. + .. exn:: Cannot coerce @qualid to an evaluable reference. + :undocumented: + .. cmd:: Hint {| Constants | Variables } {| Transparent | Opaque } {? : {+ @ident } } :name: Hint Constants; Hint Variables diff --git a/doc/sphinx/proofs/automatic-tactics/logic.rst b/doc/sphinx/proofs/automatic-tactics/logic.rst index 5aaded2726..3f1f5d46c5 100644 --- a/doc/sphinx/proofs/automatic-tactics/logic.rst +++ b/doc/sphinx/proofs/automatic-tactics/logic.rst @@ -194,9 +194,7 @@ Solvers for logic and equality additional arguments can be given to congruence by filling in the holes in the terms given in the error message, using the `with` clause. - .. flag:: Congruence Verbose - - Makes :tacn:`congruence` print debug information. + :opt:`Debug` ``"congruence"`` makes :tacn:`congruence` print debug information. .. tacn:: btauto diff --git a/doc/sphinx/proofs/writing-proofs/proof-mode.rst b/doc/sphinx/proofs/writing-proofs/proof-mode.rst index 931ac905f6..bfe8c77c14 100644 --- a/doc/sphinx/proofs/writing-proofs/proof-mode.rst +++ b/doc/sphinx/proofs/writing-proofs/proof-mode.rst @@ -155,7 +155,7 @@ When the proof is completed, you can exit proof mode with commands such as Passes a completed :term:`proof term` to Coq's kernel to check that the proof term is :term:`well-typed` and to verify that its type matches the theorem statement. If it's verified, the - proof term is added to the global environment as an opaque constant + proof term is added to the global environment as an :term:`opaque` constant using the declared name from the original goal. It's very rare for a proof term to fail verification. Generally this @@ -190,9 +190,10 @@ When the proof is completed, you can exit proof mode with commands such as .. cmd:: Defined {? @ident } - Similar to :cmd:`Qed` and :cmd:`Save`, except the proof is made *transparent*, which means + Similar to :cmd:`Qed` and :cmd:`Save`, except the proof is made + :term:`transparent`, which means that its content can be explicitly used for type checking and that it can be - unfolded in conversion tactics (see :ref:`performingcomputations`, + unfolded in conversion tactics (see :ref:`applyingconversionrules`, :cmd:`Opaque`, :cmd:`Transparent`). If :token:`ident` is specified, the proof is defined with the given name, which overrides any name provided by the :cmd:`Theorem` command or its variants. @@ -845,7 +846,7 @@ Requesting information .. cmd:: Show Existentials Displays all open goals / existential variables in the current proof - along with the type and the context of each variable. + along with the context and type of each variable. .. cmd:: Show Match @qualid diff --git a/doc/sphinx/proofs/writing-proofs/rewriting.rst b/doc/sphinx/proofs/writing-proofs/rewriting.rst index f286533d78..c2b877d372 100644 --- a/doc/sphinx/proofs/writing-proofs/rewriting.rst +++ b/doc/sphinx/proofs/writing-proofs/rewriting.rst @@ -47,7 +47,7 @@ Rewriting with Leibniz and setoid equality Replaces subterms with other subterms that have been proven to be equal. The type of :n:`@one_term` must have the form: - :n:`{? forall {+ (x__i: A__i) } , } EQ @term__1 @term__2` + :n:`{? forall @open_binders , } EQ @term__1 @term__2` .. todo :term:`Leibniz equality` does not work with Sphinx 2.3.1. It does with Sphinx 3.0.3. @@ -55,14 +55,11 @@ Rewriting with Leibniz and setoid equality Note that :n:`eq @term__1 @term__2` is typically written with the infix notation :n:`@term__1 = @term__2`. You must `Require Setoid` to use the tactic with a setoid equality or with :ref:`setoid rewriting <generalizedrewriting>`. - In the general form, any :n:`@binder` may be used, not just :n:`(x__i: A__i)`. - - .. todo doublecheck the @binder comment is correct. :n:`rewrite @one_term` finds subterms matching :n:`@term__1` in the goal, and replaces them with :n:`@term__2` (or the reverse if `<-` is given). Some of the variables :g:`x`\ :sub:`i` are solved by unification, - and some of the types :n:`A__1, ..., A__n` may become new + and some of the types :n:`A__1, …, A__n` may become new subgoals. :tacn:`rewrite` won't find occurrences inside `forall` that refer to variables bound by the `forall`; use the more advanced :tacn:`setoid_rewrite` if you want to find such occurrences. @@ -315,7 +312,7 @@ Rewriting with definitional equality .. tacn:: change {? @one_term__from {? at @occs_nums } with } @one_term__to {? @occurrences } Replaces terms with other :term:`convertible` terms. - If :n:`@one_term__from` is not specified, then :n:`@one_term__from` replaces the conclusion and/or + If :n:`@one_term__from` is not specified, then :n:`@one_term__to` replaces the conclusion and/or the specified hypotheses. If :n:`@one_term__from` is specified, the tactic replaces occurrences of :n:`@one_term__to` within the conclusion and/or the specified hypotheses. @@ -326,8 +323,8 @@ Rewriting with definitional equality whose value which will substituted for `x` in :n:`@one_term__to`, such as in `change (f ?x ?y) with (g (x, y))` or `change (fun x => ?f x) with f`. - The `at ... with ...` form is deprecated in 8.14; use `with ... at ...` instead. - For `at ... with ... in H |-`, use `with ... in H at ... |-`. + The `at … with …` form is deprecated in 8.14; use `with … at …` instead. + For `at … with … in H |-`, use `with … in H at … |-`. :n:`@occurrences` If `with` is not specified, :n:`@occurrences` must only specify @@ -346,7 +343,7 @@ Rewriting with definitional equality make some proof steps explicit when refactoring a proof script to make it readable. - .. seealso:: :ref:`Performing computations <performingcomputations>` + .. seealso:: :ref:`applyingconversionrules` .. tacn:: change_no_check {? @one_term__from {? at @occs_nums } with } @one_term__to {? @occurrences } @@ -384,440 +381,594 @@ Rewriting with definitional equality exact H. Qed. -.. _performingcomputations: - -Performing computations ---------------------------- - -.. insertprodn red_expr pattern_occs - -.. prodn:: - red_expr ::= red - | hnf - | simpl {? @delta_flag } {? {| @reference_occs | @pattern_occs } } - | cbv {? @strategy_flag } - | cbn {? @strategy_flag } - | lazy {? @strategy_flag } - | compute {? @delta_flag } - | vm_compute {? {| @reference_occs | @pattern_occs } } - | native_compute {? {| @reference_occs | @pattern_occs } } - | unfold {+, @reference_occs } - | fold {+ @one_term } - | pattern {+, @pattern_occs } - | @ident - delta_flag ::= {? - } [ {+ @reference } ] - strategy_flag ::= {+ @red_flag } - | @delta_flag - red_flag ::= beta - | iota - | match - | fix - | cofix - | zeta - | delta {? @delta_flag } - reference_occs ::= @reference {? at @occs_nums } - pattern_occs ::= @one_term {? at @occs_nums } - -This set of tactics implements different specialized usages of the -tactic :tacn:`change`. - -All conversion tactics (including :tacn:`change`) can be parameterized by the -parts of the goal where the conversion can occur. This is done using -*goal clauses* which consists in a list of hypotheses and, optionally, -of a reference to the conclusion of the goal. For defined hypothesis -it is possible to specify if the conversion should occur on the type -part, the body part or both (default). - -Goal clauses are written after a conversion tactic (tactics :tacn:`set`, -:tacn:`rewrite`, :tacn:`replace` and :tacn:`autorewrite` also use goal -clauses) and are introduced by the keyword `in`. If no goal clause is -provided, the default is to perform the conversion only in the -conclusion. - -For backward compatibility, the notation :n:`in {+ @ident}` performs -the conversion in hypotheses :n:`{+ @ident}`. - -.. tacn:: cbv {? @strategy_flag } - lazy {? @strategy_flag } - :name: cbv; lazy - - These parameterized reduction tactics apply to any goal and perform - the normalization of the goal according to the specified flags. In - correspondence with the kinds of reduction considered in Coq namely - :math:`\beta` (reduction of functional application), :math:`\delta` - (unfolding of transparent constants, see :ref:`vernac-controlling-the-reduction-strategies`), - :math:`\iota` (reduction of - pattern matching over a constructed term, and unfolding of :g:`fix` and - :g:`cofix` expressions) and :math:`\zeta` (contraction of local definitions), the - flags are either ``beta``, ``delta``, ``match``, ``fix``, ``cofix``, - ``iota`` or ``zeta``. The ``iota`` flag is a shorthand for ``match``, ``fix`` - and ``cofix``. The ``delta`` flag itself can be refined into - :n:`delta [ {+ @qualid} ]` or :n:`delta - [ {+ @qualid} ]`, restricting in the first - case the constants to unfold to the constants listed, and restricting in the - second case the constant to unfold to all but the ones explicitly mentioned. - Notice that the ``delta`` flag does not apply to variables bound by a let-in - construction inside the :n:`@term` itself (use here the ``zeta`` flag). In - any cases, opaque constants are not unfolded (see :ref:`vernac-controlling-the-reduction-strategies`). - - Normalization according to the flags is done by first evaluating the - head of the expression into a *weak-head* normal form, i.e. until the - evaluation is blocked by a variable (or an opaque constant, or an - axiom), as e.g. in :g:`x u1 ... un` , or :g:`match x with ... end`, or - :g:`(fix f x {struct x} := ...) x`, or is a constructed form (a - :math:`\lambda`-expression, a constructor, a cofixpoint, an inductive type, a - product type, a sort), or is a redex that the flags prevent to reduce. Once a +.. _applyingconversionrules: + +Applying conversion rules +------------------------- + +These tactics apply reductions and expansions, replacing :term:`convertible` subterms +with others that are equal by definition in |CiC|. +They implement different specialized uses of the +:tacn:`change` tactic. Other ways to apply these reductions are through +the :cmd:`Eval` command, the `Eval` clause in the :cmd:`Definition`/:cmd:`Example` +command and the :tacn:`eval` tactic. + +Tactics described in this section include: + +- :tacn:`lazy` and :tacn:`cbv`, which allow precise selection of which reduction + rules to apply +- :tacn:`simpl` and :tacn:`cbn`, which are "clever" tactics meant to give the most + readable result +- :tacn:`hnf` and :tacn:`red`, which apply reduction rules only to the head of the + term +- :tacn:`vm_compute` and :tacn:`native_compute`, which are performance-oriented. + +Conversion tactics, with two exceptions, only change the types and contexts +of existential variables +and leave the proof term unchanged. (The :tacn:`vm_compute` and :tacn:`native_compute` +tactics change existential variables in a way similar to other conversions while +also adding a single explicit cast to the proof term to tell the kernel +which reduction engine to use. See :ref:`type-cast`.) For example: + + .. coqtop:: all + + Goal 3 + 4 = 7. + Show Proof. + Show Existentials. + cbv. + Show Proof. + Show Existentials. + + .. coqtop:: none + + Abort. + +.. tacn:: lazy {? @reductions } @simple_occurrences + cbv {? @reductions } @simple_occurrences + + .. insertprodn reductions delta_reductions + + .. prodn:: + reductions ::= {+ @reduction } + | @delta_reductions + reduction ::= beta + | delta {? @delta_reductions } + | match + | fix + | cofix + | iota + | zeta + delta_reductions ::= {? - } [ {+ @reference } ] + + Normalize the goal as specified by :n:`@reductions`. If no reductions are + specified by name, all reductions are applied. If any reductions are specified by name, + then only the named reductions are applied. The reductions include: + + `beta` + :term:`beta-reduction` of functional application + + :n:`delta {? @delta_reductions }` + :term:`delta-reduction`: unfolding of transparent constants, see :ref:`controlling-the-reduction-strategies`. + The form in :n:`@reductions` without the keyword `delta` includes `beta`, + `iota` and `zeta` reductions in addition to `delta` using the given :n:`@delta_reductions`. + + :n:`{? - } [ {+ @reference } ]` + without the `-`, limits delta unfolding to the listed constants. If the + `-` is present, + unfolding is applied to all constants that are not listed. + Notice that the ``delta`` doesn't apply to variables bound by a let-in + construction inside the term itself (use ``zeta`` to inline these). + Opaque constants are never unfolded except by :tacn:`vm_compute` and + :tacn:`native_compute` + (see `#4476 <https://github.com/coq/coq/issues/4476>`_ and + :ref:`controlling-the-reduction-strategies`). + + `iota` + :term:`iota-reduction` of pattern matching (`match`) over a constructed term and reduction + of :g:`fix` and :g:`cofix` expressions. Shorthand for `match fix cofix`. + + `zeta` + :term:`zeta-reduction`: reduction of :ref:`let-in definitions <let-in>` + + Normalization is done by first evaluating the + head of the expression into :gdef:`weak-head normal form`, i.e. until the + evaluation is blocked by a variable, an opaque constant, an + axiom, such as in :n:`x u__1 … u__n`, :g:`match x with … end`, + :g:`(fix f x {struct x} := …) x`, a constructed form (a + :math:`\lambda`-expression, constructor, cofixpoint, inductive type, + product type or sort) or a redex for which flags prevent reduction of the redex. Once a weak-head normal form is obtained, subterms are recursively reduced using the same strategy. - Reduction to weak-head normal form can be done using two strategies: - *lazy* (``lazy`` tactic), or *call-by-value* (``cbv`` tactic). The lazy - strategy is a call-by-need strategy, with sharing of reductions: the + There are two strategies for reduction to weak-head normal form: + *lazy* (the :tacn:`lazy` tactic), or *call-by-value* (the :tacn:`cbv` tactic). + The lazy strategy is a + `call by need <https://en.wikipedia.org/wiki/Evaluation_strategy#Call_by_need>`_ + strategy, with sharing of reductions: the arguments of a function call are weakly evaluated only when necessary, and if an argument is used several times then it is weakly computed only once. This reduction is efficient for reducing expressions with dead code. For instance, the proofs of a proposition :g:`exists x. P(x)` - reduce to a pair of a witness :g:`t`, and a proof that :g:`t` satisfies the + reduce to a pair of a witness :g:`t` and a proof that :g:`t` satisfies the predicate :g:`P`. Most of the time, :g:`t` may be computed without computing the proof of :g:`P(t)`, thanks to the lazy strategy. The call-by-value strategy is the one used in ML languages: the arguments of a function call are systematically weakly evaluated - first. Despite the lazy strategy always performs fewer reductions than + first. The lazy strategy is similar to how Haskell reduces terms. + Although the lazy strategy always does fewer reductions than the call-by-value strategy, the latter is generally more efficient for evaluating purely computational expressions (i.e. with little dead code). -.. tacv:: compute - cbv - :name: compute; _ + .. tacn:: compute {? @delta_reductions } @simple_occurrences - These are synonyms for ``cbv beta delta iota zeta``. + A variant form of :tacn:`cbv`. -.. tacv:: lazy + :opt:`Debug` ``"Cbv"`` makes :tacn:`cbv` (and its derivative :tacn:`compute`) print + information about the constants it encounters and the unfolding decisions it + makes. - This is a synonym for ``lazy beta delta iota zeta``. +.. tacn:: simpl {? @delta_reductions } {? {| @reference_occs | @pattern_occs } } @simple_occurrences -.. tacv:: compute [ {+ @qualid} ] - cbv [ {+ @qualid} ] + .. insertprodn reference_occs pattern_occs - These are synonyms of :n:`cbv beta delta {+ @qualid} iota zeta`. + .. prodn:: + reference_occs ::= @reference {? at @occs_nums } + pattern_occs ::= @one_term {? at @occs_nums } -.. tacv:: compute - [ {+ @qualid} ] - cbv - [ {+ @qualid} ] + Reduces a term to + something still readable instead of fully normalizing it. It performs + a sort of strong normalization with two key differences: - These are synonyms of :n:`cbv beta delta -{+ @qualid} iota zeta`. + + It unfolds constants only if they lead to an ι-reduction, + i.e. reducing a match or unfolding a fixpoint. + + When reducing a constant unfolding to (co)fixpoints, the tactic + uses the name of the constant the (co)fixpoint comes from instead of + the (co)fixpoint definition in recursive calls. -.. tacv:: lazy [ {+ @qualid} ] - lazy - [ {+ @qualid} ] + :n:`@simple_occurrences` + Permits selecting whether to reduce the conclusion and/or one or more + hypotheses. While the `at` option of :n:`@occurrences` is not allowed here, + :n:`@reference_occs` and :n:`@pattern_occs` have a somewhat less + flexible `at` option for selecting specific occurrences. - These are respectively synonyms of :n:`lazy beta delta {+ @qualid} iota zeta` - and :n:`lazy beta delta -{+ @qualid} iota zeta`. + :tacn:`simpl` can unfold transparent constants whose name can be reused in + recursive calls as well as those designated by :cmd:`Arguments` :n:`@reference … /` + commands. For instance, a constant :g:`plus' := plus` may be unfolded and + reused in recursive calls, but a constant such as :g:`succ := plus (S O)` is + not unfolded unless it was specifically designated in an :cmd:`Arguments` + command such as :n:`Arguments succ /.`. -.. tacv:: vm_compute - :name: vm_compute + :n:`{| @reference_occs | @pattern_occs }` can limit the application of :tacn:`simpl` + to: - This tactic evaluates the goal using the optimized call-by-value evaluation - bytecode-based virtual machine described in :cite:`CompiledStrongReduction`. - This algorithm is dramatically more efficient than the algorithm used for the - :tacn:`cbv` tactic, but it cannot be fine-tuned. It is especially interesting for - full evaluation of algebraic objects. This includes the case of - reflection-based tactics. + - applicative subterms whose :term:`head` is the + constant :n:`@qualid` or is the constant used + in the notation :n:`@string` (see :n:`@reference`) + - subterms matching a pattern :n:`@one_term` -.. tacv:: native_compute - :name: native_compute +.. tacn:: cbn {? @reductions } @simple_occurrences - This tactic evaluates the goal by compilation to OCaml as described - in :cite:`FullReduction`. If Coq is running in native code, it can be - typically two to five times faster than :tacn:`vm_compute`. Note however that the - compilation cost is higher, so it is worth using only for intensive - computations. Depending on the configuration, this tactic can either default to - :tacn:`vm_compute`, recompile dependencies or fail due to some missing - precompiled dependencies, - see :ref:`the native-compiler option <native-compiler-options>` for details. + :tacn:`cbn` was intended to be a more principled, faster and more + predictable replacement for :tacn:`simpl`. - .. flag:: NativeCompute Timing + The main difference between :tacn:`cbn` and :tacn:`simpl` is that + :tacn:`cbn` may unfold constants even when they cannot be reused in recursive calls: + in the previous example, :g:`succ t` is reduced to :g:`S t`. - This flag causes all calls to the native compiler to print - timing information for the conversion to native code, - compilation, execution, and reification phases of native - compilation. Timing is printed in units of seconds of - wall-clock time. + :opt:`Debug` ``"RAKAM"`` makes :tacn:`cbn` print various debugging information. + ``RAKAM`` is the Refolding Algebraic Krivine Abstract Machine. - .. flag:: NativeCompute Profiling +.. tacn:: hnf @simple_occurrences - On Linux, if you have the ``perf`` profiler installed, this flag makes - it possible to profile :tacn:`native_compute` evaluations. + Replaces the current goal with its + weak-head normal form according to the βδιζ-reduction rules, i.e. it + reduces the :term:`head` of the goal until it becomes a product or an + irreducible term. All inner βι-redexes are also reduced. While :tacn:`hnf` + behaves similarly to :tacn:`simpl` and :tacn:`cbn`, unlike them, it does not + recurse into subterms. + The behavior of :tacn:`hnf` can be tuned using the :cmd:`Arguments` command. - .. opt:: NativeCompute Profile Filename @string - :name: NativeCompute Profile Filename + Example: The term :g:`fun n : nat => S n + S n` is not reduced by :n:`hnf`. - This option specifies the profile output; the default is - ``native_compute_profile.data``. The actual filename used - will contain extra characters to avoid overwriting an existing file; that - filename is reported to the user. - That means you can individually profile multiple uses of - :tacn:`native_compute` in a script. From the Linux command line, run ``perf report`` - on the profile file to see the results. Consult the ``perf`` documentation - for more details. + .. note:: + The δ rule only applies to transparent constants + (see :ref:`controlling-the-reduction-strategies` on transparency and opacity). -.. flag:: Debug Cbv +.. tacn:: red @simple_occurrences - This flag makes :tacn:`cbv` (and its derivative :tacn:`compute`) print - information about the constants it encounters and the unfolding decisions it - makes. + βιζ-reduces the constant at the head of `T` (which may be called + the :gdef:`head constant`; :gdef:`head` means the beginning + of the term), if possible, + in the selected hypotheses and/or the goal, which must have the form: -.. tacn:: red - :name: red + :n:`{? forall @open_binders,} T` - This tactic applies to a goal that has the form:: + (where `T` does not begin with a `forall`) to :n:`c t__1 … t__n` + where :g:`c` is a constant. + If :g:`c` is transparent then it replaces :g:`c` with its + definition and reduces again until no further reduction is possible. - forall (x:T1) ... (xk:Tk), T + .. exn:: No head constant to reduce. + :undocumented: - with :g:`T` :math:`\beta`:math:`\iota`:math:`\zeta`-reducing to :g:`c t`:sub:`1` :g:`... t`:sub:`n` and :g:`c` a - constant. If :g:`c` is transparent then it replaces :g:`c` with its - definition (say :g:`t`) and then reduces - :g:`(t t`:sub:`1` :g:`... t`:sub:`n` :g:`)` according to :math:`\beta`:math:`\iota`:math:`\zeta`-reduction rules. +.. tacn:: unfold {+, @reference_occs } {? @occurrences } -.. exn:: Not reducible. - :undocumented: + Applies :term:`delta-reduction` to + the constants specified by each :n:`@reference_occs`. + The selected hypotheses and/or goals are then reduced to βιζ-normal form. + Use the general reduction tactics if you want to only apply the + δ rule, for example :tacn:`cbv` :n:`delta [ @reference ]`. -.. exn:: No head constant to reduce. - :undocumented: + :n:`@reference_occs` + If :n:`@reference` is a :n:`@qualid`, it must be a defined transparent + constant or local definition (see :ref:`gallina-definitions` and + :ref:`controlling-the-reduction-strategies`). -.. tacn:: hnf - :name: hnf + If :n:`@reference` is a :n:`@string {? @scope_key}`, the :n:`@string` is + the discriminating + symbol of a notation (e.g. "+") or an expression defining a notation (e.g. `"_ + + _"`) and the notation is an application whose head symbol + is an unfoldable constant, then the tactic unfolds it. - This tactic applies to any goal. It replaces the current goal with its - head normal form according to the :math:`\beta`:math:`\delta`:math:`\iota`:math:`\zeta`-reduction rules, i.e. it - reduces the head of the goal until it becomes a product or an - irreducible term. All inner :math:`\beta`:math:`\iota`-redexes are also reduced. - The behavior of both :tacn:`hnf` can be tuned using the :cmd:`Arguments` command. + :n:`@occurrences` + If :n:`@occurrences` is specified, + the specified occurrences will be replaced in the selected hypotheses and/or goal. + Otherwise every occurrence of the constants in the goal is replaced. + If multiple :n:`@reference_occs` are given, any `at` clauses must be + in the :n:`@reference_occs` rather than in :n:`@occurrences`. - Example: The term :g:`fun n : nat => S n + S n` is not reduced by :n:`hnf`. + .. exn:: Cannot turn {| inductive | constructor } into an evaluable reference. -.. note:: - The :math:`\delta` rule only applies to transparent constants (see :ref:`vernac-controlling-the-reduction-strategies` - on transparency and opacity). + Occurs when trying to unfold something that is + defined as an inductive type (or constructor) and not as a + definition. -.. tacn:: cbn - simpl - :name: cbn; simpl + .. example:: - These tactics apply to any goal. They try to reduce a term to - something still readable instead of fully normalizing it. They perform - a sort of strong normalization with two key differences: + .. coqtop:: abort all fail - + They unfold a constant if and only if it leads to a :math:`\iota`-reduction, - i.e. reducing a match or unfolding a fixpoint. - + While reducing a constant unfolding to (co)fixpoints, the tactics - use the name of the constant the (co)fixpoint comes from instead of - the (co)fixpoint definition in recursive calls. + Goal 0 <= 1. + unfold le. - The :tacn:`cbn` tactic was intended to be a more principled, faster and more - predictable replacement for :tacn:`simpl`. + .. exn:: @ident is opaque. - The :tacn:`cbn` tactic accepts the same flags as :tacn:`cbv` and - :tacn:`lazy`. The behavior of both :tacn:`simpl` and :tacn:`cbn` - can be tuned using the :cmd:`Arguments` command. + Raised if you are trying to unfold a definition + that has been marked opaque. - .. todo add "See <subsection about controlling the behavior of reduction strategies>" - to TBA section + .. example:: - Notice that only transparent constants whose name can be reused in the - recursive calls are possibly unfolded by :tacn:`simpl`. For instance a - constant defined by :g:`plus' := plus` is possibly unfolded and reused in - the recursive calls, but a constant such as :g:`succ := plus (S O)` is - never unfolded. This is the main difference between :tacn:`simpl` and :tacn:`cbn`. - The tactic :tacn:`cbn` reduces whenever it will be able to reuse it or not: - :g:`succ t` is reduced to :g:`S t`. + .. coqtop:: abort all fail -.. tacv:: cbn [ {+ @qualid} ] - cbn - [ {+ @qualid} ] + Opaque Nat.add. + Goal 1 + 0 = 1. + unfold Nat.add. - These are respectively synonyms of :n:`cbn beta delta [ {+ @qualid} ] iota zeta` - and :n:`cbn beta delta - [ {+ @qualid} ] iota zeta` (see :tacn:`cbn`). + .. exn:: Bad occurrence number of @qualid. + :undocumented: -.. tacv:: simpl @pattern + .. exn:: @qualid does not occur. + :undocumented: - This applies :tacn:`simpl` only to the subterms matching - :n:`@pattern` in the current goal. +.. tacn:: fold {+ @one_term } @simple_occurrences -.. tacv:: simpl @pattern at {+ @natural} + First, this tactic reduces each :n:`@one_term` using the :tacn:`red` tactic. + Then, every occurrence of the resulting terms in the selected hypotheses and/or + goal will be replaced by its associated :n:`@one_term`. This tactic is particularly + useful for + reversing undesired unfoldings, which may make the goal very hard to read. + The undesired unfoldings may be due to the limited capabilities of + other reduction tactics. + On the other hand, when an unfolded function applied to its argument has been + reduced, the :tacn:`fold` tactic doesn't do anything. - This applies :tacn:`simpl` only to the :n:`{+ @natural}` occurrences of the subterms - matching :n:`@pattern` in the current goal. + :tacn:`fold` :n:`@one_term__1 @one_term__2` is equivalent to + :n:`fold @one_term__1; fold @one_term__2`. - .. exn:: Too few occurrences. - :undocumented: + .. example:: :tacn:`fold` doesn't always undo :tacn:`unfold` -.. tacv:: simpl @qualid - simpl @string + .. coqtop:: all - This applies :tacn:`simpl` only to the applicative subterms whose head occurrence - is the unfoldable constant :n:`@qualid` (the constant can be referred to by - its notation using :n:`@string` if such a notation exists). + Goal ~0=0. + unfold not. -.. tacv:: simpl @qualid at {+ @natural} - simpl @string at {+ @natural} + This :tacn:`fold` doesn't undo the preceeding :tacn:`unfold` (it makes no change): - This applies :tacn:`simpl` only to the :n:`{+ @natural}` applicative subterms whose - head occurrence is :n:`@qualid` (or :n:`@string`). + .. coqtop:: all -.. flag:: Debug RAKAM + fold not. - This flag makes :tacn:`cbn` print various debugging information. - ``RAKAM`` is the Refolding Algebraic Krivine Abstract Machine. + However, this :tacn:`pattern` followed by :tacn:`fold` does: -.. tacn:: unfold @qualid - :name: unfold + .. coqtop:: all abort - This tactic applies to any goal. The argument qualid must denote a - defined transparent constant or local definition (see - :ref:`gallina-definitions` and - :ref:`vernac-controlling-the-reduction-strategies`). The tactic - :tacn:`unfold` applies the :math:`\delta` rule to each occurrence - of the constant to which :n:`@qualid` refers in the current goal - and then replaces it with its :math:`\beta\iota\zeta`-normal form. - Use the general reduction tactics if you want to avoid this final - reduction, for instance :n:`cbv delta [@qualid]`. + pattern (0 = 0). + fold not. - .. exn:: Cannot coerce @qualid to an evaluable reference. + .. example:: Use :tacn:`fold` to reverse unfolding of `fold_right` - This error is frequent when trying to unfold something that has - defined as an inductive type (or constructor) and not as a - definition. + .. coqtop:: none - .. example:: + Require Import Coq.Lists.List. + Local Open Scope list_scope. - .. coqtop:: abort all fail + .. coqtop:: all abort - Goal 0 <= 1. - unfold le. + Goal forall x xs, fold_right and True (x::xs). + red. + fold (fold_right and True). - This error can also be raised if you are trying to unfold - something that has been marked as opaque. +.. tacn:: pattern {+, @pattern_occs } {? @occurrences } - .. example:: + Performs beta-expansion (the inverse of :term:`beta-reduction`) for the + selected hypotheses and/or goals. + The :n:`@one_term`\s in :n:`@pattern_occs` must be free subterms in the selected items. + The expansion is done for each selected item :g:`T` + for a set of :n:`@one_term`\s in the :n:`@pattern_occs` by: - .. coqtop:: abort all fail + + replacing all selected occurrences of the :n:`@one_term`\s in :g:`T` with fresh variables + + abstracting these variables + + applying the abstracted goal to the :n:`@one_term`\s - Opaque Nat.add. - Goal 1 + 0 = 1. - unfold Nat.add. + For instance, if the current goal :g:`T` is expressible as :n:`φ(t__1 … t__n)` + where the notation captures all the instances of the :n:`t__i` in φ, then :tacn:`pattern` + :n:`t__1, …, t__n` generates the equivalent goal + :n:`(fun (x__1:A__1 … (x__n:A__n) => φ(x__1 … x__n)) t__1 … t__n`. + If :n:`t__i` occurs in one of the generated types :n:`A__j` + (for `j > i`), + occurrences will also be considered and possibly abstracted. - .. tacv:: unfold @qualid in @goal_occurrences + This tactic can be used, for instance, when the tactic :tacn:`apply` fails + on matching or to better control the behavior of :tacn:`rewrite`. - Replaces :n:`@qualid` in hypothesis (or hypotheses) designated - by :token:`goal_occurrences` with its definition and replaces - the hypothesis with its :math:`\beta`:math:`\iota` normal form. +Fast reduction tactics: vm_compute and native_compute +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - .. tacv:: unfold {+, @qualid} +:tacn:`vm_compute` is a brute-force but efficient tactic that +first normalizes the terms before comparing them. It is based on a +bytecode representation of terms similar to the bytecode +representation used in the ZINC virtual machine :cite:`Leroy90`. It is +especially useful for intensive computation of algebraic values, such +as numbers, and for reflection-based tactics. - Replaces :n:`{+, @qualid}` with their definitions and replaces - the current goal with its :math:`\beta`:math:`\iota` normal - form. +:tacn:`native_compute` is based on on converting the Coq code to OCaml. - .. tacv:: unfold {+, @qualid at @occurrences } +Note that both these tactics ignore :cmd:`Opaque` markings +(see issue `#4776 <https://github.com/coq/coq/issues/4776>`_), nor do they +apply unfolding strategies such as from :cmd:`Strategy`. - The list :token:`occurrences` specify the occurrences of - :n:`@qualid` to be unfolded. Occurrences are located from left - to right. +:tacn:`native_compute` is typically two to five +times faster than :tacn:`vm_compute` at applying conversion rules +when Coq is running native code, but :tacn:`native_compute` requires +considerably more overhead. We recommend using :tacn:`native_compute` +when all of the following are true (otherwise use :tacn:`vm_compute`): - .. exn:: Bad occurrence number of @qualid. - :undocumented: +- the running time in :tacn:`vm_compute` at least 5-10 seconds +- the size of the input term is small (e.g. hand-generated code rather than + automatically-generated code that may have nested destructs on inductives + with dozens or hundreds of constructors) +- the output is small (e.g. you're returning a boolean, a natural number or + an integer rather than a large abstract syntax tree) - .. exn:: @qualid does not occur. - :undocumented: +These tactics change existential variables in a way similar to other conversions +while also adding a single explicit cast (see :ref:`type-cast`) to the proof term +to tell the kernel which reduction engine to use. - .. tacv:: unfold @string +.. tacn:: vm_compute {? {| @reference_occs | @pattern_occs } } {? @occurrences } - If :n:`@string` denotes the discriminating symbol of a notation - (e.g. "+") or an expression defining a notation (e.g. `"_ + - _"`), and this notation denotes an application whose head symbol - is an unfoldable constant, then the tactic unfolds it. + Evaluates the goal using the optimized call-by-value evaluation + bytecode-based virtual machine described in :cite:`CompiledStrongReduction`. + This algorithm is dramatically more efficient than the algorithm used for the + :tacn:`cbv` tactic, but it cannot be fine-tuned. It is especially useful for + full evaluation of algebraic objects. This includes the case of + reflection-based tactics. - .. tacv:: unfold @string%@ident +.. tacn:: native_compute {? {| @reference_occs | @pattern_occs } } {? @occurrences } - This is variant of :n:`unfold @string` where :n:`@string` gets - its interpretation from the scope bound to the delimiting key - :token:`ident` instead of its default interpretation (see - :ref:`Localinterpretationrulesfornotations`). + Evaluates the goal by compilation to OCaml as described + in :cite:`FullReduction`. Depending on the configuration, this tactic can either default to + :tacn:`vm_compute`, recompile dependencies or fail due to some missing + precompiled dependencies, + see :ref:`the native-compiler option <native-compiler-options>` for details. - .. tacv:: unfold {+, {| @qualid | @string{? %@ident } } {? at @occurrences } } {? in @goal_occurrences } + .. flag:: NativeCompute Timing - This is the most general form. + This flag causes all calls to the native compiler to print + timing information for the conversion to native code, + compilation, execution, and reification phases of native + compilation. Timing is printed in units of seconds of + wall-clock time. -.. tacn:: fold @term - :name: fold + .. flag:: NativeCompute Profiling - This tactic applies to any goal. The term :n:`@term` is reduced using the - :tacn:`red` tactic. Every occurrence of the resulting :n:`@term` in the goal is - then replaced by :n:`@term`. This tactic is particularly useful when a fixpoint - definition has been wrongfully unfolded, making the goal very hard to read. - On the other hand, when an unfolded function applied to its argument has been - reduced, the :tacn:`fold` tactic won't do anything. + On Linux, if you have the ``perf`` profiler installed, this flag makes + it possible to profile :tacn:`native_compute` evaluations. - .. example:: + .. opt:: NativeCompute Profile Filename @string - .. coqtop:: all abort + This option specifies the profile output; the default is + ``native_compute_profile.data``. The actual filename used + will contain extra characters to avoid overwriting an existing file; that + filename is reported to the user. + That means you can individually profile multiple uses of + :tacn:`native_compute` in a script. From the Linux command line, run ``perf report`` + on the profile file to see the results. Consult the ``perf`` documentation + for more details. - Goal ~0=0. - unfold not. - Fail progress fold not. - pattern (0 = 0). - fold not. +Computing in a term: eval and Eval +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - .. tacv:: fold {+ @term} +Evaluation of a term can be performed with: - Equivalent to :n:`fold @term ; ... ; fold @term`. +.. tacn:: eval @red_expr in @term -.. tacn:: pattern @term - :name: pattern - This command applies to any goal. The argument :n:`@term` must be a free - subterm of the current goal. The command pattern performs :math:`\beta`-expansion - (the inverse of :math:`\beta`-reduction) of the current goal (say :g:`T`) by + .. insertprodn red_expr red_expr - + replacing all occurrences of :n:`@term` in :g:`T` with a fresh variable - + abstracting this variable - + applying the abstracted goal to :n:`@term` + .. prodn:: + red_expr ::= lazy {? @reductions } + | cbv {? @reductions } + | compute {? @delta_reductions } + | vm_compute {? {| @reference_occs | @pattern_occs } } + | native_compute {? {| @reference_occs | @pattern_occs } } + | red + | hnf + | simpl {? @delta_reductions } {? {| @reference_occs | @pattern_occs } } + | cbn {? @reductions } + | unfold {+, @reference_occs } + | fold {+ @one_term } + | pattern {+, @pattern_occs } + | @ident - For instance, if the current goal :g:`T` is expressible as - :math:`\varphi`:g:`(t)` where the notation captures all the instances of :g:`t` - in :math:`\varphi`:g:`(t)`, then :n:`pattern t` transforms it into - :g:`(fun x:A =>` :math:`\varphi`:g:`(x)) t`. This tactic can be used, for - instance, when the tactic ``apply`` fails on matching. + :tacn:`eval` is a :token:`value_tactic`. It returns the result of + applying the conversion rules specified by :n:`@red_expr`. It does not + change the proof state. -.. tacv:: pattern @term at {+ @natural} + The :n:`@red_expr` alternatives that begin with a keyword correspond to the + tactic with the same name, though in several cases with simpler syntax + than the tactic. :n:`@ident` is a named reduction expression created + with :cmd:`Declare Reduction`. - Only the occurrences :n:`{+ @natural}` of :n:`@term` are considered for - :math:`\beta`-expansion. Occurrences are located from left to right. + .. seealso:: Section :ref:`applyingconversionrules`. -.. tacv:: pattern @term at - {+ @natural} +.. cmd:: Eval @red_expr in @term - 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. + Performs the specified reduction on :n:`@term` and displays + the resulting term with its type. If a proof is open, :n:`@term` + may reference hypotheses of the selected goal. :cmd:`Eval` is + a :token:`query_command`, so it may be prefixed with a goal selector. -.. tacv:: pattern {+, @term} + .. cmd:: Compute @term - Starting from a goal :math:`\varphi`:g:`(t`:sub:`1` :g:`... t`:sub:`m`:g:`)`, - the tactic :n:`pattern t`:sub:`1`:n:`, ..., t`:sub:`m` generates the - equivalent goal - :g:`(fun (x`:sub:`1`:g:`:A`:sub:`1`:g:`) ... (x`:sub:`m` :g:`:A`:sub:`m` :g:`) =>`:math:`\varphi`:g:`(x`:sub:`1` :g:`... x`:sub:`m` :g:`)) t`:sub:`1` :g:`... t`:sub:`m`. - 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. + Evaluates :n:`@term` using the bytecode-based virtual machine. + It is a shortcut for :cmd:`Eval` :n:`vm_compute in @term`. + :cmd:`Compute` is a :token:`query_command`, so it may be prefixed + with a goal selector. + +.. cmd:: Declare Reduction @ident := @red_expr + + Declares a short name for the reduction expression :n:`@red_expr`, for + instance ``lazy beta delta [foo bar]``. This short name can then be used + in :n:`Eval @ident in` or ``eval`` constructs. This command + accepts the :attr:`local` attribute, which indicates that the reduction + will be discarded at the end of the + file or module. The name is not qualified. In + particular declaring the same name in several modules or in several + functor applications will be rejected if these declarations are not + local. The name :n:`@ident` cannot be used directly as an Ltac tactic, but + nothing prevents the user from also performing a + :n:`Ltac @ident := @red_expr`. + +.. _controlling-the-reduction-strategies: + +Controlling reduction strategies and the conversion algorithm +------------------------------------------------------------- + +The commands to fine-tune the reduction strategies and the lazy conversion +algorithm are described in this section. Also see :ref:`Args_effect_on_unfolding`, +which supports additional fine-tuning. + +.. cmd:: Opaque {+ @reference } + + Marks the specified constants as :term:`opaque` so tactics won't :term:`unfold` them + with :term:`delta-reduction`. + "Constants" are items defined by commands such as :cmd:`Definition`, + :cmd:`Let` (with an explicit body), :cmd:`Fixpoint`, :cmd:`CoFixpoint` + and :cmd:`Function`. -.. tacv:: pattern {+, @term at {+ @natural}} + This command accepts the :attr:`global` attribute. By default, the scope + of :cmd:`Opaque` is limited to the current section or module. - This behaves as above but processing only the occurrences :n:`{+ @natural}` of - :n:`@term` starting from :n:`@term`. + :cmd:`Opaque` also affects Coq's conversion algorithm, causing + it to delay unfolding the specified constants as much as possible when it + has to check that two distinct applied constants are convertible. + See Section :ref:`conversion-rules`. -.. tacv:: pattern {+, @term {? at {? -} {+, @natural}}} +.. cmd:: Transparent {+ @reference } - This is the most general syntax that combines the different variants. + The opposite of :cmd:`Opaque`, it marks the specified constants + as :term:`transparent` + so that tactics may unfold them. See :cmd:`Opaque` above. + + This command accepts the :attr:`global` attribute. By default, the scope + of :cmd:`Transparent` is limited to the current section or module. + + Note that constants defined by proofs ending with :cmd:`Qed` are + irreversibly opaque; :cmd:`Transparent` will not make them transparent. + This is consistent + with the usual mathematical practice of *proof irrelevance*: what + matters in a mathematical development is the sequence of lemma + statements, not their actual proofs. This distinguishes lemmas from + the usual defined constants, whose actual values are of course + relevant in general. + + .. exn:: The reference @qualid was not found in the current environment. + + There is no constant named :n:`@qualid` in the environment. + +.. seealso:: :ref:`applyingconversionrules`, :cmd:`Qed` and :cmd:`Defined` + +.. _vernac-strategy: + +.. cmd:: Strategy {+ @strategy_level [ {+ @reference } ] } + + .. insertprodn strategy_level strategy_level + + .. prodn:: + strategy_level ::= opaque + | @integer + | expand + | transparent + + Generalizes the behavior of the :cmd:`Opaque` and :cmd:`Transparent` + commands. It is used to fine-tune the strategy for unfolding + constants, both at the tactic level and at the kernel level. This + command associates a :n:`@strategy_level` with the qualified names in the :n:`@reference` + sequence. Whenever two + expressions with two distinct head constants are compared (for + example, typechecking `f x` where `f : A -> B` and `x : C` will result in + converting `A` and `C`), the one + with lower level is expanded first. In case of a tie, the second one + (appearing in the cast type) is expanded. + + This command accepts the :attr:`local` attribute, which limits its effect + to the current section or module, in which case the section and module + behavior is the same as :cmd:`Opaque` and :cmd:`Transparent` (without :attr:`global`). + + Levels can be one of the following (higher to lower): + + + ``opaque`` : level of opaque constants. They cannot be expanded by + tactics (behaves like +∞, see next item). + + :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 + constants, while positive levels correspond to constants to be + expanded after normal transparent constants. + + ``expand`` : level of constants that should be expanded first (behaves + like −∞) + + ``transparent`` : Equivalent to level 0 + +.. cmd:: Print Strategy @reference + + This command prints the strategy currently associated with :n:`@reference`. It + fails if :n:`@reference` is not an unfoldable reference, that is, neither a + variable nor a constant. + + .. exn:: The reference is not unfoldable. + :undocumented: + +.. cmd:: Print Strategies + + Print all the currently non-transparent strategies. .. tacn:: with_strategy @strategy_level_or_var [ {+ @reference } ] @ltac_expr3 - :name: with_strategy + + .. insertprodn strategy_level_or_var strategy_level_or_var + + .. prodn:: + strategy_level_or_var ::= @strategy_level + | @ident Executes :token:`ltac_expr3`, applying the alternate unfolding behavior that the :cmd:`Strategy` command controls, but only for @@ -925,15 +1076,3 @@ the conversion in hypotheses :n:`{+ @ident}`. tactics to persist information about conversion hints in the proof term. See `#12200 <https://github.com/coq/coq/issues/12200>`_ for more details. - -Conversion tactics applied to hypotheses -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - The form :n:`@tactic in {+, @ident }` applies :token:`tactic` (any of the - conversion tactics listed in this section) to the hypotheses :n:`{+ @ident}`. - - If :token:`ident` is a local definition, then :token:`ident` can be replaced by - :n:`type of @ident` to address not the body but the type of the local - definition. - - Example: :n:`unfold not in (type of H1) (type of H3)`. diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index 609884ce1d..453e878a5d 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -442,6 +442,12 @@ Displaying information about notations Controls whether to use notations for printing terms wherever possible. Default is on. +.. flag:: Printing Raw Literals + + Controls whether to use string and number notations for printing terms + wherever possible (see :ref:`string-notations`). + Default is off. + .. flag:: Printing Parentheses If on, parentheses are printed even if implied by associativity and precedence @@ -1726,12 +1732,6 @@ Number notations * :n:`@qualid__type -> Number.number` * :n:`@qualid__type -> option Number.number` - .. deprecated:: 8.12 - Number notations on :g:`Decimal.uint`, :g:`Decimal.int` and - :g:`Decimal.decimal` are replaced respectively by number - notations on :g:`Number.uint`, :g:`Number.int` and - :g:`Number.number`. - When parsing, the application of the parsing function :n:`@qualid__parse` to the number will be fully reduced, and universes of the resulting term will be refreshed. @@ -1741,6 +1741,12 @@ Number notations sorts, primitive integers, primitive floats, primitive arrays and type constants for primitive types) will be considered for printing. + .. note:: + For example, :n:`@qualid__type` can be :n:`PrimInt63.int`, + in which case :n:`@qualid__print` takes :n:`PrimInt63.int_wrapper` as input + instead of :n:`PrimInt63.int`. See below for an + :ref:`example <example-number-notation-primitive-int>`. + .. _number-string-via: :n:`via @qualid__ind mapping [ {+, @qualid__constant => @qualid__constructor } ]` @@ -2066,6 +2072,23 @@ The following errors apply to both string and number notations: Check 3. +.. _example-number-notation-primitive-int: + +.. example:: Number Notation for primitive integers + + This shows the use of the primitive + integers :n:`PrimInt63.int` as :n:`@qualid__type`. It is the way + parsing and printing of primitive integers are actually implemented + in `PrimInt63.v`. + + .. coqtop:: in reset + + Require Import Int63. + Definition parser (x : pos_neg_int63) : option int := + match x with Pos p => Some p | Neg _ => None end. + Definition printer (x : int_wrapper) : pos_neg_int63 := Pos (int_wrap x). + Number Notation int parser printer : int63_scope. + .. _example-number-notation-non-inductive: .. example:: Number Notation for a non inductive type diff --git a/doc/stdlib/dune b/doc/stdlib/dune index 0b6ca5f178..6b51202f6e 100644 --- a/doc/stdlib/dune +++ b/doc/stdlib/dune @@ -22,7 +22,8 @@ (:header %{project_root}/doc/common/styles/html/coqremote/header.html) (:footer %{project_root}/doc/common/styles/html/coqremote/footer.html) ; For .glob files, should be gone when Coq Dune is smarter. - (package coq)) + (package coq-core) + (package coq-stdlib)) (action (progn (run mkdir -p html) diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index cbe526be68..d67906c4a8 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -286,6 +286,7 @@ through the <tt>Require Import</tt> command.</p> theories/Numbers/Cyclic/Int63/Cyclic63.v theories/Numbers/Cyclic/Int63/PrimInt63.v theories/Numbers/Cyclic/Int63/Int63.v + theories/Numbers/Cyclic/Int63/Sint63.v theories/Numbers/Cyclic/Int63/Ring63.v theories/Numbers/Cyclic/ZModulo/ZModulo.v </dd> @@ -684,6 +685,7 @@ through the <tt>Require Import</tt> command.</p> user-contrib/Ltac2/Fresh.v user-contrib/Ltac2/Ident.v user-contrib/Ltac2/Init.v + user-contrib/Ltac2/Ind.v user-contrib/Ltac2/Int.v user-contrib/Ltac2/List.v user-contrib/Ltac2/Ltac1.v @@ -691,6 +693,7 @@ through the <tt>Require Import</tt> command.</p> user-contrib/Ltac2/Notations.v user-contrib/Ltac2/Option.v user-contrib/Ltac2/Pattern.v + user-contrib/Ltac2/Printf.v user-contrib/Ltac2/Std.v user-contrib/Ltac2/String.v </dd> diff --git a/doc/tools/coqrst/coqdomain.py b/doc/tools/coqrst/coqdomain.py index fa739e97bc..1428dae7ef 100644 --- a/doc/tools/coqrst/coqdomain.py +++ b/doc/tools/coqrst/coqdomain.py @@ -529,12 +529,12 @@ class ProductionObject(CoqObject): self.signatures = [] indexnode = super().run()[0] # makes calls to handle_signature - table = nodes.container(classes=['prodn-table']) - tgroup = nodes.container(classes=['prodn-column-group']) + table = nodes.inline(classes=['prodn-table']) + tgroup = nodes.inline(classes=['prodn-column-group']) for _ in range(4): - tgroup += nodes.container(classes=['prodn-column']) + tgroup += nodes.inline(classes=['prodn-column']) table += tgroup - tbody = nodes.container(classes=['prodn-row-group']) + tbody = nodes.inline(classes=['prodn-row-group']) table += tbody # create rows @@ -542,8 +542,8 @@ class ProductionObject(CoqObject): lhs, op, rhs, tag = signature position = self.state_machine.get_source_and_line(self.lineno) - row = nodes.container(classes=['prodn-row']) - entry = nodes.container(classes=['prodn-cell-nonterminal']) + row = nodes.inline(classes=['prodn-row']) + entry = nodes.inline(classes=['prodn-cell-nonterminal']) if lhs != "": target_name = make_id('grammar-token-' + lhs) target = nodes.target('', '', ids=[target_name], names=[target_name]) @@ -553,19 +553,19 @@ class ProductionObject(CoqObject): entry += inline entry += notation_to_sphinx('@'+lhs, *position) else: - entry += nodes.Text('') + entry += nodes.literal('', '') row += entry - entry = nodes.container(classes=['prodn-cell-op']) - entry += nodes.Text(op) + entry = nodes.inline(classes=['prodn-cell-op']) + entry += nodes.literal(op, op) row += entry - entry = nodes.container(classes=['prodn-cell-production']) + entry = nodes.inline(classes=['prodn-cell-production']) entry += notation_to_sphinx(rhs, *position) row += entry - entry = nodes.container(classes=['prodn-cell-tag']) - entry += nodes.Text(tag) + entry = nodes.inline(classes=['prodn-cell-tag']) + entry += nodes.literal(tag, tag) row += entry tbody += row @@ -1171,9 +1171,12 @@ class StdGlossaryIndex(Index): name, localname, shortname = "glossindex", "Glossary", "terms" def generate(self, docnames=None): - content = defaultdict(list) + def ci_sort(entry): + ((type, itemname), (docname, anchor)) = entry + return itemname.lower() - for ((type, itemname), (docname, anchor)) in self.domain.data['objects'].items(): + content = defaultdict(list) + for ((type, itemname), (docname, anchor)) in sorted(self.domain.data['objects'].items(), key=ci_sort): if type == 'term': entries = content[itemname[0].lower()] entries.append([itemname, 0, docname, anchor, '', '', '']) diff --git a/doc/tools/docgram/common.edit_mlg b/doc/tools/docgram/common.edit_mlg index 27144fd1ad..24ecc65e9b 100644 --- a/doc/tools/docgram/common.edit_mlg +++ b/doc/tools/docgram/common.edit_mlg @@ -62,8 +62,8 @@ SPLICE: [ ] RENAME: [ -| G_LTAC2_delta_flag ltac2_delta_flag -| G_LTAC2_strategy_flag ltac2_strategy_flag +| G_LTAC2_delta_flag ltac2_delta_reductions +| G_LTAC2_strategy_flag ltac2_reductions | G_LTAC2_binder ltac2_binder | G_LTAC2_branches ltac2_branches | G_LTAC2_let_clause ltac2_let_clause @@ -640,7 +640,7 @@ delta_flag: [ | OPTINREF ] -ltac2_delta_flag: [ +ltac2_delta_reductions: [ | EDIT ADD_OPT "-" "[" refglobals "]" (* Ltac2 plugin *) ] @@ -924,6 +924,10 @@ where: [ | "before" ident ] +simple_occurrences: [ +(* placeholder (yuck) *) +] + simple_tactic: [ | REPLACE "eauto" OPT nat_or_var OPT nat_or_var auto_using hintbases | WITH "eauto" OPT nat_or_var auto_using hintbases @@ -937,6 +941,26 @@ simple_tactic: [ | DELETE "autorewrite" "*" "with" LIST1 preident clause | REPLACE "autorewrite" "*" "with" LIST1 preident clause "using" tactic | WITH "autorewrite" OPT "*" "with" LIST1 preident clause OPT ( "using" tactic ) +| REPLACE "autounfold" hintbases clause_dft_concl +| WITH "autounfold" hintbases OPT simple_occurrences +| REPLACE "red" clause_dft_concl +| WITH "red" simple_occurrences +| REPLACE "simpl" OPT delta_flag OPT ref_or_pattern_occ clause_dft_concl +| WITH "simpl" OPT delta_flag OPT ref_or_pattern_occ simple_occurrences +| REPLACE "hnf" clause_dft_concl +| WITH "hnf" simple_occurrences +| REPLACE "cbv" strategy_flag clause_dft_concl +| WITH "cbv" strategy_flag simple_occurrences +| PRINT +| REPLACE "compute" OPT delta_flag clause_dft_concl +| WITH "compute" OPT delta_flag simple_occurrences +| REPLACE "lazy" strategy_flag clause_dft_concl +| WITH "lazy" strategy_flag simple_occurrences +| REPLACE "cbn" strategy_flag clause_dft_concl +| WITH "cbn" strategy_flag simple_occurrences +| REPLACE "fold" LIST1 constr clause_dft_concl +| WITH "fold" LIST1 constr simple_occurrences + | DELETE "cofix" ident | REPLACE "cofix" ident "with" LIST1 cofixdecl | WITH "cofix" ident OPT ( "with" LIST1 cofixdecl ) @@ -2460,6 +2484,10 @@ clause_dft_concl: [ | WITH occs ] +simple_occurrences: [ +| clause_dft_concl (* semantically restricted: no "at" clause *) +] + occs_nums: [ | EDIT ADD_OPT "-" LIST1 nat_or_var ] @@ -2471,10 +2499,8 @@ variance_identref: [ conversion: [ | DELETE constr | DELETE constr "with" constr -| PRINT | REPLACE constr "at" occs_nums "with" constr | WITH OPT ( constr OPT ( "at" occs_nums ) "with" ) constr -| PRINT ] SPLICE: [ @@ -2762,6 +2788,10 @@ RENAME: [ | hypident_occ hyp_occs | concl_occ concl_occs | constr_with_bindings_arg one_term_with_bindings +| red_flag reduction +| strategy_flag reductions +| delta_flag delta_reductions +| q_strategy_flag q_reductions ] simple_tactic: [ @@ -2806,7 +2836,7 @@ NOTINRSTS: [ | q_destruction_arg | q_with_bindings | q_bindings -| q_strategy_flag +| q_reductions | q_reference | q_clause | q_occurrences diff --git a/doc/tools/docgram/dune b/doc/tools/docgram/dune index 1c07d00d4f..4ba60ddd9f 100644 --- a/doc/tools/docgram/dune +++ b/doc/tools/docgram/dune @@ -1,6 +1,6 @@ (executable (name doc_grammar) - (libraries coq.clib coqpp)) + (libraries coq-core.clib coqpp)) (env (_ (binaries doc_grammar.exe))) diff --git a/doc/tools/docgram/fullGrammar b/doc/tools/docgram/fullGrammar index bc6b803bbb..be1b9d80fb 100644 --- a/doc/tools/docgram/fullGrammar +++ b/doc/tools/docgram/fullGrammar @@ -1,492 +1,6 @@ (* Coq grammar generated from .mlg files. Do not edit by hand. Not compiled into Coq *) DOC_GRAMMAR -Constr.ident: [ -| Prim.ident -] - -Prim.name: [ -| "_" -] - -global: [ -| Prim.reference -] - -constr_pattern: [ -| constr -] - -cpattern: [ -| lconstr -] - -sort: [ -| "Set" -| "Prop" -| "SProp" -| "Type" -| "Type" "@{" "_" "}" -| "Type" "@{" universe "}" -] - -sort_family: [ -| "Set" -| "Prop" -| "SProp" -| "Type" -] - -universe_increment: [ -| "+" natural -| -] - -universe_name: [ -| global -| "Set" -| "Prop" -] - -universe_expr: [ -| universe_name universe_increment -] - -universe: [ -| "max" "(" LIST1 universe_expr SEP "," ")" -| universe_expr -] - -lconstr: [ -| term200 -] - -constr: [ -| term8 -| "@" global univ_annot -] - -term200: [ -| binder_constr -| term100 -] - -term100: [ -| term99 "<:" term200 -| term99 "<<:" term200 -| term99 ":" term200 -| term99 ":>" -| term99 -] - -term99: [ -| term90 -] - -term90: [ -| term10 -] - -term10: [ -| term9 LIST1 arg -| "@" global univ_annot LIST0 term9 -| "@" pattern_ident LIST1 identref -| term9 -] - -term9: [ -| ".." term0 ".." -| term8 -] - -term8: [ -| term1 -] - -term1: [ -| term0 ".(" global LIST0 arg ")" -| term0 ".(" "@" global LIST0 ( term9 ) ")" -| term0 "%" IDENT -| term0 -] - -term0: [ -| atomic_constr -| term_match -| "(" term200 ")" -| "{|" record_declaration bar_cbrace -| "{" binder_constr "}" -| "`{" term200 "}" -| test_array_opening "[" "|" array_elems "|" lconstr type_cstr test_array_closing "|" "]" univ_annot -| "`(" term200 ")" -| "ltac" ":" "(" Pltac.ltac_expr ")" -] - -array_elems: [ -| LIST0 lconstr SEP ";" -] - -record_declaration: [ -| fields_def -] - -fields_def: [ -| field_def ";" fields_def -| field_def -| -] - -field_def: [ -| global binders ":=" lconstr -] - -binder_constr: [ -| "forall" open_binders "," term200 -| "fun" open_binders "=>" term200 -| "let" name binders let_type_cstr ":=" term200 "in" term200 -| "let" "fix" fix_decl "in" term200 -| "let" "cofix" cofix_body "in" term200 -| "let" [ "(" LIST0 name SEP "," ")" | "()" ] as_return_type ":=" term200 "in" term200 -| "let" "'" pattern200 ":=" term200 "in" term200 -| "let" "'" pattern200 ":=" term200 case_type "in" term200 -| "let" "'" pattern200 "in" pattern200 ":=" term200 case_type "in" term200 -| "if" term200 as_return_type "then" term200 "else" term200 -| "fix" fix_decls -| "cofix" cofix_decls -| "if" term200 "is" ssr_dthen ssr_else (* SSR plugin *) -| "if" term200 "isn't" ssr_dthen ssr_else (* SSR plugin *) -| "let" ":" ssr_mpat ":=" lconstr "in" lconstr (* SSR plugin *) -| "let" ":" ssr_mpat ":=" lconstr ssr_rtype "in" lconstr (* SSR plugin *) -| "let" ":" ssr_mpat "in" pattern200 ":=" lconstr ssr_rtype "in" lconstr (* SSR plugin *) -] - -arg: [ -| test_lpar_id_coloneq "(" identref ":=" lconstr ")" -| term9 -] - -atomic_constr: [ -| global univ_annot -| sort -| NUMBER -| string -| "_" -| "?" "[" identref "]" -| "?" "[" pattern_ident "]" -| pattern_ident evar_instance -] - -inst: [ -| identref ":=" lconstr -] - -evar_instance: [ -| "@{" LIST1 inst SEP ";" "}" -| -] - -univ_annot: [ -| "@{" LIST0 universe_level "}" -| -] - -universe_level: [ -| "Set" -| "Prop" -| "Type" -| "_" -| global -] - -fix_decls: [ -| fix_decl -| fix_decl "with" LIST1 fix_decl SEP "with" "for" identref -] - -cofix_decls: [ -| cofix_body -| cofix_body "with" LIST1 cofix_body SEP "with" "for" identref -] - -fix_decl: [ -| identref binders_fixannot type_cstr ":=" term200 -] - -cofix_body: [ -| identref binders type_cstr ":=" term200 -] - -term_match: [ -| "match" LIST1 case_item SEP "," OPT case_type "with" branches "end" -] - -case_item: [ -| term100 OPT [ "as" name ] OPT [ "in" pattern200 ] -] - -case_type: [ -| "return" term100 -] - -as_return_type: [ -| OPT [ OPT [ "as" name ] case_type ] -] - -branches: [ -| OPT "|" LIST0 eqn SEP "|" -] - -mult_pattern: [ -| LIST1 pattern200 SEP "," -] - -eqn: [ -| LIST1 mult_pattern SEP "|" "=>" lconstr -] - -record_pattern: [ -| global ":=" pattern200 -] - -record_patterns: [ -| record_pattern ";" record_patterns -| record_pattern -| -] - -pattern200: [ -| pattern100 -] - -pattern100: [ -| pattern99 ":" term200 -| pattern99 -] - -pattern99: [ -| pattern90 -] - -pattern90: [ -| pattern10 -] - -pattern10: [ -| pattern1 "as" name -| pattern1 LIST1 pattern1 -| "@" Prim.reference LIST0 pattern1 -| pattern1 -] - -pattern1: [ -| pattern0 "%" IDENT -| pattern0 -] - -pattern0: [ -| Prim.reference -| "{|" record_patterns bar_cbrace -| "_" -| "(" pattern200 ")" -| "(" pattern200 "|" LIST1 pattern200 SEP "|" ")" -| NUMBER -| string -] - -fixannot: [ -| "{" "struct" identref "}" -| "{" "wf" constr identref "}" -| "{" "measure" constr OPT identref OPT constr "}" -] - -binders_fixannot: [ -| ensure_fixannot fixannot -| binder binders_fixannot -| -] - -open_binders: [ -| name LIST0 name ":" lconstr -| name LIST0 name binders -| name ".." name -| closed_binder binders -] - -binders: [ -| LIST0 binder -| Pcoq.Constr.binders -] - -binder: [ -| name -| closed_binder -] - -closed_binder: [ -| "(" name LIST1 name ":" lconstr ")" -| "(" name ":" lconstr ")" -| "(" name ":=" lconstr ")" -| "(" name ":" lconstr ":=" lconstr ")" -| "{" name "}" -| "{" name LIST1 name ":" lconstr "}" -| "{" name ":" lconstr "}" -| "{" name LIST1 name "}" -| "[" name "]" -| "[" name LIST1 name ":" lconstr "]" -| "[" name ":" lconstr "]" -| "[" name LIST1 name "]" -| "`(" LIST1 typeclass_constraint SEP "," ")" -| "`{" LIST1 typeclass_constraint SEP "," "}" -| "`[" LIST1 typeclass_constraint SEP "," "]" -| "'" pattern0 -| [ "of" | "&" ] term99 (* SSR plugin *) -] - -one_open_binder: [ -| name -| name ":" lconstr -| one_closed_binder -] - -one_closed_binder: [ -| "(" name ":" lconstr ")" -| "{" name "}" -| "{" name ":" lconstr "}" -| "[" name "]" -| "[" name ":" lconstr "]" -| "'" pattern0 -] - -typeclass_constraint: [ -| "!" term200 -| "{" name "}" ":" [ "!" | ] term200 -| test_name_colon name ":" [ "!" | ] term200 -| term200 -] - -type_cstr: [ -| ":" lconstr -| -] - -let_type_cstr: [ -| OPT [ ":" lconstr ] -] - -preident: [ -| IDENT -] - -ident: [ -| IDENT -] - -pattern_ident: [ -| LEFTQMARK ident -] - -identref: [ -| ident -] - -hyp: [ -| identref -] - -field: [ -| FIELD -] - -fields: [ -| field fields -| field -] - -fullyqualid: [ -| ident fields -| ident -] - -name: [ -| "_" -| ident -] - -reference: [ -| ident fields -| ident -] - -qualid: [ -| reference -] - -by_notation: [ -| ne_string OPT [ "%" IDENT ] -] - -smart_global: [ -| reference -| by_notation -] - -ne_string: [ -| STRING -] - -ne_lstring: [ -| ne_string -] - -dirpath: [ -| ident LIST0 field -] - -string: [ -| STRING -] - -lstring: [ -| string -] - -integer: [ -| bigint -] - -natural: [ -| bignat -] - -bigint: [ -| bignat -| test_minus_nat "-" bignat -] - -bignat: [ -| NUMBER -] - -bar_cbrace: [ -| test_pipe_closedcurly "|" "}" -] - -strategy_level: [ -| "expand" -| "opaque" -| integer -| "transparent" -] - -vernac_toplevel: [ -| "Drop" "." -| "Quit" "." -| "BackTo" natural "." -| test_show_goal "Show" "Goal" natural "at" natural "." -| "Show" "Proof" "Diffs" OPT "removed" "." -| Pvernac.Vernac_.main_entry -] - opt_hintbases: [ | | ":" LIST1 IDENT @@ -1467,6 +981,492 @@ binder_interp: [ | "as" "strict" "pattern" ] +vernac_toplevel: [ +| "Drop" "." +| "Quit" "." +| "BackTo" natural "." +| test_show_goal "Show" "Goal" natural "at" natural "." +| "Show" "Proof" "Diffs" OPT "removed" "." +| Pvernac.Vernac_.main_entry +] + +Constr.ident: [ +| Prim.ident +] + +Prim.name: [ +| "_" +] + +global: [ +| Prim.reference +] + +constr_pattern: [ +| constr +] + +cpattern: [ +| lconstr +] + +sort: [ +| "Set" +| "Prop" +| "SProp" +| "Type" +| "Type" "@{" "_" "}" +| "Type" "@{" universe "}" +] + +sort_family: [ +| "Set" +| "Prop" +| "SProp" +| "Type" +] + +universe_increment: [ +| "+" natural +| +] + +universe_name: [ +| global +| "Set" +| "Prop" +] + +universe_expr: [ +| universe_name universe_increment +] + +universe: [ +| "max" "(" LIST1 universe_expr SEP "," ")" +| universe_expr +] + +lconstr: [ +| term200 +] + +constr: [ +| term8 +| "@" global univ_annot +] + +term200: [ +| binder_constr +| term100 +] + +term100: [ +| term99 "<:" term200 +| term99 "<<:" term200 +| term99 ":" term200 +| term99 ":>" +| term99 +] + +term99: [ +| term90 +] + +term90: [ +| term10 +] + +term10: [ +| term9 LIST1 arg +| "@" global univ_annot LIST0 term9 +| "@" pattern_ident LIST1 identref +| term9 +] + +term9: [ +| ".." term0 ".." +| term8 +] + +term8: [ +| term1 +] + +term1: [ +| term0 ".(" global LIST0 arg ")" +| term0 ".(" "@" global LIST0 ( term9 ) ")" +| term0 "%" IDENT +| term0 +] + +term0: [ +| atomic_constr +| term_match +| "(" term200 ")" +| "{|" record_declaration bar_cbrace +| "{" binder_constr "}" +| "`{" term200 "}" +| test_array_opening "[" "|" array_elems "|" lconstr type_cstr test_array_closing "|" "]" univ_annot +| "`(" term200 ")" +| "ltac" ":" "(" Pltac.ltac_expr ")" +] + +array_elems: [ +| LIST0 lconstr SEP ";" +] + +record_declaration: [ +| fields_def +] + +fields_def: [ +| field_def ";" fields_def +| field_def +| +] + +field_def: [ +| global binders ":=" lconstr +] + +binder_constr: [ +| "forall" open_binders "," term200 +| "fun" open_binders "=>" term200 +| "let" name binders let_type_cstr ":=" term200 "in" term200 +| "let" "fix" fix_decl "in" term200 +| "let" "cofix" cofix_body "in" term200 +| "let" [ "(" LIST0 name SEP "," ")" | "()" ] as_return_type ":=" term200 "in" term200 +| "let" "'" pattern200 ":=" term200 "in" term200 +| "let" "'" pattern200 ":=" term200 case_type "in" term200 +| "let" "'" pattern200 "in" pattern200 ":=" term200 case_type "in" term200 +| "if" term200 as_return_type "then" term200 "else" term200 +| "fix" fix_decls +| "cofix" cofix_decls +| "if" term200 "is" ssr_dthen ssr_else (* SSR plugin *) +| "if" term200 "isn't" ssr_dthen ssr_else (* SSR plugin *) +| "let" ":" ssr_mpat ":=" lconstr "in" lconstr (* SSR plugin *) +| "let" ":" ssr_mpat ":=" lconstr ssr_rtype "in" lconstr (* SSR plugin *) +| "let" ":" ssr_mpat "in" pattern200 ":=" lconstr ssr_rtype "in" lconstr (* SSR plugin *) +] + +arg: [ +| test_lpar_id_coloneq "(" identref ":=" lconstr ")" +| term9 +] + +atomic_constr: [ +| global univ_annot +| sort +| NUMBER +| string +| "_" +| "?" "[" identref "]" +| "?" "[" pattern_ident "]" +| pattern_ident evar_instance +] + +inst: [ +| identref ":=" lconstr +] + +evar_instance: [ +| "@{" LIST1 inst SEP ";" "}" +| +] + +univ_annot: [ +| "@{" LIST0 universe_level "}" +| +] + +universe_level: [ +| "Set" +| "Prop" +| "Type" +| "_" +| global +] + +fix_decls: [ +| fix_decl +| fix_decl "with" LIST1 fix_decl SEP "with" "for" identref +] + +cofix_decls: [ +| cofix_body +| cofix_body "with" LIST1 cofix_body SEP "with" "for" identref +] + +fix_decl: [ +| identref binders_fixannot type_cstr ":=" term200 +] + +cofix_body: [ +| identref binders type_cstr ":=" term200 +] + +term_match: [ +| "match" LIST1 case_item SEP "," OPT case_type "with" branches "end" +] + +case_item: [ +| term100 OPT [ "as" name ] OPT [ "in" pattern200 ] +] + +case_type: [ +| "return" term100 +] + +as_return_type: [ +| OPT [ OPT [ "as" name ] case_type ] +] + +branches: [ +| OPT "|" LIST0 eqn SEP "|" +] + +mult_pattern: [ +| LIST1 pattern200 SEP "," +] + +eqn: [ +| LIST1 mult_pattern SEP "|" "=>" lconstr +] + +record_pattern: [ +| global ":=" pattern200 +] + +record_patterns: [ +| record_pattern ";" record_patterns +| record_pattern +| +] + +pattern200: [ +| pattern100 +] + +pattern100: [ +| pattern99 ":" term200 +| pattern99 +] + +pattern99: [ +| pattern90 +] + +pattern90: [ +| pattern10 +] + +pattern10: [ +| pattern1 "as" name +| pattern1 LIST1 pattern1 +| "@" Prim.reference LIST0 pattern1 +| pattern1 +] + +pattern1: [ +| pattern0 "%" IDENT +| pattern0 +] + +pattern0: [ +| Prim.reference +| "{|" record_patterns bar_cbrace +| "_" +| "(" pattern200 ")" +| "(" pattern200 "|" LIST1 pattern200 SEP "|" ")" +| NUMBER +| string +] + +fixannot: [ +| "{" "struct" identref "}" +| "{" "wf" constr identref "}" +| "{" "measure" constr OPT identref OPT constr "}" +] + +binders_fixannot: [ +| ensure_fixannot fixannot +| binder binders_fixannot +| +] + +open_binders: [ +| name LIST0 name ":" lconstr +| name LIST0 name binders +| name ".." name +| closed_binder binders +] + +binders: [ +| LIST0 binder +| Pcoq.Constr.binders +] + +binder: [ +| name +| closed_binder +] + +closed_binder: [ +| "(" name LIST1 name ":" lconstr ")" +| "(" name ":" lconstr ")" +| "(" name ":=" lconstr ")" +| "(" name ":" lconstr ":=" lconstr ")" +| "{" name "}" +| "{" name LIST1 name ":" lconstr "}" +| "{" name ":" lconstr "}" +| "{" name LIST1 name "}" +| "[" name "]" +| "[" name LIST1 name ":" lconstr "]" +| "[" name ":" lconstr "]" +| "[" name LIST1 name "]" +| "`(" LIST1 typeclass_constraint SEP "," ")" +| "`{" LIST1 typeclass_constraint SEP "," "}" +| "`[" LIST1 typeclass_constraint SEP "," "]" +| "'" pattern0 +| [ "of" | "&" ] term99 (* SSR plugin *) +] + +one_open_binder: [ +| name +| name ":" lconstr +| one_closed_binder +] + +one_closed_binder: [ +| "(" name ":" lconstr ")" +| "{" name "}" +| "{" name ":" lconstr "}" +| "[" name "]" +| "[" name ":" lconstr "]" +| "'" pattern0 +] + +typeclass_constraint: [ +| "!" term200 +| "{" name "}" ":" [ "!" | ] term200 +| test_name_colon name ":" [ "!" | ] term200 +| term200 +] + +type_cstr: [ +| ":" lconstr +| +] + +let_type_cstr: [ +| OPT [ ":" lconstr ] +] + +preident: [ +| IDENT +] + +ident: [ +| IDENT +] + +pattern_ident: [ +| LEFTQMARK ident +] + +identref: [ +| ident +] + +hyp: [ +| identref +] + +field: [ +| FIELD +] + +fields: [ +| field fields +| field +] + +fullyqualid: [ +| ident fields +| ident +] + +name: [ +| "_" +| ident +] + +reference: [ +| ident fields +| ident +] + +qualid: [ +| reference +] + +by_notation: [ +| ne_string OPT [ "%" IDENT ] +] + +smart_global: [ +| reference +| by_notation +] + +ne_string: [ +| STRING +] + +ne_lstring: [ +| ne_string +] + +dirpath: [ +| ident LIST0 field +] + +string: [ +| STRING +] + +lstring: [ +| string +] + +integer: [ +| bigint +] + +natural: [ +| bignat +] + +bigint: [ +| bignat +| test_minus_nat "-" bignat +] + +bignat: [ +| NUMBER +] + +bar_cbrace: [ +| test_pipe_closedcurly "|" "}" +] + +strategy_level: [ +| "expand" +| "opaque" +| integer +| "transparent" +] + simple_tactic: [ | "btauto" | "congruence" diff --git a/doc/tools/docgram/orderedGrammar b/doc/tools/docgram/orderedGrammar index a34e96ac16..5674d28139 100644 --- a/doc/tools/docgram/orderedGrammar +++ b/doc/tools/docgram/orderedGrammar @@ -337,7 +337,7 @@ NOTINRSTS: [ | q_destruction_arg | q_with_bindings | q_bindings -| q_strategy_flag +| q_reductions | q_reference | q_clause | q_occurrences @@ -550,9 +550,9 @@ term_generalizing: [ ] term_cast: [ +| term10 ":" type | term10 "<:" type | term10 "<<:" type -| term10 ":" type | term10 ":>" ] @@ -627,38 +627,38 @@ reduce: [ ] red_expr: [ -| "red" -| "hnf" -| "simpl" OPT delta_flag OPT [ reference_occs | pattern_occs ] -| "cbv" OPT strategy_flag -| "cbn" OPT strategy_flag -| "lazy" OPT strategy_flag -| "compute" OPT delta_flag +| "lazy" OPT reductions +| "cbv" OPT reductions +| "compute" OPT delta_reductions | "vm_compute" OPT [ reference_occs | pattern_occs ] | "native_compute" OPT [ reference_occs | pattern_occs ] +| "red" +| "hnf" +| "simpl" OPT delta_reductions OPT [ reference_occs | pattern_occs ] +| "cbn" OPT reductions | "unfold" LIST1 reference_occs SEP "," | "fold" LIST1 one_term | "pattern" LIST1 pattern_occs SEP "," | ident ] -delta_flag: [ -| OPT "-" "[" LIST1 reference "]" -] - -strategy_flag: [ -| LIST1 red_flag -| delta_flag +reductions: [ +| LIST1 reduction +| delta_reductions ] -red_flag: [ +reduction: [ | "beta" -| "iota" +| "delta" OPT delta_reductions | "match" | "fix" | "cofix" +| "iota" | "zeta" -| "delta" OPT delta_flag +] + +delta_reductions: [ +| OPT "-" "[" LIST1 reference "]" ] reference_occs: [ @@ -1242,6 +1242,10 @@ occurrences: [ | "in" goal_occurrences ] +simple_occurrences: [ +| occurrences +] + occs_nums: [ | OPT "-" LIST1 nat_or_var ] @@ -1741,7 +1745,7 @@ simple_tactic: [ | "info_eauto" OPT nat_or_var OPT auto_using OPT hintbases | "dfs" "eauto" OPT nat_or_var OPT auto_using OPT hintbases | "bfs" "eauto" OPT nat_or_var OPT auto_using OPT hintbases -| "autounfold" OPT hintbases OPT occurrences +| "autounfold" OPT hintbases OPT simple_occurrences | "autounfold_one" OPT hintbases OPT ( "in" ident ) | "unify" one_term one_term OPT ( "with" ident ) | "typeclasses" "eauto" OPT "bfs" OPT nat_or_var OPT ( "with" LIST1 ident ) @@ -1811,17 +1815,17 @@ simple_tactic: [ | "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 occurrences -| "hnf" OPT occurrences -| "simpl" OPT delta_flag OPT [ reference_occs | pattern_occs ] OPT occurrences -| "cbv" OPT strategy_flag OPT occurrences -| "cbn" OPT strategy_flag OPT occurrences -| "lazy" OPT strategy_flag OPT occurrences -| "compute" OPT delta_flag OPT occurrences +| "red" simple_occurrences +| "hnf" simple_occurrences +| "simpl" OPT delta_reductions OPT [ reference_occs | pattern_occs ] simple_occurrences +| "cbv" OPT reductions simple_occurrences +| "cbn" OPT reductions simple_occurrences +| "lazy" OPT reductions simple_occurrences +| "compute" OPT delta_reductions simple_occurrences | "vm_compute" OPT [ reference_occs | pattern_occs ] OPT occurrences | "native_compute" OPT [ reference_occs | pattern_occs ] OPT occurrences | "unfold" LIST1 reference_occs SEP "," OPT occurrences -| "fold" LIST1 one_term OPT occurrences +| "fold" LIST1 one_term simple_occurrences | "pattern" LIST1 pattern_occs SEP "," OPT occurrences | "change" OPT ( one_term OPT ( "at" occs_nums ) "with" ) one_term OPT occurrences | "change_no_check" OPT ( one_term OPT ( "at" occs_nums ) "with" ) one_term OPT occurrences @@ -2139,13 +2143,13 @@ ltac2_goal_tactics: [ | LIST0 ( OPT ltac2_expr ) SEP "|" (* Ltac2 plugin *) ] -q_strategy_flag: [ -| ltac2_strategy_flag (* Ltac2 plugin *) +q_reductions: [ +| ltac2_reductions (* Ltac2 plugin *) ] -ltac2_strategy_flag: [ +ltac2_reductions: [ | LIST1 ltac2_red_flag (* Ltac2 plugin *) -| OPT ltac2_delta_flag (* Ltac2 plugin *) +| OPT ltac2_delta_reductions (* Ltac2 plugin *) ] ltac2_red_flag: [ @@ -2155,10 +2159,10 @@ ltac2_red_flag: [ | "fix" (* Ltac2 plugin *) | "cofix" (* Ltac2 plugin *) | "zeta" (* Ltac2 plugin *) -| "delta" OPT ltac2_delta_flag (* Ltac2 plugin *) +| "delta" OPT ltac2_delta_reductions (* Ltac2 plugin *) ] -ltac2_delta_flag: [ +ltac2_delta_reductions: [ | OPT "-" "[" LIST1 refglobal "]" ] @@ -20,7 +20,7 @@ (install (section lib) - (package coq) + (package coq-core) (files revision)) (rule diff --git a/dune-project b/dune-project index 1187c58449..251fbd92aa 100644 --- a/dune-project +++ b/dune-project @@ -22,13 +22,13 @@ ; Note that we use coq.opam.template to have dune add the correct opam ; prefix for configure (package - (name coq) + (name coq-core) (depends (ocaml (>= 4.05.0)) - (dune (>= 2.5.0)) (ocamlfind (>= 1.8.1)) - (zarith (>= 1.10))) - (synopsis "The Coq Proof Assistant") + (zarith (>= 1.10)) + (ounit2 :with-test)) + (synopsis "The Coq Proof Assistant -- Core Binaries and Tools") (description "Coq is a formal proof management system. It provides a formal language to write mathematical definitions, executable algorithms and theorems together with an environment for @@ -38,13 +38,38 @@ Typical applications include the certification of properties of programming languages (e.g. the CompCert compiler certification project, or the Bedrock verified low-level programming library), the formalization of mathematics (e.g. the full formalization of the -Feit-Thompson theorem or homotopy type theory) and teaching.")) +Feit-Thompson theorem or homotopy type theory) and teaching. + +This package includes the Coq core binaries, plugins, and tools, but +not the vernacular standard library. + +Note that in this setup, Coq needs to be started with the -boot and +-noinit options, as will otherwise fail to find the regular Coq +prelude, now living in the coq-stdlib package.")) + +(package + (name coq-stdlib) + (depends + (coq-core (= :version))) + (synopsis "The Coq Proof Assistant -- Standard Library") + (description "Coq is a formal proof management system. It provides +a formal language to write mathematical definitions, executable +algorithms and theorems together with an environment for +semi-interactive development of machine-checked proofs. + +Typical applications include the certification of properties of +programming languages (e.g. the CompCert compiler certification +project, or the Bedrock verified low-level programming library), the +formalization of mathematics (e.g. the full formalization of the +Feit-Thompson theorem or homotopy type theory) and teaching. + +This package includes the Coq Standard Library, that is to say, the +set of modules usually bound to the Coq.* namespace.")) (package (name coqide-server) (depends - (dune (>= 2.5.0)) - (coq (= :version))) + (coq-core (= :version))) (synopsis "The Coq Proof Assistant, XML protocol server") (description "Coq is a formal proof management system. It provides a formal language to write mathematical definitions, executable @@ -59,7 +84,6 @@ structured way.")) (package (name coqide) (depends - (dune (>= 2.5.0)) (coqide-server (= :version))) (synopsis "The Coq Proof Assistant --- GTK3 IDE") (description "Coq is a formal proof management system. It provides @@ -75,6 +99,7 @@ development of interactive proofs.")) (license "OPL-1.0") (depends (dune (and :build (>= 2.5.0))) + (conf-python-3 :build) (coq (and :build (= :version)))) (synopsis "The Coq Proof Assistant --- Reference Manual") (description "Coq is a formal proof management system. It provides @@ -84,3 +109,19 @@ semi-interactive development of machine-checked proofs. This package provides the Coq Reference Manual.")) +(package + (name coq) + (depends + (coq-core (= :version)) + (coq-stdlib (= :version))) + (synopsis "The Coq Proof Assistant") + (description "Coq is a formal proof management system. It provides +a formal language to write mathematical definitions, executable +algorithms and theorems together with an environment for +semi-interactive development of machine-checked proofs. + +Typical applications include the certification of properties of +programming languages (e.g. the CompCert compiler certification +project, or the Bedrock verified low-level programming library), the +formalization of mathematics (e.g. the full formalization of the +Feit-Thompson theorem or homotopy type theory) and teaching.")) diff --git a/engine/dune b/engine/dune index e2b7ab9c87..00db94389b 100644 --- a/engine/dune +++ b/engine/dune @@ -1,6 +1,6 @@ (library (name engine) (synopsis "Coq's Tactic Engine") - (public_name coq.engine) + (public_name coq-core.engine) (wrapped false) (libraries library)) diff --git a/engine/eConstr.mli b/engine/eConstr.mli index 0d038e9a67..162d189136 100644 --- a/engine/eConstr.mli +++ b/engine/eConstr.mli @@ -365,6 +365,8 @@ val to_rel_decl : Evd.evar_map -> (t, types) Context.Rel.Declaration.pt -> (Cons val of_case_invert : Constr.case_invert -> case_invert +val of_constr_array : Constr.t array -> t array + (** {5 Unsafe operations} *) module Unsafe : diff --git a/engine/termops.ml b/engine/termops.ml index 4dc584cfa8..d60aa69ccb 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -979,69 +979,52 @@ let collapse_appl sigma c = match EConstr.kind sigma c with (* First utilities for avoiding telescope computation for subst_term *) -let prefix_application sigma eq_fun (k,c) t = +let prefix_application sigma eq_fun k l1 t = let open EConstr in - let c' = collapse_appl sigma c and t' = collapse_appl sigma t in - match EConstr.kind sigma c', EConstr.kind sigma t' with - | App (f1,cl1), App (f2,cl2) -> - let l1 = Array.length cl1 - and l2 = Array.length cl2 in + let t' = collapse_appl sigma t in + if 0 < l1 then match EConstr.kind sigma t' with + | App (f2,cl2) -> + let l2 = Array.length cl2 in if l1 <= l2 - && eq_fun sigma c' (mkApp (f2, Array.sub cl2 0 l1)) then - Some (mkApp (mkRel k, Array.sub cl2 l1 (l2 - l1))) + && eq_fun sigma k (mkApp (f2, Array.sub cl2 0 l1)) then + Some (Array.sub cl2 l1 (l2 - l1)) else None | _ -> None + else None -let my_prefix_application sigma eq_fun (k,c) by_c t = - let open EConstr in - let c' = collapse_appl sigma c and t' = collapse_appl sigma t in - match EConstr.kind sigma c', EConstr.kind sigma t' with - | App (f1,cl1), App (f2,cl2) -> - let l1 = Array.length cl1 - and l2 = Array.length cl2 in - if l1 <= l2 - && eq_fun sigma c' (mkApp (f2, Array.sub cl2 0 l1)) then - Some (mkApp ((Vars.lift k by_c), Array.sub cl2 l1 (l2 - l1))) - else - None - | _ -> None - -(* Recognizing occurrences of a given subterm in a term: [subst_term c t] - substitutes [(Rel 1)] for all occurrences of term [c] in a term [t]; - works if [c] has rels *) - -let subst_term_gen sigma eq_fun c t = - let open EConstr in - let open Vars in - let rec substrec (k,c as kc) t = - match prefix_application sigma eq_fun kc t with - | Some x -> x - | None -> - if eq_fun sigma c t then mkRel k - else - EConstr.map_with_binders sigma (fun (k,c) -> (k+1,lift 1 c)) substrec kc t +let eq_upto_lift cache c sigma k t = + let c = + try Int.Map.find k !cache + with Not_found -> + let c = EConstr.Vars.lift k c in + let () = cache := Int.Map.add k c !cache in + c in - substrec (1,c) t - -let subst_term sigma c t = subst_term_gen sigma EConstr.eq_constr c t + EConstr.eq_constr sigma c t (* Recognizing occurrences of a given subterm in a term : [replace_term c1 c2 t] substitutes [c2] for all occurrences of term [c1] in a term [t]; works if [c1] and [c2] have rels *) -let replace_term_gen sigma eq_fun c by_c in_t = - let rec substrec (k,c as kc) t = - match my_prefix_application sigma eq_fun kc by_c t with - | Some x -> x +let replace_term_gen sigma eq_fun ar by_c in_t = + let rec substrec k t = + match prefix_application sigma eq_fun k ar t with + | Some args -> EConstr.mkApp (EConstr.Vars.lift k by_c, args) | None -> - (if eq_fun sigma c t then (EConstr.Vars.lift k by_c) else - EConstr.map_with_binders sigma (fun (k,c) -> (k+1,EConstr.Vars.lift 1 c)) - substrec kc t) + (if eq_fun sigma k t then (EConstr.Vars.lift k by_c) else + EConstr.map_with_binders sigma succ substrec k t) in - substrec (0,c) in_t + substrec 0 in_t + +let replace_term sigma c byc t = + let cache = ref Int.Map.empty in + let c = collapse_appl sigma c in + let ar = Array.length (snd (decompose_app_vect sigma c)) in + let eq sigma k t = eq_upto_lift cache c sigma k t in + replace_term_gen sigma eq ar byc t -let replace_term sigma c byc t = replace_term_gen sigma EConstr.eq_constr c byc t +let subst_term sigma c t = replace_term sigma c (EConstr.mkRel 1) t let vars_of_env env = let s = Environ.ids_of_named_context_val (Environ.named_context_val env) in diff --git a/engine/termops.mli b/engine/termops.mli index 12df61e4c8..bdde2c450d 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -122,16 +122,12 @@ val pop : constr -> constr (** Substitution of an arbitrary large term. Uses equality modulo reduction of let *) -(** [subst_term_gen eq d c] replaces [d] by [Rel 1] in [c] using [eq] - as equality *) -val subst_term_gen : Evd.evar_map -> - (Evd.evar_map -> constr -> constr -> bool) -> constr -> constr -> constr - -(** [replace_term_gen eq d e c] replaces [d] by [e] in [c] using [eq] - as equality *) +(** [replace_term_gen eq arity e c] replaces matching subterms according to + [eq] by [e] in [c]. If [arity] is non-zero applications of larger length + are handled atomically. *) val replace_term_gen : - Evd.evar_map -> (Evd.evar_map -> constr -> constr -> bool) -> - constr -> constr -> constr -> constr + Evd.evar_map -> (Evd.evar_map -> int -> constr -> bool) -> + int -> constr -> constr -> constr (** [subst_term d c] replaces [d] by [Rel 1] in [c] *) val subst_term : Evd.evar_map -> constr -> constr -> constr diff --git a/gramlib/dune b/gramlib/dune index 8ca6aff25a..62c64b0c1a 100644 --- a/gramlib/dune +++ b/gramlib/dune @@ -1,4 +1,4 @@ (library (name gramlib) - (public_name coq.gramlib) - (libraries coq.lib)) + (public_name coq-core.gramlib) + (libraries coq-core.lib)) diff --git a/ide/coqide/coq.ml b/ide/coqide/coq.ml index b8228df2aa..20e9f0134f 100644 --- a/ide/coqide/coq.ml +++ b/ide/coqide/coq.ml @@ -13,13 +13,9 @@ open Preferences let ideslave_coqtop_flags = ref None -(** * Version and date *) +(** * Version *) -let get_version_date () = - let date = - if Glib.Utf8.validate Coq_config.date - then Coq_config.date - else "<date not printable>" in +let get_version () = try (* the following makes sense only when running with local layout *) let coqroot = Filename.concat @@ -29,21 +25,20 @@ let get_version_date () = let ch = open_in (Filename.concat coqroot "revision") in let ver = input_line ch in let rev = input_line ch in - (ver,rev) - with _ -> (Coq_config.version,date) + close_in ch; + Printf.sprintf "%s (%s)" ver rev + with _ -> Coq_config.version let short_version () = - let (ver,date) = get_version_date () in - Printf.sprintf "The Coq Proof Assistant, version %s (%s)\n" ver date + Printf.sprintf "The Coq Proof Assistant, version %s\n" (get_version ()) let version () = - let (ver,date) = get_version_date () in Printf.sprintf - "The Coq Proof Assistant, version %s (%s)\ + "The Coq Proof Assistant, version %s\ \nArchitecture %s running %s operating system\ \nGtk version is %s\ \nThis is %s \n" - ver date + (get_version ()) Coq_config.arch Sys.os_type (let x,y,z = GMain.Main.version in Printf.sprintf "%d.%d.%d" x y z) (Filename.basename Sys.executable_name) diff --git a/ide/coqide/coqide.ml b/ide/coqide/coqide.ml index f9e6e74372..3fbfbd66d3 100644 --- a/ide/coqide/coqide.ml +++ b/ide/coqide/coqide.ml @@ -1374,8 +1374,7 @@ let main files = let read_coqide_args argv = let set_debug () = Minilib.debug := true; - Flags.debug := true; - Exninfo.record_backtrace true + CDebug.set_debug_all true in let rec filter_coqtop coqtop project_files bindings_files out = function |"-unicode-bindings" :: sfilenames :: args -> @@ -1405,6 +1404,9 @@ let read_coqide_args argv = |"-coqtop-flags" :: flags :: args-> Coq.ideslave_coqtop_flags := Some flags; filter_coqtop coqtop project_files bindings_files out args + | ("-v" | "--version") :: _ -> + Printf.printf "CoqIDE, version %s\n" Coq_config.version; + exit 0 |arg::args when out = [] && CString.is_prefix "-psn_" arg -> (* argument added by MacOS during .app launch *) filter_coqtop coqtop project_files bindings_files out args diff --git a/ide/coqide/coqide_main.ml b/ide/coqide/coqide_main.ml index 0812e00960..a178e72806 100644 --- a/ide/coqide/coqide_main.ml +++ b/ide/coqide/coqide_main.ml @@ -35,7 +35,7 @@ let catch_gtk_messages () = let () = GToolbox.message_box ~title:"Error" (header ^ msg) in Coqide.crash_save 1 |`ERROR -> - if !Flags.debug then GToolbox.message_box ~title:"Error" (header ^ msg) + if CDebug.(get_flag misc) then GToolbox.message_box ~title:"Error" (header ^ msg) else Printf.eprintf "%s\n" (header ^ msg) |`DEBUG -> Minilib.log msg |level when Sys.os_type = "Win32" -> Minilib.log ~level msg diff --git a/ide/coqide/dune b/ide/coqide/dune index 12bad7ebc4..4bb4672cd4 100644 --- a/ide/coqide/dune +++ b/ide/coqide/dune @@ -6,7 +6,7 @@ (public_name coqide-server.core) (wrapped false) (modules document) - (libraries coq.lib)) + (libraries coq-core.lib)) (executable (name fake_ide) @@ -20,7 +20,7 @@ (public_name coqidetop.opt) (package coqide-server) (modules idetop) - (libraries coq.toplevel coqide-server.protocol) + (libraries coq-core.toplevel coqide-server.protocol) (modes native byte) (link_flags -linkall)) diff --git a/ide/coqide/idetop.ml b/ide/coqide/idetop.ml index b42c705add..a6a7f7d742 100644 --- a/ide/coqide/idetop.ml +++ b/ide/coqide/idetop.ml @@ -35,11 +35,11 @@ let pr_with_pid s = Printf.eprintf "[pid %d] %s\n%!" (Unix.getpid ()) s let pr_error s = pr_with_pid s let pr_debug s = - if !Flags.debug then pr_with_pid s + if CDebug.(get_flag misc) then pr_with_pid s let pr_debug_call q = - if !Flags.debug then pr_with_pid ("<-- " ^ Xmlprotocol.pr_call q) + if CDebug.(get_flag misc) then pr_with_pid ("<-- " ^ Xmlprotocol.pr_call q) let pr_debug_answer q r = - if !Flags.debug then pr_with_pid ("--> " ^ Xmlprotocol.pr_full_value q r) + if CDebug.(get_flag misc) then pr_with_pid ("--> " ^ Xmlprotocol.pr_full_value q r) (** Categories of commands *) @@ -397,8 +397,8 @@ let set_options options = let about () = { Interface.coqtop_version = Coq_config.version; Interface.protocol_version = Xmlprotocol.protocol_version; - Interface.release_date = Coq_config.date; - Interface.compile_date = Coq_config.compile_date; + Interface.release_date = "n/a"; + Interface.compile_date = "n/a"; } let handle_exn (e, info) = diff --git a/ide/coqide/microPG.ml b/ide/coqide/microPG.ml index 5a4871b70a..9908703cea 100644 --- a/ide/coqide/microPG.ml +++ b/ide/coqide/microPG.ml @@ -15,7 +15,7 @@ open GdkKeysyms open Printf let eprintf x = - if !Flags.debug then Printf.eprintf x else Printf.ifprintf stderr x + if CDebug.(get_flag misc) then Printf.eprintf x else Printf.ifprintf stderr x type gui = { notebook : session Wg_Notebook.typed_notebook; diff --git a/ide/coqide/protocol/dune b/ide/coqide/protocol/dune index 801ceb20ec..f48c7de0c4 100644 --- a/ide/coqide/protocol/dune +++ b/ide/coqide/protocol/dune @@ -2,6 +2,6 @@ (name protocol) (public_name coqide-server.protocol) (wrapped false) - (libraries coq.lib)) + (libraries coq-core.lib)) (ocamllex xml_lexer) diff --git a/ide/coqide/wg_Find.ml b/ide/coqide/wg_Find.ml index 7e89191bd1..7f30cc8c6c 100644 --- a/ide/coqide/wg_Find.ml +++ b/ide/coqide/wg_Find.ml @@ -219,16 +219,18 @@ class finder name (view : GText.view) = let _ = replace_all_button#connect#clicked ~callback:self#replace_all in (* Keypress interaction *) - let generic_cb esc_cb ret_cb ev = + let dispatch_key_cb esc_cb ret_cb shift_ret_cb ev = let ev_key = GdkEvent.Key.keyval ev in - let (return, _) = GtkData.AccelGroup.parse "Return" in - let (esc, _) = GtkData.AccelGroup.parse "Escape" in - if ev_key = return then (ret_cb (); true) - else if ev_key = esc then (esc_cb (); true) + let ev_modifiers = GdkEvent.Key.state ev in + if ev_key = GdkKeysyms._Return then + (if List.mem `SHIFT ev_modifiers then + shift_ret_cb () + else ret_cb (); true) + else if ev_key = GdkKeysyms._Escape then (esc_cb (); true) else false in - let find_cb = generic_cb self#hide self#find_forward in - let replace_cb = generic_cb self#hide self#replace in + let find_cb = dispatch_key_cb self#hide self#find_forward self#find_backward in + let replace_cb = dispatch_key_cb self#hide self#replace self#replace in let _ = find_entry#event#connect#key_press ~callback:find_cb in let _ = replace_entry#event#connect#key_press ~callback:replace_cb in diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 8138b4c6d9..3cabf52197 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -64,7 +64,7 @@ let print_parentheses = Notation_ops.print_parentheses (* This forces printing universe names of Type{.} *) let print_universes = Detyping.print_universes -(* This suppresses printing of primitive tokens (e.g. numeral) and notations *) +(* This suppresses printing of notations *) let print_no_symbol = ref false (* This tells to skip types if a variable has this type by default *) @@ -74,6 +74,9 @@ let print_use_implicit_types = ~key:["Printing";"Use";"Implicit";"Types"] ~value:true +(* Print primitive tokens, like strings *) +let print_raw_literal = ref false + (**********************************************************************) let hole = CAst.make @@ CHole (None, IntroAnonymous, None) @@ -434,7 +437,7 @@ let extern_record_pattern cstrsp args = (* Better to use extern_glob_constr composed with injection/retraction ?? *) let rec extern_cases_pattern_in_scope (custom,scopes as allscopes) vars pat = try - if !Flags.in_debugger || !Flags.raw_print || !print_no_symbol then raise No_match; + if !Flags.in_debugger || !Flags.raw_print || !print_raw_literal then raise No_match; let (na,p,key) = uninterp_prim_token_cases_pattern pat scopes in match availability_of_entry_coercion custom InConstrEntrySomeLevel with | None -> raise No_match @@ -853,6 +856,7 @@ let same_binder_type ty nal c = (* one with no delimiter if possible) *) let extern_possible_prim_token (custom,scopes) r = + if !print_raw_literal then raise No_match; let (n,key) = uninterp_prim_token r scopes in match availability_of_entry_coercion custom InConstrEntrySomeLevel with | None -> raise No_match @@ -969,7 +973,13 @@ let rec extern inctx ?impargs scopes vars r = with No_match -> extern inctx scopes vars r') | None -> - try extern_notations inctx scopes vars None r + let r' = match DAst.get r with + | GInt i when Coqlib.has_ref "num.int63.wrap_int" -> + let wrap = Coqlib.lib_ref "num.int63.wrap_int" in + DAst.make (GApp (DAst.make (GRef (wrap, None)), [r])) + | _ -> r in + + try extern_notations inctx scopes vars None r' with No_match -> let loc = r.CAst.loc in @@ -1123,7 +1133,7 @@ let rec extern inctx ?impargs scopes vars r = | GInt i -> extern_prim_token_delimiter_if_required - (Number (NumTok.Signed.of_int_string (Uint63.to_string i))) + (Number NumTok.(Signed.of_bigint CHex (Z.of_int64 (Uint63.to_int64 i)))) "int63" "int63_scope" (snd scopes) | GFloat f -> extern_float f (snd scopes) @@ -1255,11 +1265,12 @@ and extern_eqn inctx scopes vars {CAst.loc;v=(ids,pll,c)} = make ?loc (pll,extern inctx scopes vars c) and extern_notations inctx scopes vars nargs t = - if !Flags.raw_print || !print_no_symbol then raise No_match; + if !Flags.raw_print then raise No_match; try extern_possible_prim_token scopes t with No_match -> - let t = flatten_application t in - extern_notation inctx scopes vars t (filter_enough_applied nargs (uninterp_notations t)) + if !print_no_symbol then raise No_match; + let t = flatten_application t in + extern_notation inctx scopes vars t (filter_enough_applied nargs (uninterp_notations t)) and extern_notation inctx (custom,scopes as allscopes) vars t rules = match rules with diff --git a/interp/constrextern.mli b/interp/constrextern.mli index 298b52f0be..bb49c8697d 100644 --- a/interp/constrextern.mli +++ b/interp/constrextern.mli @@ -60,6 +60,7 @@ val print_parentheses : bool ref val print_universes : bool ref val print_no_symbol : bool ref val print_projections : bool ref +val print_raw_literal : bool ref (** Customization of the global_reference printer *) val set_extern_reference : diff --git a/interp/dune b/interp/dune index 6d73d5724c..793ce48ea3 100644 --- a/interp/dune +++ b/interp/dune @@ -1,6 +1,6 @@ (library (name interp) (synopsis "Coq's Syntactic Interpretation for AST [notations, implicits]") - (public_name coq.interp) + (public_name coq-core.interp) (wrapped false) (libraries zarith pretyping)) diff --git a/interp/notation.ml b/interp/notation.ml index d6002d71b5..4010c3487e 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -548,15 +548,15 @@ type number_ty = hexadecimal : Names.inductive; number : Names.inductive } +type pos_neg_int63_ty = + { pos_neg_int63_ty : Names.inductive } + type target_kind = | Int of int_ty (* Coq.Init.Number.int + uint *) | UInt of int_ty (* Coq.Init.Number.uint *) | Z of z_pos_ty (* Coq.Numbers.BinNums.Z and positive *) - | Int63 (* Coq.Numbers.Cyclic.Int63.Int63.int *) + | Int63 of pos_neg_int63_ty (* Coq.Numbers.Cyclic.Int63.PrimInt63.pos_neg_int63 *) | Number of number_ty (* Coq.Init.Number.number + uint + int *) - | DecimalInt of int_ty (* Coq.Init.Decimal.int + uint (deprecated) *) - | DecimalUInt of int_ty (* Coq.Init.Decimal.uint (deprecated) *) - | Decimal of number_ty (* Coq.Init.Decimal.Decimal + uint + int (deprecated) *) type string_target_kind = | ListByte @@ -869,30 +869,16 @@ let mkDecHex ind c n = match c with | CDec -> mkApp (mkConstruct (ind, 1), [|n|]) (* (UInt|Int|)Decimal *) | CHex -> mkApp (mkConstruct (ind, 2), [|n|]) (* (UInt|Int|)Hexadecimal *) -exception NonDecimal - -let decimal_coqnumber_of_rawnum inds n = - if NumTok.Signed.classify n <> CDec then raise NonDecimal; - coqnumber_of_rawnum inds CDec n - let coqnumber_of_rawnum inds n = let c = NumTok.Signed.classify n in let n = coqnumber_of_rawnum inds c n in mkDecHex inds.number c n -let decimal_coquint_of_rawnum inds n = - if NumTok.UnsignedNat.classify n <> CDec then raise NonDecimal; - coquint_of_rawnum inds CDec (Some n) - let coquint_of_rawnum inds n = let c = NumTok.UnsignedNat.classify n in let n = coquint_of_rawnum inds c (Some n) in mkDecHex inds.uint c n -let decimal_coqint_of_rawnum inds n = - if NumTok.SignedNat.classify n <> CDec then raise NonDecimal; - coqint_of_rawnum inds CDec n - let coqint_of_rawnum inds n = let c = NumTok.SignedNat.classify n in let n = coqint_of_rawnum inds c n in @@ -947,23 +933,14 @@ let destDecHex c = match Constr.kind c with | _ -> raise NotAValidPrimToken) | _ -> raise NotAValidPrimToken -let decimal_rawnum_of_coqnumber c = - rawnum_of_coqnumber CDec c - let rawnum_of_coqnumber c = let cl, c = destDecHex c in rawnum_of_coqnumber cl c -let decimal_rawnum_of_coquint c = - rawnum_of_coquint CDec c - let rawnum_of_coquint c = let cl, c = destDecHex c in rawnum_of_coquint cl c -let decimal_rawnum_of_coqint c = - rawnum_of_coqint CDec c - let rawnum_of_coqint c = let cl, c = destDecHex c in rawnum_of_coqint cl c @@ -1038,12 +1015,22 @@ let error_negative ?loc = let error_overflow ?loc 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 error_underflow ?loc n = + CErrors.user_err ?loc ~hdr:"interp_int63" Pp.(str "underflow in int63 literal: " ++ str (Z.to_string n)) + +let coqpos_neg_int63_of_bigint ?loc ind (sign,n) = + let uint = int63_of_pos_bigint ?loc n in + let pos_neg = match sign with SPlus -> 1 | SMinus -> 2 in + mkApp (mkConstruct (ind, pos_neg), [|uint|]) + +let interp_int63 ?loc ind n = + let sign = if Z.(compare n zero >= 0) then SPlus else SMinus in + let n = Z.abs n in if Z.(leq zero n) then if Z.(lt n (pow z_two 63)) - then int63_of_pos_bigint ?loc n - else error_overflow ?loc n + then coqpos_neg_int63_of_bigint ?loc ind (sign,n) + else match sign with SPlus -> error_overflow ?loc n | SMinus -> error_underflow ?loc n else error_negative ?loc let bigint_of_int63 c = @@ -1051,6 +1038,15 @@ let bigint_of_int63 c = | Int i -> Z.of_int64 (Uint63.to_int64 i) | _ -> raise NotAValidPrimToken +let bigint_of_coqpos_neg_int63 c = + match Constr.kind c with + | App (c,[|c'|]) -> + (match Constr.kind c with + | Construct ((_,1), _) (* Pos *) -> bigint_of_int63 c' + | Construct ((_,2), _) (* Neg *) -> Z.neg (bigint_of_int63 c') + | _ -> raise NotAValidPrimToken) + | _ -> raise NotAValidPrimToken + let interp o ?loc n = begin match o.warning, n with | Warning threshold, n when NumTok.Signed.is_bigger_int_than n threshold -> @@ -1062,22 +1058,13 @@ let interp o ?loc n = coqint_of_rawnum int_ty n | UInt int_ty, Some (SPlus, n) -> coquint_of_rawnum int_ty n - | DecimalInt int_ty, Some n -> - (try decimal_coqint_of_rawnum int_ty n - with NonDecimal -> no_such_prim_token "number" ?loc o.ty_name) - | DecimalUInt int_ty, Some (SPlus, n) -> - (try decimal_coquint_of_rawnum int_ty n - with NonDecimal -> no_such_prim_token "number" ?loc o.ty_name) | Z z_pos_ty, Some n -> z_of_bigint z_pos_ty (NumTok.SignedNat.to_bigint n) - | Int63, Some n -> - interp_int63 ?loc (NumTok.SignedNat.to_bigint n) - | (Int _ | UInt _ | DecimalInt _ | DecimalUInt _ | Z _ | Int63), _ -> + | Int63 pos_neg_int63_ty, Some n -> + interp_int63 ?loc pos_neg_int63_ty.pos_neg_int63_ty (NumTok.SignedNat.to_bigint n) + | (Int _ | UInt _ | Z _ | Int63 _), _ -> no_such_prim_token "number" ?loc o.ty_name | Number number_ty, _ -> coqnumber_of_rawnum number_ty n - | Decimal number_ty, _ -> - (try decimal_coqnumber_of_rawnum number_ty n - with NonDecimal -> no_such_prim_token "number" ?loc o.ty_name) in let env = Global.env () in let sigma = Evd.from_env env in @@ -1100,11 +1087,8 @@ let uninterp o n = | (Int _, c) -> NumTok.Signed.of_int (rawnum_of_coqint c) | (UInt _, c) -> NumTok.Signed.of_nat (rawnum_of_coquint c) | (Z _, c) -> NumTok.Signed.of_bigint CDec (bigint_of_z c) - | (Int63, c) -> NumTok.Signed.of_bigint CDec (bigint_of_int63 c) + | (Int63 _, c) -> NumTok.Signed.of_bigint CDec (bigint_of_coqpos_neg_int63 c) | (Number _, c) -> rawnum_of_coqnumber c - | (DecimalInt _, c) -> NumTok.Signed.of_int (decimal_rawnum_of_coqint c) - | (DecimalUInt _, c) -> NumTok.Signed.of_nat (decimal_rawnum_of_coquint c) - | (Decimal _, c) -> decimal_rawnum_of_coqnumber c end o n end diff --git a/interp/notation.mli b/interp/notation.mli index 97955bf92e..195f2a4416 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -137,15 +137,15 @@ type number_ty = hexadecimal : Names.inductive; number : Names.inductive } +type pos_neg_int63_ty = + { pos_neg_int63_ty : Names.inductive } + type target_kind = | Int of int_ty (* Coq.Init.Number.int + uint *) | UInt of int_ty (* Coq.Init.Number.uint *) | Z of z_pos_ty (* Coq.Numbers.BinNums.Z and positive *) - | Int63 (* Coq.Numbers.Cyclic.Int63.Int63.int *) + | Int63 of pos_neg_int63_ty (* Coq.Numbers.Cyclic.Int63.PrimInt63.pos_neg_int63 *) | Number of number_ty (* Coq.Init.Number.number + uint + int *) - | DecimalInt of int_ty (* Coq.Init.Decimal.int + uint (deprecated) *) - | DecimalUInt of int_ty (* Coq.Init.Decimal.uint (deprecated) *) - | Decimal of number_ty (* Coq.Init.Decimal.Decimal + uint + int (deprecated) *) type string_target_kind = | ListByte diff --git a/interp/numTok.ml b/interp/numTok.ml index 124a6cd249..12ef33717a 100644 --- a/interp/numTok.ml +++ b/interp/numTok.ml @@ -85,7 +85,7 @@ struct let string_of_nonneg_bigint c n = match c with | CDec -> Z.format "%d" n - | CHex -> Z.format "0x%x" n + | CHex -> Z.format "%#x" n let of_bigint c n = 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) diff --git a/interp/reserve.ml b/interp/reserve.ml index 07160dcf6f..cdc95285fe 100644 --- a/interp/reserve.ml +++ b/interp/reserve.ml @@ -15,8 +15,6 @@ open Util open Pp open Names open Nameops -open Libobject -open Lib open Notation_term open Notation_ops open Globnames @@ -77,15 +75,11 @@ let notation_constr_key = function (* Rem: NApp(NRef ref,[]) stands for @ref *) | NRef (ref,_) -> RefKey(canonical_gr ref), None | _ -> Oth, None -let cache_reserved_type (_,(id,t)) = +let add_reserved_type (id,t) = let key = fst (notation_constr_key t) in reserve_table := Id.Map.add id t !reserve_table; reserve_revtable := keymap_add key (id, t) !reserve_revtable -let in_reserved : Id.t * notation_constr -> obj = - declare_object {(default_object "RESERVED-TYPE") with - cache_function = cache_reserved_type } - let declare_reserved_type_binding {CAst.loc;v=id} t = if not (Id.equal id (root_of_id id)) then user_err ?loc ~hdr:"declare_reserved_type" @@ -96,7 +90,7 @@ let declare_reserved_type_binding {CAst.loc;v=id} t = user_err ?loc ~hdr:"declare_reserved_type" ((Id.print id++str" is already bound to a type")) with Not_found -> () end; - add_anonymous_leaf (in_reserved (id,t)) + add_reserved_type (id,t) let declare_reserved_type idl t = List.iter (fun id -> declare_reserved_type_binding id t) (List.rev idl) diff --git a/kernel/byterun/coq_fix_code.c b/kernel/byterun/coq_fix_code.c index 4bc6848ba7..20890a28dc 100644 --- a/kernel/byterun/coq_fix_code.c +++ b/kernel/byterun/coq_fix_code.c @@ -21,68 +21,12 @@ #include <caml/alloc.h> #include <caml/memory.h> #include "coq_instruct.h" +#include "coq_arity.h" #include "coq_fix_code.h" #ifdef THREADED_CODE char ** coq_instr_table; char * coq_instr_base; -int arity[STOP+1]; - -void init_arity () { - /* instruction with zero operand */ - arity[ACC0]=arity[ACC1]=arity[ACC2]=arity[ACC3]=arity[ACC4]=arity[ACC5]= - arity[ACC6]=arity[ACC7]= - arity[PUSH]=arity[PUSHACC1]= - arity[PUSHACC2]=arity[PUSHACC3]=arity[PUSHACC4]=arity[PUSHACC5]= - 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[CONST0]=arity[CONST1]=arity[CONST2]=arity[CONST3]= - arity[PUSHCONST0]=arity[PUSHCONST1]=arity[PUSHCONST2]=arity[PUSHCONST3]= - arity[ACCUMULATE]=arity[STOP]= - 0; - /* instruction with one operand */ - arity[ACC]=arity[PUSHACC]=arity[POP]=arity[ENVACC]=arity[PUSHENVACC]= - arity[PUSH_RETADDR]=arity[APPLY]=arity[APPTERM1]=arity[APPTERM2]= - arity[APPTERM3]=arity[RETURN]=arity[GRAB]=arity[OFFSETCLOSURE]= - arity[PUSHOFFSETCLOSURE]=arity[GETGLOBAL]=arity[PUSHGETGLOBAL]= - arity[MAKEBLOCK1]=arity[MAKEBLOCK2]=arity[MAKEBLOCK3]=arity[MAKEBLOCK4]= - arity[MAKEACCU]=arity[CONSTINT]=arity[PUSHCONSTINT]=arity[GRABREC]= - arity[PUSHFIELDS]=arity[GETFIELD]=arity[SETFIELD]= - arity[BRANCH]=arity[ENSURESTACKCAPACITY]= - arity[CHECKADDINT63]=arity[CHECKADDCINT63]=arity[CHECKADDCARRYCINT63]= - arity[CHECKSUBINT63]=arity[CHECKSUBCINT63]=arity[CHECKSUBCARRYCINT63]= - arity[CHECKMULINT63]=arity[CHECKMULCINT63]= - arity[CHECKDIVINT63]=arity[CHECKMODINT63]=arity[CHECKDIVEUCLINT63]= - arity[CHECKDIV21INT63]= - arity[CHECKLXORINT63]=arity[CHECKLORINT63]=arity[CHECKLANDINT63]= - arity[CHECKLSLINT63]=arity[CHECKLSRINT63]=arity[CHECKADDMULDIVINT63]= - arity[CHECKEQINT63]=arity[CHECKLTINT63]=arity[CHECKLEINT63]= - arity[CHECKCOMPAREINT63]=arity[CHECKHEAD0INT63]=arity[CHECKTAIL0INT63]= - arity[CHECKEQFLOAT]=arity[CHECKLTFLOAT]=arity[CHECKLEFLOAT]= - arity[CHECKOPPFLOAT]=arity[CHECKABSFLOAT]=arity[CHECKCOMPAREFLOAT]= - arity[CHECKCLASSIFYFLOAT]= - arity[CHECKADDFLOAT]=arity[CHECKSUBFLOAT]=arity[CHECKMULFLOAT]= - arity[CHECKDIVFLOAT]=arity[CHECKSQRTFLOAT]= - arity[CHECKFLOATOFINT63]=arity[CHECKFLOATNORMFRMANTISSA]= - arity[CHECKFRSHIFTEXP]=arity[CHECKLDSHIFTEXP]= - arity[CHECKNEXTUPFLOAT]=arity[CHECKNEXTDOWNFLOAT]=1; - /* instruction with two operands */ - arity[APPTERM]=arity[MAKEBLOCK]=arity[CLOSURE]= - arity[CHECKCAMLCALL1]=arity[CHECKCAMLCALL2_1]= - arity[CHECKCAMLCALL2]=arity[CHECKCAMLCALL3_1]= - arity[PROJ]= - 2; - /* instruction with four operands */ - arity[MAKESWITCHBLOCK]=4; - /* instruction with arbitrary operands */ - arity[CLOSUREREC]=arity[CLOSURECOFIX]=arity[SWITCH]=0; -} - #endif /* THREADED_CODE */ @@ -164,9 +108,7 @@ value coq_tcode_of_code (value code) { opcode_t instr; COPY32(&instr,p); p++; - if (instr < 0 || instr > STOP){ - instr = STOP; - }; + if (instr < 0 || instr > STOP) abort(); *q++ = VALINSTR(instr); if (instr == SWITCH) { uint32_t i, sizes, const_size, block_size; @@ -183,8 +125,9 @@ value coq_tcode_of_code (value code) { q++; for(i=1; i<n; i++) { COPY32(q,p); p++; q++; }; } else { - uint32_t i, ar; + int i, ar; ar = arity[instr]; + if (ar < 0) abort(); for(i=0; i<ar; i++) { COPY32(q,p); p++; q++; }; } } diff --git a/kernel/byterun/coq_fix_code.h b/kernel/byterun/coq_fix_code.h index 5a233e6178..916d9753a4 100644 --- a/kernel/byterun/coq_fix_code.h +++ b/kernel/byterun/coq_fix_code.h @@ -18,7 +18,6 @@ void * coq_stat_alloc (asize_t sz); #ifdef THREADED_CODE extern char ** coq_instr_table; extern char * coq_instr_base; -void init_arity(); #define VALINSTR(instr) ((opcode_t)(coq_instr_table[instr] - coq_instr_base)) #else #define VALINSTR(instr) instr diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index a9ea6d9f46..704eb1ef98 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -547,7 +547,7 @@ value coq_interprete CHECK_STACK(0); /* We also check for signals */ #if OCAML_VERSION >= 41000 - { + if (caml_something_to_do) { value res = caml_process_pending_actions_exn(); if (Is_exception_result(res)) { /* If there is an asynchronous exception, we reset the vm */ @@ -1426,6 +1426,41 @@ value coq_interprete Next; } + Instruct(CHECKDIVSINT63) { + print_instr("CHEKDIVSINT63"); + CheckInt2(); + int b; + Uint63_eq0(b, *sp); + if (b) { + accu = *sp++; + } + else { + Uint63_eqm1(b, *sp); + if (b) { + Uint63_neg(accu); + sp++; + } + else { + Uint63_divs(accu, *sp++); + } + } + Next; + } + + Instruct(CHECKMODSINT63) { + print_instr("CHEKMODSINT63"); + CheckInt2(); + int b; + Uint63_eq0(b, *sp); + if (b) { + accu = *sp++; + } + else { + Uint63_mods(accu,*sp++); + } + Next; + } + Instruct (CHECKDIV21INT63) { print_instr("DIV21INT63"); CheckInt3(); @@ -1473,6 +1508,13 @@ value coq_interprete Next; } + Instruct(CHECKASRINT63) { + print_instr("CHECKASRINT63"); + CheckInt2(); + Uint63_asr(accu,*sp++); + Next; + } + Instruct (CHECKADDMULDIVINT63) { print_instr("CHECKADDMULDIVINT63"); CheckInt3(); @@ -1508,6 +1550,24 @@ value coq_interprete Next; } + Instruct (CHECKLTSINT63) { + print_instr("CHECKLTSINT63"); + CheckInt2(); + int b; + Uint63_lts(b,accu,*sp++); + accu = b ? coq_true : coq_false; + Next; + } + + Instruct (CHECKLESINT63) { + print_instr("CHECKLESINT63"); + CheckInt2(); + int b; + Uint63_les(b,accu,*sp++); + accu = b ? coq_true : coq_false; + Next; + } + Instruct (CHECKCOMPAREINT63) { /* returns Eq if equal, Lt if accu is less than *sp, Gt otherwise */ /* assumes Inductive _ : _ := Eq | Lt | Gt */ @@ -1526,6 +1586,24 @@ value coq_interprete Next; } + Instruct (CHECKCOMPARESINT63) { + /* returns Eq if equal, Lt if accu is less than *sp, Gt otherwise */ + /* assumes Inductive _ : _ := Eq | Lt | Gt */ + print_instr("CHECKCOMPARESINT63"); + CheckInt2(); + int b; + Uint63_eq(b, accu, *sp); + if (b) { + accu = coq_Eq; + sp++; + } + else { + Uint63_lts(b, accu, *sp++); + accu = b ? coq_Lt : coq_Gt; + } + Next; + } + Instruct (CHECKHEAD0INT63) { print_instr("CHECKHEAD0INT63"); CheckInt1(); diff --git a/kernel/byterun/coq_memory.c b/kernel/byterun/coq_memory.c index fe076f8f04..a55ff57c8d 100644 --- a/kernel/byterun/coq_memory.c +++ b/kernel/byterun/coq_memory.c @@ -100,9 +100,6 @@ value init_coq_vm(value unit) /* ML */ fprintf(stderr,"already open \n");fflush(stderr);} else { drawinstr=0; -#ifdef THREADED_CODE - init_arity(); -#endif /* THREADED_CODE */ /* Allocate the table of global and the stack */ init_coq_stack(); /* Initialing the interpreter */ diff --git a/kernel/byterun/coq_uint63_emul.h b/kernel/byterun/coq_uint63_emul.h index dd9b9e55be..693716ee90 100644 --- a/kernel/byterun/coq_uint63_emul.h +++ b/kernel/byterun/coq_uint63_emul.h @@ -96,7 +96,10 @@ value uint63_##name##_ml(value x, value y, value z) { \ accu = uint63_return_value__; \ }while(0) +DECLARE_NULLOP(zero) DECLARE_NULLOP(one) +DECLARE_UNOP(neg) +#define Uint63_neg(x) CALL_UNOP(neg, x) DECLARE_BINOP(add) #define Uint63_add(x, y) CALL_BINOP(add, x, y) DECLARE_BINOP(addcarry) @@ -105,28 +108,40 @@ DECLARE_TEROP(addmuldiv) #define Uint63_addmuldiv(x, y, z) CALL_TEROP(addmuldiv, x, y, z) DECLARE_BINOP(div) #define Uint63_div(x, y) CALL_BINOP(div, x, y) +DECLARE_BINOP(divs) +#define Uint63_divs(x, y) CALL_BINOP(divs, x, y) DECLARE_BINOP(eq) #define Uint63_eq(r, x, y) CALL_RELATION(r, eq, x, y) DECLARE_UNOP(eq0) #define Uint63_eq0(r, x) CALL_PREDICATE(r, eq0, x) +DECLARE_UNOP(eqm1) +#define Uint63_eqm1(r, x) CALL_PREDICATE(r, eqm1, x) DECLARE_UNOP(head0) #define Uint63_head0(x) CALL_UNOP(head0, x) DECLARE_BINOP(land) #define Uint63_land(x, y) CALL_BINOP(land, x, y) DECLARE_BINOP(leq) #define Uint63_leq(r, x, y) CALL_RELATION(r, leq, x, y) +DECLARE_BINOP(les) +#define Uint63_les(r, x, y) CALL_RELATION(r, les, x, y) DECLARE_BINOP(lor) #define Uint63_lor(x, y) CALL_BINOP(lor, x, y) DECLARE_BINOP(lsl) #define Uint63_lsl(x, y) CALL_BINOP(lsl, x, y) DECLARE_BINOP(lsr) #define Uint63_lsr(x, y) CALL_BINOP(lsr, x, y) +DECLARE_BINOP(asr) +#define Uint63_asr(x, y) CALL_BINOP(asr, x, y) DECLARE_BINOP(lt) #define Uint63_lt(r, x, y) CALL_RELATION(r, lt, x, y) +DECLARE_BINOP(lts) +#define Uint63_lts(r, x, y) CALL_RELATION(r, lts, x, y) DECLARE_BINOP(lxor) #define Uint63_lxor(x, y) CALL_BINOP(lxor, x, y) DECLARE_BINOP(mod) #define Uint63_mod(x, y) CALL_BINOP(mod, x, y) +DECLARE_BINOP(mods) +#define Uint63_mods(x, y) CALL_BINOP(mods, x, y) DECLARE_BINOP(mul) #define Uint63_mul(x, y) CALL_BINOP(mul, x, y) DECLARE_BINOP(sub) diff --git a/kernel/byterun/coq_uint63_native.h b/kernel/byterun/coq_uint63_native.h index 731ae8f46e..da9ae7f147 100644 --- a/kernel/byterun/coq_uint63_native.h +++ b/kernel/byterun/coq_uint63_native.h @@ -12,21 +12,28 @@ #define uint_of_value(val) (((uint64_t)(val)) >> 1) #define uint63_of_value(val) ((uint64_t)(val) >> 1) +#define int63_of_value(val) ((int64_t)(val) >> 1) /* 2^63 * y + x as a value */ //#define Val_intint(x,y) ((value)(((uint64_t)(x)) << 1 + ((uint64_t)(y) << 64))) -#define uint63_zero ((value) 1) /* 2*0 + 1 */ +#define uint63_zero() ((value) 1) /* 2*0 + 1 */ #define uint63_one() ((value) 3) /* 2*1 + 1 */ #define uint63_eq(x,y) ((x) == (y)) #define Uint63_eq(r,x,y) ((r) = uint63_eq(x,y)) #define Uint63_eq0(r,x) ((r) = ((x) == (uint64_t)1)) +#define Uint63_eqm1(r,x) ((r) = ((x) == (uint64_t)(int64_t)(-1))) #define uint63_lt(x,y) ((uint64_t) (x) < (uint64_t) (y)) #define Uint63_lt(r,x,y) ((r) = uint63_lt(x,y)) #define uint63_leq(x,y) ((uint64_t) (x) <= (uint64_t) (y)) #define Uint63_leq(r,x,y) ((r) = uint63_leq(x,y)) +#define uint63_lts(x,y) ((int64_t) (x) < (int64_t) (y)) +#define Uint63_lts(r,x,y) ((r) = uint63_lts(x,y)) +#define uint63_les(x,y) ((int64_t) (x) <= (int64_t) (y)) +#define Uint63_les(r,x,y) ((r) = uint63_les(x,y)) +#define Uint63_neg(x) (accu = (value)(2 - (uint64_t) x)) #define Uint63_add(x,y) (accu = (value)((uint64_t) (x) + (uint64_t) (y) - 1)) #define Uint63_addcarry(x,y) (accu = (value)((uint64_t) (x) + (uint64_t) (y) + 1)) #define Uint63_sub(x,y) (accu = (value)((uint64_t) (x) - (uint64_t) (y) + 1)) @@ -34,6 +41,8 @@ #define Uint63_mul(x,y) (accu = Val_long(uint63_of_value(x) * uint63_of_value(y))) #define Uint63_div(x,y) (accu = Val_long(uint63_of_value(x) / uint63_of_value(y))) #define Uint63_mod(x,y) (accu = Val_long(uint63_of_value(x) % uint63_of_value(y))) +#define Uint63_divs(x,y) (accu = Val_long(int63_of_value(x) / int63_of_value(y))) +#define Uint63_mods(x,y) (accu = Val_long(int63_of_value(x) % int63_of_value(y))) #define Uint63_lxor(x,y) (accu = (value)(((uint64_t)(x) ^ (uint64_t)(y)) | 1)) #define Uint63_lor(x,y) (accu = (value)((uint64_t)(x) | (uint64_t)(y))) @@ -46,14 +55,21 @@ if (uint63_lsl_y__ < (uint64_t) 127) \ accu = (value)((((uint64_t)(x)-1) << uint63_of_value(uint63_lsl_y__)) | 1); \ else \ - accu = uint63_zero; \ + accu = uint63_zero(); \ }while(0) #define Uint63_lsr(x,y) do{ \ value uint63_lsl_y__ = (y); \ if (uint63_lsl_y__ < (uint64_t) 127) \ accu = (value)(((uint64_t)(x) >> uint63_of_value(uint63_lsl_y__)) | 1); \ else \ - accu = uint63_zero; \ + accu = uint63_zero(); \ + }while(0) +#define Uint63_asr(x,y) do{ \ + value uint63_asr_y__ = (y); \ + if (uint63_asr_y__ < (uint64_t) 127) \ + accu = (value)(((int64_t)(x) >> uint63_of_value(uint63_asr_y__)) | 1); \ + else \ + accu = uint63_zero(); \ }while(0) /* addmuldiv(p,x,y) = x * 2^p + y / 2 ^ (63 - p) */ diff --git a/kernel/byterun/dune b/kernel/byterun/dune index d3e2a2fa7f..b14ad5c558 100644 --- a/kernel/byterun/dune +++ b/kernel/byterun/dune @@ -1,7 +1,7 @@ (library (name byterun) (synopsis "Coq's Kernel Abstract Reduction Machine [C implementation]") - (public_name coq.vm) + (public_name coq-core.vm) (foreign_stubs (language c) (names coq_fix_code coq_float64 coq_memory coq_values coq_interp) @@ -14,3 +14,7 @@ (rule (targets coq_jumptbl.h) (action (with-stdout-to %{targets} (run ../genOpcodeFiles.exe jump)))) + +(rule + (targets coq_arity.h) + (action (with-stdout-to %{targets} (run ../genOpcodeFiles.exe arity)))) diff --git a/kernel/cPrimitives.ml b/kernel/cPrimitives.ml index 5cd91b4e74..6ef0e9fa15 100644 --- a/kernel/cPrimitives.ml +++ b/kernel/cPrimitives.ml @@ -8,6 +8,9 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) +(* Note: don't forget to update v_primitive in checker/values.ml if the *) +(* number of primitives is changed. *) + open Univ type t = @@ -18,8 +21,11 @@ type t = | Int63mul | Int63div | Int63mod + | Int63divs + | Int63mods | Int63lsr | Int63lsl + | Int63asr | Int63land | Int63lor | Int63lxor @@ -34,7 +40,10 @@ type t = | Int63eq | Int63lt | Int63le + | Int63lts + | Int63les | Int63compare + | Int63compares | Float64opp | Float64abs | Float64eq @@ -68,8 +77,11 @@ let parse = function | "int63_mul" -> Int63mul | "int63_div" -> Int63div | "int63_mod" -> Int63mod + | "int63_divs" -> Int63divs + | "int63_mods" -> Int63mods | "int63_lsr" -> Int63lsr | "int63_lsl" -> Int63lsl + | "int63_asr" -> Int63asr | "int63_land" -> Int63land | "int63_lor" -> Int63lor | "int63_lxor" -> Int63lxor @@ -84,7 +96,10 @@ let parse = function | "int63_eq" -> Int63eq | "int63_lt" -> Int63lt | "int63_le" -> Int63le + | "int63_lts" -> Int63lts + | "int63_les" -> Int63les | "int63_compare" -> Int63compare + | "int63_compares" -> Int63compares | "float64_opp" -> Float64opp | "float64_abs" -> Float64abs | "float64_eq" -> Float64eq @@ -163,6 +178,12 @@ let hash = function | Arrayset -> 46 | Arraycopy -> 47 | Arraylength -> 48 + | Int63lts -> 49 + | Int63les -> 50 + | Int63divs -> 51 + | Int63mods -> 52 + | Int63asr -> 53 + | Int63compares -> 54 (* Should match names in nativevalues.ml *) let to_string = function @@ -173,8 +194,11 @@ let to_string = function | Int63mul -> "mul" | Int63div -> "div" | Int63mod -> "rem" + | Int63divs -> "divs" + | Int63mods -> "rems" | Int63lsr -> "l_sr" | Int63lsl -> "l_sl" + | Int63asr -> "a_sr" | Int63land -> "l_and" | Int63lor -> "l_or" | Int63lxor -> "l_xor" @@ -189,7 +213,10 @@ let to_string = function | Int63eq -> "eq" | Int63lt -> "lt" | Int63le -> "le" + | Int63lts -> "lts" + | Int63les -> "les" | Int63compare -> "compare" + | Int63compares -> "compares" | Float64opp -> "fopp" | Float64abs -> "fabs" | Float64eq -> "feq" @@ -271,14 +298,15 @@ let types = | Int63head0 | Int63tail0 -> [int_ty; int_ty] | Int63add | Int63sub | Int63mul | Int63div | Int63mod - | Int63lsr | Int63lsl + | Int63divs | Int63mods + | Int63lsr | Int63lsl | Int63asr | Int63land | Int63lor | Int63lxor -> [int_ty; int_ty; int_ty] | Int63addc | Int63subc | Int63addCarryC | Int63subCarryC -> [int_ty; int_ty; PITT_ind (PIT_carry, int_ty)] | Int63mulc | Int63diveucl -> [int_ty; int_ty; PITT_ind (PIT_pair, (int_ty, int_ty))] - | Int63eq | Int63lt | Int63le -> [int_ty; int_ty; PITT_ind (PIT_bool, ())] - | Int63compare -> [int_ty; int_ty; PITT_ind (PIT_cmp, ())] + | Int63eq | Int63lt | Int63le | Int63lts | Int63les -> [int_ty; int_ty; PITT_ind (PIT_bool, ())] + | Int63compare | Int63compares -> [int_ty; int_ty; PITT_ind (PIT_cmp, ())] | Int63div21 -> [int_ty; int_ty; int_ty; PITT_ind (PIT_pair, (int_ty, int_ty))] | Int63addMulDiv -> [int_ty; int_ty; int_ty; int_ty] @@ -314,8 +342,11 @@ let params = function | Int63mul | Int63div | Int63mod + | Int63divs + | Int63mods | Int63lsr | Int63lsl + | Int63asr | Int63land | Int63lor | Int63lxor @@ -330,7 +361,10 @@ let params = function | Int63eq | Int63lt | Int63le + | Int63lts + | Int63les | Int63compare + | Int63compares | Float64opp | Float64abs | Float64eq @@ -367,8 +401,11 @@ let univs = function | Int63mul | Int63div | Int63mod + | Int63divs + | Int63mods | Int63lsr | Int63lsl + | Int63asr | Int63land | Int63lor | Int63lxor @@ -383,7 +420,10 @@ let univs = function | Int63eq | Int63lt | Int63le + | Int63lts + | Int63les | Int63compare + | Int63compares | Float64opp | Float64abs | Float64eq diff --git a/kernel/cPrimitives.mli b/kernel/cPrimitives.mli index 0db643faf4..de90179726 100644 --- a/kernel/cPrimitives.mli +++ b/kernel/cPrimitives.mli @@ -16,8 +16,11 @@ type t = | Int63mul | Int63div | Int63mod + | Int63divs + | Int63mods | Int63lsr | Int63lsl + | Int63asr | Int63land | Int63lor | Int63lxor @@ -32,7 +35,10 @@ type t = | Int63eq | Int63lt | Int63le + | Int63lts + | Int63les | Int63compare + | Int63compares | Float64opp | Float64abs | Float64eq diff --git a/kernel/dune b/kernel/dune index bd663974da..0bf51f80ec 100644 --- a/kernel/dune +++ b/kernel/dune @@ -1,7 +1,7 @@ (library (name kernel) (synopsis "The Coq Kernel") - (public_name coq.kernel) + (public_name coq-core.kernel) (wrapped false) (modules (:standard \ genOpcodeFiles uint63_31 uint63_63 float64_31 float64_63)) (libraries lib byterun dynlink)) @@ -25,7 +25,7 @@ (action (copy# %{gen-file} %{targets}))) (documentation - (package coq)) + (package coq-core)) ; In dev profile, we check the kernel against a more strict set of ; warnings. diff --git a/kernel/genOpcodeFiles.ml b/kernel/genOpcodeFiles.ml index 0e1cd0c56a..20220dd9d2 100644 --- a/kernel/genOpcodeFiles.ml +++ b/kernel/genOpcodeFiles.ml @@ -10,192 +10,201 @@ (** List of opcodes. - It is used to generate the [coq_instruct.h], [coq_jumptbl.h] and - [vmopcodes.ml] files. + It is used to generate the files [coq_instruct.h], [coq_jumptbl.h], + [coq_arity.h], and [vmopcodes.ml]. - 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. + [STOP] needs to be the last opcode. + + Arity -1 designates opcodes that need special handling in [coq_fix_code.c]. *) let opcodes = [| - "ACC0"; - "ACC1"; - "ACC2"; - "ACC3"; - "ACC4"; - "ACC5"; - "ACC6"; - "ACC7"; - "ACC"; - "PUSH"; - "PUSHACC1"; - "PUSHACC2"; - "PUSHACC3"; - "PUSHACC4"; - "PUSHACC5"; - "PUSHACC6"; - "PUSHACC7"; - "PUSHACC"; - "POP"; - "ENVACC0"; - "ENVACC1"; - "ENVACC2"; - "ENVACC3"; - "ENVACC"; - "PUSHENVACC0"; - "PUSHENVACC1"; - "PUSHENVACC2"; - "PUSHENVACC3"; - "PUSHENVACC"; - "PUSH_RETADDR"; - "APPLY"; - "APPLY1"; - "APPLY2"; - "APPLY3"; - "APPLY4"; - "APPTERM"; - "APPTERM1"; - "APPTERM2"; - "APPTERM3"; - "RETURN"; - "RESTART"; - "GRAB"; - "GRABREC"; - "CLOSURE"; - "CLOSUREREC"; - "CLOSURECOFIX"; - "OFFSETCLOSURE0"; - "OFFSETCLOSURE1"; - "OFFSETCLOSURE"; - "PUSHOFFSETCLOSURE0"; - "PUSHOFFSETCLOSURE1"; - "PUSHOFFSETCLOSURE"; - "GETGLOBAL"; - "PUSHGETGLOBAL"; - "MAKEBLOCK"; - "MAKEBLOCK1"; - "MAKEBLOCK2"; - "MAKEBLOCK3"; - "MAKEBLOCK4"; - "SWITCH"; - "PUSHFIELDS"; - "GETFIELD0"; - "GETFIELD1"; - "GETFIELD"; - "SETFIELD"; - "PROJ"; - "ENSURESTACKCAPACITY"; - "CONST0"; - "CONST1"; - "CONST2"; - "CONST3"; - "CONSTINT"; - "PUSHCONST0"; - "PUSHCONST1"; - "PUSHCONST2"; - "PUSHCONST3"; - "PUSHCONSTINT"; - "ACCUMULATE"; - "MAKESWITCHBLOCK"; - "MAKEACCU"; - "BRANCH"; - "CHECKADDINT63"; - "CHECKADDCINT63"; - "CHECKADDCARRYCINT63"; - "CHECKSUBINT63"; - "CHECKSUBCINT63"; - "CHECKSUBCARRYCINT63"; - "CHECKMULINT63"; - "CHECKMULCINT63"; - "CHECKDIVINT63"; - "CHECKMODINT63"; - "CHECKDIVEUCLINT63"; - "CHECKDIV21INT63"; - "CHECKLXORINT63"; - "CHECKLORINT63"; - "CHECKLANDINT63"; - "CHECKLSLINT63"; - "CHECKLSRINT63"; - "CHECKADDMULDIVINT63"; - "CHECKEQINT63"; - "CHECKLTINT63"; - "CHECKLEINT63"; - "CHECKCOMPAREINT63"; - "CHECKHEAD0INT63"; - "CHECKTAIL0INT63"; - "CHECKOPPFLOAT"; - "CHECKABSFLOAT"; - "CHECKEQFLOAT"; - "CHECKLTFLOAT"; - "CHECKLEFLOAT"; - "CHECKCOMPAREFLOAT"; - "CHECKCLASSIFYFLOAT"; - "CHECKADDFLOAT"; - "CHECKSUBFLOAT"; - "CHECKMULFLOAT"; - "CHECKDIVFLOAT"; - "CHECKSQRTFLOAT"; - "CHECKFLOATOFINT63"; - "CHECKFLOATNORMFRMANTISSA"; - "CHECKFRSHIFTEXP"; - "CHECKLDSHIFTEXP"; - "CHECKNEXTUPFLOAT"; - "CHECKNEXTDOWNFLOAT"; - "CHECKNEXTUPFLOATINPLACE"; - "CHECKNEXTDOWNFLOATINPLACE"; - "CHECKCAMLCALL2_1"; - "CHECKCAMLCALL1"; - "CHECKCAMLCALL2"; - "CHECKCAMLCALL3_1"; - "STOP" + "ACC0", 0; + "ACC1", 0; + "ACC2", 0; + "ACC3", 0; + "ACC4", 0; + "ACC5", 0; + "ACC6", 0; + "ACC7", 0; + "ACC", 1; + "PUSH", 0; + "PUSHACC1", 0; + "PUSHACC2", 0; + "PUSHACC3", 0; + "PUSHACC4", 0; + "PUSHACC5", 0; + "PUSHACC6", 0; + "PUSHACC7", 0; + "PUSHACC", 1; + "POP", 1; + "ENVACC0", 0; + "ENVACC1", 0; + "ENVACC2", 0; + "ENVACC3", 0; + "ENVACC", 1; + "PUSHENVACC0", 0; + "PUSHENVACC1", 0; + "PUSHENVACC2", 0; + "PUSHENVACC3", 0; + "PUSHENVACC", 1; + "PUSH_RETADDR", 1; + "APPLY", 1; + "APPLY1", 0; + "APPLY2", 0; + "APPLY3", 0; + "APPLY4", 0; + "APPTERM", 2; + "APPTERM1", 1; + "APPTERM2", 1; + "APPTERM3", 1; + "RETURN", 1; + "RESTART", 0; + "GRAB", 1; + "GRABREC", 1; + "CLOSURE", 2; + "CLOSUREREC", -1; + "CLOSURECOFIX", -1; + "OFFSETCLOSURE0", 0; + "OFFSETCLOSURE1", 0; + "OFFSETCLOSURE", 1; + "PUSHOFFSETCLOSURE0", 0; + "PUSHOFFSETCLOSURE1", 0; + "PUSHOFFSETCLOSURE", 1; + "GETGLOBAL", 1; + "PUSHGETGLOBAL", 1; + "MAKEBLOCK", 2; + "MAKEBLOCK1", 1; + "MAKEBLOCK2", 1; + "MAKEBLOCK3", 1; + "MAKEBLOCK4", 1; + "SWITCH", -1; + "PUSHFIELDS", 1; + "GETFIELD0", 0; + "GETFIELD1", 0; + "GETFIELD", 1; + "SETFIELD", 1; + "PROJ", 2; + "ENSURESTACKCAPACITY", 1; + "CONST0", 0; + "CONST1", 0; + "CONST2", 0; + "CONST3", 0; + "CONSTINT", 1; + "PUSHCONST0", 0; + "PUSHCONST1", 0; + "PUSHCONST2", 0; + "PUSHCONST3", 0; + "PUSHCONSTINT", 1; + "ACCUMULATE", 0; + "MAKESWITCHBLOCK", 4; + "MAKEACCU", 1; + "BRANCH", 1; + "CHECKADDINT63", 1; + "CHECKADDCINT63", 1; + "CHECKADDCARRYCINT63", 1; + "CHECKSUBINT63", 1; + "CHECKSUBCINT63", 1; + "CHECKSUBCARRYCINT63", 1; + "CHECKMULINT63", 1; + "CHECKMULCINT63", 1; + "CHECKDIVINT63", 1; + "CHECKMODINT63", 1; + "CHECKDIVSINT63", 1; + "CHECKMODSINT63", 1; + "CHECKDIVEUCLINT63", 1; + "CHECKDIV21INT63", 1; + "CHECKLXORINT63", 1; + "CHECKLORINT63", 1; + "CHECKLANDINT63", 1; + "CHECKLSLINT63", 1; + "CHECKLSRINT63", 1; + "CHECKASRINT63", 1; + "CHECKADDMULDIVINT63", 1; + "CHECKEQINT63", 1; + "CHECKLTINT63", 1; + "CHECKLEINT63", 1; + "CHECKLTSINT63", 1; + "CHECKLESINT63", 1; + "CHECKCOMPAREINT63", 1; + "CHECKCOMPARESINT63", 1; + "CHECKHEAD0INT63", 1; + "CHECKTAIL0INT63", 1; + "CHECKOPPFLOAT", 1; + "CHECKABSFLOAT", 1; + "CHECKEQFLOAT", 1; + "CHECKLTFLOAT", 1; + "CHECKLEFLOAT", 1; + "CHECKCOMPAREFLOAT", 1; + "CHECKCLASSIFYFLOAT", 1; + "CHECKADDFLOAT", 1; + "CHECKSUBFLOAT", 1; + "CHECKMULFLOAT", 1; + "CHECKDIVFLOAT", 1; + "CHECKSQRTFLOAT", 1; + "CHECKFLOATOFINT63", 1; + "CHECKFLOATNORMFRMANTISSA", 1; + "CHECKFRSHIFTEXP", 1; + "CHECKLDSHIFTEXP", 1; + "CHECKNEXTUPFLOAT", 1; + "CHECKNEXTDOWNFLOAT", 1; + "CHECKNEXTUPFLOATINPLACE", 1; + "CHECKNEXTDOWNFLOATINPLACE", 1; + "CHECKCAMLCALL2_1", 2; + "CHECKCAMLCALL1", 2; + "CHECKCAMLCALL2", 2; + "CHECKCAMLCALL3_1", 2; + "STOP", 0 |] let pp_c_comment fmt = - Format.fprintf fmt "/* %a */" + Format.fprintf fmt "/* %s */" let pp_ocaml_comment fmt = - Format.fprintf fmt "(* %a *)" + Format.fprintf fmt "(* %s *)" let pp_header isOcaml fmt = Format.fprintf fmt "%a" - (fun fmt -> - (if isOcaml then pp_ocaml_comment else pp_c_comment) fmt - Format.pp_print_string) + (if isOcaml then pp_ocaml_comment else pp_c_comment) "DO NOT EDIT: automatically generated by kernel/genOpcodeFiles.ml" -let pp_with_commas fmt k = - Array.iteri (fun n s -> - Format.fprintf fmt " %a%s@." - k s - (if n + 1 < Array.length opcodes - then "," else "") - ) opcodes - let pp_coq_instruct_h fmt = - let line = Format.fprintf fmt "%s@." in pp_header false fmt; - line "#pragma once"; - line "enum instructions {"; - pp_with_commas fmt Format.pp_print_string; - line "};" + Format.fprintf fmt "#pragma once@.enum instructions {@."; + Array.iter (fun (name, _) -> + Format.fprintf fmt " %s,@." name + ) opcodes; + Format.fprintf fmt "};@." let pp_coq_jumptbl_h fmt = - pp_with_commas fmt (fun fmt -> Format.fprintf fmt "&&coq_lbl_%s") + pp_header false fmt; + Array.iter (fun (name, _) -> + Format.fprintf fmt " &&coq_lbl_%s,@." name + ) opcodes + +let pp_coq_arity_h fmt = + pp_header false fmt; + Format.fprintf fmt "static signed char arity[] = {@."; + Array.iter (fun (_, arity) -> + Format.fprintf fmt " %d,@." arity + ) opcodes; + Format.fprintf fmt "};@." let pp_vmopcodes_ml fmt = pp_header true fmt; Array.iteri (fun n s -> Format.fprintf fmt "let op%s = %d@.@." s n - ) opcodes + ) (Array.map fst opcodes) let usage () = - Format.eprintf "usage: %s [enum|jump|copml]@." Sys.argv.(0); + Format.eprintf "usage: %s [enum|jump|arity|copml]@." Sys.argv.(0); exit 1 let main () = match Sys.argv.(1) with | "enum" -> pp_coq_instruct_h Format.std_formatter | "jump" -> pp_coq_jumptbl_h Format.std_formatter + | "arity" -> pp_coq_arity_h Format.std_formatter | "copml" -> pp_vmopcodes_ml Format.std_formatter | _ -> usage () | exception Invalid_argument _ -> usage () diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index c19b883e3d..9ce388929c 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -24,6 +24,11 @@ open Environ compiler. mllambda represents a fragment of ML, and can easily be printed to OCaml code. *) +let debug_native_flag, debug_native_compiler = CDebug.create_full ~name:"native-compiler" () + +let keep_debug_files () = + CDebug.get_flag debug_native_flag + (** Local names **) (* The first component is there for debugging purposes only *) @@ -1939,7 +1944,7 @@ let compile_constant env sigma con cb = | Def t -> let t = Mod_subst.force_constr t in let code = lambda_of_constr env sigma t in - if !Flags.debug then Feedback.msg_debug (Pp.str "Generated lambda code"); + debug_native_compiler (fun () -> Pp.str "Generated lambda code"); let is_lazy = is_lazy t in let code = if is_lazy then mk_lazy code else code in let l = Constant.label con in @@ -1950,11 +1955,11 @@ let compile_constant env sigma con cb = let (auxdefs,code) = compile_with_fv env sigma (Some univ) [] (Some l) code in (auxdefs,mkMLlam [|univ|] code) in - if !Flags.debug then Feedback.msg_debug (Pp.str "Generated mllambda code"); + debug_native_compiler (fun () -> Pp.str "Generated mllambda code"); let code = optimize_stk (Glet(Gconstant ("", con),code)::auxdefs) in - if !Flags.debug then Feedback.msg_debug (Pp.str "Optimized mllambda code"); + debug_native_compiler (fun () -> Pp.str "Optimized mllambda code"); code | _ -> let i = push_symbol (SymbConst con) in @@ -2125,7 +2130,7 @@ let compile_deps env sigma prefix init t = in aux env 0 init t -let compile_constant_field env _prefix con acc cb = +let compile_constant_field env con acc cb = let gl = compile_constant env empty_evars con cb in gl@acc diff --git a/kernel/nativecode.mli b/kernel/nativecode.mli index aab6e1d4a0..17312ec8ea 100644 --- a/kernel/nativecode.mli +++ b/kernel/nativecode.mli @@ -21,6 +21,10 @@ to OCaml code. *) type mllambda type global +val debug_native_compiler : CDebug.t + +val keep_debug_files : unit -> bool + val pp_global : Format.formatter -> global -> unit val mk_open : string -> global @@ -59,7 +63,9 @@ val empty_updates : code_location_updates val register_native_file : string -> unit -val compile_constant_field : env -> string -> Constant.t -> +val is_loaded_native_file : string -> bool + +val compile_constant_field : env -> Constant.t -> global list -> 'a constant_body -> global list val compile_mind_field : ModPath.t -> Label.t -> diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index d77ee759c6..f0ae5e2fbf 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -9,7 +9,6 @@ (************************************************************************) open Names -open Nativelib open Reduction open Util open Nativevalues @@ -151,22 +150,25 @@ let warn_no_native_compiler = strbrk " falling back to VM conversion test.") let native_conv_gen pb sigma env univs t1 t2 = - if not (typing_flags env).Declarations.enable_native_compiler then begin - warn_no_native_compiler (); - Vconv.vm_conv_gen pb env univs t1 t2 - end - else - let ml_filename, prefix = get_ml_filename () in + Nativelib.link_libraries (); + let ml_filename, prefix = Nativelib.get_ml_filename () in let code, upds = mk_conv_code env sigma prefix t1 t2 in - let fn = compile ml_filename code ~profile:false in - if !Flags.debug then Feedback.msg_debug (Pp.str "Running test..."); + let fn = Nativelib.compile ml_filename code ~profile:false in + debug_native_compiler (fun () -> Pp.str "Running test..."); let t0 = Sys.time () in - call_linker ~fatal:true ~prefix fn (Some upds); + let (rt1, rt2) = Nativelib.execute_library ~prefix fn upds in let t1 = Sys.time () in let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in - if !Flags.debug then Feedback.msg_debug (Pp.str time_info); + debug_native_compiler (fun () -> Pp.str time_info); (* TODO change 0 when we can have de Bruijn *) - fst (conv_val env pb 0 !rt1 !rt2 univs) + fst (conv_val env pb 0 rt1 rt2 univs) + +let native_conv_gen pb sigma env univs t1 t2 = + if not (typing_flags env).Declarations.enable_native_compiler then begin + warn_no_native_compiler (); + Vconv.vm_conv_gen pb env univs t1 t2 + end + else native_conv_gen pb sigma env univs t1 t2 (* Wrapper for [native_conv] above *) let native_conv cv_pb sigma env t1 t2 = diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml index 1e1085d5ff..73567e34cf 100644 --- a/kernel/nativelib.ml +++ b/kernel/nativelib.ml @@ -38,7 +38,7 @@ let ( / ) = Filename.concat let my_temp_dir = lazy (CUnix.mktemp_dir "Coq_native" "") let () = at_exit (fun () -> - if not !Flags.debug && Lazy.is_val my_temp_dir then + if not (keep_debug_files ()) && Lazy.is_val my_temp_dir then try let d = Lazy.force my_temp_dir in Array.iter (fun f -> Sys.remove (Filename.concat d f)) (Sys.readdir d); @@ -129,7 +129,7 @@ let call_compiler ?profile:(profile=false) ml_filename = ::"-w"::"a" ::include_dirs) @ ["-impl"; ml_filename] in - if !Flags.debug then Feedback.msg_debug (Pp.str (Envars.ocamlfind () ^ " " ^ (String.concat " " args))); + debug_native_compiler (fun () -> Pp.str (Envars.ocamlfind () ^ " " ^ (String.concat " " args))); try let res = CUnix.sys_command (Envars.ocamlfind ()) args in match res with @@ -142,7 +142,7 @@ let call_compiler ?profile:(profile=false) ml_filename = let compile fn code ~profile:profile = write_ml_code fn code; let r = call_compiler ~profile fn in - if (not !Flags.debug) && Sys.file_exists fn then Sys.remove fn; + if (not (keep_debug_files ())) && Sys.file_exists fn then Sys.remove fn; r type native_library = Nativecode.global list * Nativevalues.symbols @@ -160,34 +160,43 @@ let compile_library (code, symb) fn = let fn = dirname / basename in write_ml_code fn ~header code; let _ = call_compiler fn in - if (not !Flags.debug) && Sys.file_exists fn then Sys.remove fn + if (not (keep_debug_files ())) && Sys.file_exists fn then Sys.remove fn -(* call_linker links dynamically the code for constants in environment or a *) -(* conversion test. *) -let call_linker ?(fatal=true) ~prefix f upds = +let execute_library ~prefix f upds = rt1 := dummy_value (); rt2 := dummy_value (); if not (Sys.file_exists f) then - begin - let msg = "Cannot find native compiler file " ^ f in - if fatal then CErrors.user_err Pp.(str msg) - else if !Flags.debug then Feedback.msg_debug (Pp.str msg) - end - else - (try - if Dynlink.is_native then Dynlink.loadfile f else !load_obj f; - register_native_file prefix - with Dynlink.Error _ as exn -> - let exn = Exninfo.capture exn in - if fatal then Exninfo.iraise exn - else if !Flags.debug then Feedback.msg_debug CErrors.(iprint exn)); - match upds with Some upds -> update_locations upds | _ -> () - -let link_library ~prefix ~dirname ~basename = + CErrors.user_err Pp.(str "Cannot find native compiler file " ++ str f); + if Dynlink.is_native then Dynlink.loadfile f else !load_obj f; + register_native_file prefix; + update_locations upds; + (!rt1, !rt2) + +let link_library dirname prefix = + let basename = Dynlink.adapt_filename (prefix ^ "cmo") in (* We try both [output_dir] and [.coq-native], unfortunately from [Require] we don't know if we are loading a library in the build dir or in the installed layout *) let install_location = dirname / dft_output_dir / basename in let build_location = dirname / !output_dir / basename in let f = if Sys.file_exists build_location then build_location else install_location in - call_linker ~fatal:false ~prefix f None + try + if Dynlink.is_native then Dynlink.loadfile f else !load_obj f; + register_native_file prefix + with + | Dynlink.Error _ as exn -> + debug_native_compiler (fun () -> CErrors.iprint (Exninfo.capture exn)) + +let delayed_link = ref [] + +let link_libraries () = + let delayed = List.rev !delayed_link in + delayed_link := []; + List.iter (fun (dirname, libname) -> + let prefix = mod_uid_of_dirpath libname ^ "." in + if not (Nativecode.is_loaded_native_file prefix) then + link_library dirname prefix + ) delayed + +let enable_library dirname libname = + delayed_link := (dirname, libname) :: !delayed_link diff --git a/kernel/nativelib.mli b/kernel/nativelib.mli index 0c0fe3acc9..ba04c28ab0 100644 --- a/kernel/nativelib.mli +++ b/kernel/nativelib.mli @@ -7,7 +7,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (* * (see LICENSE file for the text of the license) *) (************************************************************************) -open Nativecode (** This file provides facilities to access OCaml compiler and dynamic linker, used by the native compiler. *) @@ -25,7 +24,7 @@ val get_ml_filename : unit -> string * string (** [compile file code ~profile] will compile native [code] to [file], and return the name of the object file; this name depends on whether are in byte mode or not; file is expected to be .ml file *) -val compile : string -> global list -> profile:bool -> string +val compile : string -> Nativecode.global list -> profile:bool -> string type native_library = Nativecode.global list * Nativevalues.symbols @@ -33,18 +32,19 @@ type native_library = Nativecode.global list * Nativevalues.symbols but will perform some extra tweaks to handle [code] as a Coq lib. *) val compile_library : native_library -> string -> unit -val call_linker - : ?fatal:bool - -> prefix:string - -> string - -> code_location_updates option - -> unit +(** [execute_library file upds] dynamically loads library [file], + updates the library locations [upds], and returns the values stored + in [rt1] and [rt2] *) +val execute_library : + prefix:string -> string -> Nativecode.code_location_updates -> + Nativevalues.t * Nativevalues.t -val link_library - : prefix:string - -> dirname:string - -> basename:string - -> unit +(** [enable_library] marks the given library for dynamic loading + the next time [link_libraries] is called. *) +val enable_library : string -> Names.DirPath.t -> unit +val link_libraries : unit -> unit + +(* used for communication with the loaded libraries *) val rt1 : Nativevalues.t ref val rt2 : Nativevalues.t ref diff --git a/kernel/nativelibrary.ml b/kernel/nativelibrary.ml index c95880dc36..6dd7f315e0 100644 --- a/kernel/nativelibrary.ml +++ b/kernel/nativelibrary.ml @@ -17,55 +17,54 @@ open Nativecode (** This file implements separate compilation for libraries in the native compiler *) -let rec translate_mod prefix mp env mod_expr acc = +let rec translate_mod mp env mod_expr acc = match mod_expr with | NoFunctor struc -> let env' = add_structure mp struc empty_delta_resolver env in - List.fold_left (translate_field prefix mp env') acc struc + List.fold_left (translate_field mp env') acc struc | MoreFunctor _ -> acc -and translate_field prefix mp env acc (l,x) = +and translate_field mp env acc (l,x) = match x with | SFBconst cb -> let con = Constant.make2 mp l in - (if !Flags.debug then + (debug_native_compiler (fun () -> let msg = Printf.sprintf "Compiling constant %s..." (Constant.to_string con) in - Feedback.msg_debug (Pp.str msg)); - compile_constant_field env prefix con acc cb + Pp.str msg)); + compile_constant_field env con acc cb | SFBmind mb -> - (if !Flags.debug then + (debug_native_compiler (fun () -> let id = mb.mind_packets.(0).mind_typename in let msg = Printf.sprintf "Compiling inductive %s..." (Id.to_string id) in - Feedback.msg_debug (Pp.str msg)); + Pp.str msg)); compile_mind_field mp l acc mb | SFBmodule md -> let mp = md.mod_mp in - (if !Flags.debug then + (debug_native_compiler (fun () -> let msg = Printf.sprintf "Compiling module %s..." (ModPath.to_string mp) in - Feedback.msg_debug (Pp.str msg)); - translate_mod prefix mp env md.mod_type acc + Pp.str msg)); + translate_mod mp env md.mod_type acc | SFBmodtype mdtyp -> let mp = mdtyp.mod_mp in - (if !Flags.debug then + (debug_native_compiler (fun () -> let msg = Printf.sprintf "Compiling module type %s..." (ModPath.to_string mp) in - Feedback.msg_debug (Pp.str msg)); - translate_mod prefix mp env mdtyp.mod_type acc + Pp.str msg)); + translate_mod mp env mdtyp.mod_type acc -let dump_library mp dp env mod_expr = - if !Flags.debug then Feedback.msg_debug (Pp.str "Compiling library..."); +let dump_library mp env mod_expr = + debug_native_compiler (fun () -> Pp.str "Compiling library..."); match mod_expr with | NoFunctor struc -> let env = add_structure mp struc empty_delta_resolver env in - let prefix = mod_uid_of_dirpath dp ^ "." in let t0 = Sys.time () in clear_global_tbl (); clear_symbols (); let mlcode = - List.fold_left (translate_field prefix mp env) [] struc + List.fold_left (translate_field mp env) [] struc in let t1 = Sys.time () in let time_info = Format.sprintf "Time spent generating this code: %.5fs" (t1-.t0) in diff --git a/kernel/nativelibrary.mli b/kernel/nativelibrary.mli index 8f58dfa8d3..1d0d56703d 100644 --- a/kernel/nativelibrary.mli +++ b/kernel/nativelibrary.mli @@ -15,5 +15,5 @@ open Nativecode (** This file implements separate compilation for libraries in the native compiler *) -val dump_library : ModPath.t -> DirPath.t -> env -> module_signature -> +val dump_library : ModPath.t -> env -> module_signature -> global list * Nativevalues.symbols diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index bd6241ae67..c986cb473d 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -333,6 +333,22 @@ let rem accu x y = if is_int x && is_int y then no_check_rem x y else accu x y +let no_check_divs x y = + mk_uint (Uint63.divs (to_uint x) (to_uint y)) +[@@ocaml.inline always] + +let divs accu x y = + if is_int x && is_int y then no_check_divs x y + else accu x y + +let no_check_rems x y = + mk_uint (Uint63.rems (to_uint x) (to_uint y)) +[@@ocaml.inline always] + +let rems accu x y = + if is_int x && is_int y then no_check_rems x y + else accu x y + let no_check_l_sr x y = mk_uint (Uint63.l_sr (to_uint x) (to_uint y)) [@@ocaml.inline always] @@ -349,6 +365,14 @@ let l_sl accu x y = if is_int x && is_int y then no_check_l_sl x y else accu x y +let no_check_a_sr x y = + mk_uint (Uint63.a_sr (to_uint x) (to_uint y)) +[@@ocaml.inline always] + +let a_sr accu x y = + if is_int x && is_int y then no_check_a_sr x y + else accu x y + let no_check_l_and x y = mk_uint (Uint63.l_and (to_uint x) (to_uint y)) [@@ocaml.inline always] @@ -502,6 +526,22 @@ let le accu x y = if is_int x && is_int y then no_check_le x y else accu x y +let no_check_lts x y = + mk_bool (Uint63.lts (to_uint x) (to_uint y)) +[@@ocaml.inline always] + +let lts accu x y = + if is_int x && is_int y then no_check_lts x y + else accu x y + +let no_check_les x y = + mk_bool (Uint63.les (to_uint x) (to_uint y)) +[@@ocaml.inline always] + +let les accu x y = + if is_int x && is_int y then no_check_les x y + else accu x y + let no_check_compare x y = match Uint63.compare (to_uint x) (to_uint y) with | x when x < 0 -> (Obj.magic CmpLt:t) @@ -512,6 +552,16 @@ let compare accu x y = if is_int x && is_int y then no_check_compare x y else accu x y +let no_check_compares x y = + match Uint63.compares (to_uint x) (to_uint y) with + | x when x < 0 -> (Obj.magic CmpLt:t) + | 0 -> (Obj.magic CmpEq:t) + | _ -> (Obj.magic CmpGt:t) + +let compares accu x y = + if is_int x && is_int y then no_check_compares x y + else accu x y + let print x = Printf.fprintf stderr "%s" (Uint63.to_string (to_uint x)); flush stderr; diff --git a/kernel/nativevalues.mli b/kernel/nativevalues.mli index b9b75a9d7c..98cf4219a0 100644 --- a/kernel/nativevalues.mli +++ b/kernel/nativevalues.mli @@ -158,9 +158,12 @@ val sub : t -> t -> t -> t val mul : t -> t -> t -> t val div : t -> t -> t -> t val rem : t -> t -> t -> t +val divs : t -> t -> t -> t +val rems : t -> t -> t -> t val l_sr : t -> t -> t -> t val l_sl : t -> t -> t -> t +val a_sr : t -> t -> t -> t val l_and : t -> t -> t -> t val l_xor : t -> t -> t -> t val l_or : t -> t -> t -> t @@ -179,7 +182,10 @@ val addMulDiv : t -> t -> t -> t -> t val eq : t -> t -> t -> t val lt : t -> t -> t -> t val le : t -> t -> t -> t +val lts : t -> t -> t -> t +val les : t -> t -> t -> t val compare : t -> t -> t -> t +val compares : t -> t -> t -> t val print : t -> t @@ -205,12 +211,21 @@ val no_check_div : t -> t -> t val no_check_rem : t -> t -> t [@@ocaml.inline always] +val no_check_divs : t -> t -> t +[@@ocaml.inline always] + +val no_check_rems : t -> t -> t +[@@ocaml.inline always] + val no_check_l_sr : t -> t -> t [@@ocaml.inline always] val no_check_l_sl : t -> t -> t [@@ocaml.inline always] +val no_check_a_sr : t -> t -> t +[@@ocaml.inline always] + val no_check_l_and : t -> t -> t [@@ocaml.inline always] @@ -253,8 +268,16 @@ val no_check_lt : t -> t -> t val no_check_le : t -> t -> t [@@ocaml.inline always] +val no_check_lts : t -> t -> t +[@@ocaml.inline always] + +val no_check_les : t -> t -> t +[@@ocaml.inline always] + val no_check_compare : t -> t -> t +val no_check_compares : t -> t -> t + (** Support for machine floating point values *) val is_float : t -> bool diff --git a/kernel/primred.ml b/kernel/primred.ml index f0b4d6d362..23b7e13ab8 100644 --- a/kernel/primred.ml +++ b/kernel/primred.ml @@ -223,10 +223,16 @@ struct let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.div i1 i2) | Int63mod -> let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.rem i1 i2) + | Int63divs -> + let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.divs i1 i2) + | Int63mods -> + let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.rems i1 i2) | Int63lsr -> let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.l_sr i1 i2) | Int63lsl -> let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.l_sl i1 i2) + | Int63asr -> + let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.a_sr i1 i2) | Int63land -> let i1, i2 = get_int2 evd args in E.mkInt env (Uint63.l_and i1 i2) | Int63lor -> @@ -276,6 +282,12 @@ struct | Int63le -> let i1, i2 = get_int2 evd args in E.mkBool env (Uint63.le i1 i2) + | Int63lts -> + let i1, i2 = get_int2 evd args in + E.mkBool env (Uint63.lts i1 i2) + | Int63les -> + let i1, i2 = get_int2 evd args in + E.mkBool env (Uint63.les i1 i2) | Int63compare -> let i1, i2 = get_int2 evd args in begin match Uint63.compare i1 i2 with @@ -283,6 +295,13 @@ struct | 0 -> E.mkEq env | _ -> E.mkGt env end + | Int63compares -> + let i1, i2 = get_int2 evd args in + begin match Uint63.compares i1 i2 with + | x when x < 0 -> E.mkLt env + | 0 -> E.mkEq env + | _ -> E.mkGt env + end | Float64opp -> let f = get_float1 evd args in E.mkFloat env (Float64.opp f) | Float64abs -> diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index a35f94e3ce..5f83e78eb0 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -1273,7 +1273,7 @@ let export ?except ~output_native_objects senv dir = in let ast, symbols = if output_native_objects then - Nativelibrary.dump_library mp dir senv.env str + Nativelibrary.dump_library mp senv.env str else [], Nativevalues.empty_symbols in let lib = { diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 24aa4ed771..013892ad74 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -269,16 +269,14 @@ let build_constant_declaration env result = in Environ.really_needed env (Id.Set.union ids_typ ids_def), def | Some declared -> - let needed = Environ.really_needed env declared in - (* Transitive closure ensured by the upper layers *) - let () = assert (Id.Set.equal needed declared) in - (* We use the declared set and chain a check of correctness *) - declared, - match def with - | Undef _ | Primitive _ | OpaqueDef _ as x -> x (* nothing to check *) - | Def cs as x -> - let () = check_section_variables env declared typ (Mod_subst.force_constr cs) in - x + let declared = Environ.really_needed env declared in + (* We use the declared set and chain a check of correctness *) + declared, + match def with + | Undef _ | Primitive _ | OpaqueDef _ as x -> x (* nothing to check *) + | Def cs as x -> + let () = check_section_variables env declared typ (Mod_subst.force_constr cs) in + x in 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 diff --git a/kernel/uint63.mli b/kernel/uint63.mli index 6b2519918a..ff8d1eefb7 100644 --- a/kernel/uint63.mli +++ b/kernel/uint63.mli @@ -48,6 +48,7 @@ val l_xor : t -> t -> t val l_or : t -> t -> t (* Arithmetic operations *) +val a_sr : t -> t -> t val add : t -> t -> t val sub : t -> t -> t val mul : t -> t -> t @@ -56,6 +57,10 @@ val rem : t -> t -> t val diveucl : t -> t -> t * t + (* Signed arithmetic opeartions *) +val divs : t -> t -> t +val rems : t -> t -> t + (* Specific arithmetic operations *) val mulc : t -> t -> t * t val addmuldiv : t -> t -> t -> t @@ -71,6 +76,11 @@ val equal : t -> t -> bool val le : t -> t -> bool val compare : t -> t -> int + (* signed comparision *) +val lts : t -> t -> bool +val les : t -> t -> bool +val compares : t -> t -> int + (* head and tail *) val head0 : t -> t val tail0 : t -> t diff --git a/kernel/uint63_31.ml b/kernel/uint63_31.ml index 4f2cbc4262..9c8401105e 100644 --- a/kernel/uint63_31.ml +++ b/kernel/uint63_31.ml @@ -52,6 +52,15 @@ let lt x y = let le x y = Int64.compare x y <= 0 + (* signed comparison *) +(* We shift the arguments by 1 to the left so that the top-most bit is interpreted as a sign *) +(* The zero at the end doesn't change the order (it is stable by multiplication by 2) *) +let lts x y = + Int64.(compare (shift_left x 1) (shift_left y 1)) < 0 + +let les x y = + Int64.(compare (shift_left x 1) (shift_left y 1)) <= 0 + (* logical shift *) let l_sl x y = if le 0L y && lt y 63L then mask63 (Int64.shift_left x (Int64.to_int y)) else 0L @@ -59,6 +68,12 @@ let l_sl x y = let l_sr x y = if le 0L y && lt y 63L then Int64.shift_right x (Int64.to_int y) else 0L + (* arithmetic shift (for sint63) *) +let a_sr x y = + if les 0L y && lts y 63L then + mask63 (Int64.shift_right (Int64.shift_left x 1) ((Int64.to_int y) + 1)) + else 0L + let l_and x y = Int64.logand x y let l_or x y = Int64.logor x y let l_xor x y = Int64.logxor x y @@ -86,6 +101,15 @@ let rem x y = let diveucl x y = (div x y, rem x y) + (* signed division *) +let divs x y = + if y = 0L then 0L else mask63 Int64.(div (shift_left x 1) (shift_left y 1)) + + (* signed modulo *) +let rems x y = + if y = 0L then 0L else + Int64.shift_right_logical (Int64.(rem (shift_left x 1) (shift_left y 1))) 1 + let addmuldiv p x y = l_or (l_sl x p) (l_sr y Int64.(sub (of_int uint_size) p)) @@ -139,6 +163,8 @@ let equal (x : t) y = x = y let compare x y = Int64.compare x y +let compares x y = Int64.(compare (shift_left x 1) (shift_left y 1)) + (* Number of leading zeroes *) let head0 x = let r = ref 0 in @@ -198,22 +224,30 @@ let () = Callback.register "uint63 addcarry" addcarry; Callback.register "uint63 addmuldiv" addmuldiv; Callback.register "uint63 div" div; + Callback.register "uint63 divs" divs; Callback.register "uint63 div21_ml" div21; Callback.register "uint63 eq" equal; Callback.register "uint63 eq0" (equal Int64.zero); + Callback.register "uint63 eqm1" (equal (sub zero one)); Callback.register "uint63 head0" head0; Callback.register "uint63 land" l_and; Callback.register "uint63 leq" le; + Callback.register "uint63 les" les; Callback.register "uint63 lor" l_or; Callback.register "uint63 lsl" l_sl; Callback.register "uint63 lsr" l_sr; + Callback.register "uint63 asr" a_sr; Callback.register "uint63 lt" lt; + Callback.register "uint63 lts" lts; Callback.register "uint63 lxor" l_xor; Callback.register "uint63 mod" rem; + Callback.register "uint63 mods" rems; Callback.register "uint63 mul" mul; Callback.register "uint63 mulc_ml" mulc; + Callback.register "uint63 zero" zero; Callback.register "uint63 one" one; Callback.register "uint63 sub" sub; + Callback.register "uint63 neg" (sub zero); Callback.register "uint63 subcarry" subcarry; Callback.register "uint63 tail0" tail0; Callback.register "uint63 of_float" of_float; diff --git a/kernel/uint63_63.ml b/kernel/uint63_63.ml index 8d052d6593..d017dafd3c 100644 --- a/kernel/uint63_63.ml +++ b/kernel/uint63_63.ml @@ -53,6 +53,10 @@ let l_sl x y = let l_sr x y = if 0 <= y && y < 63 then x lsr y else 0 + (* arithmetic shift (for sint63) *) +let a_sr x y = + if 0 <= y && y < 63 then x asr y else 0 + let l_and x y = x land y [@@ocaml.inline always] @@ -84,6 +88,14 @@ let rem (x : int) (y : int) = let diveucl x y = (div x y, rem x y) + (* signed division *) +let divs (x : int) (y : int) = + if y = 0 then 0 else x / y + + (* modulo *) +let rems (x : int) (y : int) = + if y = 0 then 0 else x mod y + let addmuldiv p x y = l_or (l_sl x p) (l_sr y (uint_size - p)) @@ -96,6 +108,15 @@ let le (x : int) (y : int) = (x lxor 0x4000000000000000) <= (y lxor 0x4000000000000000) [@@ocaml.inline always] + (* signed comparison *) +let lts (x : int) (y : int) = + x < y +[@@ocaml.inline always] + +let les (x : int) (y : int) = + x <= y +[@@ocaml.inline always] + let to_int_min n m = if lt n m then n else m [@@ocaml.inline always] @@ -175,9 +196,10 @@ let equal (x : int) (y : int) = x = y let compare (x:int) (y:int) = let x = x lxor 0x4000000000000000 in let y = y lxor 0x4000000000000000 in - if x > y then 1 - else if y > x then -1 - else 0 + Int.compare x y + +let compares (x : int) (y : int) = + Int.compare x y (* head tail *) diff --git a/kernel/vconv.ml b/kernel/vconv.ml index 1432fb9310..d31d7a03b6 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -196,8 +196,9 @@ let vm_conv_gen cv_pb env univs t1 t2 = TransparentState.full env univs t1 t2 else try - let v1 = val_of_constr env t1 in - let v2 = val_of_constr env t2 in + let sigma _ = assert false in + let v1 = val_of_constr env sigma t1 in + let v2 = val_of_constr env sigma t2 in fst (conv_val env cv_pb (nb_rel env) v1 v2 univs) with Not_found | Invalid_argument _ -> warn_bytecode_compiler_failed (); diff --git a/kernel/vmbytegen.ml b/kernel/vmbytegen.ml index 20de4bc81b..7d3b3469b0 100644 --- a/kernel/vmbytegen.ml +++ b/kernel/vmbytegen.ml @@ -840,21 +840,21 @@ let dump_bytecodes init code fvs = prlist_with_sep (fun () -> str "; ") pp_fv_elem fvs ++ fnl ()) -let compile ~fail_on_error ?universes:(universes=0) env c = +let compile ~fail_on_error ?universes:(universes=0) env sigma c = init_fun_code (); Label.reset_label_counter (); let cont = [Kstop] in try let cenv, init_code = if Int.equal universes 0 then - let lam = lambda_of_constr ~optimize:true env c in + let lam = lambda_of_constr ~optimize:true env sigma c in let cenv = empty_comp_env () in cenv, ensure_stack_capacity (compile_lam env cenv lam 0) cont else (* We are going to generate a lambda, but merge the universe closure * with the function closure if it exists. *) - let lam = lambda_of_constr ~optimize:true env c in + let lam = lambda_of_constr ~optimize:true env sigma c in let params, body = decompose_Llam lam in let arity = Array.length params in let cenv = empty_comp_env () in @@ -896,7 +896,8 @@ let compile_constant_body ~fail_on_error env univs = function let con= Constant.make1 (Constant.canonical kn') in Some (BCalias (get_alias env con)) | _ -> - let res = compile ~fail_on_error ~universes:instance_size env body in + let sigma _ = assert false in + let res = compile ~fail_on_error ~universes:instance_size env sigma body in Option.map (fun x -> BCdefined (to_memory x)) res (* Shortcut of the previous function used during module strengthening *) diff --git a/kernel/vmbytegen.mli b/kernel/vmbytegen.mli index aef7ac3d6b..c724cad5ec 100644 --- a/kernel/vmbytegen.mli +++ b/kernel/vmbytegen.mli @@ -15,8 +15,10 @@ open Declarations open Environ (** Should only be used for monomorphic terms *) -val compile : fail_on_error:bool -> - ?universes:int -> env -> constr -> (bytecodes * bytecodes * fv) option +val compile : + fail_on_error:bool -> ?universes:int -> + env -> (existential -> constr option) -> constr -> + (bytecodes * bytecodes * fv) option (** init, fun, fv *) val compile_constant_body : fail_on_error:bool -> diff --git a/kernel/vmemitcodes.ml b/kernel/vmemitcodes.ml index d3af8bf09b..caa263432e 100644 --- a/kernel/vmemitcodes.ml +++ b/kernel/vmemitcodes.ml @@ -226,8 +226,11 @@ let check_prim_op = function | Int63mul -> opCHECKMULINT63 | Int63div -> opCHECKDIVINT63 | Int63mod -> opCHECKMODINT63 + | Int63divs -> opCHECKDIVSINT63 + | Int63mods -> opCHECKMODSINT63 | Int63lsr -> opCHECKLSRINT63 | Int63lsl -> opCHECKLSLINT63 + | Int63asr -> opCHECKASRINT63 | Int63land -> opCHECKLANDINT63 | Int63lor -> opCHECKLORINT63 | Int63lxor -> opCHECKLXORINT63 @@ -242,7 +245,10 @@ let check_prim_op = function | Int63eq -> opCHECKEQINT63 | Int63lt -> opCHECKLTINT63 | Int63le -> opCHECKLEINT63 + | Int63lts -> opCHECKLTSINT63 + | Int63les -> opCHECKLESINT63 | Int63compare -> opCHECKCOMPAREINT63 + | Int63compares -> opCHECKCOMPARESINT63 | Float64opp -> opCHECKOPPFLOAT | Float64abs -> opCHECKABSFLOAT | Float64eq -> opCHECKEQFLOAT diff --git a/kernel/vmlambda.ml b/kernel/vmlambda.ml index 91de58b0e6..e353348ac7 100644 --- a/kernel/vmlambda.ml +++ b/kernel/vmlambda.ml @@ -591,12 +591,14 @@ struct type t = { global_env : env; + evar_body : existential -> constr option; name_rel : Name.t Vect.t; construct_tbl : (constructor, constructor_info) Hashtbl.t; } - let make env = { + let make env sigma = { global_env = env; + evar_body = sigma; name_rel = Vect.make 16 Anonymous; construct_tbl = Hashtbl.create 111 } @@ -633,9 +635,13 @@ open Renv let rec lambda_of_constr env c = match Constr.kind c with | 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) + | Evar (evk, args as ev) -> + begin match env.evar_body ev with + | None -> + let args = Array.map_of_list (fun c -> lambda_of_constr env c) args in + Levar (evk, args) + | Some t -> lambda_of_constr env t + end | Cast (c, _, _) -> lambda_of_constr env c @@ -774,8 +780,8 @@ let optimize_lambda lam = let lam = simplify subst_id lam in remove_let subst_id lam -let lambda_of_constr ~optimize genv c = - let env = Renv.make genv in +let lambda_of_constr ~optimize genv sigma c = + let env = Renv.make genv sigma in let ids = List.rev_map Context.Rel.Declaration.get_annot (rel_context genv) in Renv.push_rels env (Array.of_list ids); let lam = lambda_of_constr env c in diff --git a/kernel/vmlambda.mli b/kernel/vmlambda.mli index ad5f81638f..03d3393219 100644 --- a/kernel/vmlambda.mli +++ b/kernel/vmlambda.mli @@ -33,7 +33,7 @@ and fix_decl = Name.t Context.binder_annot array * lambda array * lambda array exception TooLargeInductive of Pp.t -val lambda_of_constr : optimize:bool -> env -> Constr.t -> lambda +val lambda_of_constr : optimize:bool -> env -> (existential -> constr option) -> Constr.t -> lambda val decompose_Llam : lambda -> Name.t Context.binder_annot array * lambda diff --git a/kernel/vmsymtable.ml b/kernel/vmsymtable.ml index ae0fa38571..90ee1c5378 100644 --- a/kernel/vmsymtable.ml +++ b/kernel/vmsymtable.ml @@ -144,7 +144,7 @@ let slot_for_proj_name key = ProjNameTable.add proj_name_tbl key n; n -let rec slot_for_getglobal env kn = +let rec slot_for_getglobal env sigma kn = let (cb,(_,rk)) = lookup_constant_key kn env in try key rk with NotEvaluated -> @@ -155,22 +155,22 @@ let rec slot_for_getglobal env kn = | Some code -> match Vmemitcodes.force code with | BCdefined(code,pl,fv) -> - let v = eval_to_patch env (code,pl,fv) in + let v = eval_to_patch env sigma (code,pl,fv) in set_global v - | BCalias kn' -> slot_for_getglobal env kn' + | BCalias kn' -> slot_for_getglobal env sigma kn' | BCconstant -> set_global (val_of_constant kn) in (*Pp.msgnl(str"value stored at: "++int pos);*) rk := Some (CEphemeron.create pos); pos -and slot_for_fv env fv = +and slot_for_fv env sigma fv = let fill_fv_cache cache id v_of_id env_of_id b = let v,d = match b with | None -> v_of_id id, Id.Set.empty | Some c -> - val_of_constr (env_of_id id env) c, + val_of_constr (env_of_id id env) sigma c, Environ.global_vars_set env c in build_lazy_val cache (v, d); v in let val_of_rel i = val_of_rel (nb_rel env - i) in @@ -194,11 +194,11 @@ and slot_for_fv env fv = | FVuniv_var _idu -> assert false -and eval_to_patch env (buff,pl,fv) = +and eval_to_patch env sigma (buff,pl,fv) = let slots = function | Reloc_annot a -> slot_for_annot a | Reloc_const sc -> slot_for_str_cst sc - | Reloc_getglobal kn -> slot_for_getglobal env kn + | Reloc_getglobal kn -> slot_for_getglobal env sigma kn | Reloc_proj_name p -> slot_for_proj_name p | Reloc_caml_prim op -> slot_for_caml_prim op in @@ -207,13 +207,13 @@ and eval_to_patch env (buff,pl,fv) = (* 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; + Array.iteri (fun i v -> a.(i + 2) <- slot_for_fv env sigma v) fv; a in eval_tcode tc (get_atom_rel ()) (vm_global global_data.glob_val) vm_env -and val_of_constr env c = - match compile ~fail_on_error:true env c with - | Some v -> eval_to_patch env (to_memory v) +and val_of_constr env sigma c = + match compile ~fail_on_error:true env sigma c with + | Some v -> eval_to_patch env sigma (to_memory v) | None -> assert false let set_transparent_const _kn = () (* !?! *) diff --git a/kernel/vmsymtable.mli b/kernel/vmsymtable.mli index e480bfcec1..c6dc09d944 100644 --- a/kernel/vmsymtable.mli +++ b/kernel/vmsymtable.mli @@ -14,7 +14,7 @@ open Names open Constr open Environ -val val_of_constr : env -> constr -> Vmvalues.values +val val_of_constr : env -> (existential -> constr option) -> constr -> Vmvalues.values val set_opaque_const : Constant.t -> unit val set_transparent_const : Constant.t -> unit diff --git a/lib/cDebug.ml b/lib/cDebug.ml new file mode 100644 index 0000000000..efa7365b91 --- /dev/null +++ b/lib/cDebug.ml @@ -0,0 +1,92 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +type flag = bool ref + +type t = (unit -> Pp.t) -> unit + +let debug = ref CString.Map.empty + +(* Used to remember level of Set Debug "all" for debugs created by + plugins dynlinked after the Set *) +let all_flag = ref false + +let set_debug_backtrace b = + Exninfo.record_backtrace b + +let set_debug_all b = + set_debug_backtrace b; + CString.Map.iter (fun _ flag -> flag := b) !debug; + all_flag := b + +let create_full ~name () = + let anomaly pp = CErrors.anomaly ~label:"CDebug.create" pp in + let () = match name with + | "all"|"backtrace" -> anomaly Pp.(str"The debug name \""++str name++str"\" is reserved.") + | _ -> + if CString.Map.mem name !debug then + anomaly Pp.(str "The debug name \"" ++ str name ++ str "\" is already used.") + in + let pp x = + Feedback.msg_debug Pp.(str "[" ++ str name ++ str "] " ++ x) + in + let flag = ref !all_flag in + debug := CString.Map.add name flag !debug; + let pp x = + if !flag + then pp (x ()) + in + flag, pp + +let create ~name () = + snd (create_full ~name ()) + +let get_flag flag = !flag + +let warn_unknown_debug = CWarnings.create ~name:"unknown-debug-flag" ~category:"option" + Pp.(fun name -> str "There is no debug flag \"" ++ str name ++ str "\".") + +let get_flags () = + let pp_flag name flag = if flag then name else "-"^name in + let flags = + CString.Map.fold + (fun name v acc -> pp_flag name !v :: acc) + !debug [] + in + let all = pp_flag "all" !all_flag in + let bt = pp_flag "backtrace" (Printexc.backtrace_status()) in + String.concat "," (all::bt::flags) + +exception Error + +let parse_flags s = + let parse_flag s = + if CString.is_empty s then raise Error + else if s.[0] = '-' + then String.sub s 1 (String.length s - 1), false + else s, true + in + try + Some (CList.map parse_flag @@ String.split_on_char ',' s) + with Error -> None + +let set_flags s = match parse_flags s with + | None -> CErrors.user_err Pp.(str "Syntax error in debug flags.") + | Some flags -> + let set_one_flag (name,b) = match name with + | "all" -> set_debug_all b + | "backtrace" -> set_debug_backtrace b + | _ -> match CString.Map.find_opt name !debug with + | None -> warn_unknown_debug name + | Some flag -> flag := b + in + List.iter set_one_flag flags + +let misc, pp_misc = create_full ~name:"misc" () diff --git a/lib/cDebug.mli b/lib/cDebug.mli new file mode 100644 index 0000000000..846c4b493b --- /dev/null +++ b/lib/cDebug.mli @@ -0,0 +1,50 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +type flag + +type t = (unit -> Pp.t) -> unit + +(** Creates a debug component, which may be used to print debug + messages. + + A debug component is named by the string [name]. It is either + active or inactive. + + The special component ["all"] may be used to control all components. + + There is also a special component ["backtrace"] to control + backtrace recording. +*) +val create : name:string -> unit -> t + +(** Useful when interacting with a component from code, typically when + doing something more complicated than printing. + + Note that the printer function prints some metadata compared to + [ fun pp -> if get_flag flag then Feedback.msg_debug (pp ()) ] + *) +val create_full : name:string -> unit -> flag * t + +val get_flag : flag -> bool + +(** [get_flags] and [set_flags] use the user syntax: a comma separated + list of activated "component" and "-component"s. [get_flags] starts + with "all" or "-all" and lists all components after it (even if redundant). *) +val get_flags : unit -> string + +(** Components not mentioned are not affected (use the "all" component + at the start if you want to reset everything). *) +val set_flags : string -> unit + +val set_debug_all : bool -> unit + +val misc : flag +val pp_misc : t diff --git a/lib/cErrors.ml b/lib/cErrors.ml index 760c07783b..1baedb64c9 100644 --- a/lib/cErrors.ml +++ b/lib/cErrors.ml @@ -30,6 +30,7 @@ let anomaly ?loc ?info ?label pp = let info = Option.cata (Loc.add_loc info) info loc in Exninfo.iraise (Anomaly (label, pp), info) +(* TODO remove the option *) exception UserError of string option * Pp.t (* User errors *) let user_err ?loc ?info ?hdr strm = @@ -46,7 +47,7 @@ exception Timeout = Control.Timeout let where = function | None -> mt () | Some s -> - if !Flags.debug then str "in " ++ str s ++ str ":" ++ spc () else mt () + str "in " ++ str s ++ str ":" ++ spc () let raw_anomaly e = match e with | Anomaly (s, pps) -> @@ -133,7 +134,7 @@ let print_no_report e = iprint_no_report (e, Exninfo.info e) let _ = register_handler begin function | UserError(s, pps) -> - Some (where s ++ pps) + Some pps | _ -> None end diff --git a/lib/cWarnings.ml b/lib/cWarnings.ml index cc1fa647f9..ee7dab92bc 100644 --- a/lib/cWarnings.ml +++ b/lib/cWarnings.ml @@ -173,3 +173,9 @@ let create ~name ~category ?(default=Enabled) pp = | Disabled -> () | AsError -> CErrors.user_err ?loc (pp x) | Enabled -> Feedback.msg_warning ?loc (pp x) + +(* Remark: [warn] does not need to start with a comma, but if present + it won't hurt (",," is normalized into ","). *) +let with_warn warn (f:'b -> 'a) x = + let s = get_flags () in + Util.try_finally (fun x -> set_flags (s^","^warn);f x) x set_flags s diff --git a/lib/cWarnings.mli b/lib/cWarnings.mli index ded1f9be3b..b63eed09d0 100644 --- a/lib/cWarnings.mli +++ b/lib/cWarnings.mli @@ -19,3 +19,10 @@ val set_flags : string -> unit (** Cleans up a user provided warnings status string, e.g. removing unknown warnings (in which case a warning is emitted) or subsumed warnings . *) val normalize_flags_string : string -> string + +(** [with_warn "-xxx,+yyy..." f x] calls [f x] after setting the + warnings as specified in the string (keeping other previously set + warnings), and restores current warnings after [f()] returns or + raises an exception. If both f and restoring the warnings raise + exceptions, the latter is raised. *) +val with_warn: string -> ('b -> 'a) -> 'b -> 'a diff --git a/lib/control.ml b/lib/control.ml index ea94bda064..5a38022291 100644 --- a/lib/control.ml +++ b/lib/control.ml @@ -29,22 +29,32 @@ let check_for_interrupt () = end (** This function does not work on windows, sigh... *) +(* This function assumes it is the only function calling [setitimer] *) let unix_timeout n f x = let open Unix in let timeout_handler _ = raise Timeout in - let psh = Sys.signal Sys.sigalrm (Sys.Signal_handle timeout_handler) in - let _ = setitimer ITIMER_REAL {it_interval = 0.; it_value = n} in - let restore_timeout () = - let _ = setitimer ITIMER_REAL { it_interval = 0.; it_value = 0. } in - Sys.set_signal Sys.sigalrm psh - in - try - let res = f x in - restore_timeout (); - Some res - with Timeout -> - restore_timeout (); - None + let old_timer = getitimer ITIMER_REAL in + (* Here we assume that the existing timer will also interrupt us. *) + if old_timer.it_value > 0. && old_timer.it_value <= n then Some (f x) else + let psh = Sys.signal Sys.sigalrm (Sys.Signal_handle timeout_handler) in + let old_timer = setitimer ITIMER_REAL {it_interval = 0.; it_value = n} in + let restore_timeout () = + let timer_status = getitimer ITIMER_REAL in + let old_timer_value = old_timer.it_value -. n +. timer_status.it_value in + (* We want to make sure that the parent timer triggers, even if somehow the parent timeout + has already passed. This should not happen, but due to timer imprecision it can happen in practice *) + let old_timer_value = if old_timer.it_value <= 0. then 0. else + (if old_timer_value <= 0. then epsilon_float else old_timer_value) in + let _ = setitimer ITIMER_REAL { old_timer with it_value = old_timer_value } in + Sys.set_signal Sys.sigalrm psh + in + try + let res = f x in + restore_timeout (); + Some res + with Timeout -> + restore_timeout (); + None let windows_timeout n f x = @@ -1,7 +1,7 @@ (library (name lib) (synopsis "Coq's Utility Library [coq-specific]") - (public_name coq.lib) + (public_name coq-core.lib) (wrapped false) (modules_without_implementation xml_datatype) - (libraries coq.clib coq.config)) + (libraries coq-core.clib coq-core.config)) diff --git a/lib/envars.ml b/lib/envars.ml index 1702b5d7a2..823d255f58 100644 --- a/lib/envars.ml +++ b/lib/envars.ml @@ -132,7 +132,9 @@ let guess_coqlib fail = if not Coq_config.local && Sys.file_exists (Coq_config.coqlib / prelude) then Coq_config.coqlib else - fail "cannot guess a path for Coq libraries; please use -coqlib option") + fail "cannot guess a path for Coq libraries; please use -coqlib option \ + or ensure you have installed the package contaning Coq's stdlib (coq-stdlib in OPAM) \ + If you intend to use Coq without a standard library, the -boot -noinit options must be used.") ) let coqlib : string option ref = ref None @@ -205,6 +207,7 @@ let print_config ?(prefix_var_name="") f coq_src_subdirs = let open Printf in fprintf f "%sLOCAL=%s\n" prefix_var_name (if Coq_config.local then "1" else "0"); fprintf f "%sCOQLIB=%s/\n" prefix_var_name (coqlib ()); + fprintf f "%sCOQCORELIB=%s/\n" prefix_var_name (if Coq_config.local then coqlib () else coqlib () / "../coq-core/"); fprintf f "%sDOCDIR=%s/\n" prefix_var_name (docdir ()); fprintf f "%sOCAMLFIND=%s\n" prefix_var_name (ocamlfind ()); fprintf f "%sCAMLFLAGS=%s\n" prefix_var_name Coq_config.caml_flags; diff --git a/lib/flags.ml b/lib/flags.ml index 83733cf00d..57e879add7 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -46,7 +46,6 @@ let async_proofs_is_worker () = !async_proofs_worker_id <> "master" let load_vos_libraries = ref false -let debug = ref false let xml_debug = ref false let in_debugger = ref false diff --git a/lib/flags.mli b/lib/flags.mli index ebd23a4d20..e10e2c8cb8 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -40,7 +40,6 @@ val async_proofs_is_worker : unit -> bool val load_vos_libraries : bool ref (** Debug flags *) -val debug : bool ref val xml_debug : bool ref val in_debugger : bool ref val in_toplevel : bool ref diff --git a/lib/lib.mllib b/lib/lib.mllib index 4e08e87084..bbc9966498 100644 --- a/lib/lib.mllib +++ b/lib/lib.mllib @@ -10,6 +10,7 @@ Loc Feedback CErrors CWarnings +CDebug AcyclicGraph Rtree diff --git a/lib/pp.mli b/lib/pp.mli index 12f1ba9bb2..b3c2301d34 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -10,30 +10,31 @@ (** Coq document type. *) -(** Pretty printing guidelines ******************************************) -(* *) -(* `Pp.t` is the main pretty printing document type *) -(* in the Coq system. Documents are composed laying out boxes, and *) -(* users can add arbitrary tag metadata that backends are free *) -(* to interpret. *) -(* *) -(* The datatype has a public view to allow serialization or advanced *) -(* uses, however regular users are _strongly_ warned against its use, *) -(* they should instead rely on the available functions below. *) -(* *) -(* Box order and number is indeed an important factor. Try to create *) -(* a proper amount of boxes. The `++` operator provides "efficient" *) -(* concatenation, but using the list constructors is usually preferred. *) -(* *) -(* That is to say, this: *) -(* *) -(* `hov [str "Term"; hov (pr_term t); str "is defined"]` *) -(* *) -(* is preferred to: *) -(* *) -(* `hov (str "Term" ++ hov (pr_term t) ++ str "is defined")` *) -(* *) -(************************************************************************) +(** +{4 Pretty printing guidelines} + +[Pp.t] is the main pretty printing document type +in the Coq system. Documents are composed laying out boxes, and +users can add arbitrary tag metadata that backends are free +to interpret. + +The datatype has a public view to allow serialization or advanced +uses, however regular users are _strongly_ warned against its use, +they should instead rely on the available functions below. + +Box order and number is indeed an important factor. Try to create +a proper amount of boxes. The [++] operator provides "efficient" +concatenation, but using the list constructors is usually preferred. + +That is to say, this: + +[hov [str "Term"; hov (pr_term t); str "is defined"]] + +is preferred to: + +[hov (str "Term" ++ hov (pr_term t) ++ str "is defined")] +*) + (* XXX: Improve and add attributes *) type pp_tag = string diff --git a/lib/spawn.ml b/lib/spawn.ml index 2fe7b31d04..27b4387b61 100644 --- a/lib/spawn.ml +++ b/lib/spawn.ml @@ -13,7 +13,7 @@ let prefer_sock = Sys.os_type = "Win32" let accept_timeout = 10.0 let pr_err s = Printf.eprintf "(Spawn ,%d) %s\n%!" (Unix.getpid ()) s -let prerr_endline s = if !Flags.debug then begin pr_err s end else () +let prerr_endline s = if CDebug.(get_flag misc) then begin pr_err s end else () type req = ReqDie | Hello of int * int diff --git a/lib/util.ml b/lib/util.ml index 87cc30e557..e8aa0f3e48 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -135,6 +135,13 @@ type 'a delayed = unit -> 'a let delayed_force f = f () +(* finalize - Credit X.Leroy, D.Remy. *) +let try_finally f x finally y = + let res = try f x with exn -> finally y; raise exn in + finally y; + res + + (* Misc *) type ('a, 'b) union = ('a, 'b) CSig.union = Inl of 'a | Inr of 'b diff --git a/lib/util.mli b/lib/util.mli index fe34525671..aefb015c38 100644 --- a/lib/util.mli +++ b/lib/util.mli @@ -112,6 +112,15 @@ type 'a delayed = unit -> 'a val delayed_force : 'a delayed -> 'a +(** [try_finally f x g y] applies the main code [f] to [x] and + returns the result after having applied the finalization + code [g] to [y]. If the main code raises the exception + [exn], the finalization code is executed and [exn] is raised. + If the finalization code itself fails, the exception + returned is always the one from the finalization code. + Credit X.Leroy, D.Remy. *) +val try_finally: ('a -> 'b) -> 'a -> ('c -> unit) -> 'c -> 'b + (** {6 Enriched exceptions} *) type iexn = Exninfo.iexn diff --git a/library/dune b/library/dune index 344fad5a75..bf90511ead 100644 --- a/library/dune +++ b/library/dune @@ -1,9 +1,9 @@ (library (name library) (synopsis "Coq's Loadable Libraries (vo) Support") - (public_name coq.library) + (public_name coq-core.library) (wrapped false) (libraries kernel)) (documentation - (package coq)) + (package coq-core)) diff --git a/library/nametab.ml b/library/nametab.ml index e94b696b60..bd96446f1c 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -574,7 +574,7 @@ let pr_global_env env ref = try pr_qualid (shortest_qualid_of_global env ref) with Not_found as exn -> let exn, info = Exninfo.capture exn in - if !Flags.debug then Feedback.msg_debug (Pp.str "pr_global_env not found"); + if CDebug.(get_flag misc) then Feedback.msg_debug (Pp.str "pr_global_env not found"); Exninfo.iraise (exn, info) let global_inductive qid = @@ -1,6 +1,6 @@ (install (section man) - (package coq) + (package coq-core) (files coqc.1 coqtop.1 coqtop.byte.1 coqtop.opt.1 coqchk.1 coqdep.1 coqdoc.1 coq_makefile.1 coq-tex.1 coqwc.1)) (install diff --git a/parsing/dune b/parsing/dune index 8a31434101..17011d10de 100644 --- a/parsing/dune +++ b/parsing/dune @@ -1,7 +1,7 @@ (library (name parsing) - (public_name coq.parsing) + (public_name coq-core.parsing) (wrapped false) - (libraries coq.gramlib interp)) + (libraries coq-core.gramlib interp)) (coq.pp (modules g_prim g_constr)) diff --git a/plugins/btauto/dune b/plugins/btauto/dune index d2f5b65980..f7b3477460 100644 --- a/plugins/btauto/dune +++ b/plugins/btauto/dune @@ -1,7 +1,7 @@ (library (name btauto_plugin) - (public_name coq.plugins.btauto) + (public_name coq-core.plugins.btauto) (synopsis "Coq's btauto plugin") - (libraries coq.plugins.ltac)) + (libraries coq-core.plugins.ltac)) (coq.pp (modules g_btauto)) diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 129b220680..6617f4726e 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -19,20 +19,12 @@ open Sorts open Constr open Context open Vars -open Goptions open Tacmach open Util let init_size=5 -let cc_verbose= - declare_bool_option_and_ref - ~depr:false - ~key:["Congruence";"Verbose"] - ~value:false - -let debug x = - if cc_verbose () then Feedback.msg_debug (x ()) +let debug_congruence = CDebug.create ~name:"congruence" () (* Signature table *) @@ -576,7 +568,7 @@ let add_inst state (inst,int_subst) = Control.check_for_interrupt (); if state.rew_depth > 0 then if is_redundant state inst.qe_hyp_id int_subst then - debug (fun () -> str "discarding redundant (dis)equality") + debug_congruence (fun () -> str "discarding redundant (dis)equality") else begin Identhash.add state.q_history inst.qe_hyp_id int_subst; @@ -591,7 +583,7 @@ let add_inst state (inst,int_subst) = state.rew_depth<-pred state.rew_depth; if inst.qe_pol then begin - debug (fun () -> + debug_congruence (fun () -> (str "Adding new equality, depth="++ int state.rew_depth) ++ fnl () ++ (str " [" ++ Printer.pr_econstr_env state.env state.sigma (EConstr.of_constr prf) ++ str " : " ++ pr_term state.env state.sigma s ++ str " == " ++ pr_term state.env state.sigma t ++ str "]")); @@ -599,7 +591,7 @@ let add_inst state (inst,int_subst) = end else begin - debug (fun () -> + debug_congruence (fun () -> (str "Adding new disequality, depth="++ int state.rew_depth) ++ fnl () ++ (str " [" ++ Printer.pr_econstr_env state.env state.sigma (EConstr.of_constr prf) ++ str " : " ++ pr_term state.env state.sigma s ++ str " <> " ++ pr_term state.env state.sigma t ++ str "]")); @@ -630,7 +622,7 @@ let join_path uf i j= min_path (down_path uf i [],down_path uf j []) let union state i1 i2 eq= - debug (fun () -> str "Linking " ++ pr_idx_term state.env state.sigma state.uf i1 ++ + debug_congruence (fun () -> str "Linking " ++ pr_idx_term state.env state.sigma state.uf i1 ++ str " and " ++ pr_idx_term state.env state.sigma state.uf i2 ++ str "."); let r1= get_representative state.uf i1 and r2= get_representative state.uf i2 in @@ -670,7 +662,7 @@ let union state i1 i2 eq= | _,_ -> () let merge eq state = (* merge and no-merge *) - debug + debug_congruence (fun () -> str "Merging " ++ pr_idx_term state.env state.sigma state.uf eq.lhs ++ str " and " ++ pr_idx_term state.env state.sigma state.uf eq.rhs ++ str "."); let uf=state.uf in @@ -683,7 +675,7 @@ let merge eq state = (* merge and no-merge *) union state j i (swap eq) let update t state = (* update 1 and 2 *) - debug + debug_congruence (fun () -> str "Updating term " ++ pr_idx_term state.env state.sigma state.uf t ++ str "."); let (i,j) as sign = signature state.uf t in let (u,v) = subterms state.uf t in @@ -745,7 +737,7 @@ let process_constructor_mark t i rep pac state = end let process_mark t m state = - debug + debug_congruence (fun () -> str "Processing mark for term " ++ pr_idx_term state.env state.sigma state.uf t ++ str "."); let i=find state.uf t in let rep=get_representative state.uf i in @@ -766,7 +758,7 @@ let check_disequalities state = if Int.equal (find uf dis.lhs) (find uf dis.rhs) then (str "Yes", Some dis) else (str "No", check_aux q) in - let _ = debug + let _ = debug_congruence (fun () -> str "Checking if " ++ pr_idx_term state.env state.sigma state.uf dis.lhs ++ str " = " ++ pr_idx_term state.env state.sigma state.uf dis.rhs ++ str " ... " ++ info) in ans @@ -953,7 +945,7 @@ let find_instances state = let pb_stack= init_pb_stack state in let res =ref [] in let _ = - debug (fun () -> str "Running E-matching algorithm ... "); + debug_congruence (fun () -> str "Running E-matching algorithm ... "); try while true do Control.check_for_interrupt (); @@ -964,7 +956,7 @@ let find_instances state = !res let rec execute first_run state = - debug (fun () -> str "Executing ... "); + debug_congruence (fun () -> str "Executing ... "); try while Control.check_for_interrupt (); @@ -974,7 +966,7 @@ let rec execute first_run state = None -> if not(Int.Set.is_empty state.pa_classes) then begin - debug (fun () -> str "First run was incomplete, completing ... "); + debug_congruence (fun () -> str "First run was incomplete, completing ... "); complete state; execute false state end @@ -989,12 +981,12 @@ let rec execute first_run state = end else begin - debug (fun () -> str "Out of instances ... "); + debug_congruence (fun () -> str "Out of instances ... "); None end else begin - debug (fun () -> str "Out of depth ... "); + debug_congruence (fun () -> str "Out of depth ... "); None end | Some dis -> Some diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli index 3270f74479..047756deef 100644 --- a/plugins/cc/ccalgo.mli +++ b/plugins/cc/ccalgo.mli @@ -121,7 +121,7 @@ val term_equal : term -> term -> bool val constr_of_term : term -> constr -val debug : (unit -> Pp.t) -> unit +val debug_congruence : CDebug.t val forest : state -> forest diff --git a/plugins/cc/ccproof.ml b/plugins/cc/ccproof.ml index 53d8c5bdd9..e7e0822916 100644 --- a/plugins/cc/ccproof.ml +++ b/plugins/cc/ccproof.ml @@ -95,13 +95,13 @@ let pinject p c n a = p_rule=Inject(p,c,n,a)} let rec equal_proof env sigma uf i j= - debug (fun () -> str "equal_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); + debug_congruence (fun () -> str "equal_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); if i=j then prefl (term uf i) else let (li,lj)=join_path uf i j in ptrans (path_proof env sigma uf i li) (psym (path_proof env sigma uf j lj)) and edge_proof env sigma uf ((i,j),eq)= - debug (fun () -> str "edge_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); + debug_congruence (fun () -> str "edge_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); let pi=equal_proof env sigma uf i eq.lhs in let pj=psym (equal_proof env sigma uf j eq.rhs) in let pij= @@ -117,7 +117,7 @@ and edge_proof env sigma uf ((i,j),eq)= ptrans (ptrans pi pij) pj and constr_proof env sigma uf i ipac= - debug (fun () -> str "constr_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20)); + debug_congruence (fun () -> str "constr_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20)); let t=find_oldest_pac uf i ipac in let eq_it=equal_proof env sigma uf i t in if ipac.args=[] then @@ -130,20 +130,20 @@ and constr_proof env sigma uf i ipac= ptrans eq_it (pcongr p (prefl targ)) and path_proof env sigma uf i l= - debug (fun () -> str "path_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ str "{" ++ + debug_congruence (fun () -> str "path_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ str "{" ++ (prlist_with_sep (fun () -> str ",") (fun ((_,j),_) -> int j) l) ++ str "}"); match l with | [] -> prefl (term uf i) | x::q->ptrans (path_proof env sigma uf (snd (fst x)) q) (edge_proof env sigma uf x) and congr_proof env sigma uf i j= - debug (fun () -> str "congr_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); + debug_congruence (fun () -> str "congr_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); let (i1,i2) = subterms uf i and (j1,j2) = subterms uf j in pcongr (equal_proof env sigma uf i1 j1) (equal_proof env sigma uf i2 j2) and ind_proof env sigma uf i ipac j jpac= - debug (fun () -> str "ind_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); + debug_congruence (fun () -> str "ind_proof " ++ pr_idx_term env sigma uf i ++ brk (1,20) ++ pr_idx_term env sigma uf j); let p=equal_proof env sigma uf i j and p1=constr_proof env sigma uf i ipac and p2=constr_proof env sigma uf j jpac in diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 72f77508d8..341fde7b77 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -420,16 +420,16 @@ let cc_tactic depth additionnal_terms = Proofview.Goal.enter begin fun gl -> let sigma = Tacmach.New.project gl in Coqlib.(check_required_library logic_module_name); - let _ = debug (fun () -> Pp.str "Reading goal ...") in + let _ = debug_congruence (fun () -> Pp.str "Reading goal ...") in let state = make_prb gl depth additionnal_terms in - let _ = debug (fun () -> Pp.str "Problem built, solving ...") in + let _ = debug_congruence (fun () -> Pp.str "Problem built, solving ...") in let sol = execute true state in - let _ = debug (fun () -> Pp.str "Computation completed.") in + let _ = debug_congruence (fun () -> Pp.str "Computation completed.") in let uf=forest state in match sol with None -> Tacticals.New.tclFAIL 0 (str "congruence failed") | Some reason -> - debug (fun () -> Pp.str "Goal solved, generating proof ..."); + debug_congruence (fun () -> Pp.str "Goal solved, generating proof ..."); match reason with Discrimination (i,ipac,j,jpac) -> let p=build_proof (Tacmach.New.pf_env gl) sigma uf (`Discr (i,ipac,j,jpac)) in diff --git a/plugins/cc/dune b/plugins/cc/dune index f7fa3adb56..ee28148c5a 100644 --- a/plugins/cc/dune +++ b/plugins/cc/dune @@ -1,7 +1,7 @@ (library (name cc_plugin) - (public_name coq.plugins.cc) + (public_name coq-core.plugins.cc) (synopsis "Coq's congruence closure plugin") - (libraries coq.plugins.ltac)) + (libraries coq-core.plugins.ltac)) (coq.pp (modules g_congruence)) diff --git a/plugins/derive/dune b/plugins/derive/dune index 1931339471..d382031a58 100644 --- a/plugins/derive/dune +++ b/plugins/derive/dune @@ -1,7 +1,7 @@ (library (name derive_plugin) - (public_name coq.plugins.derive) + (public_name coq-core.plugins.derive) (synopsis "Coq's derive plugin") - (libraries coq.plugins.ltac)) + (libraries coq-core.plugins.ltac)) (coq.pp (modules g_derive)) diff --git a/plugins/extraction/dune b/plugins/extraction/dune index d9d675fe6a..7f2582f84e 100644 --- a/plugins/extraction/dune +++ b/plugins/extraction/dune @@ -1,7 +1,7 @@ (library (name extraction_plugin) - (public_name coq.plugins.extraction) + (public_name coq-core.plugins.extraction) (synopsis "Coq's extraction plugin") - (libraries coq.plugins.ltac)) + (libraries coq-core.plugins.ltac)) (coq.pp (modules g_extraction)) diff --git a/plugins/firstorder/dune b/plugins/firstorder/dune index 1b05452d8f..0299ca802f 100644 --- a/plugins/firstorder/dune +++ b/plugins/firstorder/dune @@ -1,7 +1,7 @@ (library (name ground_plugin) - (public_name coq.plugins.firstorder) + (public_name coq-core.plugins.firstorder) (synopsis "Coq's first order logic solver plugin") - (libraries coq.plugins.ltac)) + (libraries coq-core.plugins.ltac)) (coq.pp (modules g_ground)) diff --git a/plugins/funind/dune b/plugins/funind/dune index e594ffbd02..42377f37f4 100644 --- a/plugins/funind/dune +++ b/plugins/funind/dune @@ -1,7 +1,7 @@ (library (name recdef_plugin) - (public_name coq.plugins.funind) + (public_name coq-core.plugins.funind) (synopsis "Coq's functional induction plugin") - (libraries coq.plugins.extraction)) + (libraries coq-core.plugins.extraction)) (coq.pp (modules g_indfun)) diff --git a/plugins/funind/g_indfun.mlg b/plugins/funind/g_indfun.mlg index ca6ae150a7..15cf88f827 100644 --- a/plugins/funind/g_indfun.mlg +++ b/plugins/funind/g_indfun.mlg @@ -195,16 +195,29 @@ let is_interactive recsl = } +(* For usability we temporarily switch off some flags during the call + to Function. However this is not satisfactory: + + 1- Function should not warn "non-recursive" and call the Definition + mechanism instead of Fixpoint when needed + + 2- Only for automatically generated names should + unused-pattern-matching-variable be ignored. *) + VERNAC COMMAND EXTEND Function STATE CUSTOM | ["Function" ne_function_fix_definition_list_sep(recsl,"with")] => { classify_funind recsl } -> { - if is_interactive recsl then - Vernacextend.VtOpenProof (fun () -> - Gen_principle.do_generate_principle_interactive (List.map snd recsl)) - else - Vernacextend.VtDefault (fun () -> - Gen_principle.do_generate_principle (List.map snd recsl)) } + let warn = "-unused-pattern-matching-variable,-matching-variable,-non-recursive" in + if is_interactive recsl then + Vernacextend.VtOpenProof (fun () -> + CWarnings.with_warn warn + Gen_principle.do_generate_principle_interactive (List.map snd recsl)) + else + Vernacextend.VtDefault (fun () -> + CWarnings.with_warn warn + Gen_principle.do_generate_principle (List.map snd recsl)) + } END { diff --git a/plugins/ltac/dune b/plugins/ltac/dune index 6558ecbfe8..9ec2b10873 100644 --- a/plugins/ltac/dune +++ b/plugins/ltac/dune @@ -1,15 +1,15 @@ (library (name ltac_plugin) - (public_name coq.plugins.ltac) + (public_name coq-core.plugins.ltac) (synopsis "Coq's LTAC tactic language") (modules :standard \ tauto) - (libraries coq.stm)) + (libraries coq-core.stm)) (library (name tauto_plugin) - (public_name coq.plugins.tauto) + (public_name coq-core.plugins.tauto) (synopsis "Coq's tauto tactic") (modules tauto) - (libraries coq.plugins.ltac)) + (libraries coq-core.plugins.ltac)) (coq.pp (modules extratactics g_tactic g_rewrite g_eqdecide g_auto g_obligations g_ltac profile_ltac_tactics coretactics g_class extraargs)) diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 6d0e0c36b3..c7bda43465 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -251,10 +251,10 @@ end) = struct (** Folding/unfolding of the tactic constants. *) - let unfold_impl sigma t = + let unfold_impl n sigma t = match EConstr.kind sigma t with | App (arrow, [| a; b |])(* when eq_constr arrow (Lazy.force impl) *) -> - mkProd (make_annot Anonymous Sorts.Relevant, a, lift 1 b) + mkProd (make_annot n Sorts.Relevant, a, lift 1 b) | _ -> assert false let unfold_all sigma t = @@ -273,16 +273,16 @@ end) = struct | _ -> assert false) | _ -> assert false - let arrow_morphism env evd ta tb a b = + let arrow_morphism env evd n ta tb a b = let ap = is_Prop (goalevars evd) ta and bp = is_Prop (goalevars evd) tb in - if ap && bp then app_poly env evd impl [| a; b |], unfold_impl + if ap && bp then app_poly env evd impl [| a; b |], unfold_impl n else if ap then (* Domain in Prop, CoDomain in Type *) - (app_poly env evd arrow [| a; b |]), unfold_impl + (app_poly env evd arrow [| a; b |]), unfold_impl n (* (evd, mkProd (Anonymous, a, b)), (fun x -> x) *) else if bp then (* Dummy forall *) - (app_poly env evd coq_all [| a; mkLambda (make_annot Anonymous Sorts.Relevant, a, lift 1 b) |]), unfold_forall + (app_poly env evd coq_all [| a; mkLambda (make_annot n Sorts.Relevant, a, lift 1 b) |]), unfold_forall else (* None in Prop, use arrow *) - (app_poly env evd arrow [| a; b |]), unfold_impl + (app_poly env evd arrow [| a; b |]), unfold_impl n let rec decomp_pointwise sigma n c = if Int.equal n 0 then c @@ -1079,7 +1079,7 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = let arr = if prop then PropGlobal.arrow_morphism else TypeGlobal.arrow_morphism in - let (evars', mor), unfold = arr env evars tx tb x b in + let (evars', mor), unfold = arr env evars n.binder_name tx tb x b in let state, res = aux { state ; env ; unfresh ; term1 = mor ; ty1 = ty ; cstr = (prop,cstr) ; evars = evars' } in diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml index f2241e78d2..54d7c310aa 100644 --- a/plugins/ltac/tacinterp.ml +++ b/plugins/ltac/tacinterp.ml @@ -2148,7 +2148,8 @@ let interp_redexp env sigma r = (* Backwarding recursive needs of tactic glob/interp/eval functions *) let _ = - let eval lfun poly env sigma ty tac = + let eval ?loc ~poly env sigma tycon tac = + let lfun = GlobEnv.lfun env in let extra = TacStore.set TacStore.empty f_debug (get_debug ()) in let ist = { lfun; poly; extra; } in let tac = eval_tactic_ist ist tac in @@ -2156,8 +2157,13 @@ let _ = poly seems like enough to get reasonable behavior in practice *) 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) + let sigma, ty = match tycon with + | Some ty -> sigma, ty + | None -> GlobEnv.new_type_evar env sigma ~src:(loc,Evar_kinds.InternalHole) + in + let (c, sigma) = Proof.refine_by_tactic ~name ~poly (GlobEnv.renamed_env env) sigma ty tac in + let j = { Environ.uj_val = EConstr.of_constr c; uj_type = ty } in + (j, sigma) in GlobEnv.register_constr_interp0 wit_tactic eval diff --git a/plugins/micromega/certificate.ml b/plugins/micromega/certificate.ml index ed608bb1df..53aa619d10 100644 --- a/plugins/micromega/certificate.ml +++ b/plugins/micromega/certificate.ml @@ -223,6 +223,28 @@ let find_point l = let optimise v l = if use_simplex () then Simplex.optimise v l else Mfourier.Fourier.optimise v l +let output_cstr_sys o sys = + List.iter + (fun (c, wp) -> + Printf.fprintf o "%a by %a\n" output_cstr c ProofFormat.output_prf_rule wp) + sys + +let output_sys o sys = + List.iter (fun s -> Printf.fprintf o "%a\n" WithProof.output s) sys + +let tr_sys str f sys = + let sys' = f sys in + if debug then + Printf.fprintf stdout "[%s\n%a=>\n%a]\n" str output_sys sys output_sys sys'; + sys' + +let tr_cstr_sys str f sys = + let sys' = f sys in + if debug then + Printf.fprintf stdout "[%s\n%a=>\n%a]\n" str output_cstr_sys sys + output_cstr_sys sys'; + sys' + let dual_raw_certificate l = if debug then begin Printf.printf "dual_raw_certificate\n"; @@ -375,25 +397,7 @@ let elim_simple_linear_equality sys0 = in iterate_until_stable elim sys0 -let output_sys o sys = - List.iter (fun s -> Printf.fprintf o "%a\n" WithProof.output s) sys - -let subst sys = - let sys' = WithProof.subst sys in - if debug then - Printf.fprintf stdout "[subst:\n%a\n==>\n%a\n]" output_sys sys output_sys - sys'; - sys' - -let tr_sys str f sys = - let sys' = f sys in - if debug then ( - Printf.fprintf stdout "[%s\n" str; - List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys; - Printf.fprintf stdout "\n => \n"; - List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys'; - Printf.fprintf stdout "]\n" ); - sys' +let subst sys = tr_sys "subst" WithProof.subst sys (** [saturate_linear_equality sys] generate new constraints obtained by eliminating linear equalities by pivoting. @@ -489,12 +493,10 @@ let nlinear_preprocess (sys : WithProof.t list) = ISet.fold (fun i acc -> square_of_var i :: acc) collect_vars sys in let sys = sys @ all_pairs WithProof.product sys in - if debug then begin - Printf.fprintf stdout "Preprocessed\n"; - List.iter (fun s -> Printf.fprintf stdout "%a\n" WithProof.output s) sys - end; List.map (WithProof.annot "P") sys +let nlinear_preprocess = tr_sys "nlinear_preprocess" nlinear_preprocess + let nlinear_prover prfdepth sys = let sys = develop_constraints prfdepth q_spec sys in let sys1 = elim_simple_linear_equality sys in @@ -698,6 +700,15 @@ let pivot v (c1, p1) (c2, p2) = Some (xpivot cv1 cv2) else None +let pivot v c1 c2 = + let res = pivot v c1 c2 in + ( match res with + | None -> () + | Some (c, _) -> + if Vect.get v c.coeffs =/ Q.zero then () + else Printf.printf "pivot error %a\n" output_cstr c ); + res + (* op2 could be Eq ... this might happen *) let simpl_sys sys = @@ -762,6 +773,8 @@ let reduce_coprime psys = in Some (pivot_sys v (cstr, prf) ((c1, p1) :: sys)) +(*let pivot_sys v pc sys = tr_cstr_sys "pivot_sys" (pivot_sys v pc) sys*) + (** If there is an equation [eq] of the form 1.x + e = c, do a pivot over x with equation [eq] *) let reduce_unary psys = let is_unary_equation (cstr, prf) = @@ -820,6 +833,8 @@ let reduction_equations psys = [reduce_unary; reduce_coprime; reduce_var_change (*; reduce_pivot*)]) psys +let reduction_equations = tr_cstr_sys "reduction_equations" reduction_equations + (** [get_bound sys] returns upon success an interval (lb,e,ub) with proofs *) let get_bound sys = let is_small (v, i) = @@ -891,11 +906,6 @@ let check_sys sys = open ProofFormat -let output_cstr_sys sys = - (pp_list ";" (fun o (c, wp) -> - Printf.fprintf o "%a by %a" output_cstr c ProofFormat.output_prf_rule wp)) - sys - let xlia (can_enum : bool) reduction_equations sys = let rec enum_proof (id : int) (sys : prf_sys) = if debug then ( @@ -1170,7 +1180,9 @@ let nlia enum prfdepth sys = No: if a wrong equation is chosen, the proof may fail. It would only be safe if the variable is linear... *) - let sys1 = elim_simple_linear_equality sys in + let sys1 = + elim_simple_linear_equality (WithProof.subst_constant true sys) + in let sys2 = saturate_by_linear_equalities sys1 in let sys3 = nlinear_preprocess (sys1 @ sys2) in let sys4 = make_cstr_system (*sys2@*) sys3 in diff --git a/plugins/micromega/dune b/plugins/micromega/dune index 204125ab56..41f894bce3 100644 --- a/plugins/micromega/dune +++ b/plugins/micromega/dune @@ -1,24 +1,24 @@ (library (name micromega_plugin) - (public_name coq.plugins.micromega) + (public_name coq-core.plugins.micromega) ; be careful not to link the executable to the plugin! (modules (:standard \ csdpcert g_zify zify)) (synopsis "Coq's micromega plugin") - (libraries coq.plugins.ltac)) + (libraries coq-core.plugins.ltac)) (executable (name csdpcert) (public_name csdpcert) - (package coq) + (package coq-core) (modules csdpcert) (flags :standard -open Micromega_plugin) - (libraries coq.plugins.micromega)) + (libraries coq-core.plugins.micromega)) (library (name zify_plugin) - (public_name coq.plugins.zify) + (public_name coq-core.plugins.zify) (modules g_zify zify) (synopsis "Coq's zify plugin") - (libraries coq.plugins.ltac)) + (libraries coq-core.plugins.ltac)) (coq.pp (modules g_micromega g_zify)) diff --git a/plugins/micromega/polynomial.ml b/plugins/micromega/polynomial.ml index 7b29aa15f9..024fc6dade 100644 --- a/plugins/micromega/polynomial.ml +++ b/plugins/micromega/polynomial.ml @@ -485,7 +485,7 @@ module ProofFormat = struct let rec output_proof o = function | Done -> Printf.fprintf o "." | Step (i, p, pf) -> - Printf.fprintf o "%i:= %a ; %a" i output_prf_rule p output_proof pf + Printf.fprintf o "%i:= %a\n ; %a" i output_prf_rule p output_proof pf | Split (i, v, p1, p2) -> Printf.fprintf o "%i:=%a ; { %a } { %a }" i Vect.pp v output_proof p1 output_proof p2 @@ -496,6 +496,48 @@ module ProofFormat = struct Printf.fprintf o "%i := %i = %i - %i ; %i := %i >= 0 ; %i := %i >= 0 ; %a" i x z t j z k t output_proof pr + module OrdPrfRule = struct + type t = prf_rule + + let id_of_constr = function + | Annot _ -> 0 + | Hyp _ -> 1 + | Def _ -> 2 + | Cst _ -> 3 + | Zero -> 4 + | Square _ -> 5 + | MulC _ -> 6 + | Gcd _ -> 7 + | MulPrf _ -> 8 + | AddPrf _ -> 9 + | CutPrf _ -> 10 + + let cmp_pair c1 c2 (x1, x2) (y1, y2) = + match c1 x1 y1 with 0 -> c2 x2 y2 | i -> i + + let rec compare p1 p2 = + match (p1, p2) with + | Annot (s1, p1), Annot (s2, p2) -> + if s1 = s2 then compare p1 p2 else String.compare s1 s2 + | Hyp i, Hyp j -> Int.compare i j + | Def i, Def j -> Int.compare i j + | Cst n, Cst m -> Q.compare n m + | Zero, Zero -> 0 + | Square v1, Square v2 -> Vect.compare v1 v2 + | MulC (v1, p1), MulC (v2, p2) -> + cmp_pair Vect.compare compare (v1, p1) (v2, p2) + | Gcd (b1, p1), Gcd (b2, p2) -> + cmp_pair Z.compare compare (b1, p1) (b2, p2) + | MulPrf (p1, q1), MulPrf (p2, q2) -> + cmp_pair compare compare (p1, q1) (p2, q2) + | AddPrf (p1, q1), AddPrf (p2, q2) -> + cmp_pair compare compare (p1, q1) (p2, q2) + | CutPrf p, CutPrf p' -> compare p p' + | _, _ -> Int.compare (id_of_constr p1) (id_of_constr p2) + end + + module PrfRuleMap = Map.Make (OrdPrfRule) + let rec pr_size = function | Annot (_, p) -> pr_size p | Zero | Square _ -> Q.zero @@ -537,33 +579,38 @@ module ProofFormat = struct (** [pr_rule_def_cut id pr] gives an explicit [id] to cut rules. This is because the Coq proof format only accept they as a proof-step *) - let rec pr_rule_def_cut id = function - | Annot (_, p) -> pr_rule_def_cut id p - | MulC (p, prf) -> - let bds, id', prf' = pr_rule_def_cut id prf in - (bds, id', MulC (p, prf')) - | MulPrf (p1, p2) -> - let bds1, id, p1 = pr_rule_def_cut id p1 in - let bds2, id, p2 = pr_rule_def_cut id p2 in - (bds2 @ bds1, id, MulPrf (p1, p2)) - | AddPrf (p1, p2) -> - let bds1, id, p1 = pr_rule_def_cut id p1 in - let bds2, id, p2 = pr_rule_def_cut id p2 in - (bds2 @ bds1, id, AddPrf (p1, p2)) - | CutPrf p -> - let bds, id, p = pr_rule_def_cut id p in - ((id, p) :: bds, id + 1, Def id) - | Gcd (c, p) -> - let bds, id, p = pr_rule_def_cut id p in - ((id, p) :: bds, id + 1, Def id) - | (Square _ | Cst _ | Def _ | Hyp _ | Zero) as x -> ([], id, x) + let pr_rule_def_cut m id p = + let rec pr_rule_def_cut m id = function + | Annot (_, p) -> pr_rule_def_cut m id p + | MulC (p, prf) -> + let bds, m, id', prf' = pr_rule_def_cut m id prf in + (bds, m, id', MulC (p, prf')) + | MulPrf (p1, p2) -> + let bds1, m, id, p1 = pr_rule_def_cut m id p1 in + let bds2, m, id, p2 = pr_rule_def_cut m id p2 in + (bds2 @ bds1, m, id, MulPrf (p1, p2)) + | AddPrf (p1, p2) -> + let bds1, m, id, p1 = pr_rule_def_cut m id p1 in + let bds2, m, id, p2 = pr_rule_def_cut m id p2 in + (bds2 @ bds1, m, id, AddPrf (p1, p2)) + | CutPrf p | Gcd (_, p) -> ( + let bds, m, id, p = pr_rule_def_cut m id p in + try + let id' = PrfRuleMap.find p m in + (bds, m, id, Def id') + with Not_found -> + let m = PrfRuleMap.add p id m in + ((id, p) :: bds, m, id + 1, Def id) ) + | (Square _ | Cst _ | Def _ | Hyp _ | Zero) as x -> ([], m, id, x) + in + pr_rule_def_cut m id p (* Do not define top-level cuts *) - let pr_rule_def_cut id = function + let pr_rule_def_cut m id = function | CutPrf p -> - let bds, ids, p' = pr_rule_def_cut id p in - (bds, ids, CutPrf p') - | p -> pr_rule_def_cut id p + let bds, m, ids, p' = pr_rule_def_cut m id p in + (bds, m, ids, CutPrf p') + | p -> pr_rule_def_cut m id p let rec implicit_cut p = match p with CutPrf p -> implicit_cut p | _ -> p @@ -577,6 +624,69 @@ module ProofFormat = struct | MulPrf (p1, p2) | AddPrf (p1, p2) -> ISet.union (pr_rule_collect_defs p1) (pr_rule_collect_defs p2) + let add_proof x y = + match (x, y) with Zero, p | p, Zero -> p | _ -> AddPrf (x, y) + + let rec mul_cst_proof c p = + match p with + | Annot (s, p) -> Annot (s, mul_cst_proof c p) + | MulC (v, p') -> MulC (Vect.mul c v, p') + | _ -> ( + match Q.sign c with + | 0 -> Zero (* This is likely to be a bug *) + | -1 -> + MulC (LinPoly.constant c, p) (* [p] should represent an equality *) + | 1 -> if Q.one =/ c then p else MulPrf (Cst c, p) + | _ -> assert false ) + + let sMulC v p = + let c, v' = Vect.decomp_cst v in + if Vect.is_null v' then mul_cst_proof c p else MulC (v, p) + + let mul_proof p1 p2 = + match (p1, p2) with + | Zero, _ | _, Zero -> Zero + | Cst c, p | p, Cst c -> mul_cst_proof c p + | _, _ -> MulPrf (p1, p2) + + let prf_rule_of_map m = + PrfRuleMap.fold (fun k v acc -> add_proof (sMulC v k) acc) m Zero + + let rec dev_prf_rule p = + match p with + | Annot (s, p) -> dev_prf_rule p + | Hyp _ | Def _ | Cst _ | Zero | Square _ -> + PrfRuleMap.singleton p (LinPoly.constant Q.one) + | MulC (v, p) -> + PrfRuleMap.map (fun v1 -> LinPoly.product v v1) (dev_prf_rule p) + | AddPrf (p1, p2) -> + PrfRuleMap.merge + (fun k o1 o2 -> + match (o1, o2) with + | None, None -> None + | None, Some v | Some v, None -> Some v + | Some v1, Some v2 -> Some (LinPoly.addition v1 v2)) + (dev_prf_rule p1) (dev_prf_rule p2) + | MulPrf (p1, p2) -> ( + let p1' = dev_prf_rule p1 in + let p2' = dev_prf_rule p2 in + let p1'' = prf_rule_of_map p1' in + let p2'' = prf_rule_of_map p2' in + match p1'' with + | Cst c -> PrfRuleMap.map (fun v1 -> Vect.mul c v1) p2' + | _ -> PrfRuleMap.singleton (MulPrf (p1'', p2'')) (LinPoly.constant Q.one) + ) + | Gcd (c, p) -> + PrfRuleMap.singleton + (Gcd (c, prf_rule_of_map (dev_prf_rule p))) + (LinPoly.constant Q.one) + | CutPrf p -> + PrfRuleMap.singleton + (CutPrf (prf_rule_of_map (dev_prf_rule p))) + (LinPoly.constant Q.one) + + let simplify_prf_rule p = prf_rule_of_map (dev_prf_rule p) + (** [simplify_proof p] removes proof steps that are never re-used. *) let rec simplify_proof p = match p with @@ -618,7 +728,9 @@ module ProofFormat = struct | Done -> (id, Done) | Step (i, Gcd (c, p), Done) -> normalise_proof id (Step (i, p, Done)) | Step (i, p, prf) -> - let bds, id, p' = pr_rule_def_cut id p in + let bds, m, id, p' = + pr_rule_def_cut PrfRuleMap.empty id (simplify_prf_rule p) + in let id, prf = normalise_proof id prf in let prf = List.fold_left @@ -642,8 +754,10 @@ module ProofFormat = struct (List.fold_left max 0 ids , Enum(i,p1,v,p2,prfs)) *) - let bds1, id, p1' = pr_rule_def_cut id (implicit_cut p1) in - let bds2, id, p2' = pr_rule_def_cut id (implicit_cut p2) in + let bds1, m, id, p1' = + pr_rule_def_cut PrfRuleMap.empty id (implicit_cut p1) + in + let bds2, m, id, p2' = pr_rule_def_cut m id (implicit_cut p2) in let ids, prfs = List.split (List.map (normalise_proof id) pl) in ( List.fold_left max 0 ids , List.fold_left @@ -659,104 +773,6 @@ module ProofFormat = struct (snd res); res - module OrdPrfRule = struct - type t = prf_rule - - let id_of_constr = function - | Annot _ -> 0 - | Hyp _ -> 1 - | Def _ -> 2 - | Cst _ -> 3 - | Zero -> 4 - | Square _ -> 5 - | MulC _ -> 6 - | Gcd _ -> 7 - | MulPrf _ -> 8 - | AddPrf _ -> 9 - | CutPrf _ -> 10 - - let cmp_pair c1 c2 (x1, x2) (y1, y2) = - match c1 x1 y1 with 0 -> c2 x2 y2 | i -> i - - let rec compare p1 p2 = - match (p1, p2) with - | Annot (s1, p1), Annot (s2, p2) -> - if s1 = s2 then compare p1 p2 else String.compare s1 s2 - | Hyp i, Hyp j -> Int.compare i j - | Def i, Def j -> Int.compare i j - | Cst n, Cst m -> Q.compare n m - | Zero, Zero -> 0 - | Square v1, Square v2 -> Vect.compare v1 v2 - | MulC (v1, p1), MulC (v2, p2) -> - cmp_pair Vect.compare compare (v1, p1) (v2, p2) - | Gcd (b1, p1), Gcd (b2, p2) -> - cmp_pair Z.compare compare (b1, p1) (b2, p2) - | MulPrf (p1, q1), MulPrf (p2, q2) -> - cmp_pair compare compare (p1, p2) (q1, q2) - | AddPrf (p1, q1), AddPrf (p2, q2) -> - cmp_pair compare compare (p1, p2) (q1, q2) - | CutPrf p, CutPrf p' -> compare p p' - | _, _ -> Int.compare (id_of_constr p1) (id_of_constr p2) - end - - let add_proof x y = - match (x, y) with Zero, p | p, Zero -> p | _ -> AddPrf (x, y) - - let rec mul_cst_proof c p = - match p with - | Annot (s, p) -> Annot (s, mul_cst_proof c p) - | MulC (v, p') -> MulC (Vect.mul c v, p') - | _ -> ( - match Q.sign c with - | 0 -> Zero (* This is likely to be a bug *) - | -1 -> - MulC (LinPoly.constant c, p) (* [p] should represent an equality *) - | 1 -> if Q.one =/ c then p else MulPrf (Cst c, p) - | _ -> assert false ) - - let sMulC v p = - let c, v' = Vect.decomp_cst v in - if Vect.is_null v' then mul_cst_proof c p else MulC (v, p) - - let mul_proof p1 p2 = - match (p1, p2) with - | Zero, _ | _, Zero -> Zero - | Cst c, p | p, Cst c -> mul_cst_proof c p - | _, _ -> MulPrf (p1, p2) - - module PrfRuleMap = Map.Make (OrdPrfRule) - - let prf_rule_of_map m = - PrfRuleMap.fold (fun k v acc -> add_proof (sMulC v k) acc) m Zero - - let rec dev_prf_rule p = - match p with - | Annot (s, p) -> dev_prf_rule p - | Hyp _ | Def _ | Cst _ | Zero | Square _ -> - PrfRuleMap.singleton p (LinPoly.constant Q.one) - | MulC (v, p) -> - PrfRuleMap.map (fun v1 -> LinPoly.product v v1) (dev_prf_rule p) - | AddPrf (p1, p2) -> - PrfRuleMap.merge - (fun k o1 o2 -> - match (o1, o2) with - | None, None -> None - | None, Some v | Some v, None -> Some v - | Some v1, Some v2 -> Some (LinPoly.addition v1 v2)) - (dev_prf_rule p1) (dev_prf_rule p2) - | MulPrf (p1, p2) -> ( - let p1' = dev_prf_rule p1 in - let p2' = dev_prf_rule p2 in - let p1'' = prf_rule_of_map p1' in - let p2'' = prf_rule_of_map p2' in - match p1'' with - | Cst c -> PrfRuleMap.map (fun v1 -> Vect.mul c v1) p2' - | _ -> PrfRuleMap.singleton (MulPrf (p1'', p2'')) (LinPoly.constant Q.one) - ) - | _ -> PrfRuleMap.singleton p (LinPoly.constant Q.one) - - let simplify_prf_rule p = prf_rule_of_map (dev_prf_rule p) - (* let mul_proof p1 p2 = let res = mul_proof p1 p2 in @@ -835,7 +851,8 @@ module ProofFormat = struct Printf.printf "cmpl_pol_z %s %a\n" (Printexc.to_string x) LinPoly.pp lp; raise x - let rec cmpl_proof env = function + let rec cmpl_proof env prf = + match prf with | Done -> Mc.DoneProof | Step (i, p, prf) -> ( match p with @@ -1097,15 +1114,33 @@ module WithProof = struct in List.sort cmp (List.rev_map (fun wp -> (size wp, wp)) sys) - let subst sys0 = + let iterate_pivot p sys0 = let elim sys = - let oeq, sys' = extract (is_substitution true) sys in + let oeq, sys' = extract p sys in match oeq with | None -> None | Some (v, pc) -> simplify (linear_pivot sys0 pc v) sys' in iterate_until_stable elim (List.map snd (sort sys0)) + let subst_constant is_int sys = + let is_integer q = Q.(q =/ floor q) in + let is_constant ((c, o), p) = + match o with + | Ge | Gt -> None + | Eq -> ( + Vect.Bound.( + match of_vect c with + | None -> None + | Some b -> + if (not is_int) || is_integer (b.cst // b.coeff) then + Monomial.get_var (LinPoly.MonT.retrieve b.var) + else None) ) + in + iterate_pivot is_constant sys + + let subst sys0 = iterate_pivot (is_substitution true) sys0 + let saturate_subst b sys0 = let select = is_substitution b in let gen (v, pc) ((c, op), prf) = diff --git a/plugins/micromega/polynomial.mli b/plugins/micromega/polynomial.mli index 84b5421207..81c131fe78 100644 --- a/plugins/micromega/polynomial.mli +++ b/plugins/micromega/polynomial.mli @@ -393,6 +393,10 @@ module WithProof : sig val subst : t list -> t list + (** [subst_constant b sys] performs the equivalent of the 'subst' tactic of Coq + only if there is an equation a.x = c for a,c a constant and a divides c if b= true*) + val subst_constant : bool -> t list -> t list + (** [subst1 sys] performs a single substitution *) val subst1 : t list -> t list diff --git a/plugins/micromega/zify.ml b/plugins/micromega/zify.ml index d1403558ad..61966b60c0 100644 --- a/plugins/micromega/zify.ml +++ b/plugins/micromega/zify.ml @@ -14,7 +14,7 @@ open Pp open Lazy module NamedDecl = Context.Named.Declaration -let debug = false +let debug_zify = CDebug.create ~name:"zify" () (* The following [constr] are necessary for constructing the proof terms *) @@ -805,12 +805,11 @@ let pp_prf prf = let interp_prf evd inj source prf = let t, prf' = interp_prf evd inj source prf in - if debug then - Feedback.msg_debug + debug_zify (fun () -> Pp.( str "interp_prf " ++ gl_pr_constr inj.EInjT.inj ++ str " " ++ gl_pr_constr source ++ str " = " ++ gl_pr_constr t ++ str " by " - ++ gl_pr_constr prf' ++ str " from " ++ pp_prf prf ++ fnl ()); + ++ gl_pr_constr prf' ++ str " from " ++ pp_prf prf ++ fnl ())); (t, prf') let mkvar evd inj e = @@ -888,13 +887,12 @@ let app_unop evd src unop arg prf = let app_unop evd src unop arg prf = let res = app_unop evd src unop arg prf in - if debug then - Feedback.msg_debug + debug_zify (fun () -> Pp.( str "\napp_unop " ++ pp_prf evd unop.EUnOpT.inj1_t arg prf ++ str " => " - ++ pp_prf evd unop.EUnOpT.inj2_t src res); + ++ pp_prf evd unop.EUnOpT.inj2_t src res)); res let app_binop evd src binop arg1 prf1 arg2 prf2 = @@ -1066,8 +1064,7 @@ let match_operator env evd hd args (t, d) = let pp_trans_expr env evd e res = let {deriv = inj} = get_injection env evd e.typ in - if debug then - Feedback.msg_debug Pp.(str "\ntrans_expr " ++ pp_prf evd inj e.constr res); + debug_zify (fun () -> Pp.(str "\ntrans_expr " ++ pp_prf evd inj e.constr res)); res let declared_term env evd hd args = @@ -1187,7 +1184,7 @@ let trans_binrel evd src rop a1 prf1 a2 prf2 = let trans_binrel evd src rop a1 prf1 a2 prf2 = let res = trans_binrel evd src rop a1 prf1 a2 prf2 in - if debug then Feedback.msg_debug Pp.(str "\ntrans_binrel " ++ pp_prfp res); + debug_zify (fun () -> Pp.(str "\ntrans_binrel " ++ pp_prfp res)); res let mkprf t p = @@ -1199,11 +1196,10 @@ let mkprf t p = let mkprf t p = let t', p = mkprf t p in - if debug then - Feedback.msg_debug + debug_zify (fun () -> Pp.( str "mkprf " ++ gl_pr_constr t ++ str " <-> " ++ gl_pr_constr t' - ++ str " by " ++ gl_pr_constr p); + ++ str " by " ++ gl_pr_constr p)); (t', p) let trans_bin_prop op_constr op_iff t1 p1 t2 p2 = @@ -1221,7 +1217,7 @@ let trans_bin_prop op_constr op_iff t1 p1 t2 p2 = let trans_bin_prop op_constr op_iff t1 p1 t2 p2 = let prf = trans_bin_prop op_constr op_iff t1 p1 t2 p2 in - if debug then Feedback.msg_debug (pp_prfp prf); + debug_zify (fun () -> pp_prfp prf); prf let trans_un_prop op_constr op_iff p1 prf1 = @@ -1285,8 +1281,7 @@ let trans_hyps env evd l = [] l let trans_hyp h t0 prfp = - if debug then - Feedback.msg_debug Pp.(str "trans_hyp: " ++ pp_prfp prfp ++ fnl ()); + debug_zify (fun () -> Pp.(str "trans_hyp: " ++ pp_prfp prfp ++ fnl ())); match prfp with | IProof -> Tacticals.New.tclIDTAC (* Should detect before *) | CProof t' -> @@ -1313,8 +1308,7 @@ let trans_hyp h t0 prfp = (tclTHEN (Tactics.clear [h]) (Tactics.rename_hyp [(h', h)]))))) let trans_concl prfp = - if debug then - Feedback.msg_debug Pp.(str "trans_concl: " ++ pp_prfp prfp ++ fnl ()); + debug_zify (fun () -> Pp.(str "trans_concl: " ++ pp_prfp prfp ++ fnl ())); match prfp with | IProof -> Tacticals.New.tclIDTAC | CProof t -> diff --git a/plugins/nsatz/dune b/plugins/nsatz/dune index 3b67ab3429..2aaeec2665 100644 --- a/plugins/nsatz/dune +++ b/plugins/nsatz/dune @@ -1,7 +1,7 @@ (library (name nsatz_plugin) - (public_name coq.plugins.nsatz) + (public_name coq-core.plugins.nsatz) (synopsis "Coq's nsatz solver plugin") - (libraries coq.plugins.ltac)) + (libraries coq-core.plugins.ltac)) (coq.pp (modules g_nsatz)) diff --git a/plugins/nsatz/utile.ml b/plugins/nsatz/utile.ml index 1caa042db6..19bdcbac58 100644 --- a/plugins/nsatz/utile.ml +++ b/plugins/nsatz/utile.ml @@ -1,9 +1,9 @@ (* Printing *) let pr x = - if !Flags.debug then (Format.printf "@[%s@]" x; flush(stdout);)else () + if CDebug.(get_flag misc) then (Format.printf "@[%s@]" x; flush(stdout);)else () let prt0 s = () (* print_string s;flush(stdout)*) -let sinfo s = if !Flags.debug then Feedback.msg_debug (Pp.str s) -let info s = if !Flags.debug then Feedback.msg_debug (Pp.str (s ())) +let sinfo s = if CDebug.(get_flag misc) then Feedback.msg_debug (Pp.str s) +let info s = if CDebug.(get_flag misc) then Feedback.msg_debug (Pp.str (s ())) diff --git a/plugins/omega/dune b/plugins/omega/dune index 0db71ed6fb..a3c9342322 100644 --- a/plugins/omega/dune +++ b/plugins/omega/dune @@ -1,7 +1,7 @@ (library (name omega_plugin) - (public_name coq.plugins.omega) + (public_name coq-core.plugins.omega) (synopsis "Coq's omega plugin") - (libraries coq.plugins.ltac)) + (libraries coq-core.plugins.ltac)) (coq.pp (modules g_omega)) diff --git a/plugins/ring/dune b/plugins/ring/dune index 080d8c672e..40f310831a 100644 --- a/plugins/ring/dune +++ b/plugins/ring/dune @@ -1,7 +1,7 @@ (library (name ring_plugin) - (public_name coq.plugins.ring) + (public_name coq-core.plugins.ring) (synopsis "Coq's ring plugin") - (libraries coq.plugins.ltac)) + (libraries coq-core.plugins.ltac)) (coq.pp (modules g_ring)) diff --git a/plugins/rtauto/dune b/plugins/rtauto/dune index 43efa0eca5..a13f063550 100644 --- a/plugins/rtauto/dune +++ b/plugins/rtauto/dune @@ -1,7 +1,7 @@ (library (name rtauto_plugin) - (public_name coq.plugins.rtauto) + (public_name coq-core.plugins.rtauto) (synopsis "Coq's rtauto plugin") - (libraries coq.plugins.ltac)) + (libraries coq-core.plugins.ltac)) (coq.pp (modules g_rtauto)) diff --git a/plugins/ssr/dune b/plugins/ssr/dune index a117d09a16..4c28776bb7 100644 --- a/plugins/ssr/dune +++ b/plugins/ssr/dune @@ -1,9 +1,9 @@ (library (name ssreflect_plugin) - (public_name coq.plugins.ssreflect) + (public_name coq-core.plugins.ssreflect) (synopsis "Coq's ssreflect plugin") (modules_without_implementation ssrast) (flags :standard -open Gramlib) - (libraries coq.plugins.ssrmatching)) + (libraries coq-core.plugins.ssrmatching)) (coq.pp (modules ssrvernac ssrparser)) diff --git a/plugins/ssr/ssrcommon.ml b/plugins/ssr/ssrcommon.ml index 4d57abb465..41fd96ccb5 100644 --- a/plugins/ssr/ssrcommon.ml +++ b/plugins/ssr/ssrcommon.ml @@ -252,7 +252,7 @@ let interp_refine ist gl rc = in let sigma, c = Pretyping.understand_ltac flags (pf_env gl) (project gl) vars kind rc in (* ppdebug(lazy(str"sigma@interp_refine=" ++ pr_evar_map None sigma)); *) - ppdebug(lazy(str"c@interp_refine=" ++ Printer.pr_econstr_env (pf_env gl) sigma c)); + debug_ssr (fun () -> str"c@interp_refine=" ++ Printer.pr_econstr_env (pf_env gl) sigma c); (sigma, (sigma, c)) @@ -1207,7 +1207,7 @@ let gentac gen = Proofview.V82.tactic begin fun gl -> (* ppdebug(lazy(str"sigma@gentac=" ++ pr_evar_map None (project gl))); *) let conv, _, cl, c, clr, ucst,gl = pf_interp_gen_aux gl false gen in - ppdebug(lazy(str"c@gentac=" ++ pr_econstr_env (pf_env gl) (project gl) c)); + debug_ssr (fun () -> str"c@gentac=" ++ pr_econstr_env (pf_env gl) (project gl) c); let gl = pf_merge_uc ucst gl in if conv then tclTHEN (Proofview.V82.of_tactic (convert_concl ~check:true cl)) (old_cleartac clr) gl diff --git a/plugins/ssr/ssrelim.ml b/plugins/ssr/ssrelim.ml index 582c45cde1..78a59abda9 100644 --- a/plugins/ssr/ssrelim.ml +++ b/plugins/ssr/ssrelim.ml @@ -126,17 +126,17 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = fun (oc, orig_clr, occ, c_gen) -> pfLIFT begin fun gl -> let orig_gl, concl, env = gl, pf_concl gl, pf_env gl in - ppdebug(lazy(Pp.str(if is_case then "==CASE==" else "==ELIM=="))); + debug_ssr (fun () -> (Pp.str(if is_case then "==CASE==" else "==ELIM=="))); let fire_subst gl t = Reductionops.nf_evar (project gl) t in let is_undef_pat = function | sigma, T t -> EConstr.isEvar sigma (EConstr.of_constr t) | _ -> false in let match_pat env p occ h cl = let sigma0 = project orig_gl in - ppdebug(lazy Pp.(str"matching: " ++ pr_occ occ ++ pp_pattern env p)); + debug_ssr (fun () -> Pp.(str"matching: " ++ pr_occ occ ++ pp_pattern env p)); let (c,ucst), cl = fill_occ_pattern ~raise_NoMatch:true env sigma0 (EConstr.Unsafe.to_constr cl) p occ h in - ppdebug(lazy Pp.(str" got: " ++ pr_constr_env env sigma0 c)); + debug_ssr (fun () -> Pp.(str" got: " ++ pr_constr_env env sigma0 c)); c, EConstr.of_constr cl, ucst in let mkTpat gl t = (* takes a term, refreshes it and makes a T pattern *) let n, t, _, ucst = pf_abs_evars orig_gl (project gl, fire_subst gl t) in @@ -212,10 +212,10 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let renamed_tys = Array.mapi (fun j (ctx, cty) -> let t = Term.it_mkProd_or_LetIn cty ctx in - ppdebug(lazy Pp.(str "Search" ++ Printer.pr_constr_env env (project gl) t)); + debug_ssr (fun () -> Pp.(str "Search" ++ Printer.pr_constr_env env (project gl) t)); let t = Arguments_renaming.rename_type t (GlobRef.ConstructRef((kn,i),j+1)) in - ppdebug(lazy Pp.(str"Done Search " ++ Printer.pr_constr_env env (project gl) t)); + debug_ssr (fun () -> Pp.(str"Done Search " ++ Printer.pr_constr_env env (project gl) t)); t) tys in @@ -241,8 +241,8 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = in let () = let sigma = project gl in - ppdebug(lazy Pp.(str"elim= "++ pr_econstr_pat env sigma elim)); - ppdebug(lazy Pp.(str"elimty= "++ pr_econstr_pat env sigma elimty)) in + debug_ssr (fun () -> Pp.(str"elim= "++ pr_econstr_pat env sigma elim)); + debug_ssr (fun () -> Pp.(str"elimty= "++ pr_econstr_pat env sigma elimty)) in let open EConstr in let inf_deps_r = match kind_of_type (project gl) elimty with | AtomicType (_, args) -> List.rev (Array.to_list args) @@ -301,7 +301,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = | Some (c, _, _,gl) -> Some(true, gl) | None -> None in first [try_c_last_arg;try_c_last_pattern] in - ppdebug(lazy Pp.(str"c_is_head_p= " ++ bool c_is_head_p)); + debug_ssr (fun () -> Pp.(str"c_is_head_p= " ++ bool c_is_head_p)); let gl, predty = pfe_type_of gl pred in (* Patterns for the inductive types indexes to be bound in pred are computed * looking at the ones provided by the user and the inferred ones looking at @@ -321,7 +321,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = loop (patterns @ [i, p, inf_t, occ]) (clr_t @ clr) (i+1) (deps, inf_deps) | [], c :: inf_deps -> - ppdebug(lazy Pp.(str"adding inf pattern " ++ pr_econstr_pat env (project gl) c)); + debug_ssr (fun () -> Pp.(str"adding inf pattern " ++ pr_econstr_pat env (project gl) c)); loop (patterns @ [i, mkTpat gl c, c, allocc]) clr (i+1) ([], inf_deps) | _::_, [] -> errorstrm Pp.(str "Too many dependent abstractions") in @@ -337,8 +337,8 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = loop [] orig_clr (List.length head_p+1) (List.rev deps, inf_deps_r) in head_p @ patterns, Util.List.uniquize clr, gl in - ppdebug(lazy Pp.(pp_concat (str"patterns=") (List.map pp_pat patterns))); - ppdebug(lazy Pp.(pp_concat (str"inf. patterns=") (List.map (pp_inf_pat gl) patterns))); + debug_ssr (fun () -> Pp.(pp_concat (str"patterns=") (List.map pp_pat patterns))); + debug_ssr (fun () -> Pp.(pp_concat (str"inf. patterns=") (List.map (pp_inf_pat gl) patterns))); (* Predicate generation, and (if necessary) tactic to generalize the * equation asked by the user *) let elim_pred, gen_eq_tac, clr, gl = @@ -348,7 +348,7 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = let match_or_postpone (cl, gl, post) (h, p, inf_t, occ) = let p = unif_redex gl p inf_t in if is_undef_pat p then - let () = ppdebug(lazy Pp.(str"postponing " ++ pp_pattern env p)) in + let () = debug_ssr (fun () -> Pp.(str"postponing " ++ pp_pattern env p)) in cl, gl, post @ [h, p, inf_t, occ] else try let c, cl, ucst = match_pat env p occ h cl in @@ -420,8 +420,8 @@ let ssrelim ?(is_case=false) deps what ?elim eqid elim_intro_tac = else gl, concl in concl, gen_eq_tac, clr, gl in let gl, pty = pf_e_type_of gl elim_pred in - ppdebug(lazy Pp.(str"elim_pred=" ++ pp_term gl elim_pred)); - ppdebug(lazy Pp.(str"elim_pred_ty=" ++ pp_term gl pty)); + debug_ssr (fun () -> Pp.(str"elim_pred=" ++ pp_term gl elim_pred)); + debug_ssr (fun () -> Pp.(str"elim_pred_ty=" ++ pp_term gl pty)); let gl = pf_unify_HO gl pred elim_pred in let elim = fire_subst gl elim in let gl = pf_resolve_typeclasses ~where:elim ~fail:false gl in diff --git a/plugins/ssr/ssrequality.ml b/plugins/ssr/ssrequality.ml index 0008d31ffd..92a481dd18 100644 --- a/plugins/ssr/ssrequality.ml +++ b/plugins/ssr/ssrequality.ml @@ -76,7 +76,7 @@ let simpltac s = Proofview.Goal.enter (fun _ -> simpltac s) (** The "congr" tactic *) let interp_congrarg_at ist gl n rf ty m = - ppdebug(lazy Pp.(str"===interp_congrarg_at===")); + debug_ssr (fun () -> Pp.(str"===interp_congrarg_at===")); let congrn, _ = mkSsrRRef "nary_congruence" in let args1 = mkRnat n :: mkRHoles n @ [ty] in let args2 = mkRHoles (3 * n) in @@ -84,7 +84,7 @@ let interp_congrarg_at ist gl n rf ty m = if i + n > m then None else try let rt = mkRApp congrn (args1 @ mkRApp rf (mkRHoles i) :: args2) in - ppdebug(lazy Pp.(str"rt=" ++ Printer.pr_glob_constr_env (pf_env gl) (project gl) rt)); + debug_ssr (fun () -> Pp.(str"rt=" ++ Printer.pr_glob_constr_env (pf_env gl) (project gl) rt)); Some (interp_refine ist gl rt) with _ -> loop (i + 1) in loop 0 @@ -92,8 +92,8 @@ let interp_congrarg_at ist gl n rf ty m = let pattern_id = mk_internal_id "pattern value" let congrtac ((n, t), ty) ist gl = - ppdebug(lazy (Pp.str"===congr===")); - ppdebug(lazy Pp.(str"concl=" ++ Printer.pr_econstr_env (pf_env gl) (project gl) (Tacmach.pf_concl gl))); + debug_ssr (fun () -> (Pp.str"===congr===")); + debug_ssr (fun () -> Pp.(str"concl=" ++ Printer.pr_econstr_env (pf_env gl) (project gl) (Tacmach.pf_concl gl))); let sigma, _ as it = interp_term (pf_env gl) (project gl) ist t in let gl = pf_merge_uc_of sigma gl in let _, f, _, _ucst = pf_abs_evars gl it in @@ -124,8 +124,8 @@ let newssrcongrtac arg ist = Proofview.Goal.enter_one ~__LOC__ begin fun _g -> (Ssrcommon.tacMK_SSR_CONST "ssr_congr_arrow") end >>= fun arr -> Proofview.V82.tactic begin fun gl -> - ppdebug(lazy Pp.(str"===newcongr===")); - ppdebug(lazy Pp.(str"concl=" ++ Printer.pr_econstr_env (pf_env gl) (project gl) (pf_concl gl))); + debug_ssr (fun () -> Pp.(str"===newcongr===")); + debug_ssr (fun () -> Pp.(str"concl=" ++ Printer.pr_econstr_env (pf_env gl) (project gl) (pf_concl gl))); (* utils *) let fs gl t = Reductionops.nf_evar (project gl) t in let tclMATCH_GOAL (c, gl_c) proj t_ok t_fail gl = @@ -385,8 +385,8 @@ let pirrel_rewrite ?(under=false) ?(map_redex=id_map_redex) pred rdx rdx_ty new_ | Pretype_errors.PretypeError (env, sigma, te) -> raise (PRtype_error (Some (env, sigma, te))) | e when CErrors.noncritical e -> raise (PRtype_error None) in - ppdebug(lazy Pp.(str"pirrel_rewrite: proof term: " ++ pr_econstr_env env sigma proof)); - ppdebug(lazy Pp.(str"pirrel_rewrite of type: " ++ pr_econstr_env env sigma proof_ty)); + debug_ssr (fun () -> Pp.(str"pirrel_rewrite: proof term: " ++ pr_econstr_env env sigma proof)); + debug_ssr (fun () -> Pp.(str"pirrel_rewrite of type: " ++ pr_econstr_env env sigma proof_ty)); try Proofview.V82.of_tactic (refine_with ~first_goes_last:(not !ssroldreworder || under) ~with_evars:under (sigma, proof)) gl with e when CErrors.noncritical e -> @@ -435,12 +435,12 @@ let rwcltac ?under ?map_redex cl rdx dir sr = let sigma0 = Evd.set_universe_context sigma0 ucst in let rdxt = Retyping.get_type_of env (fst sr) rdx in (* ppdebug(lazy(str"sigma@rwcltac=" ++ pr_evar_map None (fst sr))); *) - ppdebug(lazy Pp.(str"r@rwcltac=" ++ pr_econstr_env env sigma0 (snd sr))); + debug_ssr (fun () -> Pp.(str"r@rwcltac=" ++ pr_econstr_env env sigma0 (snd sr))); let cvtac, rwtac, sigma0 = if EConstr.Vars.closed0 sigma0 r' then let sigma, c, c_eq = fst sr, snd sr, Coqlib.(lib_ref "core.eq.type") in let sigma, c_ty = Typing.type_of env sigma c in - ppdebug(lazy Pp.(str"c_ty@rwcltac=" ++ pr_econstr_env env sigma c_ty)); + debug_ssr (fun () -> Pp.(str"c_ty@rwcltac=" ++ pr_econstr_env env sigma c_ty)); let open EConstr in match kind_of_type sigma (Reductionops.whd_all env sigma c_ty) with | AtomicType(e, a) when Ssrcommon.is_ind_ref sigma e c_eq -> @@ -521,7 +521,7 @@ let rwprocess_rule env dir rule = let t = if red = 1 then Tacred.hnf_constr env sigma t0 else Reductionops.whd_betaiotazeta env sigma t0 in - ppdebug(lazy Pp.(str"rewrule="++pr_econstr_pat env sigma t)); + debug_ssr (fun () -> Pp.(str"rewrule="++pr_econstr_pat env sigma t)); match EConstr.kind sigma t with | Prod (_, xt, at) -> let sigma = Evd.create_evar_defs sigma in diff --git a/plugins/ssr/ssrfwd.ml b/plugins/ssr/ssrfwd.ml index f2c7f495b3..bc46c23761 100644 --- a/plugins/ssr/ssrfwd.ml +++ b/plugins/ssr/ssrfwd.ml @@ -296,8 +296,8 @@ let wlogtac ist (((clr0, pats),_),_) (gens, ((_, ct))) hint suff ghave = | Some id -> if pats = [] then Tacticals.New.tclIDTAC else let args = Array.of_list args in - ppdebug(lazy(str"specialized="++ pr_econstr_env (pf_env gl) (project gl) EConstr.(mkApp (mkVar id,args)))); - ppdebug(lazy(str"specialized_ty="++ pr_econstr_env (pf_env gl) (project gl) ct)); + debug_ssr (fun () -> str"specialized="++ pr_econstr_env (pf_env gl) (project gl) EConstr.(mkApp (mkVar id,args))); + debug_ssr (fun () -> str"specialized_ty="++ pr_econstr_env (pf_env gl) (project gl) ct); Tacticals.New.tclTHENS (basecuttac "ssr_have" ct) [Tactics.apply EConstr.(mkApp (mkVar id,args)); Tacticals.New.tclIDTAC] in "ssr_have", @@ -395,7 +395,7 @@ let intro_lock ipats = Array.length args = 3 && is_app_evar sigma args.(2) -> protect_subgoal env sigma hd args | _ -> - ppdebug(lazy Pp.(str"under: stop:" ++ pr_econstr_env env sigma t)); + debug_ssr (fun () -> Pp.(str"under: stop:" ++ pr_econstr_env env sigma t)); Proofview.tclUNIT () end) @@ -468,13 +468,13 @@ let undertac ?(pad_intro = false) ist ipats ((dir,_),_ as rule) hint = | Some l -> [IPatCase(Regular [l;[]])] in let map_redex env evar_map ~before:_ ~after:t = - ppdebug(lazy Pp.(str"under vars: " ++ prlist Names.Name.print varnames)); + debug_ssr (fun () -> Pp.(str"under vars: " ++ prlist Names.Name.print varnames)); let evar_map, ty = Typing.type_of env evar_map t in let new_t = (* pretty-rename the bound variables *) try begin match EConstr.destApp evar_map t with (f, ar) -> let lam = Array.last ar in - ppdebug(lazy Pp.(str"under: mapping:" ++ + debug_ssr(fun () -> Pp.(str"under: mapping:" ++ pr_econstr_env env evar_map lam)); let new_lam = pretty_rename evar_map lam varnames in let new_ar, len1 = Array.copy ar, pred (Array.length ar) in @@ -482,10 +482,10 @@ let undertac ?(pad_intro = false) ist ipats ((dir,_),_ as rule) hint = EConstr.mkApp (f, new_ar) end with | DestKO -> - ppdebug(lazy Pp.(str"under: cannot pretty-rename bound variables with destApp")); + debug_ssr (fun () -> Pp.(str"under: cannot pretty-rename bound variables with destApp")); t in - ppdebug(lazy Pp.(str"under: to:" ++ pr_econstr_env env evar_map new_t)); + debug_ssr (fun () -> Pp.(str"under: to:" ++ pr_econstr_env env evar_map new_t)); evar_map, new_t in let undertacs = diff --git a/plugins/ssr/ssripats.ml b/plugins/ssr/ssripats.ml index 1e940b5ad3..f8abed5482 100644 --- a/plugins/ssr/ssripats.ml +++ b/plugins/ssr/ssripats.ml @@ -324,7 +324,7 @@ end `tac`, where k is the size of `seeds` *) let tclSEED_SUBGOALS seeds tac = tclTHENin tac (fun i n -> - Ssrprinters.ppdebug (lazy Pp.(str"seeding")); + Ssrprinters.debug_ssr (fun () -> Pp.(str"seeding")); (* eg [case: (H _ : nat)] generates 3 goals: - 1 for _ - 2 for the nat constructors *) @@ -416,11 +416,11 @@ let tclMK_ABSTRACT_VARS ids = (* Debugging *) let tclLOG p t = tclUNIT () >>= begin fun () -> - Ssrprinters.ppdebug (lazy Pp.(str "exec: " ++ pr_ipatop p)); + Ssrprinters.debug_ssr (fun () -> Pp.(str "exec: " ++ pr_ipatop p)); tclUNIT () end <*> Goal.enter begin fun g -> - Ssrprinters.ppdebug (lazy Pp.(str" on state:" ++ spc () ++ + Ssrprinters.debug_ssr (fun () -> Pp.(str" on state:" ++ spc () ++ isPRINT g ++ str" goal:" ++ spc () ++ Printer.pr_goal (Goal.print g))); tclUNIT () @@ -429,7 +429,7 @@ let tclLOG p t = t p >>= fun ret -> Goal.enter begin fun g -> - Ssrprinters.ppdebug (lazy Pp.(str "done: " ++ isPRINT g)); + Ssrprinters.debug_ssr (fun () -> Pp.(str "done: " ++ isPRINT g)); tclUNIT () end >>= fun () -> tclUNIT ret @@ -579,10 +579,10 @@ let tclCompileIPats l = elab l ;; let tclCompileIPats l = - Ssrprinters.ppdebug (lazy Pp.(str "tclCompileIPats input: " ++ + Ssrprinters.debug_ssr (fun () -> Pp.(str "tclCompileIPats input: " ++ prlist_with_sep spc Ssrprinters.pr_ipat l)); let ops = tclCompileIPats l in - Ssrprinters.ppdebug (lazy Pp.(str "tclCompileIPats output: " ++ + Ssrprinters.debug_ssr (fun () -> Pp.(str "tclCompileIPats output: " ++ prlist_with_sep spc pr_ipatop ops)); ops @@ -597,11 +597,11 @@ let main ?eqtac ~first_case_is_dispatch iops = end (* }}} *) let tclIPAT_EQ eqtac ip = - Ssrprinters.ppdebug (lazy Pp.(str "ipat@run: " ++ Ssrprinters.pr_ipats ip)); + Ssrprinters.debug_ssr (fun () -> Pp.(str "ipat@run: " ++ Ssrprinters.pr_ipats ip)); IpatMachine.(main ~eqtac ~first_case_is_dispatch:true (tclCompileIPats ip)) let tclIPATssr ip = - Ssrprinters.ppdebug (lazy Pp.(str "ipat@run: " ++ Ssrprinters.pr_ipats ip)); + Ssrprinters.debug_ssr (fun () -> Pp.(str "ipat@run: " ++ Ssrprinters.pr_ipats ip)); IpatMachine.(main ~first_case_is_dispatch:true (tclCompileIPats ip)) let tclCompileIPats = IpatMachine.tclCompileIPats diff --git a/plugins/ssr/ssrprinters.ml b/plugins/ssr/ssrprinters.ml index 6ed68094dc..434568b554 100644 --- a/plugins/ssr/ssrprinters.ml +++ b/plugins/ssr/ssrprinters.ml @@ -15,7 +15,6 @@ open Names open Printer open Tacmach -open Ssrmatching_plugin open Ssrast let pr_spc () = str " " @@ -121,15 +120,4 @@ and pr_block = function (Prefix id) -> str"^" ++ Id.print id | (SuffixId id) -> str"^~" ++ Id.print id | (SuffixNum n) -> str"^~" ++ int n -(* 0 cost pp function. Active only if Debug Ssreflect is Set *) -let ppdebug_ref = ref (fun _ -> ()) -let ssr_pp s = Feedback.msg_debug (str"SSR: "++Lazy.force s) -let () = - Goptions.(declare_bool_option - { optkey = ["Debug";"Ssreflect"]; - optdepr = false; - optread = (fun _ -> !ppdebug_ref == ssr_pp); - optwrite = (fun b -> - Ssrmatching.debug b; - if b then ppdebug_ref := ssr_pp else ppdebug_ref := fun _ -> ()) }) -let ppdebug s = !ppdebug_ref s +let debug_ssr = CDebug.create ~name:"ssreflect" () diff --git a/plugins/ssr/ssrprinters.mli b/plugins/ssr/ssrprinters.mli index 21fb28038a..994577a0c9 100644 --- a/plugins/ssr/ssrprinters.mli +++ b/plugins/ssr/ssrprinters.mli @@ -51,5 +51,4 @@ val pr_guarded : val pr_occ : ssrocc -> Pp.t -val ppdebug : Pp.t Lazy.t -> unit - +val debug_ssr : CDebug.t diff --git a/plugins/ssr/ssrview.ml b/plugins/ssr/ssrview.ml index 97926753f5..b3a9e71a3f 100644 --- a/plugins/ssr/ssrview.ml +++ b/plugins/ssr/ssrview.ml @@ -194,17 +194,17 @@ let mkGApp f args = let interp_glob ist glob = Goal.enter_one ~__LOC__ begin fun goal -> let env = Goal.env goal in let sigma = Goal.sigma goal in - Ssrprinters.ppdebug (lazy + Ssrprinters.debug_ssr (fun () -> Pp.(str"interp-in: " ++ Printer.pr_glob_constr_env env sigma glob)); try let sigma,term = Tacinterp.interp_open_constr ist env sigma (glob,None) in - Ssrprinters.ppdebug (lazy + Ssrprinters.debug_ssr (fun () -> Pp.(str"interp-out: " ++ Printer.pr_econstr_env env sigma term)); tclUNIT (env,sigma,term) with e -> (* XXX this is another catch all! *) let e, info = Exninfo.capture e in - Ssrprinters.ppdebug (lazy + Ssrprinters.debug_ssr (fun () -> Pp.(str"interp-err: " ++ Printer.pr_glob_constr_env env sigma glob)); tclZERO ~info e end @@ -217,7 +217,7 @@ end let tclKeepOpenConstr (_env, sigma, t) = Unsafe.tclEVARS sigma <*> tclUNIT t let tclADD_CLEAR_IF_ID (env, ist, t) x = - Ssrprinters.ppdebug (lazy + Ssrprinters.debug_ssr (fun () -> Pp.(str"tclADD_CLEAR_IF_ID: " ++ Printer.pr_econstr_env env ist t)); let hd, args = EConstr.decompose_app ist t in match EConstr.kind ist hd with @@ -269,11 +269,11 @@ let interp_view ~clear_if_id ist v p = let p_id = DAst.make p_id in match DAst.get v with | Glob_term.GApp (hd, rargs) when is_specialize hd -> - Ssrprinters.ppdebug (lazy Pp.(str "specialize")); + Ssrprinters.debug_ssr (fun () -> Pp.(str "specialize")); interp_glob ist (mkGApp p_id rargs) >>= tclKeepOpenConstr >>= tclPAIR [] | _ -> - Ssrprinters.ppdebug (lazy Pp.(str "view")); + Ssrprinters.debug_ssr (fun () -> Pp.(str "view")); (* We find out how to build (v p) eventually using an adaptor *) let adaptors = AdaptorDb.(get Forward) in Proofview.tclORELSE @@ -324,7 +324,7 @@ Goal.enter_one ~__LOC__ begin fun g -> let rigid = rigid_of und0 in let n, p, to_prune, _ucst = pf_abs_evars2 s0 rigid (sigma, p) in let p = if simple_types then pf_abs_cterm s0 n p else p in - Ssrprinters.ppdebug (lazy Pp.(str"view@finalized: " ++ + Ssrprinters.debug_ssr (fun () -> Pp.(str"view@finalized: " ++ Printer.pr_econstr_env env sigma p)); let sigma = List.fold_left Evd.remove sigma to_prune in Unsafe.tclEVARS sigma <*> @@ -349,26 +349,26 @@ let rec apply_all_views_aux ~clear_if_id vs finalization conclusion s0 = pose_proof name p <*> conclusion ~to_clear:name) <*> tclUNIT false) | v :: vs -> - Ssrprinters.ppdebug (lazy Pp.(str"piling...")); + Ssrprinters.debug_ssr (fun () -> Pp.(str"piling...")); is_tac_in_term ~extra_scope:"ssripat" v >>= function | `Term v -> - Ssrprinters.ppdebug (lazy Pp.(str"..a term")); + Ssrprinters.debug_ssr (fun () -> Pp.(str"..a term")); pile_up_view ~clear_if_id v <*> apply_all_views_aux ~clear_if_id vs finalization conclusion s0 | `Tac tac -> - Ssrprinters.ppdebug (lazy Pp.(str"..a tactic")); + Ssrprinters.debug_ssr (fun () -> Pp.(str"..a tactic")); finalization s0 (fun name p -> (match p with | None -> tclUNIT () | Some p -> pose_proof name p) <*> Tacinterp.eval_tactic tac <*> if vs = [] then begin - Ssrprinters.ppdebug (lazy Pp.(str"..was the last view")); + Ssrprinters.debug_ssr (fun () -> Pp.(str"..was the last view")); conclusion ~to_clear:name <*> tclUNIT true end else Tactics.clear name <*> tclINDEPENDENTL begin - Ssrprinters.ppdebug (lazy Pp.(str"..was NOT the last view")); + Ssrprinters.debug_ssr (fun () -> Pp.(str"..was NOT the last view")); Ssrcommon.tacSIGMA >>= apply_all_views_aux ~clear_if_id vs finalization conclusion end >>= reduce_or) diff --git a/plugins/ssrmatching/dune b/plugins/ssrmatching/dune index 629d723816..efaa09c939 100644 --- a/plugins/ssrmatching/dune +++ b/plugins/ssrmatching/dune @@ -1,7 +1,7 @@ (library (name ssrmatching_plugin) - (public_name coq.plugins.ssrmatching) + (public_name coq-core.plugins.ssrmatching) (synopsis "Coq ssrmatching plugin") - (libraries coq.plugins.ltac)) + (libraries coq-core.plugins.ltac)) (coq.pp (modules g_ssrmatching)) diff --git a/plugins/ssrsearch/dune b/plugins/ssrsearch/dune index 2851835eae..a38bec496f 100644 --- a/plugins/ssrsearch/dune +++ b/plugins/ssrsearch/dune @@ -1,7 +1,7 @@ (library (name ssrsearch_plugin) - (public_name coq.plugins.ssrsearch) + (public_name coq-core.plugins.ssrsearch) (synopsis "Deprecated Search command from SSReflect") - (libraries coq.plugins.ssreflect)) + (libraries coq-core.plugins.ssreflect)) (coq.pp (modules g_search)) diff --git a/plugins/syntax/dune b/plugins/syntax/dune index f930fc265a..b00242be1a 100644 --- a/plugins/syntax/dune +++ b/plugins/syntax/dune @@ -1,22 +1,15 @@ (library (name number_string_notation_plugin) - (public_name coq.plugins.number_string_notation) + (public_name coq-core.plugins.number_string_notation) (synopsis "Coq number and string notation plugin") (modules g_number_string string_notation number) - (libraries coq.vernac)) - -(library - (name int63_syntax_plugin) - (public_name coq.plugins.int63_syntax) - (synopsis "Coq syntax plugin: int63") - (modules int63_syntax) - (libraries coq.vernac)) + (libraries coq-core.vernac)) (library (name float_syntax_plugin) - (public_name coq.plugins.float_syntax) + (public_name coq-core.plugins.float_syntax) (synopsis "Coq syntax plugin: float") (modules float_syntax) - (libraries coq.vernac)) + (libraries coq-core.vernac)) (coq.pp (modules g_number_string)) diff --git a/plugins/syntax/int63_syntax.ml b/plugins/syntax/int63_syntax.ml deleted file mode 100644 index 110b26581f..0000000000 --- a/plugins/syntax/int63_syntax.ml +++ /dev/null @@ -1,58 +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) *) -(************************************************************************) - - -(* Poor's man DECLARE PLUGIN *) -let __coq_plugin_name = "int63_syntax_plugin" -let () = Mltop.add_known_module __coq_plugin_name - -(* digit-based syntax for int63 *) - -open Names -open Libnames - -(*** Constants for locating int63 constructors ***) - -let q_int63 = qualid_of_string "Coq.Numbers.Cyclic.Int63.PrimInt63.int" -let q_id_int63 = qualid_of_string "Coq.Numbers.Cyclic.Int63.PrimInt63.id_int" - -let make_dir l = DirPath.make (List.rev_map Id.of_string l) -let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) - -(* int63 stuff *) -let int63_module = ["Coq"; "Numbers"; "Cyclic"; "Int63"; "PrimInt63"] -let int63_path = make_path int63_module "int" -let int63_scope = "int63_scope" - -let at_declare_ml_module f x = - Mltop.declare_cache_obj (fun () -> f x) __coq_plugin_name - -(* Actually declares the interpreter for int63 *) - -let _ = - let open Notation in - at_declare_ml_module - (fun () -> - let id_int63 = Nametab.locate q_id_int63 in - let o = { to_kind = Int63, Direct; - to_ty = id_int63; - to_post = [||]; - of_kind = Int63, Direct; - of_ty = id_int63; - ty_name = q_int63; - warning = Nop } in - enable_prim_token_interpretation - { pt_local = false; - pt_scope = int63_scope; - pt_interp_info = NumberNotation o; - pt_required = (int63_path, int63_module); - pt_refs = []; - pt_in_match = false }) - () diff --git a/plugins/syntax/number.ml b/plugins/syntax/number.ml index 0e7640f430..551e2bac5d 100644 --- a/plugins/syntax/number.ml +++ b/plugins/syntax/number.ml @@ -106,10 +106,12 @@ let locate_number () = let locate_int63 () = let int63n = "num.int63.type" in - if Coqlib.has_ref int63n + let pos_neg_int63n = "num.int63.pos_neg_int63" in + if Coqlib.has_ref int63n && Coqlib.has_ref pos_neg_int63n then - let q_int63 = qualid_of_ref int63n in - Some (mkRefC q_int63) + let q_pos_neg_int63 = qualid_of_ref pos_neg_int63n in + Some ({pos_neg_int63_ty = unsafe_locate_ind q_pos_neg_int63}, + mkRefC q_pos_neg_int63) else None let has_type env sigma f ty = @@ -121,20 +123,13 @@ let type_error_to f ty = CErrors.user_err (pr_qualid f ++ str " should go from Number.int to " ++ pr_qualid ty ++ str " or (option " ++ pr_qualid ty ++ str ")." ++ - fnl () ++ str "Instead of Number.int, the types Number.uint or Z or Int63.int or Number.number could be used (you may need to require BinNums or Number or Int63 first).") + fnl () ++ str "Instead of Number.int, the types Number.uint or Z or PrimInt63.pos_neg_int63 or Number.number could be used (you may need to require BinNums or Number or PrimInt63 first).") let type_error_of g ty = CErrors.user_err (pr_qualid g ++ str " should go from " ++ pr_qualid ty ++ str " to Number.int or (option Number.int)." ++ fnl () ++ - str "Instead of Number.int, the types Number.uint or Z or Int63.int or Number.number could be used (you may need to require BinNums or Number or Int63 first).") - -let warn_deprecated_decimal = - CWarnings.create ~name:"decimal-numeral-notation" ~category:"deprecated" - (fun () -> - strbrk "Deprecated Number Notation for Decimal.uint, \ - Decimal.int or Decimal.decimal. Use Number.uint, \ - Number.int or Number.number respectively.") + str "Instead of Number.int, the types Number.uint or Z or PrimInt63.pos_neg_int63 or Number.number could be used (you may need to require BinNums or Number or PrimInt63 first).") let error_params ind = CErrors.user_err @@ -381,22 +376,37 @@ let elaborate_to_post_via env sigma ty_name ty_ind l = let pt_refs = List.map (fun (_, cnst, _) -> cnst) (to_post.(0)) in to_post, pt_refs -let locate_global_inductive allow_params qid = - let locate_param_inductive qid = +type target_type = + | TargetInd of (inductive * GlobRef.t option list) + | TargetPrim of required_module + +let locate_global_inductive_with_params allow_params qid = + if not allow_params then raise Not_found else match Nametab.locate_extended qid with | Globnames.TrueGlobal _ -> raise Not_found | Globnames.SynDef kn -> match Syntax_def.search_syntactic_definition kn with - | [], Notation_term.(NApp (NRef (GlobRef.IndRef i,None), l)) when allow_params -> + | [], Notation_term.(NApp (NRef (GlobRef.IndRef i,None), l)) -> i, List.map (function | Notation_term.NRef (r,None) -> Some r | Notation_term.NHole _ -> None | _ -> raise Not_found) l - | _ -> raise Not_found in - try locate_param_inductive qid + | _ -> raise Not_found + +let locate_global_inductive allow_params qid = + try locate_global_inductive_with_params allow_params qid with Not_found -> Smartlocate.global_inductive_with_alias qid, [] +let locate_global_inductive_or_int63 allow_params qid = + try TargetInd (locate_global_inductive_with_params allow_params qid) + with Not_found -> + let int63n = "num.int63.type" in + if allow_params && Coqlib.has_ref int63n + && GlobRef.equal (Smartlocate.global_with_alias qid) (Coqlib.lib_ref int63n) + then TargetPrim (Nametab.path_of_global (Coqlib.lib_ref int63n), []) + else TargetInd (Smartlocate.global_inductive_with_alias qid, []) + let vernac_number_notation local ty f g opts scope = let rec parse_opts = function | [] -> None, Nop @@ -421,7 +431,7 @@ let vernac_number_notation local ty f g opts scope = let ty_name = ty in let ty, via = match via with None -> ty, via | Some (ty', a) -> ty', Some (ty, a) in - let tyc, params = locate_global_inductive (via = None) ty in + let tyc_params = locate_global_inductive_or_int63 (via = None) ty in let to_ty = Smartlocate.global_with_alias f in let of_ty = Smartlocate.global_with_alias g in let cty = mkRefC ty in @@ -439,23 +449,20 @@ let vernac_number_notation local ty f g opts scope = | Some (int_ty, _, cuint, _, _, _, _, _) when has_type env sigma f (arrow cuint (opt cty)) -> UInt int_ty, Option | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma f (arrow cnum cty) -> Number num_ty, Direct | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma f (arrow cnum (opt cty)) -> Number num_ty, Option - | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma f (arrow cint cty) -> DecimalInt int_ty, Direct - | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma f (arrow cint (opt cty)) -> DecimalInt int_ty, Option - | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma f (arrow cuint cty) -> DecimalUInt int_ty, Direct - | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma f (arrow cuint (opt cty)) -> DecimalUInt int_ty, Option - | Some (_, _, _, _, _, num_ty, _, cdec) when has_type env sigma f (arrow cdec cty) -> Decimal num_ty, Direct - | Some (_, _, _, _, _, num_ty, _, cdec) when has_type env sigma f (arrow cdec (opt cty)) -> Decimal num_ty, Option | _ -> match z_pos_ty with | Some (z_pos_ty, cZ) when has_type env sigma f (arrow cZ cty) -> Z z_pos_ty, Direct | Some (z_pos_ty, cZ) when has_type env sigma f (arrow cZ (opt cty)) -> Z z_pos_ty, Option | _ -> match int63_ty with - | Some cint63 when has_type env sigma f (arrow cint63 cty) -> Int63, Direct - | Some cint63 when has_type env sigma f (arrow cint63 (opt cty)) -> Int63, Option + | Some (pos_neg_int63_ty, cint63) when has_type env sigma f (arrow cint63 cty) -> Int63 pos_neg_int63_ty, Direct + | Some (pos_neg_int63_ty, cint63) when has_type env sigma f (arrow cint63 (opt cty)) -> Int63 pos_neg_int63_ty, Option | _ -> type_error_to f ty in (* Check the type of g *) + let cty = match tyc_params with + | TargetPrim _ -> mkRefC (qualid_of_string "Coq.Numbers.Cyclic.Int63.PrimInt63.int_wrapper") + | TargetInd _ -> cty in let of_kind = match num_ty with | Some (int_ty, cint, _, _, _, _, _, _) when has_type env sigma g (arrow cty cint) -> Int int_ty, Direct @@ -464,30 +471,24 @@ let vernac_number_notation local ty f g opts scope = | Some (int_ty, _, cuint, _, _, _, _, _) when has_type env sigma g (arrow cty (opt cuint)) -> UInt int_ty, Option | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma g (arrow cty cnum) -> Number num_ty, Direct | Some (_, _, _, _, _, num_ty, cnum, _) when has_type env sigma g (arrow cty (opt cnum)) -> Number num_ty, Option - | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma g (arrow cty cint) -> DecimalInt int_ty, Direct - | Some (int_ty, _, _, cint, _, _, _, _) when has_type env sigma g (arrow cty (opt cint)) -> DecimalInt int_ty, Option - | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma g (arrow cty cuint) -> DecimalUInt int_ty, Direct - | Some (int_ty, _, _, _, cuint, _, _, _) when has_type env sigma g (arrow cty (opt cuint)) -> DecimalUInt int_ty, Option - | Some (_, _, _, _, _, num_ty, _, cdec) when has_type env sigma g (arrow cty cdec) -> Decimal num_ty, Direct - | Some (_, _, _, _, _, num_ty, _, cdec) when has_type env sigma g (arrow cty (opt cdec)) -> Decimal num_ty, Option | _ -> match z_pos_ty with | Some (z_pos_ty, cZ) when has_type env sigma g (arrow cty cZ) -> Z z_pos_ty, Direct | Some (z_pos_ty, cZ) when has_type env sigma g (arrow cty (opt cZ)) -> Z z_pos_ty, Option | _ -> match int63_ty with - | Some cint63 when has_type env sigma g (arrow cty cint63) -> Int63, Direct - | Some cint63 when has_type env sigma g (arrow cty (opt cint63)) -> Int63, Option + | Some (pos_neg_int63_ty, cint63) when has_type env sigma g (arrow cty cint63) -> Int63 pos_neg_int63_ty, Direct + | Some (pos_neg_int63_ty, cint63) when has_type env sigma g (arrow cty (opt cint63)) -> Int63 pos_neg_int63_ty, Option | _ -> type_error_of g ty in - (match to_kind, of_kind with - | ((DecimalInt _ | DecimalUInt _ | Decimal _), _), _ - | _, ((DecimalInt _ | DecimalUInt _ | Decimal _), _) -> - warn_deprecated_decimal () - | _ -> ()); - let to_post, pt_refs = match via with - | None -> elaborate_to_post_params env sigma tyc params - | Some (ty, l) -> elaborate_to_post_via env sigma ty tyc l in + let to_post, pt_required, pt_refs = match tyc_params with + | TargetPrim path -> [||], path, [Coqlib.lib_ref "num.int63.wrap_int"] + | TargetInd (tyc, params) -> + let to_post, pt_refs = + match via with + | None -> elaborate_to_post_params env sigma tyc params + | Some (ty, l) -> elaborate_to_post_via env sigma ty tyc l in + to_post, (Nametab.path_of_global (GlobRef.IndRef tyc), []), pt_refs in let o = { to_kind; to_ty; to_post; of_kind; of_ty; ty_name; warning = opts } in @@ -498,7 +499,7 @@ let vernac_number_notation local ty f g opts scope = { pt_local = local; pt_scope = scope; pt_interp_info = NumberNotation o; - pt_required = Nametab.path_of_global (GlobRef.IndRef tyc),[]; + pt_required; pt_refs; pt_in_match = true } in diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index 7930c3d634..02fb347d08 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -201,10 +201,7 @@ let cofixp_reducible flgs _ stk = else false -let get_debug_cbv = Goptions.declare_bool_option_and_ref - ~depr:false - ~value:false - ~key:["Debug";"Cbv"] +let debug_cbv = CDebug.create ~name:"Cbv" () (* Reduction of primitives *) @@ -525,7 +522,7 @@ and norm_head_ref k info env stack normt t = if red_set_ref info.reds normt then match cbv_value_cache info normt with | Declarations.Def body -> - if get_debug_cbv () then Feedback.msg_debug Pp.(str "Unfolding " ++ debug_pr_key normt); + debug_cbv (fun () -> Pp.(str "Unfolding " ++ debug_pr_key normt)); strip_appl (shift_value k body) stack | Declarations.Primitive op -> let c = match normt with @@ -534,11 +531,11 @@ and norm_head_ref k info env stack normt t = in (PRIMITIVE(op,c,[||]),stack) | Declarations.OpaqueDef _ | Declarations.Undef _ -> - if get_debug_cbv () then Feedback.msg_debug Pp.(str "Not unfolding " ++ debug_pr_key normt); + debug_cbv (fun () -> Pp.(str "Not unfolding " ++ debug_pr_key normt)); (VAL(0,make_constr_ref k normt t),stack) else begin - if get_debug_cbv () then Feedback.msg_debug Pp.(str "Not unfolding " ++ debug_pr_key normt); + debug_cbv (fun () -> Pp.(str "Not unfolding " ++ debug_pr_key normt)); (VAL(0,make_constr_ref k normt t),stack) end diff --git a/pretyping/coercionops.ml b/pretyping/coercionops.ml index 8ddc576d83..274dbfd7ed 100644 --- a/pretyping/coercionops.ml +++ b/pretyping/coercionops.ml @@ -34,6 +34,31 @@ type cl_info_typ = { cl_param : int } +let cl_typ_ord t1 t2 = match t1, t2 with + | CL_SECVAR v1, CL_SECVAR v2 -> Id.compare v1 v2 + | CL_CONST c1, CL_CONST c2 -> Constant.CanOrd.compare c1 c2 + | CL_PROJ c1, CL_PROJ c2 -> Projection.Repr.CanOrd.compare c1 c2 + | CL_IND i1, CL_IND i2 -> Ind.CanOrd.compare i1 i2 + | _ -> pervasives_compare t1 t2 (** OK *) + +let cl_typ_eq t1 t2 = Int.equal (cl_typ_ord t1 t2) 0 + +module ClTyp = struct + type t = cl_typ + let compare = cl_typ_ord +end + +module ClPairOrd = +struct + type t = cl_typ * cl_typ + let compare (i1, j1) (i2, j2) = + let c = cl_typ_ord i1 i2 in + if Int.equal c 0 then cl_typ_ord j1 j2 else c +end + +module ClTypMap = Map.Make(ClTyp) +module ClPairMap = Map.Make(ClPairOrd) + type coe_typ = GlobRef.t module CoeTypMap = GlobRef.Map_env @@ -43,6 +68,8 @@ type coe_info_typ = { coe_local : bool; coe_is_identity : bool; coe_is_projection : Projection.Repr.t option; + coe_source : cl_typ; + coe_target : cl_typ; coe_param : int; } @@ -53,88 +80,26 @@ let coe_info_typ_equal c1 c2 = c1.coe_is_projection == c2.coe_is_projection && Int.equal c1.coe_param c2.coe_param -let cl_typ_ord t1 t2 = match t1, t2 with - | CL_SECVAR v1, CL_SECVAR v2 -> Id.compare v1 v2 - | CL_CONST c1, CL_CONST c2 -> Constant.CanOrd.compare c1 c2 - | CL_PROJ c1, CL_PROJ c2 -> Projection.Repr.CanOrd.compare c1 c2 - | CL_IND i1, CL_IND i2 -> Ind.CanOrd.compare i1 i2 - | _ -> pervasives_compare t1 t2 (** OK *) - -module ClTyp = struct - type t = cl_typ - let compare = cl_typ_ord -end - -module ClTypMap = Map.Make(ClTyp) - -let cl_typ_eq t1 t2 = Int.equal (cl_typ_ord t1 t2) 0 - type inheritance_path = coe_info_typ list -(* table des classes, des coercions et graphe d'heritage *) - -module Bijint : -sig - module Index : - sig - type t - val compare : t -> t -> int - val equal : t -> t -> bool - val print : t -> Pp.t - end - type 'a t - val empty : 'a t - val mem : cl_typ -> 'a t -> bool - val map : Index.t -> 'a t -> cl_typ * 'a - val revmap : cl_typ -> 'a t -> Index.t * 'a - val add : cl_typ -> 'a -> 'a t -> 'a t - val dom : 'a t -> cl_typ list -end -= -struct - - module Index = struct include Int let print = Pp.int end - - type 'a t = { v : (cl_typ * 'a) Int.Map.t; s : int; inv : int ClTypMap.t } - let empty = { v = Int.Map.empty; s = 0; inv = ClTypMap.empty } - let mem y b = ClTypMap.mem y b.inv - let map x b = Int.Map.find x b.v - let revmap y b = let n = ClTypMap.find y b.inv in (n, snd (Int.Map.find n b.v)) - let add x y b = - { v = Int.Map.add b.s (x,y) b.v; s = b.s+1; inv = ClTypMap.add x b.s b.inv } - let dom b = List.rev (ClTypMap.fold (fun x _ acc -> x::acc) b.inv []) -end - -type cl_index = Bijint.Index.t - let init_class_tab = - let open Bijint in + let open ClTypMap in add CL_FUN { cl_param = 0 } (add CL_SORT { cl_param = 0 } empty) let class_tab = - Summary.ref ~name:"class_tab" (init_class_tab : cl_info_typ Bijint.t) + Summary.ref ~name:"class_tab" (init_class_tab : cl_info_typ ClTypMap.t) let coercion_tab = Summary.ref ~name:"coercion_tab" (CoeTypMap.empty : coe_info_typ CoeTypMap.t) -module ClPairOrd = -struct - type t = cl_index * cl_index - let compare (i1, j1) (i2, j2) = - let c = Bijint.Index.compare i1 i2 in - if Int.equal c 0 then Bijint.Index.compare j1 j2 else c -end - -module ClPairMap = Map.Make(ClPairOrd) - let inheritance_graph = Summary.ref ~name:"inheritance_graph" (ClPairMap.empty : inheritance_path ClPairMap.t) (* ajout de nouveaux "objets" *) let add_new_class cl s = - if not (Bijint.mem cl !class_tab) then - class_tab := Bijint.add cl s !class_tab + if not (ClTypMap.mem cl !class_tab) then + class_tab := ClTypMap.add cl s !class_tab let add_new_coercion coe s = coercion_tab := CoeTypMap.add coe s !coercion_tab @@ -144,19 +109,9 @@ let add_new_path x y = (* class_info : cl_typ -> int * cl_info_typ *) -let class_info cl = Bijint.revmap cl !class_tab - -let class_exists cl = Bijint.mem cl !class_tab - -(* class_info_from_index : int -> cl_typ * cl_info_typ *) +let class_info cl = ClTypMap.find cl !class_tab -let class_info_from_index i = Bijint.map i !class_tab - -let cl_fun_index = fst(class_info CL_FUN) - -let cl_sort_index = fst(class_info CL_SORT) - -(* coercion_info : coe_typ -> coe_info_typ *) +let class_exists cl = ClTypMap.mem cl !class_tab let coercion_info coe = CoeTypMap.find coe !coercion_tab @@ -202,20 +157,18 @@ let subst_coe_typ subst t = subst_global_reference subst t (* class_of : Term.constr -> int *) let class_of env sigma t = - let (t, n1, i, u, args) = + let (t, n1, cl, u, args) = try let (cl, u, args) = find_class_type env sigma t in - let (i, { cl_param = n1 } ) = class_info cl in - (t, n1, i, u, args) + let { cl_param = n1 } = class_info cl in + (t, n1, cl, u, args) with Not_found -> let t = Tacred.hnf_constr env sigma t in let (cl, u, args) = find_class_type env sigma t in - let (i, { cl_param = n1 } ) = class_info cl in - (t, n1, i, u, args) + let { cl_param = n1 } = class_info cl in + (t, n1, cl, u, args) in - if Int.equal (List.length args) n1 then t, i else raise Not_found - -let inductive_class_of ind = fst (class_info (CL_IND ind)) + if Int.equal (List.length args) n1 then t, cl else raise Not_found let class_args_of env sigma c = pi3 (find_class_type env sigma c) @@ -240,26 +193,26 @@ let lookup_path_between_class (s,t) = ClPairMap.find (s,t) !inheritance_graph let lookup_path_to_fun_from_class s = - lookup_path_between_class (s,cl_fun_index) + lookup_path_between_class (s, CL_FUN) let lookup_path_to_sort_from_class s = - lookup_path_between_class (s,cl_sort_index) + lookup_path_between_class (s, CL_SORT) (* advanced path lookup *) let apply_on_class_of env sigma t cont = try let (cl,u,args) = find_class_type env sigma t in - let (i, { cl_param = n1 } ) = class_info cl in + let { cl_param = n1 } = class_info cl in if not (Int.equal (List.length args) n1) then raise Not_found; - t, cont i + t, cont cl with Not_found -> (* Is it worth to be more incremental on the delta steps? *) let t = Tacred.hnf_constr env sigma t in let (cl, u, args) = find_class_type env sigma t in - let (i, { cl_param = n1 } ) = class_info cl in + let { cl_param = n1 } = class_info cl in if not (Int.equal (List.length args) n1) then raise Not_found; - t, cont i + t, cont cl let lookup_path_between env sigma (s,t) = let (s,(t,p)) = @@ -289,25 +242,25 @@ let get_coercion_constructor env coe = | _ -> raise Not_found let lookup_pattern_path_between env (s,t) = - let i = inductive_class_of s in - let j = inductive_class_of t in - List.map (get_coercion_constructor env) (ClPairMap.find (i,j) !inheritance_graph) + List.map (get_coercion_constructor env) + (ClPairMap.find (CL_IND s, CL_IND t) !inheritance_graph) (* rajouter une coercion dans le graphe *) -let path_printer : ((cl_index * cl_index) * inheritance_path -> Pp.t) ref = +let path_printer : ((cl_typ * cl_typ) * inheritance_path -> Pp.t) ref = ref (fun _ -> str "<a class path>") let install_path_printer f = path_printer := f let print_path x = !path_printer x -let path_comparator : (Environ.env -> Evd.evar_map -> cl_index -> inheritance_path -> inheritance_path -> bool) ref = +let path_comparator : + (Environ.env -> Evd.evar_map -> cl_typ -> inheritance_path -> inheritance_path -> bool) ref = ref (fun _ _ _ _ _ -> false) let install_path_comparator f = path_comparator := f -let compare_path p q = !path_comparator p q +let compare_path env sigma cl p q = !path_comparator env sigma cl p q let warn_ambiguous_path = CWarnings.create ~name:"ambiguous-paths" ~category:"typechecker" @@ -318,29 +271,29 @@ let warn_ambiguous_path = else str" is ambiguous with existing " ++ print_path (c, q) ++ str".") l) -(* add_coercion_in_graph : coe_index * cl_index * cl_index -> unit +(* add_coercion_in_graph : coe_index * cl_typ * cl_typ -> unit coercion,source,target *) -let different_class_params env i = - let ci = class_info_from_index i in - if (snd ci).cl_param > 0 then true - else - match fst ci with - | CL_IND i -> Environ.is_polymorphic env (GlobRef.IndRef i) - | CL_CONST c -> Environ.is_polymorphic env (GlobRef.ConstRef c) - | _ -> false +let different_class_params env ci = + if (class_info ci).cl_param > 0 then true + else + match ci with + | CL_IND i -> Environ.is_polymorphic env (GlobRef.IndRef i) + | CL_CONST c -> Environ.is_polymorphic env (GlobRef.ConstRef c) + | _ -> false -let add_coercion_in_graph env sigma (ic,source,target) = +let add_coercion_in_graph env sigma ic = let old_inheritance_graph = !inheritance_graph in - let ambig_paths = - (ref [] : ((cl_index * cl_index) * inheritance_path * inheritance_path) list ref) in + let ambig_paths : + ((cl_typ * cl_typ) * inheritance_path * inheritance_path) list ref = + ref [] in let try_add_new_path (i,j as ij) p = (* If p is a cycle, we check whether p is definitionally an identity function or not. If it is not, we report p as an ambiguous inheritance path. *) - if Bijint.Index.equal i j && not (compare_path env sigma i p []) then + if cl_typ_eq i j && not (compare_path env sigma i p []) then ambig_paths := (ij,p,[])::!ambig_paths; - if not (Bijint.Index.equal i j) || different_class_params env i then + if not (cl_typ_eq i j) || different_class_params env i then match lookup_path_between_class ij with | q -> (* p has the same source and target classes as an existing path q. We @@ -361,45 +314,36 @@ let add_coercion_in_graph env sigma (ic,source,target) = let try_add_new_path1 ij p = let _ = try_add_new_path ij p in () in - if try_add_new_path (source,target) [ic] then begin + if try_add_new_path (ic.coe_source, ic.coe_target) [ic] then begin ClPairMap.iter (fun (s,t) p -> - if not (Bijint.Index.equal s t) then begin - if Bijint.Index.equal t source then begin - try_add_new_path1 (s,target) (p@[ic]); + if not (cl_typ_eq s t) then begin + if cl_typ_eq t ic.coe_source then begin + try_add_new_path1 (s, ic.coe_target) (p@[ic]); ClPairMap.iter (fun (u,v) q -> - if not (Bijint.Index.equal u v) && Bijint.Index.equal u target then + if not (cl_typ_eq u v) && cl_typ_eq u ic.coe_target then try_add_new_path1 (s,v) (p@[ic]@q)) old_inheritance_graph end; - if Bijint.Index.equal s target then try_add_new_path1 (source,t) (ic::p) + if cl_typ_eq s ic.coe_target then + try_add_new_path1 (ic.coe_source, t) (ic::p) end) old_inheritance_graph end; match !ambig_paths with [] -> () | _ -> warn_ambiguous_path !ambig_paths -type coercion = { - coercion_type : coe_typ; - coercion_local : bool; - coercion_is_id : bool; - coercion_is_proj : Projection.Repr.t option; - coercion_source : cl_typ; - coercion_target : cl_typ; - coercion_params : int; -} - let subst_coercion subst c = let env = Global.env () in - let coe = subst_coe_typ subst c.coercion_type in - let cls = subst_cl_typ env subst c.coercion_source in - let clt = subst_cl_typ env subst c.coercion_target in - let clp = Option.Smart.map (subst_proj_repr subst) c.coercion_is_proj in - if c.coercion_type == coe && c.coercion_source == cls && - c.coercion_target == clt && c.coercion_is_proj == clp + let coe = subst_coe_typ subst c.coe_value in + let cls = subst_cl_typ env subst c.coe_source in + let clt = subst_cl_typ env subst c.coe_target in + let clp = Option.Smart.map (subst_proj_repr subst) c.coe_is_projection in + if c.coe_value == coe && c.coe_source == cls && c.coe_target == clt && + c.coe_is_projection == clp then c - else { c with coercion_type = coe; coercion_source = cls; - coercion_target = clt; coercion_is_proj = clp; } + else { c with coe_value = coe; coe_source = cls; coe_target = clt; + coe_is_projection = clp; } (* Computation of the class arity *) @@ -424,24 +368,14 @@ let add_class env sigma cl = add_new_class cl { cl_param = class_params env sigma cl } let declare_coercion env sigma c = - let () = add_class env sigma c.coercion_source in - let () = add_class env sigma c.coercion_target in - let is, _ = class_info c.coercion_source in - let it, _ = class_info c.coercion_target in - let xf = - { coe_value = c.coercion_type; - coe_local = c.coercion_local; - coe_is_identity = c.coercion_is_id; - coe_is_projection = c.coercion_is_proj; - coe_param = c.coercion_params; - } in - let () = add_new_coercion c.coercion_type xf in - add_coercion_in_graph env sigma (xf,is,it) + let () = add_class env sigma c.coe_source in + let () = add_class env sigma c.coe_target in + let () = add_new_coercion c.coe_value c in + add_coercion_in_graph env sigma c (* For printing purpose *) -let pr_cl_index = Bijint.Index.print - -let classes () = Bijint.dom !class_tab +let classes () = + List.rev (ClTypMap.fold (fun x _ acc -> x :: acc) !class_tab []) let coercions () = List.rev (CoeTypMap.fold (fun _ y acc -> y::acc) !coercion_tab []) diff --git a/pretyping/coercionops.mli b/pretyping/coercionops.mli index 31600dd17f..fb5621dd3a 100644 --- a/pretyping/coercionops.mli +++ b/pretyping/coercionops.mli @@ -44,12 +44,11 @@ type coe_info_typ = { coe_local : bool; coe_is_identity : bool; coe_is_projection : Projection.Repr.t option; + coe_source : cl_typ; + coe_target : cl_typ; coe_param : int; } -(** [cl_index] is the type of class keys *) -type cl_index - (** This is the type of paths from a class to another *) type inheritance_path = coe_info_typ list @@ -57,46 +56,32 @@ type inheritance_path = coe_info_typ list val class_exists : cl_typ -> bool -val class_info : cl_typ -> (cl_index * cl_info_typ) (** @raise Not_found if this type is not a class *) - -val class_info_from_index : cl_index -> cl_typ * cl_info_typ +val class_info : cl_typ -> cl_info_typ (** [find_class_type env sigma c] returns the head reference of [c], its universe instance and its arguments *) val find_class_type : env -> evar_map -> types -> cl_typ * EInstance.t * constr list (** raises [Not_found] if not convertible to a class *) -val class_of : env -> evar_map -> types -> types * cl_index - -(** raises [Not_found] if not mapped to a class *) -val inductive_class_of : inductive -> cl_index +val class_of : env -> evar_map -> types -> types * cl_typ val class_args_of : env -> evar_map -> types -> constr list -(** {6 [declare_coercion] adds a coercion in the graph of coercion paths } *) -type coercion = { - coercion_type : coe_typ; - coercion_local : bool; - coercion_is_id : bool; - coercion_is_proj : Projection.Repr.t option; - coercion_source : cl_typ; - coercion_target : cl_typ; - coercion_params : int; -} - -val subst_coercion : substitution -> coercion -> coercion +val subst_coercion : substitution -> coe_info_typ -> coe_info_typ -val declare_coercion : env -> evar_map -> coercion -> unit +val declare_coercion : env -> evar_map -> coe_info_typ -> unit (** {6 Access to coercions infos } *) val coercion_exists : coe_typ -> bool +val coercion_info : coe_typ -> coe_info_typ + (** {6 Lookup functions for coercion paths } *) (** @raise Not_found in the following functions when no path exists *) -val lookup_path_between_class : cl_index * cl_index -> inheritance_path +val lookup_path_between_class : cl_typ * cl_typ -> inheritance_path val lookup_path_between : env -> evar_map -> types * types -> types * types * inheritance_path val lookup_path_to_fun_from : env -> evar_map -> types -> @@ -109,16 +94,15 @@ val lookup_pattern_path_between : (**/**) (* Crade *) val install_path_printer : - ((cl_index * cl_index) * inheritance_path -> Pp.t) -> unit + ((cl_typ * cl_typ) * inheritance_path -> Pp.t) -> unit val install_path_comparator : - (env -> evar_map -> cl_index -> inheritance_path -> inheritance_path -> bool) -> unit + (env -> evar_map -> cl_typ -> inheritance_path -> inheritance_path -> bool) -> unit (**/**) (** {6 This is for printing purpose } *) val string_of_class : cl_typ -> string val pr_class : cl_typ -> Pp.t -val pr_cl_index : cl_index -> Pp.t -val inheritance_graph : unit -> ((cl_index * cl_index) * inheritance_path) list +val inheritance_graph : unit -> ((cl_typ * cl_typ) * inheritance_path) list val classes : unit -> cl_typ list val coercions : unit -> coe_info_typ list diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 722a0a2048..48f34e7c6b 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -744,9 +744,11 @@ let detype_level sigma l = UNamed (detype_level_name sigma l) let detype_instance sigma l = - let l = EInstance.kind sigma l in - if Univ.Instance.is_empty l then None - else Some (List.map (detype_level sigma) (Array.to_list (Univ.Instance.to_array l))) + if not !print_universes then None + else + let l = EInstance.kind sigma l in + if Univ.Instance.is_empty l then None + else Some (List.map (detype_level sigma) (Array.to_list (Univ.Instance.to_array l))) let delay (type a) (d : a delay) (f : a delay -> _ -> _ -> _ -> _ -> _ -> a glob_constr_r) flags env avoid sigma t : a glob_constr_g = match d with @@ -928,10 +930,12 @@ and detype_binder d flags bk avoid env sigma decl c = 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 = - (* 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 + if !Flags.in_debugger then InType + else + (* 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/dune b/pretyping/dune index 14bce92de1..d9b5609bd4 100644 --- a/pretyping/dune +++ b/pretyping/dune @@ -1,6 +1,6 @@ (library (name pretyping) (synopsis "Coq's Type Inference Component (Pretyper)") - (public_name coq.pretyping) + (public_name coq-core.pretyping) (wrapped false) (libraries engine)) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 990e84e5a7..e1d6fff3e4 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -47,17 +47,9 @@ let default_flags env = let ts = default_transparent_state env in default_flags_of ts -let debug_unification = - Goptions.declare_bool_option_and_ref - ~depr:false - ~key:["Debug";"Unification"] - ~value:false - -let debug_ho_unification = - Goptions.declare_bool_option_and_ref - ~depr:false - ~key:["Debug";"HO";"Unification"] - ~value:false +let debug_unification = CDebug.create ~name:"unification" () + +let debug_ho_unification = CDebug.create ~name:"ho-unification" () (*******************************************) (* Functions to deal with impossible cases *) @@ -808,9 +800,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) flags env evd pbty in let app_empty = match sk1, sk2 with [], [] -> true | _ -> false in (* Evar must be undefined since we have flushed evars *) - let () = if debug_unification () then - let open Pp in - Feedback.msg_debug (v 0 (pr_state env evd appr1 ++ cut () ++ pr_state env evd appr2 ++ cut ())) in + let () = debug_unification (fun () -> Pp.(v 0 (pr_state env evd appr1 ++ cut () ++ pr_state env evd appr2 ++ cut ()))) in match (flex_kind_of_term flags env evd term1 sk1, flex_kind_of_term flags env evd term2 sk2) with | Flexible (sp1,al1), Flexible (sp2,al2) -> @@ -1288,17 +1278,17 @@ let apply_on_subterm env evd fixed f test c t = (fun d (env,(k,c)) -> (push_rel d env, (k+1,lift 1 c))) applyrec acc t else - (if debug_ho_unification () then - Feedback.msg_debug Pp.(str"Testing " ++ prc env !evdref c ++ str" against " ++ prc env !evdref t); + (debug_ho_unification (fun () -> + Pp.(str"Testing " ++ prc env !evdref c ++ str" against " ++ prc env !evdref t)); let b, evd = 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"); + if b then (debug_ho_unification (fun () -> Pp.str "succeeded"); 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"); + debug_ho_unification (fun () -> Pp.str "failed"); map_constr_with_binders_left_to_right env !evdref (fun d (env,(k,c)) -> (push_rel d env, (k+1,lift 1 c))) applyrec acc t)) @@ -1404,9 +1394,9 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = let env_evar = evar_filtered_env env_rhs evi in let sign = named_context_val env_evar in let ctxt = evar_filtered_context evi in - if debug_ho_unification () then - (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)); + debug_ho_unification (fun () -> + Pp.(str"env rhs: " ++ Termops.Internal.print_env env_rhs ++ fnl () ++ + str"env evars: " ++ Termops.Internal.print_env env_evar)); let args = List.map (nf_evar evd) args in let argsubst = List.map2 (fun decl c -> (NamedDecl.get_id decl, c)) ctxt args in let instance = evar_identity_subst evi in @@ -1439,17 +1429,17 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = 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 - Feedback.msg_debug Pp.(str"set holes for: " ++ + debug_ho_unification (fun () -> + Pp.(str"set holes for: " ++ prc env_rhs evd (mkVar id.binder_name) ++ spc () ++ prc env_rhs evd c ++ str" in " ++ - prc env_rhs evd rhs); + prc env_rhs evd rhs)); let occ = ref 1 in let set_var evd fixed k inst = let oc = !occ in - if debug_ho_unification () then - (Feedback.msg_debug Pp.(str"Found one occurrence"); - Feedback.msg_debug Pp.(str"cty: " ++ prc env_rhs evd c)); + debug_ho_unification (fun () -> + Pp.(str"Found one occurrence" ++ fnl () ++ + str"cty: " ++ prc env_rhs evd c)); incr occ; match occs with | AtOccurrences occs -> @@ -1458,10 +1448,10 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = | Unspecified prefer_abstraction -> 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 ++ - str" of type: " ++ prc env_evar evd evty ++ - str " for " ++ prc env_rhs evd c); + debug_ho_unification (fun () -> + Pp.(str"abstracting one occurrence " ++ prc env_rhs evd inst ++ + str" of type: " ++ prc env_evar evd evty ++ + str " for " ++ prc env_rhs evd c)); let instance = Filter.filter_list filter instance in (* Allow any type lower than the variable's type as the abstracted subterm might have a smaller type, which could be @@ -1477,8 +1467,8 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = evd, fixed, mkEvar (evk, instance) 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'); + debug_ho_unification (fun () -> + 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 fixed rhs' subst @@ -1491,9 +1481,9 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = (* Thin evars making the term typable in env_evar *) let evd, rhs' = thin_evars env_evar evd ctxt rhs' in (* We instantiate the evars of which the value is forced by typing *) - if debug_ho_unification () then - (Feedback.msg_debug Pp.(str"solve_evars on: " ++ prc env_evar evd rhs'); - Feedback.msg_debug Pp.(str"evars: " ++ pr_evar_map (Some 0) env_evar evd)); + debug_ho_unification (fun () -> + Pp.(str"solve_evars on: " ++ prc env_evar evd rhs' ++ fnl () ++ + str"evars: " ++ pr_evar_map (Some 0) env_evar evd)); let evd,rhs' = try !solve_evars env_evar evd rhs' with e when Pretype_errors.precatchable_exception e -> @@ -1501,18 +1491,18 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = raise (TypingFailed evd) in let rhs' = nf_evar evd rhs' in (* We instantiate the evars of which the value is forced by typing *) - if debug_ho_unification () then - (Feedback.msg_debug Pp.(str"after solve_evars: " ++ prc env_evar evd rhs'); - Feedback.msg_debug Pp.(str"evars: " ++ pr_evar_map (Some 0) env_evar evd)); + debug_ho_unification (fun () -> + Pp.(str"after solve_evars: " ++ prc env_evar evd rhs' ++ fnl () ++ + str"evars: " ++ pr_evar_map (Some 0) env_evar evd)); let rec abstract_free_holes evd = function | (id,idty,c,cty,evsref,_,_)::l -> let id = id.binder_name in let c = nf_evar evd c in - if debug_ho_unification () then - Feedback.msg_debug Pp.(str"abstracting: " ++ - prc env_rhs evd (mkVar id) ++ spc () ++ - prc env_rhs evd c); + debug_ho_unification (fun () -> + Pp.(str"abstracting: " ++ + prc env_rhs evd (mkVar id) ++ spc () ++ + prc env_rhs evd c)); let rec force_instantiation evd = function | (evk,evty,inst,abstract)::evs -> let evk = Option.default evk (Evarutil.advance evd evk) in @@ -1541,14 +1531,14 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = with IllTypedInstance _ (* from instantiate_evar *) | TypingFailed _ -> user_err (Pp.str "Cannot find an instance.") else - ((if debug_ho_unification () then + ((debug_ho_unification (fun () -> let evi = Evd.find evd evk in let env = Evd.evar_env env_rhs evi in - Feedback.msg_debug Pp.(str"evar is defined: " ++ + Pp.(str"evar is defined: " ++ int (Evar.repr evk) ++ spc () ++ prc env evd (match evar_body evi with Evar_defined c -> c | Evar_empty -> assert false))); - evd) + evd)) in force_instantiation evd evs | [] -> abstract_free_holes evd l in force_instantiation evd !evsref @@ -1556,27 +1546,27 @@ let second_order_matching flags env_rhs evd (evk,args) (test,argoccs) rhs = if Evd.is_defined evd evk then (* Can happen due to dependencies: instantiating evars in the arguments of evk might instantiate evk itself. *) - (if debug_ho_unification () then + (debug_ho_unification (fun () -> begin let evi = Evd.find evd evk in let evenv = evar_env env_rhs evi in let body = match evar_body evi with Evar_empty -> assert false | Evar_defined c -> c in - Feedback.msg_debug Pp.(str"evar was defined already as: " ++ prc evenv evd body) - end; + Pp.(str"evar was defined already as: " ++ prc evenv evd body) + end); evd) else try let evi = Evd.find_undefined evd evk in let evenv = evar_env env_rhs evi in let rhs' = nf_evar evd rhs' in - if debug_ho_unification () then - Feedback.msg_debug Pp.(str"abstracted type before second solve_evars: " ++ - prc evenv evd rhs'); + debug_ho_unification (fun () -> + Pp.(str"abstracted type before second solve_evars: " ++ + prc evenv evd rhs')); (* solve_evars is not commuting with nf_evar, because restricting an evar might provide a more specific type. *) let evd, _ = !solve_evars evenv evd rhs' in - if debug_ho_unification () then - Feedback.msg_debug Pp.(str"abstracted type: " ++ prc evenv evd (nf_evar evd rhs')); + debug_ho_unification (fun () -> + Pp.(str"abstracted type: " ++ prc evenv evd (nf_evar evd rhs'))); let flags = default_flags_of TransparentState.full in Evarsolve.instantiate_evar evar_unify flags env_rhs evd evk rhs' with IllTypedInstance _ -> raise (TypingFailed evd) @@ -1629,11 +1619,10 @@ let apply_conversion_problem_heuristic flags env evd with_ho pbty t1 t2 = let t2 = apprec_nohdbeta flags env evd (whd_head_evar evd t2) in let (term1,l1 as appr1) = try destApp evd t1 with DestKO -> (t1, [||]) in let (term2,l2 as appr2) = try destApp evd t2 with DestKO -> (t2, [||]) in - let () = if debug_unification () then - let open Pp in - Feedback.msg_debug (v 0 (str "Heuristic:" ++ spc () ++ + let () = debug_unification (fun () -> + Pp.(v 0 (str "Heuristic:" ++ spc () ++ Termops.Internal.print_constr_env env evd t1 ++ cut () ++ - Termops.Internal.print_constr_env env evd t2 ++ cut ())) in + 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), (Rel _|Var _) when app_empty diff --git a/pretyping/globEnv.ml b/pretyping/globEnv.ml index 34fae613bf..ad28b54900 100644 --- a/pretyping/globEnv.ml +++ b/pretyping/globEnv.ml @@ -51,6 +51,8 @@ let make ~hypnaming env sigma lvar = } let env env = env.static_env +let renamed_env env = env.renamed_env +let lfun env = env.lvar.ltac_genargs let vars_of_env env = Id.Set.union (Id.Map.domain env.lvar.ltac_genargs) (vars_of_env env.static_env) @@ -183,10 +185,13 @@ let interp_ltac_variable ?loc typing_fun env sigma id : Evd.evar_map * unsafe_ju let interp_ltac_id env id = ltac_interp_id env.lvar id +type 'a obj_interp_fun = + ?loc:Loc.t -> poly:bool -> t -> Evd.evar_map -> Evardefine.type_constraint -> + 'a -> unsafe_judgment * Evd.evar_map + module ConstrInterpObj = struct - type ('r, 'g, 't) obj = - unbound_ltac_var_map -> bool -> env -> Evd.evar_map -> types -> 'g -> constr * Evd.evar_map + type ('r, 'g, 't) obj = 'g obj_interp_fun let name = "constr_interp" let default _ = None end @@ -195,8 +200,8 @@ module ConstrInterp = Genarg.Register(ConstrInterpObj) let register_constr_interp0 = ConstrInterp.register0 -let interp_glob_genarg env poly sigma ty arg = +let interp_glob_genarg ?loc ~poly env sigma ty arg = let open Genarg in let GenArg (Glbwit tag, arg) = arg in let interp = ConstrInterp.obj tag in - interp env.lvar.ltac_genargs poly env.renamed_env sigma ty arg + interp ?loc ~poly env sigma ty arg diff --git a/pretyping/globEnv.mli b/pretyping/globEnv.mli index 023e24e6d8..40feb8206b 100644 --- a/pretyping/globEnv.mli +++ b/pretyping/globEnv.mli @@ -15,11 +15,18 @@ open EConstr open Ltac_pretype open Evarutil +(** Type of environment extended with naming and ltac interpretation data *) + +type t + (** To embed constr in glob_constr *) +type 'a obj_interp_fun = + ?loc:Loc.t -> poly:bool -> t -> Evd.evar_map -> Evardefine.type_constraint -> + 'a -> unsafe_judgment * Evd.evar_map + val register_constr_interp0 : - ('r, 'g, 't) Genarg.genarg_type -> - (unbound_ltac_var_map -> bool -> env -> evar_map -> types -> 'g -> constr * evar_map) -> unit + ('r, 'g, 't) Genarg.genarg_type -> 'g obj_interp_fun -> unit (** {6 Pretyping name management} *) @@ -32,10 +39,6 @@ val register_constr_interp0 : variables used to build purely-named evar contexts *) -(** Type of environment extended with naming and ltac interpretation data *) - -type t - (** Build a pretyping environment from an ltac environment *) val make : hypnaming:naming_mode -> env -> evar_map -> ltac_var_map -> t @@ -43,6 +46,8 @@ val make : hypnaming:naming_mode -> env -> evar_map -> ltac_var_map -> t (** Export the underlying environment *) val env : t -> env +val renamed_env : t -> env +val lfun : t -> unbound_ltac_var_map val vars_of_env : t -> Id.Set.t @@ -85,5 +90,5 @@ val interp_ltac_id : t -> Id.t -> Id.t (** Interpreting a generic argument, typically a "ltac:(...)", taking into account the possible renaming *) -val interp_glob_genarg : t -> bool -> evar_map -> constr -> - Genarg.glob_generic_argument -> constr * evar_map +val interp_glob_genarg : ?loc:Loc.t -> poly:bool -> t -> evar_map -> Evardefine.type_constraint -> + Genarg.glob_generic_argument -> unsafe_judgment * evar_map diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index d02b015604..2e678f5700 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -347,37 +347,50 @@ let make_case_invert env (IndType (((ind,u),params),indices)) ci = then CaseInvert {indices=Array.of_list indices} else NoInvert +let make_project env sigma ind pred c branches ps = + let open EConstr in + assert(Array.length branches == 1); + let na, ty, t = destLambda sigma pred in + let () = + let mib, _ = Inductive.lookup_mind_specif env ind in + if (* dependent *) not (Vars.noccurn sigma 1 t) && + not (has_dependent_elim mib) then + user_err ~hdr:"make_case_or_project" + Pp.(str"Dependent case analysis not allowed" ++ + str" on inductive type " ++ Termops.Internal.print_constr_env env sigma (mkInd ind)) + in + let branch = branches.(0) in + let ctx, br = decompose_lam_n_assum sigma (Array.length ps) branch in + let n, len, ctx = + List.fold_right + (fun decl (i, j, ctx) -> + match decl with + | LocalAssum (na, ty) -> + let t = mkProj (Projection.make ps.(i) true, mkRel j) in + (i + 1, j + 1, LocalDef (na, t, Vars.liftn 1 j ty) :: ctx) + | LocalDef (na, b, ty) -> + (i, j + 1, LocalDef (na, Vars.liftn 1 j b, Vars.liftn 1 j ty) :: ctx)) + ctx (0, 1, []) + in + mkLetIn (na, c, ty, it_mkLambda_or_LetIn (Vars.liftn 1 (Array.length ps + 1) br) ctx) + +let simple_make_case_or_project env sigma ci pred invert c branches = + let open EConstr in + let ind = ci.ci_ind in + let projs = get_projections env ind in + match projs with + | None -> mkCase (EConstr.contract_case env sigma (ci, pred, invert, c, branches)) + | Some ps -> make_project env sigma ind pred c branches ps + let make_case_or_project env sigma indt ci pred c branches = let open EConstr in let IndType (((ind,_),_),_) = indt in let projs = get_projections env ind in match projs with - | None -> (mkCase (EConstr.contract_case env sigma (ci, pred, make_case_invert env indt ci, c, branches))) - | Some ps -> - assert(Array.length branches == 1); - let na, ty, t = destLambda sigma pred in - let () = - let mib, _ = Inductive.lookup_mind_specif env ind in - if (* dependent *) not (Vars.noccurn sigma 1 t) && - not (has_dependent_elim mib) then - user_err ~hdr:"make_case_or_project" - Pp.(str"Dependent case analysis not allowed" ++ - str" on inductive type " ++ Termops.Internal.print_constr_env env sigma (mkInd ind)) - in - let branch = branches.(0) in - let ctx, br = decompose_lam_n_assum sigma (Array.length ps) branch in - let n, len, ctx = - List.fold_right - (fun decl (i, j, ctx) -> - match decl with - | LocalAssum (na, ty) -> - let t = mkProj (Projection.make ps.(i) true, mkRel j) in - (i + 1, j + 1, LocalDef (na, t, Vars.liftn 1 j ty) :: ctx) - | LocalDef (na, b, ty) -> - (i, j + 1, LocalDef (na, Vars.liftn 1 j b, Vars.liftn 1 j ty) :: ctx)) - ctx (0, 1, []) - in - mkLetIn (na, c, ty, it_mkLambda_or_LetIn (Vars.liftn 1 (Array.length ps + 1) br) ctx) + | None -> + let invert = make_case_invert env indt ci in + mkCase (EConstr.contract_case env sigma (ci, pred, invert, c, branches)) + | Some ps -> make_project env sigma ind pred c branches ps (* substitution in a signature *) diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index 8e83814fa0..59ef8e08e3 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -212,6 +212,12 @@ val make_case_or_project : env -> evar_map -> inductive_type -> case_info -> (* pred *) EConstr.constr -> (* term *) EConstr.constr -> (* branches *) EConstr.constr array -> EConstr.constr +(** Sometimes [make_case_or_project] is nicer to call with a pre-built + [case_invert] than [inductive_type]. *) +val simple_make_case_or_project : + env -> evar_map -> case_info -> + (* pred *) EConstr.constr -> EConstr.case_invert -> (* term *) EConstr.constr -> (* branches *) EConstr.constr array -> EConstr.constr + val make_case_invert : env -> inductive_type -> case_info -> EConstr.case_invert diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 92e412a537..b19dbd46be 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -135,8 +135,9 @@ let construct_of_constr_notnative const env tag (mind, _ as ind) u allargs = let construct_of_constr const env sigma tag typ = - let t, l = app_type env typ in - match EConstr.kind_upto sigma t with + let typ = Reductionops.clos_whd_flags CClosure.all env sigma (EConstr.of_constr typ) in + let t, l = decompose_appvect (EConstr.Unsafe.to_constr typ) in + match Constr.kind t with | Ind (ind,u) -> construct_of_constr_notnative const env tag ind u l | _ -> @@ -469,15 +470,15 @@ let start_profiler_linux profile_fn = Unix.stdin dev_null dev_null in (* doesn't seem to be a way to test whether process creation succeeded *) - if !Flags.debug then - Feedback.msg_debug (Pp.str (Format.sprintf "Native compute profiler started, pid = %d, output to: %s" profiler_pid profile_fn)); + debug_native_compiler (fun () -> + Pp.str (Format.sprintf "Native compute profiler started, pid = %d, output to: %s" profiler_pid profile_fn)); Some profiler_pid (* kill profiler via SIGINT *) let stop_profiler_linux m_pid = match m_pid with | Some pid -> ( - let _ = if !Flags.debug then Feedback.msg_debug (Pp.str "Stopping native code profiler") in + let _ = debug_native_compiler (fun () -> Pp.str "Stopping native code profiler") in try Unix.kill pid Sys.sigint; let _ = Unix.waitpid [] pid in () @@ -502,15 +503,9 @@ let stop_profiler m_pid = | _ -> () let native_norm env sigma c ty = + Nativelib.link_libraries (); let c = EConstr.Unsafe.to_constr c in let ty = EConstr.Unsafe.to_constr ty in - if not (Flags.get_native_compiler ()) then - user_err Pp.(str "Native_compute reduction has been disabled.") - else - (* - Format.eprintf "Numbers of free variables (named): %i\n" (List.length vl1); - Format.eprintf "Numbers of free variables (rel): %i\n" (List.length vl2); - *) let profile = get_profiling_enabled () in let print_timing = get_timing_enabled () in let ml_filename, prefix = Nativelib.get_ml_filename () in @@ -526,17 +521,22 @@ let native_norm env sigma c ty = if print_timing then Feedback.msg_info (Pp.str time_info); let profiler_pid = if profile then start_profiler () else None in let t0 = Unix.gettimeofday () in - Nativelib.call_linker ~fatal:true ~prefix fn (Some upd); + let (rt1, _) = Nativelib.execute_library ~prefix fn upd in let t1 = Unix.gettimeofday () in if profile then stop_profiler profiler_pid; let time_info = Format.sprintf "native_compute: Evaluation done in %.5f" (t1 -. t0) in if print_timing then Feedback.msg_info (Pp.str time_info); - let res = nf_val env sigma !Nativelib.rt1 ty in + let res = nf_val env sigma rt1 ty in let t2 = Unix.gettimeofday () in let time_info = Format.sprintf "native_compute: Reification done in %.5f" (t2 -. t1) in if print_timing then Feedback.msg_info (Pp.str time_info); EConstr.of_constr res +let native_norm env sigma c ty = + if not (Flags.get_native_compiler ()) then + user_err Pp.(str "Native_compute reduction has been disabled."); + native_norm env sigma c ty + let native_conv_generic pb sigma t = Nativeconv.native_conv_gen pb (evars_of_evar_map sigma) t diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index e86a8a28c9..800096f2b3 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -653,12 +653,8 @@ struct sigma, { uj_val; uj_type } | Some arg -> - let sigma, ty = - match tycon with - | Some ty -> sigma, ty - | None -> new_type_evar env sigma ~src:(loc,Evar_kinds.InternalHole) in - let c, sigma = GlobEnv.interp_glob_genarg env poly sigma ty arg in - sigma, { uj_val = c; uj_type = ty } + let j, sigma = GlobEnv.interp_glob_genarg ?loc ~poly env sigma tycon arg in + sigma, j let pretype_rec self (fixkind, names, bl, lar, vdef) = fun ?loc ~program_mode ~poly resolve_tc tycon env sigma -> @@ -1398,7 +1394,7 @@ let understand_ltac flags env sigma lvar kind c = let (sigma, c, _) = ise_pretype_gen flags env sigma lvar kind c in (sigma, c) -let path_convertible env sigma i p q = +let path_convertible env sigma cl p q = let open Coercionops in let mkGRef ref = DAst.make @@ Glob_term.GRef(ref,None) in let mkGVar id = DAst.make @@ Glob_term.GVar(id) in @@ -1423,7 +1419,7 @@ let path_convertible env sigma i p q = p' | [] -> (* identity function for the class [i]. *) - let cl,params = class_info_from_index i in + let params = (class_info cl).cl_param in let clty = match cl with | CL_SORT -> mkGSort (Glob_term.UAnonymous {rigid=false}) @@ -1434,8 +1430,7 @@ let path_convertible env sigma i p q = | CL_PROJ p -> mkGRef (GlobRef.ConstRef (Projection.Repr.constant p)) in let names = - List.init params.cl_param - (fun n -> Id.of_string ("x" ^ string_of_int n)) + List.init params (fun n -> Id.of_string ("x" ^ string_of_int n)) in List.fold_right (fun id t -> mkGLambda (Name id, mkGHole (), t)) names @@ diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 54a47a252d..4083d3bc23 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -686,11 +686,7 @@ module CredNative = RedNative(CNativeEntries) contract_* in any case . *) -let debug_RAKAM = - Goptions.declare_bool_option_and_ref - ~depr:false - ~key:["Debug";"RAKAM"] - ~value:false +let debug_RAKAM = CDebug.create ~name:"RAKAM" () let apply_branch env sigma (ind, i) args (ci, u, pms, iv, r, lf) = let args = Stack.tail ci.ci_npar args in @@ -709,18 +705,18 @@ let apply_branch env sigma (ind, i) args (ci, u, pms, iv, r, lf) = let rec whd_state_gen flags env sigma = let open Context.Named.Declaration in let rec whrec (x, stack) : state = - let () = if debug_RAKAM () then + let () = let open Pp in let pr c = Termops.Internal.print_constr_env env sigma c in - Feedback.msg_debug + debug_RAKAM (fun () -> (h (str "<<" ++ pr x ++ str "|" ++ cut () ++ Stack.pr pr stack ++ - str ">>")) + str ">>"))) in let c0 = EConstr.kind sigma x in let fold () = - let () = if debug_RAKAM () then - let open Pp in Feedback.msg_debug (str "<><><><><>") in + let () = debug_RAKAM (fun () -> + let open Pp in str "<><><><><>") in ((EConstr.of_kind c0, stack)) in match c0 with diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 41d16f1c3c..09bcc860d0 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -19,7 +19,7 @@ open Environ exception Elimconst -val debug_RAKAM : unit -> bool +val debug_RAKAM : CDebug.t module CredNative : Primred.RedNative with type elem = EConstr.t and type args = EConstr.t array and type evd = Evd.evar_map diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 430813e874..4e89018656 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -1203,9 +1203,7 @@ let unfoldn loccname env sigma c = (* Re-folding constants tactics: refold com in term c *) let fold_one_com com env sigma c = - let rcom = - try red_product env sigma com - with Redelimination -> user_err Pp.(str "Not reducible.") in + let rcom = red_product env sigma com in (* Reason first on the beta-iota-zeta normal form of the constant as unfold produces it, so that the "unfold f; fold f" configuration works to refold fix expressions *) diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 83e46e3295..df0f49a033 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -49,11 +49,7 @@ let is_keyed_unification = ~key:["Keyed";"Unification"] ~value:false -let debug_unification = - Goptions.declare_bool_option_and_ref - ~depr:false - ~key:["Debug";"Tactic";"Unification"] - ~value:false +let debug_tactic_unification = CDebug.create ~name:"tactic-unification" () (** Making this unification algorithm correct w.r.t. the evar-map abstraction breaks too much stuff. So we redefine incorrect functions here. *) @@ -713,8 +709,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e let cM = Evarutil.whd_head_evar sigma curm and cN = Evarutil.whd_head_evar sigma curn in let () = - if debug_unification () then - Feedback.msg_debug ( + debug_tactic_unification (fun () -> Termops.Internal.print_constr_env curenv sigma cM ++ str" ~= " ++ Termops.Internal.print_constr_env curenv sigma cN) in @@ -1138,7 +1133,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e else error_cannot_unify (fst curenvnb) sigma (cM,cN) in - if debug_unification () then Feedback.msg_debug (str "Starting unification"); + debug_tactic_unification (fun () -> str "Starting unification"); let opt = { at_top = conv_at_top; with_types = false; with_cs = true } in try let res = @@ -1165,11 +1160,11 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e let a = match res with | Some sigma -> sigma, ms, es | None -> unirec_rec (env,0) cv_pb opt subst (fst m) (fst n) in - if debug_unification () then Feedback.msg_debug (str "Leaving unification with success"); + debug_tactic_unification (fun () -> str "Leaving unification with success"); a with e -> let e = Exninfo.capture e in - if debug_unification () then Feedback.msg_debug (str "Leaving unification with failure"); + debug_tactic_unification (fun () -> str "Leaving unification with failure"); Exninfo.iraise e let unify_0 env sigma pb flags c1 c2 = diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index cf6d581066..9939764069 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -78,8 +78,9 @@ let type_constructor mind mib u (ctx, typ) params = -let construct_of_constr const env tag typ = - let (t, allargs) = decompose_appvect (whd_all env typ) in +let construct_of_constr const env sigma tag typ = + let typ = Reductionops.clos_whd_flags CClosure.all env sigma (EConstr.of_constr typ) in + let t, allargs = decompose_appvect (EConstr.Unsafe.to_constr typ) in match Constr.kind t with | Ind ((mind,_ as ind), u as indu) -> let mib,mip = lookup_mind_specif env ind in @@ -92,8 +93,8 @@ let construct_of_constr const env tag typ = assert (Constr.equal t (Typeops.type_of_int env)); (mkInt (Uint63.of_int tag), t) -let construct_of_constr_const env tag typ = - fst (construct_of_constr true env tag typ) +let construct_of_constr_const env sigma tag typ = + fst (construct_of_constr true env sigma tag typ) let construct_of_constr_block = construct_of_constr false @@ -156,7 +157,7 @@ and nf_whd env sigma whd typ = let _, args = nf_args env sigma vargs t in mkApp(cfd,args) | Vconstr_const n -> - construct_of_constr_const env n typ + construct_of_constr_const env sigma n typ | Vconstr_block b -> let tag = btag b in let (tag,ofs) = @@ -165,7 +166,7 @@ and nf_whd env sigma whd typ = | Vconstr_const tag -> (tag+Obj.last_non_constant_constructor_tag, 1) | _ -> assert false else (tag, 0) in - let capp,ctyp = construct_of_constr_block env tag typ in + let capp,ctyp = construct_of_constr_block env sigma tag typ in let args = nf_bargs env sigma b ofs ctyp in mkApp(capp,args) | Vint64 i -> i |> Uint63.of_int64 |> mkInt @@ -414,9 +415,9 @@ let cbv_vm env sigma c t = if Termops.occur_meta sigma c then CErrors.user_err Pp.(str "vm_compute does not support metas."); (* 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 = Vmsymtable.val_of_constr env c in + let c = EConstr.Unsafe.to_constr c in + let t = EConstr.Unsafe.to_constr t in + let v = Vmsymtable.val_of_constr env (Evd.existential_opt_value0 sigma) 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/dune b/printing/dune index 3392342165..a24a7535eb 100644 --- a/printing/dune +++ b/printing/dune @@ -1,6 +1,6 @@ (library (name printing) (synopsis "Coq's Term Pretty Printing Library") - (public_name coq.printing) + (public_name coq-core.printing) (wrapped false) (libraries parsing proofs)) diff --git a/proofs/dune b/proofs/dune index 36e9799998..f8e7661997 100644 --- a/proofs/dune +++ b/proofs/dune @@ -1,6 +1,6 @@ (library (name proofs) (synopsis "Coq's Higher-level Refinement Proof Engine and Top-level Proof Structure") - (public_name coq.proofs) + (public_name coq-core.proofs) (wrapped false) (libraries pretyping)) diff --git a/proofs/refine.ml b/proofs/refine.ml index ac410a958f..ce04c35e11 100644 --- a/proofs/refine.ml +++ b/proofs/refine.ml @@ -129,7 +129,6 @@ let solve_constraints = tclENV >>= fun env -> tclEVARMAP >>= fun sigma -> try let sigma = Evarconv.solve_unif_constraints_with_heuristics env sigma in Unsafe.tclEVARSADVANCE sigma - with e -> - (* XXX this is absorbing anomalies? *) + with e when CErrors.noncritical e -> let info = Exninfo.reify () in tclZERO ~info e diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index 4c4c26f47e..dd80ff21aa 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -13,7 +13,7 @@ open Pp open Util let stm_pr_err pp = Format.eprintf "%s] @[%a@]\n%!" (Spawned.process_id ()) Pp.pp_with pp -let stm_prerr_endline s = if !Flags.debug then begin stm_pr_err (str s) end else () +let stm_prerr_endline s = if CDebug.(get_flag misc) then begin stm_pr_err (str s) end else () type cancel_switch = bool ref let async_proofs_flags_for_workers = ref [] @@ -1,6 +1,6 @@ (library (name stm) (synopsis "Coq's Document Manager and Proof Checking Scheduler") - (public_name coq.stm) + (public_name coq-core.stm) (wrapped false) (libraries sysinit)) diff --git a/stm/spawned.ml b/stm/spawned.ml index 5cc8be78f5..ee9c8e9942 100644 --- a/stm/spawned.ml +++ b/stm/spawned.ml @@ -11,7 +11,7 @@ open Spawn let pr_err s = Printf.eprintf "(Spawned,%d) %s\n%!" (Unix.getpid ()) s -let prerr_endline s = if !Flags.debug then begin pr_err s end else () +let prerr_endline s = if CDebug.(get_flag misc) then begin pr_err s end else () type chandescr = AnonPipe | Socket of string * int * int diff --git a/stm/stm.ml b/stm/stm.ml index 7de109e596..5ed6adbd63 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -9,7 +9,7 @@ (************************************************************************) (* enable in case of stm problems *) -(* let stm_debug () = !Flags.debug *) +(* let stm_debug () = CDebug.(get_flag misc) *) let stm_debug = ref false let stm_pr_err s = Format.eprintf "%s] %s\n%!" (Spawned.process_id ()) s @@ -18,7 +18,7 @@ let stm_pp_err pp = Format.eprintf "%s] @[%a@]\n%!" (Spawned.process_id ()) Pp.p let stm_prerr_endline s = if !stm_debug then begin stm_pr_err (s ()) end else () let stm_pperr_endline s = if !stm_debug then begin stm_pp_err (s ()) end else () -let stm_prerr_debug s = if !Flags.debug then begin stm_pr_err (s ()) end else () +let stm_prerr_debug s = if CDebug.(get_flag misc) then begin stm_pr_err (s ()) end else () open Pp open CErrors @@ -785,7 +785,7 @@ end = struct (* {{{ *) end let print ?(now=false) () = - if !Flags.debug then NB.command ~now (print_dag !vcs) + if CDebug.(get_flag misc) then NB.command ~now (print_dag !vcs) let backup () = !vcs let restore v = vcs := v @@ -1533,7 +1533,7 @@ end = struct (* {{{ *) 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"); + if CDebug.(get_flag misc) then msg_debug (Pp.str "STM: sending back a fat state"); Some (id, `Full s) | _, Some s -> Some (id, `Full s) in let rec aux seen = function diff --git a/sysinit/coqargs.ml b/sysinit/coqargs.ml index c4f12f6bb7..8be73ca028 100644 --- a/sysinit/coqargs.ml +++ b/sysinit/coqargs.ml @@ -22,14 +22,6 @@ let error_missing_arg s = exit 1 (******************************************************************************) -(* Imperative effects! This must be fixed at some point. *) -(******************************************************************************) - -let set_debug () = - let () = Exninfo.record_backtrace true in - Flags.debug := true - -(******************************************************************************) type native_compiler = Coq_config.native_compiler = NativeOff | NativeOn of { ondemand : bool } @@ -44,6 +36,7 @@ type option_command = type injection_command = | OptionInjection of (Goptions.option_name * option_command) | RequireInjection of (string * string option * bool option) + | WarnNoNative of string type coqargs_logic_config = { impredicative_set : Declarations.set_predicativity; @@ -75,8 +68,6 @@ type coqargs_pre = { load_vernacular_list : (string * bool) list; injections : injection_command list; - - inputstate : string option; } type coqargs_query = @@ -133,7 +124,6 @@ let default_pre = { vo_includes = []; load_vernacular_list = []; injections = []; - inputstate = None; } let default_queries = [] @@ -170,6 +160,9 @@ let add_load_vernacular opts verb s = let add_set_option opts opt_name value = { opts with pre = { opts.pre with injections = OptionInjection (opt_name, value) :: opts.pre.injections }} +let add_set_debug opts flags = + add_set_option opts ["Debug"] (OptionAppend flags) + (** Options for proof general *) let set_emacs opts = let opts = add_set_option opts Printer.print_goal_tag_opt_name (OptionSet None) in @@ -184,18 +177,6 @@ let set_query opts q = | Queries queries -> Queries (queries@[q]) } -let warn_deprecated_sprop_cumul = - CWarnings.create ~name:"deprecated-spropcumul" ~category:"deprecated" - (fun () -> Pp.strbrk "Use the \"Cumulative StrictProp\" flag instead.") - -let warn_deprecated_inputstate = - CWarnings.create ~name:"deprecated-inputstate" ~category:"deprecated" - (fun () -> Pp.strbrk "The inputstate option is deprecated and discouraged.") - -let set_inputstate opts s = - warn_deprecated_inputstate (); - { opts with pre = { opts.pre with inputstate = Some s }} - (******************************************************************************) (* Parsing helpers *) (******************************************************************************) @@ -255,12 +236,6 @@ let parse_option_set opt = let v = String.sub opt (eqi+1) (len - eqi - 1) in to_opt_key (String.sub opt 0 eqi), Some v -let warn_no_native_compiler = - CWarnings.create ~name:"native-compiler-disabled" ~category:"native-compiler" - Pp.(fun s -> strbrk "Native compiler is disabled," ++ - strbrk " -native-compiler " ++ strbrk s ++ - strbrk " option ignored.") - let get_native_compiler s = (* We use two boolean flags because the four states make sense, even if only three are accessible to the user at the moment. The selection of the @@ -274,10 +249,8 @@ let get_native_compiler s = | _ -> error_wrong_arg ("Error: (yes|no|ondemand) expected after option -native-compiler") in if Coq_config.native_compiler = NativeOff && n <> NativeOff then - let () = warn_no_native_compiler s in - NativeOff - else - n + NativeOff, Some (WarnNoNative s) + else n, None (* Main parsing routine *) (*s Parsing of the command line *) @@ -333,9 +306,6 @@ let parse_args ~usage ~init arglist : t * string list = |"-init-file" -> { oval with config = { oval.config with rcfile = Some (next ()); }} - |"-inputstate"|"-is" -> - set_inputstate oval (next ()) - |"-load-vernac-object" -> add_vo_require oval (next ()) None None @@ -385,8 +355,9 @@ let parse_args ~usage ~init arglist : t * string list = { oval with config = { oval.config with enable_VM = get_bool ~opt (next ()) }} |"-native-compiler" -> - let native_compiler = get_native_compiler (next ()) in - { oval with config = { oval.config with native_compiler }} + let native_compiler, warn = get_native_compiler (next ()) in + { oval with config = { oval.config with native_compiler }; + pre = { oval.pre with injections = Option.List.cons warn oval.pre.injections }} | "-set" -> let opt, v = parse_option_set @@ next() in @@ -406,10 +377,15 @@ let parse_args ~usage ~init arglist : t * string list = (* Options with zero arg *) |"-test-mode" -> Vernacinterp.test_mode := true; oval |"-beautify" -> Flags.beautify := true; oval - |"-bt" -> Exninfo.record_backtrace true; oval + |"-bt" -> add_set_debug oval "backtrace" |"-config"|"--config" -> set_query oval PrintConfig - |"-debug" -> set_debug (); oval - |"-xml-debug" -> Flags.xml_debug := true; set_debug (); oval + + |"-debug" -> add_set_debug oval "all" + |"-d" | "-D" -> add_set_debug oval (next()) + + (* -xml-debug implies -debug. TODO don't be imperative here. *) + |"-xml-debug" -> Flags.xml_debug := true; add_set_debug oval "all" + |"-diffs" -> add_set_option oval Proof_diffs.opt_name @@ OptionSet (Some (next ())) |"-emacs" -> set_emacs oval @@ -419,9 +395,6 @@ let parse_args ~usage ~init arglist : t * string list = add_set_option oval Vernacentries.allow_sprop_opt_name (OptionSet None) |"-disallow-sprop" -> add_set_option oval Vernacentries.allow_sprop_opt_name OptionUnset - |"-sprop-cumulative" -> - warn_deprecated_sprop_cumul(); - add_set_option oval Vernacentries.cumul_sprop_opt_name (OptionSet None) |"-indices-matter" -> set_logic (fun o -> { o with indices_matter = true }) oval |"-m"|"--memory" -> { oval with post = { memory_stat = true }} |"-noinit"|"-nois" -> { oval with pre = { oval.pre with load_init = false }} diff --git a/sysinit/coqargs.mli b/sysinit/coqargs.mli index aef50193f2..9725a849a4 100644 --- a/sysinit/coqargs.mli +++ b/sysinit/coqargs.mli @@ -28,7 +28,12 @@ type injection_command = ready. Parameters follow [Library], that is to say, [lib,prefix,import_export] means require library [lib] from optional [prefix] and [import_export] if [Some false/Some true] - is used. *) + is used. *) + | WarnNoNative of string + (** Used so that "-w -native-compiler-disabled -native-compiler yes" + does not cause a warning. The native option must be processed + before injections (because it affects require), so the + instruction to emit a message is separated. *) type coqargs_logic_config = { impredicative_set : Declarations.set_predicativity; @@ -60,8 +65,6 @@ type coqargs_pre = { load_vernacular_list : (string * bool) list; injections : injection_command list; - - inputstate : string option; } type coqargs_query = diff --git a/sysinit/coqinit.ml b/sysinit/coqinit.ml index 16c8389de5..25da2c5302 100644 --- a/sysinit/coqinit.ml +++ b/sysinit/coqinit.ml @@ -126,10 +126,16 @@ let require_file (dir, from, exp) = let mfrom = Option.map Libnames.qualid_of_string from in Flags.silently (Vernacentries.vernac_require mfrom exp) [mp] -let handle_injection = function - | Coqargs.RequireInjection r -> require_file r - (* | LoadInjection l -> *) - | Coqargs.OptionInjection o -> Coqargs.set_option o +let warn_no_native_compiler = + CWarnings.create ~name:"native-compiler-disabled" ~category:"native-compiler" + Pp.(fun s -> strbrk "Native compiler is disabled," ++ + strbrk " -native-compiler " ++ strbrk s ++ + strbrk " option ignored.") + +let handle_injection = let open Coqargs in function + | RequireInjection r -> require_file r + | OptionInjection o -> set_option o + | WarnNoNative s -> warn_no_native_compiler s let start_library ~top injections = Flags.verbosely Declaremods.start_library top; diff --git a/sysinit/coqloadpath.ml b/sysinit/coqloadpath.ml index 8635345e00..95ae5da3de 100644 --- a/sysinit/coqloadpath.ml +++ b/sysinit/coqloadpath.ml @@ -44,8 +44,18 @@ let init_load_path ~coqlib = let coq_path = Names.DirPath.make [Libnames.coq_root] in (* ML includes *) - let plugins_dirs = System.all_subdirs ~unix_path:(coqlib/"plugins") |> List.map fst in - + let unix_path = + (* Usually lib/coq-stdlib/../plugins ; this kind of hacks with the + ML path should go away once we use ocamlfind to load plugins *) + CPath.choose_existing + [ CPath.make [ coqlib ; "plugins" ] + ; CPath.make [ coqlib ; ".."; "coq-core"; "plugins" ] + ] |> function + | None -> + CErrors.user_err (Pp.str "Cannot find plugins directory") + | Some f -> (f :> string) + in + let plugins_dirs = System.all_subdirs ~unix_path |> List.map fst in let contrib_ml, contrib_vo = build_userlib_path ~unix_path:user_contrib in let misc_ml, misc_vo = diff --git a/sysinit/dune b/sysinit/dune index 04b46fb2a2..f882f987ff 100644 --- a/sysinit/dune +++ b/sysinit/dune @@ -1,7 +1,6 @@ (library (name sysinit) - (public_name coq.sysinit) + (public_name coq-core.sysinit) (synopsis "Coq's initialization") (wrapped false) - (libraries coq.vernac) - ) + (libraries coq-core.vernac)) diff --git a/sysinit/usage.ml b/sysinit/usage.ml index 1831a3f9b2..5886b1c5b5 100644 --- a/sysinit/usage.ml +++ b/sysinit/usage.ml @@ -9,9 +9,8 @@ (************************************************************************) let version () = - Printf.printf "The Coq Proof Assistant, version %s (%s)\n" - Coq_config.version Coq_config.date; - Printf.printf "compiled on %s with OCaml %s\n" Coq_config.compile_date Coq_config.caml_version + Printf.printf "The Coq Proof Assistant, version %s\n" Coq_config.version; + Printf.printf "compiled with OCaml %s\n" Coq_config.caml_version let machine_readable_version () = Printf.printf "%s %s\n" @@ -74,12 +73,9 @@ let print_usage_common co command = \n -debug debug mode (implies -bt)\ \n -xml-debug debug mode and print XML messages to/from coqide\ \n -diffs (on|off|removed) highlight differences between proof steps\ -\n -noglob do not dump globalizations\ -\n -dump-glob f dump globalizations in file f (to be used by coqdoc)\ \n -impredicative-set set sort Set impredicative\ \n -allow-sprop allow using the proof irrelevant SProp sort\ \n -disallow-sprop forbid using the proof irrelevant SProp sort\ -\n -sprop-cumulative make sort SProp cumulative with the rest of the hierarchy\ \n -indices-matter levels of indices (and nonuniform parameters) contribute to the level of inductives\ \n -type-in-type disable universe consistency checking\ \n -mangle-names x mangle auto-generated names using prefix x\ diff --git a/tactics/cbn.ml b/tactics/cbn.ml index 6fb6cff04f..99d579f5c6 100644 --- a/tactics/cbn.ml +++ b/tactics/cbn.ml @@ -402,11 +402,11 @@ let safe_meta_value sigma ev = (* Beta Reduction tools *) -let apply_subst recfun env sigma refold cst_l t stack = +let apply_subst recfun env sigma cst_l t stack = let rec aux env cst_l t stack = match (Stack.decomp stack, EConstr.kind sigma t) with | Some (h,stacktl), Lambda (_,_,c) -> - let cst_l' = if refold then Cst_stack.add_param h cst_l else cst_l in + let cst_l' = Cst_stack.add_param h cst_l in aux (h::env) cst_l' c stacktl | _ -> recfun sigma cst_l (substl env t, stack) in aux env cst_l t stack @@ -453,50 +453,42 @@ let magically_constant_of_fixbody env sigma reference bd = function | None -> bd end -let contract_cofix ?env sigma ?reference (bodynum,(names,types,bodies as typedbodies)) = +let contract_cofix ~env sigma ?reference (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 - match env with + match reference with | None -> bd - | Some e -> - match reference with - | None -> bd - | Some r -> magically_constant_of_fixbody e sigma r bd names.(ind).binder_name in + | Some r -> magically_constant_of_fixbody env sigma r bd names.(ind).binder_name in let closure = List.init nbodies make_Fi in substl closure bodies.(bodynum) (** Similar to the "fix" case below *) -let reduce_and_refold_cofix recfun env sigma refold cst_l cofix sk = +let reduce_and_refold_cofix recfun env sigma cst_l cofix sk = let raw_answer = - let env = if refold then Some env else None in - contract_cofix ?env sigma ?reference:(Cst_stack.reference sigma cst_l) cofix in + contract_cofix ~env sigma ?reference:(Cst_stack.reference sigma cst_l) cofix in apply_subst (fun sigma x (t,sk') -> - let t' = - if refold then Cst_stack.best_replace sigma (mkCoFix cofix) cst_l t else t in + let t' = Cst_stack.best_replace sigma (mkCoFix cofix) cst_l t in recfun x (t',sk')) - [] sigma refold Cst_stack.empty raw_answer sk + [] sigma Cst_stack.empty raw_answer sk (* contracts fix==FIX[nl;i](A1...Ak;[F1...Fk]{B1....Bk}) to produce Bi[Fj --> FIX[nl;j](A1...Ak;[F1...Fk]{B1...Bk})] *) -let contract_fix ?env sigma ?reference ((recindices,bodynum),(names,types,bodies as typedbodies)) = +let contract_fix ~env sigma ?reference ((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 - match env with + match reference with | None -> bd - | Some e -> - match reference with - | None -> bd - | Some r -> magically_constant_of_fixbody e sigma r bd names.(ind).binder_name in + | Some r -> magically_constant_of_fixbody env sigma r bd names.(ind).binder_name in let closure = List.init nbodies make_Fi in substl closure bodies.(bodynum) @@ -504,18 +496,14 @@ let contract_fix ?env sigma ?reference ((recindices,bodynum),(names,types,bodies replace the fixpoint by the best constant from [cst_l] Other rels are directly substituted by constants "magically found from the context" in contract_fix *) -let reduce_and_refold_fix recfun env sigma refold cst_l fix sk = +let reduce_and_refold_fix recfun env sigma cst_l fix sk = let raw_answer = - let env = if refold then Some env else None in - contract_fix ?env sigma ?reference:(Cst_stack.reference sigma cst_l) fix in + contract_fix ~env sigma ?reference:(Cst_stack.reference sigma cst_l) fix in apply_subst (fun sigma x (t,sk') -> - let t' = - if refold then - Cst_stack.best_replace sigma (mkFix fix) cst_l t - else t - in recfun x (t',sk')) - [] sigma refold Cst_stack.empty raw_answer sk + let t' = Cst_stack.best_replace sigma (mkFix fix) cst_l t in + recfun x (t',sk')) + [] sigma Cst_stack.empty raw_answer sk module CredNative = Reductionops.CredNative @@ -524,7 +512,7 @@ module CredNative = Reductionops.CredNative Here is where unfolded constant are stored in order to be eventually refolded. - If tactic_mode is true, it uses ReductionBehaviour, prefers + It uses ReductionBehaviour, prefers refold constant instead of value and tries to infer constants fix and cofix came from. @@ -558,23 +546,22 @@ let apply_branch env sigma (ind, i) args (ci, u, pms, iv, r, lf) = in Vars.substl subst (snd br) -let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = +let rec whd_state_gen ?csts flags env sigma = let open Context.Named.Declaration in let open ReductionBehaviour in let rec whrec cst_l (x, stack) = - let () = if debug_RAKAM () then + let () = debug_RAKAM (fun () -> let open Pp in let pr c = Termops.Internal.print_constr_env env sigma c in - Feedback.msg_debug (h (str "<<" ++ pr x ++ str "|" ++ cut () ++ Cst_stack.pr env sigma cst_l ++ str "|" ++ cut () ++ Stack.pr pr stack ++ - str ">>")) + str ">>"))) in let c0 = EConstr.kind sigma x in let fold () = - let () = if debug_RAKAM () then - let open Pp in Feedback.msg_debug (str "<><><><><>") in + let () = debug_RAKAM (fun () -> + Pp.(str "<><><><><>")) in ((EConstr.of_kind c0, stack),cst_l) in match c0 with @@ -585,7 +572,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = | Var id when CClosure.RedFlags.red_set flags (CClosure.RedFlags.fVAR id) -> (match lookup_named id env with | LocalDef (_,body,_) -> - whrec (if refold then Cst_stack.add_cst (mkVar id) cst_l else cst_l) (body, stack) + whrec (Cst_stack.add_cst (mkVar id) cst_l) (body, stack) | _ -> fold ()) | Evar ev -> fold () | Meta ev -> @@ -601,10 +588,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = | body -> begin let body = EConstr.of_constr body in - if not tactic_mode - then whrec (if refold then Cst_stack.add_cst (mkConstU const) cst_l else cst_l) - (body, stack) - else (* Looks for ReductionBehaviour *) + (* Looks for ReductionBehaviour *) match ReductionBehaviour.get (GlobRef.ConstRef c) with | None -> whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, stack) | Some behavior -> @@ -653,10 +637,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = else fold () | Proj (p, c) when CClosure.RedFlags.red_projection flags p -> (let npars = Projection.npars p in - if not tactic_mode then - let stack' = (c, Stack.Proj (p, Cst_stack.empty (*cst_l*)) :: stack) in - whrec Cst_stack.empty stack' - else match ReductionBehaviour.get (GlobRef.ConstRef (Projection.constant p)) with + match ReductionBehaviour.get (GlobRef.ConstRef (Projection.constant p)) with | None -> let stack' = (c, Stack.Proj (p, cst_l) :: stack) in let stack'', csts = whrec Cst_stack.empty stack' in @@ -694,24 +675,24 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = end) | LetIn (_,b,_,c) when CClosure.RedFlags.red_set flags CClosure.RedFlags.fZETA -> - apply_subst (fun _ -> whrec) [b] sigma refold cst_l c stack + apply_subst (fun _ -> whrec) [b] sigma cst_l c stack | Cast (c,_,_) -> whrec cst_l (c, stack) | App (f,cl) -> whrec - (if refold then Cst_stack.add_args cl cst_l else cst_l) + (Cst_stack.add_args cl cst_l) (f, Stack.append_app cl stack) | Lambda (na,t,c) -> (match Stack.decomp stack with | Some _ when CClosure.RedFlags.red_set flags CClosure.RedFlags.fBETA -> - apply_subst (fun _ -> whrec) [] sigma refold cst_l x stack + apply_subst (fun _ -> whrec) [] sigma cst_l x stack | None when CClosure.RedFlags.red_set flags CClosure.RedFlags.fETA -> let env' = push_rel (LocalAssum (na, t)) env in - let whrec' = whd_state_gen ~refold ~tactic_mode flags env' sigma in - (match EConstr.kind sigma (Stack.zip ~refold sigma (fst (whrec' (c, Stack.empty)))) with + let whrec' = whd_state_gen flags env' sigma in + (match EConstr.kind sigma (Stack.zip ~refold:true sigma (whrec' (c, Stack.empty))) with | App (f,cl) -> let napp = Array.length cl in if napp > 0 then - let (x', l'),_ = whrec' (Array.last cl, Stack.empty) in + let (x', l') = whrec' (Array.last cl, Stack.empty) in match EConstr.kind sigma x', l' with | Rel 1, [] -> let lc = Array.sub cl 0 (napp-1) in @@ -744,7 +725,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = |args, (Stack.Fix (f,s',cst_l)::s'') when use_fix -> let x' = Stack.zip sigma (x, args) in let out_sk = s' @ (Stack.append_app [|x'|] s'') in - reduce_and_refold_fix whrec env sigma refold cst_l f out_sk + reduce_and_refold_fix whrec env sigma cst_l f out_sk |args, (Stack.Cst (const,curr,remains,s',cst_l) :: s'') -> let x' = Stack.zip sigma (x, args) in begin match remains with @@ -756,7 +737,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = | Some body -> let const = (fst const, EInstance.make (snd const)) in let body = EConstr.of_constr body in - whrec (if refold then Cst_stack.add_cst (mkConstU const) cst_l else cst_l) + whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, s' @ (Stack.append_app [|x'|] s''))) | Stack.Cst_proj p -> let stack = s' @ (Stack.append_app [|x'|] s'') in @@ -779,7 +760,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = if CClosure.RedFlags.red_set flags CClosure.RedFlags.fCOFIX then match Stack.strip_app stack with |args, ((Stack.Case _ |Stack.Proj _)::s') -> - reduce_and_refold_cofix whrec env sigma refold cst_l cofix stack + reduce_and_refold_cofix whrec env sigma cst_l cofix stack |_ -> fold () else fold () @@ -813,12 +794,10 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = in fun xs -> let (s,cst_l as res) = whrec (Option.default Cst_stack.empty csts) xs in - if tactic_mode then (Stack.best_state sigma s cst_l,Cst_stack.empty) else res + (Stack.best_state sigma s cst_l) let whd_cbn flags env sigma t = - let (state,_) = - (whd_state_gen ~refold:true ~tactic_mode:true flags env sigma (t, Stack.empty)) - in + let state = whd_state_gen flags env sigma (t, Stack.empty) in Stack.zip ~refold:true sigma state let norm_cbn flags env sigma t = diff --git a/tactics/dune b/tactics/dune index 908dde5253..29378f52d1 100644 --- a/tactics/dune +++ b/tactics/dune @@ -1,6 +1,6 @@ (library (name tactics) (synopsis "Coq's Core Tactics [ML implementation]") - (public_name coq.tactics) + (public_name coq-core.tactics) (wrapped false) (libraries printing)) diff --git a/tactics/hints.ml b/tactics/hints.ml index 058602acfd..5e9c3baeb1 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -1019,18 +1019,6 @@ let remove_hint dbname grs = let db' = Hint_db.remove_list env grs db in searchtable_add (dbname, db') -type hint_action = - | CreateDB of bool * TransparentState.t - | AddTransparency of { - superglobal : bool; - grefs : evaluable_global_reference hints_transparency_target; - state : bool; - } - | AddHints of { superglobal : bool; hints : hint_entry list } - | RemoveHints of { superglobal : bool; hints : GlobRef.t list } - | AddCut of { superglobal : bool; paths : hints_path } - | AddMode of { superglobal : bool; gref : GlobRef.t; mode : hint_mode array } - let add_cut dbname path = let db = get_db dbname in let db' = Hint_db.add_cut path db in @@ -1041,30 +1029,72 @@ let add_mode dbname l m = let db' = Hint_db.add_mode l m db in searchtable_add (dbname, db') +type db_obj = { + db_local : bool; + db_name : string; + db_use_dn : bool; + db_ts : TransparentState.t; +} + +let cache_db (_, {db_name=name; db_use_dn=b; db_ts=ts}) = + searchtable_add (name, Hint_db.empty ~name ts b) + +let load_db _ x = cache_db x + +let classify_db db = if db.db_local then Dispose else Substitute db + +let inDB : db_obj -> obj = + declare_object {(default_object "AUTOHINT_DB") with + cache_function = cache_db; + load_function = load_db; + subst_function = (fun (_,x) -> x); + classify_function = classify_db; } + +let create_hint_db l n ts b = + let hint = {db_local=l; db_name=n; db_use_dn=b; db_ts=ts} in + Lib.add_anonymous_leaf (inDB hint) + +type hint_action = + | AddTransparency of { + grefs : evaluable_global_reference hints_transparency_target; + state : bool; + } + | AddHints of hint_entry list + | RemoveHints of GlobRef.t list + | AddCut of hints_path + | AddMode of { gref : GlobRef.t; mode : hint_mode array } + +type hint_locality = Local | Export | SuperGlobal + type hint_obj = { - hint_local : bool; + hint_local : hint_locality; hint_name : string; hint_action : hint_action; } +let superglobal h = match h.hint_local with + | SuperGlobal -> true + | Local | Export -> false + let load_autohint _ (kn, h) = let name = h.hint_name in + let superglobal = superglobal h in match h.hint_action with - | CreateDB (b, st) -> searchtable_add (name, Hint_db.empty ~name st b) - | AddTransparency { superglobal; grefs; state } -> + | AddTransparency { grefs; state } -> if superglobal then add_transparency name grefs state - | AddHints { superglobal; hints } -> + | AddHints hints -> if superglobal then add_hint name hints - | RemoveHints { superglobal; hints } -> + | RemoveHints hints -> if superglobal then remove_hint name hints - | AddCut { superglobal; paths } -> + | AddCut paths -> if superglobal then add_cut name paths - | AddMode { superglobal; gref; mode } -> + | AddMode { gref; mode } -> if superglobal then add_mode name gref mode let open_autohint i (kn, h) = + let superglobal = superglobal h in if Int.equal i 1 then match h.hint_action with - | AddHints { superglobal; hints } -> + | AddHints hints -> let () = if not superglobal then (* Import-bound hints must be declared when not imported yet *) @@ -1073,15 +1103,14 @@ let open_autohint i (kn, h) = in let add (_, hint) = statustable := KNmap.add hint.code.uid true !statustable in List.iter add hints - | AddCut { superglobal; paths } -> + | AddCut paths -> if not superglobal then add_cut h.hint_name paths - | AddTransparency { superglobal; grefs; state } -> + | AddTransparency { grefs; state } -> if not superglobal then add_transparency h.hint_name grefs state - | RemoveHints { superglobal; hints } -> + | RemoveHints hints -> if not superglobal then remove_hint h.hint_name hints - | AddMode { superglobal; gref; mode } -> + | AddMode { gref; mode } -> if not superglobal then add_mode h.hint_name gref mode - | CreateDB _ -> () let cache_autohint (kn, obj) = load_autohint 1 (kn, obj); open_autohint 1 (kn, obj) @@ -1137,8 +1166,7 @@ let subst_autohint (subst, obj) = if k' == k && data' == data then hint else (k',data') in let action = match obj.hint_action with - | CreateDB _ -> obj.hint_action - | AddTransparency { superglobal; grefs = target; state = b } -> + | AddTransparency { grefs = target; state = b } -> let target' = match target with | HintsVariables -> target @@ -1148,26 +1176,28 @@ let subst_autohint (subst, obj) = if grs == grs' then target else HintsReferences grs' in - if target' == target then obj.hint_action else AddTransparency { superglobal; grefs = target'; state = b } - | AddHints { superglobal; hints } -> + if target' == target then obj.hint_action else AddTransparency { grefs = target'; state = b } + | AddHints hints -> let hints' = List.Smart.map subst_hint hints in - if hints' == hints then obj.hint_action else AddHints { superglobal; hints = hints' } - | RemoveHints { superglobal; hints = grs } -> + if hints' == hints then obj.hint_action else AddHints hints' + | RemoveHints grs -> let grs' = List.Smart.map (subst_global_reference subst) grs in - if grs == grs' then obj.hint_action else RemoveHints { superglobal; hints = grs' } - | AddCut { superglobal; paths = path } -> + if grs == grs' then obj.hint_action else RemoveHints grs' + | AddCut path -> let path' = subst_hints_path subst path in - if path' == path then obj.hint_action else AddCut { superglobal; paths = path' } - | AddMode { superglobal; gref = l; mode = m } -> + if path' == path then obj.hint_action else AddCut path' + | AddMode { gref = l; mode = m } -> let l' = subst_global_reference subst l in - if l' == l then obj.hint_action else AddMode { superglobal; gref = l'; mode = m } + if l' == l then obj.hint_action else AddMode { gref = l'; mode = m } in if action == obj.hint_action then obj else { obj with hint_action = action } let classify_autohint obj = match obj.hint_action with - | AddHints { hints = [] } -> Dispose - | _ -> if obj.hint_local then Dispose else Substitute obj + | AddHints [] -> Dispose + | _ -> match obj.hint_local with + | Local -> Dispose + | Export | SuperGlobal -> Substitute obj let inAutoHint : hint_obj -> obj = declare_object {(default_object "AUTOHINT") with @@ -1177,16 +1207,12 @@ let inAutoHint : hint_obj -> obj = subst_function = subst_autohint; classify_function = classify_autohint; } -let make_hint ?(local = false) name action = { +let make_hint ~local name action = { hint_local = local; hint_name = name; hint_action = action; } -let create_hint_db l n st b = - let hint = make_hint ~local:l n (CreateDB (b, st)) in - Lib.add_anonymous_leaf (inAutoHint hint) - let warn_deprecated_hint_without_locality = CWarnings.create ~name:"deprecated-hint-without-locality" ~category:"deprecated" (fun () -> strbrk "The default value for hint locality is currently \ @@ -1210,16 +1236,16 @@ let check_hint_locality = let open Goptions in function | OptLocal -> () let interp_locality = function -| Goptions.OptDefault | Goptions.OptGlobal -> false, true -| Goptions.OptExport -> false, false -| Goptions.OptLocal -> true, false +| Goptions.OptDefault | Goptions.OptGlobal -> SuperGlobal +| Goptions.OptExport -> Export +| Goptions.OptLocal -> Local let remove_hints ~locality dbnames grs = - let local, superglobal = interp_locality locality in + let local = interp_locality locality in let dbnames = if List.is_empty dbnames then ["core"] else dbnames in List.iter (fun dbname -> - let hint = make_hint ~local dbname (RemoveHints { superglobal; hints = grs }) in + let hint = make_hint ~local dbname (RemoveHints grs) in Lib.add_anonymous_leaf (inAutoHint hint)) dbnames @@ -1227,7 +1253,7 @@ let remove_hints ~locality dbnames grs = (* The "Hint" vernacular command *) (**************************************************************************) -let add_resolves env sigma clist ~local ~superglobal dbnames = +let add_resolves env sigma clist ~local dbnames = List.iter (fun dbname -> let r = @@ -1254,56 +1280,56 @@ let add_resolves env sigma clist ~local ~superglobal dbnames = | _ -> () in let () = if not !Flags.quiet then List.iter check r in - let hint = make_hint ~local dbname (AddHints { superglobal; hints = r }) in + let hint = make_hint ~local dbname (AddHints r) in Lib.add_anonymous_leaf (inAutoHint hint)) dbnames -let add_unfolds l ~local ~superglobal dbnames = +let add_unfolds l ~local dbnames = List.iter (fun dbname -> - let hint = make_hint ~local dbname (AddHints { superglobal; hints = List.map make_unfold l }) in + let hint = make_hint ~local dbname (AddHints (List.map make_unfold l)) in Lib.add_anonymous_leaf (inAutoHint hint)) dbnames -let add_cuts l ~local ~superglobal dbnames = +let add_cuts l ~local dbnames = List.iter (fun dbname -> - let hint = make_hint ~local dbname (AddCut { superglobal; paths = l }) in + let hint = make_hint ~local dbname (AddCut l) in Lib.add_anonymous_leaf (inAutoHint hint)) dbnames -let add_mode l m ~local ~superglobal dbnames = +let add_mode l m ~local dbnames = List.iter (fun dbname -> let m' = make_mode l m in - let hint = make_hint ~local dbname (AddMode { superglobal; gref = l; mode = m' }) in + let hint = make_hint ~local dbname (AddMode { gref = l; mode = m' }) in Lib.add_anonymous_leaf (inAutoHint hint)) dbnames -let add_transparency l b ~local ~superglobal dbnames = +let add_transparency l b ~local dbnames = List.iter (fun dbname -> - let hint = make_hint ~local dbname (AddTransparency { superglobal; grefs = l; state = b }) in + let hint = make_hint ~local dbname (AddTransparency { grefs = l; state = b }) in Lib.add_anonymous_leaf (inAutoHint hint)) dbnames -let add_extern info tacast ~local ~superglobal dbname = +let add_extern info tacast ~local dbname = let pat = match info.hint_pattern with | None -> None | Some (_, pat) -> Some pat in let hint = make_hint ~local dbname - (AddHints { superglobal; hints = [make_extern (Option.get info.hint_priority) pat tacast] }) in + (AddHints [make_extern (Option.get info.hint_priority) pat tacast]) in Lib.add_anonymous_leaf (inAutoHint hint) -let add_externs info tacast ~local ~superglobal dbnames = - List.iter (add_extern info tacast ~local ~superglobal) dbnames +let add_externs info tacast ~local dbnames = + List.iter (add_extern info tacast ~local) dbnames -let add_trivials env sigma l ~local ~superglobal dbnames = +let add_trivials env sigma l ~local dbnames = List.iter (fun dbname -> 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 + let hint = make_hint ~local dbname (AddHints l) in Lib.add_anonymous_leaf (inAutoHint hint)) dbnames @@ -1360,22 +1386,22 @@ let prepare_hint check env init (sigma,c) = (c', diff) let add_hints ~locality dbnames h = - let local, superglobal = interp_locality locality in + let local = interp_locality locality in if String.List.mem "nocore" dbnames then user_err Pp.(str "The hint database \"nocore\" is meant to stay empty."); assert (not (List.is_empty dbnames)); let env = Global.env() in let sigma = Evd.from_env env in match h with - | HintsResolveEntry lhints -> add_resolves env sigma lhints ~local ~superglobal dbnames - | HintsImmediateEntry lhints -> add_trivials env sigma lhints ~local ~superglobal dbnames - | HintsCutEntry lhints -> add_cuts lhints ~local ~superglobal dbnames - | HintsModeEntry (l,m) -> add_mode l m ~local ~superglobal dbnames - | HintsUnfoldEntry lhints -> add_unfolds lhints ~local ~superglobal dbnames + | HintsResolveEntry lhints -> add_resolves env sigma lhints ~local dbnames + | HintsImmediateEntry lhints -> add_trivials env sigma lhints ~local dbnames + | HintsCutEntry lhints -> add_cuts lhints ~local dbnames + | HintsModeEntry (l,m) -> add_mode l m ~local dbnames + | HintsUnfoldEntry lhints -> add_unfolds lhints ~local dbnames | HintsTransparencyEntry (lhints, b) -> - add_transparency lhints b ~local ~superglobal dbnames + add_transparency lhints b ~local dbnames | HintsExternEntry (info, tacexp) -> - add_externs info tacexp ~local ~superglobal dbnames + add_externs info tacexp ~local dbnames let hint_globref gr = IsGlobRef gr diff --git a/tactics/redexpr.ml b/tactics/redexpr.ml index 87cae3abe5..3ee85f6b1b 100644 --- a/tactics/redexpr.ml +++ b/tactics/redexpr.ml @@ -271,11 +271,14 @@ let reduction_of_red_expr env r = let error_illegal_clause () = CErrors.user_err Pp.(str "\"at\" clause not supported in presence of an occurrence clause.") +let error_multiple_patterns () = + CErrors.user_err Pp.(str "\"at\" clause in occurences not supported with multiple patterns or references.") + let error_illegal_non_atomic_clause () = CErrors.user_err Pp.(str "\"at\" clause not supported in presence of a non atomic \"in\" clause.") -let error_occurrences_not_unsupported () = - CErrors.user_err Pp.(str "Occurrences not supported for this reduction tactic.") +let error_at_in_occurrences_not_supported () = + CErrors.user_err Pp.(str "\"at\" clause not supported for this reduction tactic.") let bind_red_expr_occurrences occs nbcl redexp = let open Locus in @@ -292,14 +295,14 @@ let bind_red_expr_occurrences occs nbcl redexp = else match redexp with | Unfold (_::_::_) -> - error_illegal_clause () + error_multiple_patterns () | Unfold [(occl,c)] -> if occl != AllOccurrences then error_illegal_clause () else Unfold [(occs,c)] | Pattern (_::_::_) -> - error_illegal_clause () + error_multiple_patterns () | Pattern [(occl,c)] -> if occl != AllOccurrences then error_illegal_clause () @@ -322,7 +325,7 @@ let bind_red_expr_occurrences occs nbcl redexp = CbvNative (Some (occs,c)) | Red _ | Hnf | Cbv _ | Lazy _ | Cbn _ | ExtraRedExpr _ | Fold _ | Simpl (_,None) | CbvVm None | CbvNative None -> - error_occurrences_not_unsupported () + error_at_in_occurrences_not_supported () | Unfold [] | Pattern [] -> assert false diff --git a/tactics/tactics.ml b/tactics/tactics.ml index cbf12ac22f..67bf8d0d29 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -2796,7 +2796,24 @@ let generalize_goal_gen env sigma ids i ((occs,c,b),na) t cl = let open Context.Rel.Declaration in let decls,cl = decompose_prod_n_assum sigma i cl in let dummy_prod = it_mkProd_or_LetIn mkProp decls in - let newdecls,_ = decompose_prod_n_assum sigma i (subst_term_gen sigma EConstr.eq_constr_nounivs c dummy_prod) in + let newdecls,_ = + let c = Termops.collapse_appl sigma c in + let arity = Array.length (snd (Termops.decompose_app_vect sigma c)) in + let cache = ref Int.Map.empty in + let eq sigma k t = + let c = + try Int.Map.find k !cache + with Not_found -> + let c = EConstr.Vars.lift k c in + let () = cache := Int.Map.add k c !cache in + c + in + (* We use a nounivs equality because generalize morally takes a pattern as + argument, so we have to ignore freshly generated sorts. *) + EConstr.eq_constr_nounivs sigma c t + in + decompose_prod_n_assum sigma i (replace_term_gen sigma eq arity (mkRel 1) dummy_prod) + in let cl',sigma' = subst_closed_term_occ env sigma (AtOccs occs) c (it_mkProd_or_LetIn cl newdecls) in let na = generalized_name env sigma c t ids cl' na in let r = Retyping.relevance_of_type env sigma t in diff --git a/test-suite/Makefile b/test-suite/Makefile index 245c717d42..2a2f62e23f 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -46,7 +46,11 @@ BIN := $(ROOT)/bin/ COQLIB?= ifeq ($(COQLIB),) + ifeq ($(LOCAL),true) COQLIB := $(shell ocaml ocaml_pwd.ml ..) + else + COQLIB := $(shell ocaml ocaml_pwd.ml $(COQLIBINSTALL)) + endif endif endif # exists ../_build export COQLIB @@ -320,7 +324,7 @@ 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,ounit2 \ + $(HIDE)$(OCAMLBEST) -linkall -linkpkg -package coq-core.toplevel,ounit2 \ -I unit-tests/src $(UNIT_LINK) $< -o $<.test; $(HIDE)./$<.test diff --git a/test-suite/bugs/closed/bug_12011.v b/test-suite/bugs/closed/bug_12011.v new file mode 100644 index 0000000000..f149b4e8ae --- /dev/null +++ b/test-suite/bugs/closed/bug_12011.v @@ -0,0 +1,21 @@ +From Coq Require Import Setoid ssreflect. + +Lemma test A (R : relation A) `{Equivalence _ R} (x y z : A) : + R x y -> R y z -> R x z. +Proof. + intros Hxy Hyz. + rewrite -Hxy in Hyz. + exact Hyz. +Qed. + + + +Axiom envs_lookup_delete : bool. +Axiom envs_lookup_delete_Some : envs_lookup_delete = true <-> False. + +Goal envs_lookup_delete = true -> False. +Proof. +intros Hlookup. +rewrite envs_lookup_delete_Some in Hlookup *. (* <- used to revert Hlookup *) +exact Hlookup. +Qed. diff --git a/test-suite/bugs/closed/bug_13586.v b/test-suite/bugs/closed/bug_13586.v new file mode 100644 index 0000000000..6a739c364a --- /dev/null +++ b/test-suite/bugs/closed/bug_13586.v @@ -0,0 +1,6 @@ +Goal True. +Fail timeout 2 ((timeout 1 repeat cut True) || (repeat cut True)). +Fail Timeout 2 ((timeout 1 repeat cut True) || (repeat cut True)). +Fail timeout 1 ((timeout 2 repeat cut True) || idtac "fail"). +auto. +Qed. diff --git a/test-suite/bugs/closed/bug_13732.v b/test-suite/bugs/closed/bug_13732.v new file mode 100644 index 0000000000..24840abdf6 --- /dev/null +++ b/test-suite/bugs/closed/bug_13732.v @@ -0,0 +1,16 @@ +Module Sort. + Set Printing Universes. + + Implicit Types TT : Type. + + Check fun TT => nat. +End Sort. + +Module Ref. + Set Universe Polymorphism. + + Axiom tele : Type. + + Implicit Types TT : tele. + Check fun TT => nat. +End Ref. diff --git a/test-suite/bugs/closed/bug_13841.v b/test-suite/bugs/closed/bug_13841.v new file mode 100644 index 0000000000..60fca8b49c --- /dev/null +++ b/test-suite/bugs/closed/bug_13841.v @@ -0,0 +1,11 @@ +Goal True. +evar (p : bool). +unify ?p true. +let v := eval vm_compute in (orb p false) in +match v with true => idtac end. +assert (orb p false = true). +vm_compute. +match goal with |- true = _ => idtac end. +easy. +easy. +Qed. diff --git a/test-suite/bugs/closed/bug_13896.v b/test-suite/bugs/closed/bug_13896.v new file mode 100644 index 0000000000..10f24d8564 --- /dev/null +++ b/test-suite/bugs/closed/bug_13896.v @@ -0,0 +1,24 @@ +Inductive type : Set := + Tptr : type -> type + | Tref : type -> type + | Trv_ref : type -> type + | Tint : type -> type -> type + | Tvoid : type + | Tarray : type -> type -> type + | Tnamed : type -> type + | Tfunction : type -> type -> type -> type + | Tbool : type + | Tmember_pointer : type -> type -> type + | Tfloat : type -> type + | Tqualified : type -> type -> type + | Tnullptr : type + | Tarch : type -> type -> type +. +Definition type_eq_dec : forall (ty1 ty2 : type), { ty1 = ty2 } + { ty1 <> ty2 }. +Proof. fix IHty1 1. decide equality. Defined. + +Goal (if type_eq_dec (Tptr Tvoid) (Tptr Tvoid) then True else False). +Proof. +timeout 1 cbn. +constructor. +Qed. diff --git a/test-suite/bugs/closed/bug_13903.v b/test-suite/bugs/closed/bug_13903.v new file mode 100644 index 0000000000..7c1820b85c --- /dev/null +++ b/test-suite/bugs/closed/bug_13903.v @@ -0,0 +1,5 @@ +Section test. +Variables (T : Type) (x : T). +#[using="x"] Definition test : unit := tt. +End test. +Check test : forall T, T -> unit. diff --git a/test-suite/bugs/closed/bug_13960.v b/test-suite/bugs/closed/bug_13960.v new file mode 100644 index 0000000000..947db9586f --- /dev/null +++ b/test-suite/bugs/closed/bug_13960.v @@ -0,0 +1,10 @@ +Require Ltac2.Ltac2. + +Set Default Goal Selector "!". + +Ltac2 t () := let _ := Message.print (Message.of_string "hi") in 42. + +Goal False. +Proof. +Ltac2 Eval t (). +Abort. diff --git a/test-suite/bugs/closed/bug_4836.v b/test-suite/bugs/closed/bug_4836.v index 9aefb10172..62d39619b0 100644 --- a/test-suite/bugs/closed/bug_4836.v +++ b/test-suite/bugs/closed/bug_4836.v @@ -1 +1 @@ -(* -*- coq-prog-args: ("bugs/closed/PLACEHOLDER.v") -*- *) +(* Placeholder file for directory / file test *) diff --git a/test-suite/bugs/closed/bug_7631.v b/test-suite/bugs/closed/bug_7631.v index 93aeb83e28..14ab4de9b7 100644 --- a/test-suite/bugs/closed/bug_7631.v +++ b/test-suite/bugs/closed/bug_7631.v @@ -21,3 +21,9 @@ Definition bar (x := foo) := Eval native_compute in x. Definition barvm (x := foo) := Eval vm_compute in x. End RelContext. + +Definition bar (t:=_) (x := true : t) := Eval native_compute in x. +Definition barvm (t:=_) (x := true : t) := Eval vm_compute in x. + +Definition baz (z:nat) (t:=_ z) (x := true : t) := Eval native_compute in x. +Definition bazvm (z:nat) (t:=_ z) (x := true : t) := Eval vm_compute in x. 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 index 47d0e09e1a..258eb04271 100644 --- 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 @@ -744,7 +744,7 @@ CONTRIBUTING.md CREDITS INSTALL.md LICENSE -META.coq.in +META.coq-core.in Makefile Makefile.build Makefile.checker @@ -5626,4 +5626,4 @@ 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 +[0;m diff --git a/test-suite/dune b/test-suite/dune index 1864153021..09597fc864 100644 --- a/test-suite/dune +++ b/test-suite/dune @@ -35,7 +35,8 @@ ; For the changelog test ../config/coq_config.py (source_tree doc/changelog) - (package coq) + (package coq-core) + (package coq-stdlib) ; For fake_ide (package coqide-server) (source_tree .)) diff --git a/test-suite/ltac2/ind.v b/test-suite/ltac2/ind.v new file mode 100644 index 0000000000..6f7352d224 --- /dev/null +++ b/test-suite/ltac2/ind.v @@ -0,0 +1,25 @@ +Require Import Ltac2.Ltac2. +Require Import Ltac2.Option. + +Ltac2 Eval + let nat := Option.get (Env.get [@Coq; @Init; @Datatypes; @nat]) in + let nat := match nat with + | Std.IndRef nat => nat + | _ => Control.throw Not_found + end in + let data := Ind.data nat in + (* Check that there is only one inductive in the block *) + let ntypes := Ind.nblocks data in + let () := if Int.equal ntypes 1 then () else Control.throw Not_found in + let nat' := Ind.repr (Ind.get_block data 0) in + (* Check it corresponds *) + let () := if Ind.equal nat nat' then () else Control.throw Not_found in + let () := if Int.equal (Ind.index nat) 0 then () else Control.throw Not_found in + (* Check the number of constructors *) + let nconstr := Ind.nconstructors data in + let () := if Int.equal nconstr 2 then () else Control.throw Not_found in + (* Create a fresh instance *) + let s := Ind.get_constructor data 1 in + let s := Env.instantiate (Std.ConstructRef s) in + constr:($s 0) +. diff --git a/test-suite/ltac2/printf.v b/test-suite/ltac2/printf.v new file mode 100644 index 0000000000..f96a01a9c9 --- /dev/null +++ b/test-suite/ltac2/printf.v @@ -0,0 +1,31 @@ +Require Import Ltac2.Ltac2. +Require Import Ltac2.Printf. + +(* Check that the arguments have type unit *) +Ltac2 ignore (x : unit) := (). + +Ltac2 dummy (_ : unit) (_ : int) := Message.of_string "dummy". + +(** Simple test for all specifications *) + +Ltac2 Eval ignore (printf "%i" 42). +Ltac2 Eval ignore (printf "%s" "abc"). +Ltac2 Eval ignore (printf "%I" @Foo). +Ltac2 Eval ignore (printf "%t" '(1 + 1 = 0)). +Ltac2 Eval ignore (printf "%%"). +Ltac2 Eval ignore (printf "%a" dummy 18). + +(** More complex tests *) + +Ltac2 Eval ignore (printf "%I foo%a bar %s" @ok dummy 18 "yes"). + +Ltac2 Eval Message.print (fprintf "%I foo%a bar %s" @ok dummy 18 "yes"). + +(** Failure tests *) + +Fail Ltac2 Eval printf "%i" "foo". +Fail Ltac2 Eval printf "%s" 0. +Fail Ltac2 Eval printf "%I" "foo". +Fail Ltac2 Eval printf "%t" "foo". +Fail Ltac2 Eval printf "%a" (fun _ _ => ()). +Fail Ltac2 Eval printf "%a" (fun _ i => Message.of_int i) "foo". diff --git a/test-suite/micromega/bug_13794.v b/test-suite/micromega/bug_13794.v new file mode 100644 index 0000000000..5e303a0b7f --- /dev/null +++ b/test-suite/micromega/bug_13794.v @@ -0,0 +1,39 @@ +From Coq Require Import Lia ZArith.ZArith NArith.NArith. +Unset Nia Cache. + +Open Scope N_scope. + + +Lemma over (n0 n1 n2 n3 n4 n5 n6 : N) + (e0 : 1 + 8 * n0 = n1 * n1 + n2) + (e1 : n1 - 1 = 2 * n3 + n4) + (e2 : n3 * (1 + n3) = 2 * n5) + (e3 : n2 + 2 * n4 * n1 - n4 = 8 * n6) + (o0 : n4 = 0 \/ n4 = 1) : + n6 = n0 - n5. +Proof. + Time nia. +Qed. + +Lemma over2 (n0 n1 n2 n3 n4 n5 n6 : N) + (e0 : 1 + 8 * n0 = n1 * n1 + n2) + (e1 : n1 + 1 = 2 * n3 + n4) + (e2 : n3 * (1 + n3) = 2 * n5) + (e3 : n2 + 2 * n4 * n1 + n4 = 8 * n6) + (o0 : n4 = 0) : + n6 = n0 + n5. +Proof. + Fail nia. +Abort. + +Open Scope Z_scope. + +Lemma over3 (n1 n2 n3 n4 n5 : Z) + (e : 0 <= n1 /\ 0 <= n2 /\ 0 <= n3 /\ 0 <= n4 + /\ 0 <= n5) + (e1 : n1 + 1 = 20 * n3 + n4) + (e3 : n2 + 2 * n4 * n1 + n4 = 8 * n5) : + n5 = 0. +Proof. +Time Fail nia. +Abort. diff --git a/test-suite/misc/coq_environment.sh b/test-suite/misc/coq_environment.sh index 667d11f89e..6f7b11c8f1 100755 --- a/test-suite/misc/coq_environment.sh +++ b/test-suite/misc/coq_environment.sh @@ -16,7 +16,7 @@ EOT cp $BIN/coqc . cp $BIN/coq_makefile . mkdir -p overridden/tools/ -cp $COQLIB/tools/CoqMakefile.in overridden/tools/ +cp $COQLIB/tools/CoqMakefile.in overridden/tools/ || cp $COQLIB/../coq-core/tools/CoqMakefile.in overridden/tools/ unset COQLIB N=`./coqc -config | grep COQLIB | grep /overridden | wc -l` diff --git a/test-suite/misc/coqtop_print-mod-uid.sh b/test-suite/misc/coqtop_print-mod-uid.sh new file mode 100755 index 0000000000..db1df4bb4b --- /dev/null +++ b/test-suite/misc/coqtop_print-mod-uid.sh @@ -0,0 +1,6 @@ +#!/usr/bin/env bash + +export COQBIN=$BIN +export PATH=$COQBIN:$PATH + +[ "$(coqtop -print-mod-uid prerequisite/admit.vo)" = "prerequisite/.coq-native/NTestSuite_admit" ] diff --git a/test-suite/output/DebugFlags.out b/test-suite/output/DebugFlags.out new file mode 100644 index 0000000000..0385413937 --- /dev/null +++ b/test-suite/output/DebugFlags.out @@ -0,0 +1,44 @@ +File "stdin", line 1, characters 0-16: +Warning: There is no debug flag "cbn". [unknown-debug-flag,option] +Debug: [RAKAM] <<forall A : Type, A -> A -> Prop|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<forall A : Type, A -> A -> Prop|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<?A -> ?A -> Prop|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<?A -> ?A -> Prop|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> nat|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> Prop|>> +Debug: [RAKAM] <><><><><> +Debug: [RAKAM] <<nat -> Prop|>> +Debug: [RAKAM] <><><><><> +2 + 3 = 0 + : Prop diff --git a/test-suite/output/DebugFlags.v b/test-suite/output/DebugFlags.v new file mode 100644 index 0000000000..32c0f2d24b --- /dev/null +++ b/test-suite/output/DebugFlags.v @@ -0,0 +1,5 @@ +Set Debug "cbn". + +Set Debug "RAKAM". + +Check 2 + 3 = 0. diff --git a/test-suite/bugs/closed/PLACEHOLDER.v b/test-suite/output/Function.out index e69de29bb2..e69de29bb2 100644 --- a/test-suite/bugs/closed/PLACEHOLDER.v +++ b/test-suite/output/Function.out diff --git a/test-suite/output/Function.v b/test-suite/output/Function.v new file mode 100644 index 0000000000..b3e2a93895 --- /dev/null +++ b/test-suite/output/Function.v @@ -0,0 +1,31 @@ +Require Import FunInd List. + +(* Explanations: This kind of pattern matching displays a legitimate + unused variable warning in v8.13. + +Fixpoint f (l:list nat) : nat := + match l with + | nil => O + | S n :: nil => 1 + | x :: l' => f l' + end. +*) + +(* In v8.13 the same code with "Function" generates a lot more + warnings about variables created automatically by Function. These + are not legitimate. PR #13776 (post v8.13) removes all warnings + about pattern matching variables (and non truly recursive fixpoint) + for "Function". So this should not generate any warning. Note that + this PR removes also the legitimate warnings. It would be better if + this test generate the same warning as the Fixpoint above. This + test would then need to be updated. *) + +(* Ensuring the warning is a warning. *) +Set Warnings "matching-variable". +(* But no warning generated here. *) +Function f (l:list nat) : nat := + match l with + | nil => O + | S n :: nil => 1 + | n :: l' => f l' + end. diff --git a/test-suite/output/Int63Syntax.out b/test-suite/output/Int63Syntax.out index 7ca4de1e46..96af456891 100644 --- a/test-suite/output/Int63Syntax.out +++ b/test-suite/output/Int63Syntax.out @@ -15,9 +15,9 @@ 427 : int The command has indeed failed with message: -Cannot interpret this number as a value of type Coq.Numbers.Cyclic.Int63.PrimInt63.int +Cannot interpret this number as a value of type int The command has indeed failed with message: -Cannot interpret this number as a value of type Coq.Numbers.Cyclic.Int63.PrimInt63.int +Cannot interpret this number as a value of type int 0 : int 0 @@ -33,9 +33,11 @@ The reference x was not found in the current environment. add 2 2 : int The command has indeed failed with message: -int63 are only non-negative numbers. +Cannot interpret this number as a value of type int The command has indeed failed with message: overflow in int63 literal: 9223372036854775808 +0x1 + : int 2 : nat 2%int63 diff --git a/test-suite/output/Int63Syntax.v b/test-suite/output/Int63Syntax.v index 50910264f2..be0ee701af 100644 --- a/test-suite/output/Int63Syntax.v +++ b/test-suite/output/Int63Syntax.v @@ -20,6 +20,11 @@ Fail Check 0x. Check (PrimInt63.add 2 2). Fail Check -1. Fail Check 9223372036854775808. + +Set Printing All. +Check 1%int63. +Unset Printing All. + Open Scope nat_scope. Check 2. (* : nat *) Check 2%int63. diff --git a/test-suite/output/Notations3.out b/test-suite/output/Notations3.out index 60213cab0c..cc9e745f6b 100644 --- a/test-suite/output/Notations3.out +++ b/test-suite/output/Notations3.out @@ -6,7 +6,7 @@ : nat * nat * (nat * nat) (0, 2, (2, 2)) : nat * nat * (nat * nat) -pair (pair O (S (S O))) (pair (S (S O)) O) +pair (pair 0 2) (pair 2 0) : prod (prod nat nat) (prod nat nat) << 0, 2, 4 >> : nat * nat * nat * (nat * (nat * nat)) @@ -16,8 +16,7 @@ pair (pair O (S (S O))) (pair (S (S O)) O) : nat * nat * nat * (nat * (nat * nat)) (0, 2, 4, (0, (2, 4))) : nat * nat * nat * (nat * (nat * nat)) -pair (pair (pair O (S (S O))) (S (S (S (S O))))) - (pair (S (S (S (S O)))) (pair (S (S O)) O)) +pair (pair (pair 0 2) 4) (pair 4 (pair 2 0)) : prod (prod (prod nat nat) nat) (prod nat (prod nat nat)) ETA x y : nat, Nat.add : nat -> nat -> nat @@ -174,9 +173,8 @@ forall_non_null x y z t : nat , x = y /\ z = t : nat * (nat * nat) * (nat * nat * nat) * (nat * (nat * nat)) * (nat * nat * nat) pair - (pair - (pair (pair (S (S O)) (pair (S O) O)) (pair (pair O (S (S O))) (S O))) - (pair (S O) (pair (S (S O)) O))) (pair (pair O (S O)) (S (S O))) + (pair (pair (pair 2 (pair 1 0)) (pair (pair 0 2) 1)) (pair 1 (pair 2 0))) + (pair (pair 0 1) 2) : prod (prod (prod (prod nat (prod nat nat)) (prod (prod nat nat) nat)) (prod nat (prod nat nat))) (prod (prod nat nat) nat) diff --git a/test-suite/output/Notations4.out b/test-suite/output/Notations4.out index 3477a293e3..0b18981f4e 100644 --- a/test-suite/output/Notations4.out +++ b/test-suite/output/Notations4.out @@ -77,18 +77,18 @@ fun x : nat => [x] : nat -> nat ∀ x : nat, x = x : Prop -File "stdin", line 184, characters 0-160: +File "stdin", line 187, characters 0-160: Warning: Notation "∀ _ .. _ , _" was already defined with a different format in scope type_scope. [notation-incompatible-format,parsing] ∀x : nat,x = x : Prop -File "stdin", line 197, characters 0-60: +File "stdin", line 200, characters 0-60: Warning: Notation "_ %%% _" was already defined with a different format. [notation-incompatible-format,parsing] -File "stdin", line 201, characters 0-64: +File "stdin", line 204, characters 0-64: Warning: Notation "_ %%% _" was already defined with a different format. [notation-incompatible-format,parsing] -File "stdin", line 206, characters 0-62: +File "stdin", line 209, characters 0-62: Warning: Lonely notation "_ %%%% _" was already defined with a different format. [notation-incompatible-format,parsing] 3 %% 4 @@ -97,10 +97,10 @@ format. [notation-incompatible-format,parsing] : nat 3 %% 4 : nat -File "stdin", line 234, characters 0-61: +File "stdin", line 237, characters 0-61: Warning: The format modifier is irrelevant for only parsing rules. [irrelevant-format-only-parsing,parsing] -File "stdin", line 238, characters 0-63: +File "stdin", line 241, characters 0-63: Warning: The only parsing modifier has no effect in Reserved Notation. [irrelevant-reserved-notation-only-parsing,parsing] fun x : nat => U (S x) @@ -111,7 +111,7 @@ fun x : nat => V x : forall x : nat, nat * (?T -> ?T) where ?T : [x : nat x0 : ?T |- Type] (x0 cannot be used) -File "stdin", line 255, characters 0-30: +File "stdin", line 258, characters 0-30: Warning: Notation "_ :=: _" was already used. [notation-overridden,parsing] 0 :=: 0 : Prop diff --git a/test-suite/output/Notations4.v b/test-suite/output/Notations4.v index ebad12af88..a5ec92fe3c 100644 --- a/test-suite/output/Notations4.v +++ b/test-suite/output/Notations4.v @@ -103,7 +103,10 @@ Module NumberNotations. Delimit Scope test17_scope with test17. Local Set Primitive Projections. Record myint63 := of_int { to_int : int }. - Number Notation myint63 of_int to_int : test17_scope. + Definition parse x := + match x with Pos x => Some (of_int x) | Neg _ => None end. + Definition print x := Pos (to_int x). + Number Notation myint63 parse print : test17_scope. Check let v := 0%test17 in v : myint63. End Test17. End NumberNotations. diff --git a/test-suite/output/NumberNotations.out b/test-suite/output/NumberNotations.out index 60682edec8..df9b39389c 100644 --- a/test-suite/output/NumberNotations.out +++ b/test-suite/output/NumberNotations.out @@ -260,28 +260,28 @@ The command has indeed failed with message: add is not a constructor of an inductive type. The command has indeed failed with message: Missing mapping for constructor Iempty. -File "stdin", line 574, characters 56-61: +File "stdin", line 577, characters 56-61: Warning: Type of I'sum seems incompatible with the type of sum. Expected type is: (I' -> I' -> I') instead of (I -> I' -> I'). This might yield ill typed terms when using the notation. [via-type-mismatch,numbers] -File "stdin", line 579, characters 32-33: +File "stdin", line 582, characters 32-33: Warning: I was already mapped to Set, mapping it also to nat might yield ill typed terms when using the notation. [via-type-remapping,numbers] -File "stdin", line 579, characters 37-42: +File "stdin", line 582, characters 37-42: Warning: Type of Iunit seems incompatible with the type of O. Expected type is: I instead of I. This might yield ill typed terms when using the notation. [via-type-mismatch,numbers] The command has indeed failed with message: 'via' and 'abstract' cannot be used together. -File "stdin", line 659, characters 21-23: +File "stdin", line 662, characters 21-23: Warning: Type of I1 seems incompatible with the type of Fin.F1. Expected type is: (nat -> I) instead of I. This might yield ill typed terms when using the notation. [via-type-mismatch,numbers] -File "stdin", line 659, characters 35-37: +File "stdin", line 662, characters 35-37: Warning: Type of IS seems incompatible with the type of Fin.FS. Expected type is: (nat -> I -> I) instead of (I -> I). This might yield ill typed terms when using the notation. diff --git a/test-suite/output/NumberNotations.v b/test-suite/output/NumberNotations.v index 718da13500..85400c2fd4 100644 --- a/test-suite/output/NumberNotations.v +++ b/test-suite/output/NumberNotations.v @@ -328,7 +328,10 @@ Module Test17. Delimit Scope test17_scope with test17. Local Set Primitive Projections. Record myint63 := of_int { to_int : int }. - Number Notation myint63 of_int to_int : test17_scope. + Definition parse x := + match x with Pos x => Some (of_int x) | Neg _ => None end. + Definition print x := Pos (to_int x). + Number Notation myint63 parse print : test17_scope. Check let v := 0%test17 in v : myint63. End Test17. diff --git a/test-suite/output/Sint63Syntax.out b/test-suite/output/Sint63Syntax.out new file mode 100644 index 0000000000..db14658307 --- /dev/null +++ b/test-suite/output/Sint63Syntax.out @@ -0,0 +1,66 @@ +2%sint63 + : int +2 + : int +-3 + : int +4611686018427387903 + : int +-4611686018427387904 + : int +427 + : int +427 + : int +427 + : int +427 + : int +427 + : int +The command has indeed failed with message: +Cannot interpret this number as a value of type int +The command has indeed failed with message: +Cannot interpret this number as a value of type int +0 + : int +0 + : int +The command has indeed failed with message: +The reference xg was not found in the current environment. +The command has indeed failed with message: +The reference xG was not found in the current environment. +The command has indeed failed with message: +The reference x1 was not found in the current environment. +The command has indeed failed with message: +The reference x was not found in the current environment. +2 + 2 + : int +The command has indeed failed with message: +Cannot interpret this number as a value of type int +The command has indeed failed with message: +Cannot interpret this number as a value of type int +0x1%int63 + : int +0x7fffffffffffffff%int63 + : int +2 + : nat +2%sint63 + : int +t = 2%si63 + : int +t = 2%si63 + : int +2 + : nat +2 + : int +(2 + 2)%sint63 + : int +2 + 2 + : int + = 4 + : int + = 37151199385380486 + : int diff --git a/test-suite/output/Sint63Syntax.v b/test-suite/output/Sint63Syntax.v new file mode 100644 index 0000000000..b9ed596537 --- /dev/null +++ b/test-suite/output/Sint63Syntax.v @@ -0,0 +1,49 @@ +Require Import Sint63. + +Check 2%sint63. +Open Scope sint63_scope. +Check 2. +Check -3. +Check 4611686018427387903. +Check -4611686018427387904. +Check 0x1ab. +Check 0X1ab. +Check 0x1Ab. +Check 0x1aB. +Check 0x1AB. +Fail Check 0x1ap5. (* exponents not implemented (yet?) *) +Fail Check 0x1aP5. +Check 0x0. +Check 0x000. +Fail Check 0xg. +Fail Check 0xG. +Fail Check 00x1. +Fail Check 0x. +Check (PrimInt63.add 2 2). +Fail Check 4611686018427387904. +Fail Check -4611686018427387905. + +Set Printing All. +Check 1%sint63. +Check (-1)%sint63. +Unset Printing All. + +Open Scope nat_scope. +Check 2. (* : nat *) +Check 2%sint63. +Delimit Scope sint63_scope with si63. +Definition t := 2%sint63. +Print t. +Delimit Scope nat_scope with sint63. +Print t. +Check 2. +Close Scope nat_scope. +Check 2. +Close Scope sint63_scope. +Delimit Scope sint63_scope with sint63. + +Check (2 + 2)%sint63. +Open Scope sint63_scope. +Check (2+2). +Eval vm_compute in 2+2. +Eval vm_compute in 65675757 * 565675998. diff --git a/test-suite/output/bug_13821_native_command_line_warn.out b/test-suite/output/bug_13821_native_command_line_warn.out new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/test-suite/output/bug_13821_native_command_line_warn.out diff --git a/test-suite/output/bug_13821_native_command_line_warn.v b/test-suite/output/bug_13821_native_command_line_warn.v new file mode 100644 index 0000000000..a28210b6c2 --- /dev/null +++ b/test-suite/output/bug_13821_native_command_line_warn.v @@ -0,0 +1 @@ +(* -*- coq-prog-args: ("-w" "-native-compiler-disabled" "-native-compiler" "ondemand"); -*- *) diff --git a/test-suite/output/primitive_tokens.out b/test-suite/output/primitive_tokens.out new file mode 100644 index 0000000000..afe9b25442 --- /dev/null +++ b/test-suite/output/primitive_tokens.out @@ -0,0 +1,61 @@ +"foo" + : string +1234 + : nat +Nat.add 1 2 + : nat +match "a" with +| "a" => true +| _ => false +end + : bool +match 1 with +| 1 => true +| _ => false +end + : bool +{| field := 7 |} + : test +String (Ascii.Ascii false true true false false true true false) + (String (Ascii.Ascii true true true true false true true false) + (String (Ascii.Ascii true true true true false true true false) + EmptyString)) + : string +S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S + (S (S (S (S (S (S ...))))))))))))))))))))))) + : nat +Nat.add (S O) (S (S O)) + : nat +match + String (Ascii.Ascii true false false false false true true false) + EmptyString +with +| String (Ascii.Ascii true false false false false true true false) + EmptyString => true +| _ => false +end + : bool +match S O with +| S O => true +| _ => false +end + : bool +{| field := S (S (S (S (S (S (S O)))))) |} + : test diff --git a/test-suite/output/primitive_tokens.v b/test-suite/output/primitive_tokens.v new file mode 100644 index 0000000000..3207e5983f --- /dev/null +++ b/test-suite/output/primitive_tokens.v @@ -0,0 +1,23 @@ +Require Import String. + +Record test := { field : nat }. + +Open Scope string_scope. + +Unset Printing Notations. + +Check "foo". +Check 1234. +Check 1 + 2. +Check match "a" with "a" => true | _ => false end. +Check match 1 with 1 => true | _ => false end. +Check {| field := 7 |}. + +Set Printing Raw Literals. + +Check "foo". +Check 1234. +Check 1 + 2. +Check match "a" with "a" => true | _ => false end. +Check match 1 with 1 => true | _ => false end. +Check {| field := 7 |}. diff --git a/test-suite/output/relaxed_ambiguous_paths.out b/test-suite/output/relaxed_ambiguous_paths.out index ac5a09bad7..48368c7ede 100644 --- a/test-suite/output/relaxed_ambiguous_paths.out +++ b/test-suite/output/relaxed_ambiguous_paths.out @@ -3,32 +3,32 @@ Warning: New coercion path [ac; cd] : A >-> D is ambiguous with existing [ab; bd] : A >-> D. [ambiguous-paths,typechecker] [ab] : A >-> B -[ab; bd] : A >-> D [ac] : A >-> C +[ab; bd] : A >-> D [bd] : B >-> D [cd] : C >-> D File "stdin", line 26, characters 0-28: Warning: New coercion path [ab; bc] : A >-> C is ambiguous with existing [ac] : A >-> C. [ambiguous-paths,typechecker] +[ab] : A >-> B [ac] : A >-> C [ac; cd] : A >-> D -[ab] : A >-> B -[cd] : C >-> D [bc] : B >-> C [bc; cd] : B >-> D +[cd] : C >-> D [B_A] : B >-> A [C_A] : C >-> A -[D_B] : D >-> B [D_A] : D >-> A +[D_B] : D >-> B [D_C] : D >-> C [A'_A] : A' >-> A -[B_A'] : B >-> A' [B_A'; A'_A] : B >-> A -[C_A'] : C >-> A' +[B_A'] : B >-> A' [C_A'; A'_A] : C >-> A -[D_B; B_A'] : D >-> A' +[C_A'] : C >-> A' [D_A] : D >-> A +[D_B; B_A'] : D >-> A' [D_B] : D >-> B [D_C] : D >-> C File "stdin", line 121, characters 0-86: @@ -36,12 +36,12 @@ Warning: New coercion path [D_C; C_A'] : D >-> A' is ambiguous with existing [D_B; B_A'] : D >-> A'. [ambiguous-paths,typechecker] [A'_A] : A' >-> A -[B_A'] : B >-> A' [B_A'; A'_A] : B >-> A -[C_A'] : C >-> A' +[B_A'] : B >-> A' [C_A'; A'_A] : C >-> A -[D_B; B_A'] : D >-> A' +[C_A'] : C >-> A' [D_A] : D >-> A +[D_B; B_A'] : D >-> A' [D_B] : D >-> B [D_C] : D >-> C File "stdin", line 130, characters 0-47: diff --git a/test-suite/primitive/sint63/add.v b/test-suite/primitive/sint63/add.v new file mode 100644 index 0000000000..dcafd64181 --- /dev/null +++ b/test-suite/primitive/sint63/add.v @@ -0,0 +1,25 @@ +Require Import Sint63. + +Set Implicit Arguments. + +Open Scope sint63_scope. + +Check (eq_refl : 2 + 3 = 5). +Check (eq_refl 5 <: 2 + 3 = 5). +Check (eq_refl 5 <<: 2 + 3 = 5). +Definition compute1 := Eval compute in 2 + 3. +Check (eq_refl compute1 : 5 = 5). + +Check (eq_refl : 4611686018427387903 + 1 = -4611686018427387904). +Check (eq_refl (-4611686018427387904) <: + 4611686018427387903 + 1 = -4611686018427387904). +Check (eq_refl (-4611686018427387904) <<: + 4611686018427387903 + 1 = -4611686018427387904). +Definition compute2 := Eval compute in 4611686018427387903 + 1. +Check (eq_refl compute2 : -4611686018427387904 = -4611686018427387904). + +Check (eq_refl : 2 - 3 = -1). +Check (eq_refl (-1) <: 2 - 3 = -1). +Check (eq_refl (-1) <<: 2 - 3 = -1). +Definition compute3 := Eval compute in 2 - 3. +Check (eq_refl compute3 : -1 = -1). diff --git a/test-suite/primitive/sint63/asr.v b/test-suite/primitive/sint63/asr.v new file mode 100644 index 0000000000..4524ae4e6f --- /dev/null +++ b/test-suite/primitive/sint63/asr.v @@ -0,0 +1,41 @@ +Require Import Sint63. + +Set Implicit Arguments. + +Open Scope sint63_scope. + +Check (eq_refl : (-2305843009213693952) >> 61 = -1). +Check (eq_refl (-1) <: (-2305843009213693952) >> 61 = -1). +Check (eq_refl (-1) <<: (-2305843009213693952) >> 61 = -1). +Definition compute1 := Eval compute in (-2305843009213693952) >> 61. +Check (eq_refl compute1 : -1 = -1). + +Check (eq_refl : 2305843009213693952 >> 62 = 0). +Check (eq_refl 0 <: 2305843009213693952 >> 62 = 0). +Check (eq_refl 0 <<: 2305843009213693952 >> 62 = 0). +Definition compute2 := Eval compute in 2305843009213693952 >> 62. +Check (eq_refl compute2 : 0 = 0). + +Check (eq_refl : 4611686018427387903 >> 63 = 0). +Check (eq_refl 0 <: 4611686018427387903 >> 63 = 0). +Check (eq_refl 0 <<: 4611686018427387903 >> 63 = 0). +Definition compute3 := Eval compute in 4611686018427387903 >> 63. +Check (eq_refl compute3 : 0 = 0). + +Check (eq_refl : (-1) >> 1 = -1). +Check (eq_refl (-1) <: (-1) >> 1 = -1). +Check (eq_refl (-1) <<: (-1) >> 1 = -1). +Definition compute4 := Eval compute in (-1) >> 1. +Check (eq_refl compute4 : -1 = -1). + +Check (eq_refl : (-1) >> (-1) = 0). +Check (eq_refl 0 <: (-1) >> (-1) = 0). +Check (eq_refl 0 <<: (-1) >> (-1) = 0). +Definition compute5 := Eval compute in (-1) >> (-1). +Check (eq_refl compute5 : 0 = 0). + +Check (eq_refl : 73 >> (-2) = 0). +Check (eq_refl 0 <: 73 >> (-2) = 0). +Check (eq_refl 0 <<: 73 >> (-2) = 0). +Definition compute6 := Eval compute in 73 >> (-2). +Check (eq_refl compute6 : 0 = 0). diff --git a/test-suite/primitive/sint63/compare.v b/test-suite/primitive/sint63/compare.v new file mode 100644 index 0000000000..7a9882f1c8 --- /dev/null +++ b/test-suite/primitive/sint63/compare.v @@ -0,0 +1,36 @@ +Require Import Sint63. + +Set Implicit Arguments. + +Open Scope sint63_scope. + +Check (eq_refl : 1 ?= 1 = Eq). +Check (eq_refl Eq <: 1 ?= 1 = Eq). +Check (eq_refl Eq <<: 1 ?= 1 = Eq). +Definition compute1 := Eval compute in 1 ?= 1. +Check (eq_refl compute1 : Eq = Eq). + +Check (eq_refl : 1 ?= 2 = Lt). +Check (eq_refl Lt <: 1 ?= 2 = Lt). +Check (eq_refl Lt <<: 1 ?= 2 = Lt). +Definition compute2 := Eval compute in 1 ?= 2. +Check (eq_refl compute2 : Lt = Lt). + +Check (eq_refl : 4611686018427387903 ?= 0 = Gt). +Check (eq_refl Gt <: 4611686018427387903 ?= 0 = Gt). +Check (eq_refl Gt <<: 4611686018427387903 ?= 0 = Gt). +Definition compute3 := Eval compute in 4611686018427387903 ?= 0. +Check (eq_refl compute3 : Gt = Gt). + +Check (eq_refl : -1 ?= 1 = Lt). +Check (eq_refl Lt <: -1 ?= 1 = Lt). +Check (eq_refl Lt <<: -1 ?= 1 = Lt). +Definition compute4 := Eval compute in -1 ?= 1. +Check (eq_refl compute4 : Lt = Lt). + +Check (eq_refl : 4611686018427387903 ?= -4611686018427387904 = Gt). +Check (eq_refl Gt <: 4611686018427387903 ?= -4611686018427387904 = Gt). +Check (eq_refl Gt <<: 4611686018427387903 ?= -4611686018427387904 = Gt). +Definition compute5 := + Eval compute in 4611686018427387903 ?= -4611686018427387904. +Check (eq_refl compute5 : Gt = Gt). diff --git a/test-suite/primitive/sint63/div.v b/test-suite/primitive/sint63/div.v new file mode 100644 index 0000000000..9da628ce1e --- /dev/null +++ b/test-suite/primitive/sint63/div.v @@ -0,0 +1,61 @@ +Require Import Sint63. + +Set Implicit Arguments. + +Open Scope sint63_scope. + +Check (eq_refl : 6 / 3 = 2). +Check (eq_refl 2 <: 6 / 3 = 2). +Check (eq_refl 2 <<: 6 / 3 = 2). +Definition compute1 := Eval compute in 6 / 3. +Check (eq_refl compute1 : 2 = 2). + +Check (eq_refl : -6 / 3 = -2). +Check (eq_refl (-2) <: -6 / 3 = -2). +Check (eq_refl (-2) <<: -6 / 3 = -2). +Definition compute2 := Eval compute in -6 / 3. +Check (eq_refl compute2 : -2 = -2). + +Check (eq_refl : 6 / -3 = -2). +Check (eq_refl (-2) <: 6 / -3 = -2). +Check (eq_refl (-2) <<: 6 / -3 = -2). +Definition compute3 := Eval compute in 6 / -3. +Check (eq_refl compute3 : -2 = -2). + +Check (eq_refl : -6 / -3 = 2). +Check (eq_refl 2 <: -6 / -3 = 2). +Check (eq_refl 2 <<: -6 / -3 = 2). +Definition compute4 := Eval compute in -6 / -3. +Check (eq_refl compute4 : 2 = 2). + +Check (eq_refl : 3 / 2 = 1). +Check (eq_refl 1 <: 3 / 2 = 1). +Check (eq_refl 1 <<: 3 / 2 = 1). +Definition compute5 := Eval compute in 3 / 2. +Check (eq_refl compute5 : 1 = 1). + +Check (eq_refl : -3 / 2 = -1). +Check (eq_refl (-1) <: -3 / 2 = -1). +Check (eq_refl (-1) <<: -3 / 2 = -1). +Definition compute6 := Eval compute in -3 / 2. +Check (eq_refl compute6 : -1 = -1). + +Check (eq_refl : 3 / -2 = -1). +Check (eq_refl (-1) <: 3 / -2 = -1). +Check (eq_refl (-1) <<: 3 / -2 = -1). +Definition compute7 := Eval compute in 3 / -2. +Check (eq_refl compute7 : -1 = -1). + +Check (eq_refl : -3 / -2 = 1). +Check (eq_refl 1 <: -3 / -2 = 1). +Check (eq_refl 1 <<: -3 / -2 = 1). +Definition compute8 := Eval compute in -3 / -2. +Check (eq_refl compute8 : 1 = 1). + +Check (eq_refl : -4611686018427387904 / -1 = -4611686018427387904). +Check (eq_refl (-4611686018427387904) <: + -4611686018427387904 / -1 = -4611686018427387904). +Check (eq_refl (-4611686018427387904) <<: + -4611686018427387904 / -1 = -4611686018427387904). +Definition compute9 := Eval compute in -4611686018427387904 / -1. +Check (eq_refl compute9 : -4611686018427387904 = -4611686018427387904). diff --git a/test-suite/primitive/sint63/eqb.v b/test-suite/primitive/sint63/eqb.v new file mode 100644 index 0000000000..4d365acf54 --- /dev/null +++ b/test-suite/primitive/sint63/eqb.v @@ -0,0 +1,17 @@ +Require Import Sint63. + +Set Implicit Arguments. + +Open Scope sint63_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 compute1 : true = true). + +Check (eq_refl : 4611686018427387903 =? 0 = false). +Check (eq_refl false <: 4611686018427387903 =? 0 = false). +Check (eq_refl false <<: 4611686018427387903 =? 0 = false). +Definition compute2 := Eval compute in 4611686018427387903 =? 0. +Check (eq_refl compute2 : false = false). diff --git a/test-suite/primitive/sint63/isint.v b/test-suite/primitive/sint63/isint.v new file mode 100644 index 0000000000..f1c9c2cfd1 --- /dev/null +++ b/test-suite/primitive/sint63/isint.v @@ -0,0 +1,50 @@ +(* This file tests the check that arithmetic operations use to know if their +arguments are ground. The various test cases correspond to possible +optimizations of these tests made by the compiler. *) +Require Import Sint63. + +Set Implicit Arguments. + +Open Scope sint63_scope. + +Section test. + +Variable m n : int. + +Check (eq_refl : (fun x => x + 3) m = m + 3). +Check (eq_refl (m + 3) <: (fun x => x + 3) m = m + 3). +Check (eq_refl (m + 3) <<: (fun x => x + 3) m = m + 3). +Definition compute1 := Eval compute in (fun x => x + 3) m. +Check (eq_refl compute1 : m + 3 = m + 3). + +Check (eq_refl : (fun x => 3 + x) m = 3 + m). +Check (eq_refl (3 + m) <: (fun x => 3 + x) m = 3 + m). +Check (eq_refl (3 + m) <<: (fun x => 3 + x) m = 3 + m). +Definition compute2 := Eval compute in (fun x => 3 + x) m. +Check (eq_refl compute2 : 3 + m = 3 + m). + +Check (eq_refl : (fun x y => x + y) m n = m + n). +Check (eq_refl (m + n) <: (fun x y => x + y) m n = m + n). +Check (eq_refl (m + n) <<: (fun x y => x + y) m n = m + n). +Definition compute3 := Eval compute in (fun x y => x + y) m n. +Check (eq_refl compute3 : m + n = m + n). + +Check (eq_refl : (fun x y => x + y) 2 3 = 5). +Check (eq_refl 5 <: (fun x y => x + y) 2 3 = 5). +Check (eq_refl 5 <<: (fun x y => x + y) 2 3 = 5). +Definition compute4 := Eval compute in (fun x y => x + y) 2 3. +Check (eq_refl compute4 : 5 = 5). + +Check (eq_refl : (fun x => x + x) m = m + m). +Check (eq_refl (m + m) <: (fun x => x + x) m = m + m). +Check (eq_refl (m + m) <<: (fun x => x + x) m = m + m). +Definition compute5 := Eval compute in (fun x => x + x) m. +Check (eq_refl compute5 : m + m = m + m). + +Check (eq_refl : (fun x => x + x) 2 = 4). +Check (eq_refl 4 <: (fun x => x + x) 2 = 4). +Check (eq_refl 4 <<: (fun x => x + x) 2 = 4). +Definition compute6 := Eval compute in (fun x => x + x) 2. +Check (eq_refl compute6 : 4 = 4). + +End test. diff --git a/test-suite/primitive/sint63/leb.v b/test-suite/primitive/sint63/leb.v new file mode 100644 index 0000000000..dbe958e41d --- /dev/null +++ b/test-suite/primitive/sint63/leb.v @@ -0,0 +1,29 @@ +Require Import Sint63. + +Set Implicit Arguments. + +Open Scope sint63_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 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 compute2 : true = true). + +Check (eq_refl : 4611686018427387903 <=? 0 = false). +Check (eq_refl false <: 4611686018427387903 <=? 0 = false). +Check (eq_refl false <<: 4611686018427387903 <=? 0 = false). +Definition compute3 := Eval compute in 4611686018427387903 <=? 0. +Check (eq_refl compute3 : false = false). + +Check (eq_refl : 1 <=? -1 = false). +Check (eq_refl false <: 1 <=? -1 = false). +Check (eq_refl false <<: 1 <=? -1 = false). +Definition compute4 := Eval compute in 1 <=? -1. +Check (eq_refl compute4 : false = false). diff --git a/test-suite/primitive/sint63/lsl.v b/test-suite/primitive/sint63/lsl.v new file mode 100644 index 0000000000..082c42979a --- /dev/null +++ b/test-suite/primitive/sint63/lsl.v @@ -0,0 +1,43 @@ +Require Import Sint63. + +Set Implicit Arguments. + +Open Scope sint63_scope. + +Check (eq_refl : 3 << 61 = -2305843009213693952). +Check (eq_refl (-2305843009213693952) <: 3 << 61 = -2305843009213693952). +Check (eq_refl (-2305843009213693952) <<: 3 << 61 = -2305843009213693952). +Definition compute1 := Eval compute in 3 << 61. +Check (eq_refl compute1 : -2305843009213693952 = -2305843009213693952). + +Check (eq_refl : 2 << 62 = 0). +Check (eq_refl 0 <: 2 << 62 = 0). +Check (eq_refl 0 <<: 2 << 62 = 0). +Definition compute2 := Eval compute in 2 << 62. +Check (eq_refl compute2 : 0 = 0). + +Check (eq_refl : 4611686018427387903 << 63 = 0). +Check (eq_refl 0 <: 4611686018427387903 << 63 = 0). +Check (eq_refl 0 <<: 4611686018427387903 << 63 = 0). +Definition compute3 := Eval compute in 4611686018427387903 << 63. +Check (eq_refl compute3 : 0 = 0). + +Check (eq_refl : 4611686018427387903 << 62 = -4611686018427387904). +Check (eq_refl (-4611686018427387904) <: + 4611686018427387903 << 62 = -4611686018427387904). +Check (eq_refl (-4611686018427387904) <<: + 4611686018427387903 << 62 = -4611686018427387904). +Definition compute4 := Eval compute in 4611686018427387903 << 62. +Check (eq_refl compute4 : -4611686018427387904 = -4611686018427387904). + +Check (eq_refl : 1 << 62 = -4611686018427387904). +Check (eq_refl (-4611686018427387904) <: 1 << 62 = -4611686018427387904). +Check (eq_refl (-4611686018427387904) <<: 1 << 62 = -4611686018427387904). +Definition compute5 := Eval compute in 1 << 62. +Check (eq_refl compute5 : -4611686018427387904 = -4611686018427387904). + +Check (eq_refl : -1 << 1 = -2). +Check (eq_refl (-2) <: -1 << 1 = -2). +Check (eq_refl (-2) <<: -1 << 1 = -2). +Definition compute6 := Eval compute in -1 << 1. +Check (eq_refl compute6 : -2 = -2). diff --git a/test-suite/primitive/sint63/ltb.v b/test-suite/primitive/sint63/ltb.v new file mode 100644 index 0000000000..aa72e1d377 --- /dev/null +++ b/test-suite/primitive/sint63/ltb.v @@ -0,0 +1,29 @@ +Require Import Sint63. + +Set Implicit Arguments. + +Open Scope sint63_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 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 compute2 : true = true). + +Check (eq_refl : 4611686018427387903 <? 0 = false). +Check (eq_refl false <: 4611686018427387903 <? 0 = false). +Check (eq_refl false <<: 4611686018427387903 <? 0 = false). +Definition compute3 := Eval compute in 4611686018427387903 <? 0. +Check (eq_refl compute3 : false = false). + +Check (eq_refl : 1 <? -1 = false). +Check (eq_refl false <: 1 <? -1 = false). +Check (eq_refl false <<: 1 <? -1 = false). +Definition compute4 := Eval compute in 1 <? -1. +Check (eq_refl compute4 : false = false). diff --git a/test-suite/primitive/sint63/mod.v b/test-suite/primitive/sint63/mod.v new file mode 100644 index 0000000000..a4872b45f3 --- /dev/null +++ b/test-suite/primitive/sint63/mod.v @@ -0,0 +1,53 @@ +Require Import Sint63. + +Set Implicit Arguments. + +Open Scope sint63_scope. + +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 : -6 mod 3 = 0). +Check (eq_refl 0 <: -6 mod 3 = 0). +Check (eq_refl 0 <<: -6 mod 3 = 0). +Definition compute2 := Eval compute in -6 mod 3. +Check (eq_refl compute2 : 0 = 0). + +Check (eq_refl : 6 mod -3 = 0). +Check (eq_refl 0 <: 6 mod -3 = 0). +Check (eq_refl 0 <<: 6 mod -3 = 0). +Definition compute3 := Eval compute in 6 mod -3. +Check (eq_refl compute3 : 0 = 0). + +Check (eq_refl : -6 mod -3 = 0). +Check (eq_refl 0 <: -6 mod -3 = 0). +Check (eq_refl 0 <<: -6 mod -3 = 0). +Definition compute4 := Eval compute in -6 mod -3. +Check (eq_refl compute4 : 0 = 0). + +Check (eq_refl : 5 mod 3 = 2). +Check (eq_refl 2 <: 5 mod 3 = 2). +Check (eq_refl 2 <<: 5 mod 3 = 2). +Definition compute5 := Eval compute in 5 mod 3. +Check (eq_refl compute5 : 2 = 2). + +Check (eq_refl : -5 mod 3 = -2). +Check (eq_refl (-2) <: -5 mod 3 = -2). +Check (eq_refl (-2) <<: -5 mod 3 = -2). +Definition compute6 := Eval compute in -5 mod 3. +Check (eq_refl compute6 : -2 = -2). + +Check (eq_refl : 5 mod -3 = 2). +Check (eq_refl 2 <: 5 mod -3 = 2). +Check (eq_refl 2 <<: 5 mod -3 = 2). +Definition compute7 := Eval compute in 5 mod -3. +Check (eq_refl compute7 : 2 = 2). + +Check (eq_refl : -5 mod -3 = -2). +Check (eq_refl (-2) <: -5 mod -3 = -2). +Check (eq_refl (-2) <<: -5 mod -3 = -2). +Definition compute8 := Eval compute in -5 mod -3. +Check (eq_refl compute8 : -2 = -2). diff --git a/test-suite/primitive/sint63/mul.v b/test-suite/primitive/sint63/mul.v new file mode 100644 index 0000000000..f72f643083 --- /dev/null +++ b/test-suite/primitive/sint63/mul.v @@ -0,0 +1,35 @@ +Require Import Sint63. + +Set Implicit Arguments. + +Open Scope sint63_scope. + +Check (eq_refl : 2 * 3 = 6). +Check (eq_refl 6 <: 2 * 3 = 6). +Check (eq_refl 6 <<: 2 * 3 = 6). +Definition compute1 := Eval compute in 2 * 3. +Check (eq_refl compute1 : 6 = 6). + +Check (eq_refl : -2 * 3 = -6). +Check (eq_refl (-6) <: -2 * 3 = -6). +Check (eq_refl (-6) <<: -2 * 3 = -6). +Definition compute2 := Eval compute in -2 * 3. +Check (eq_refl compute2 : -6 = -6). + +Check (eq_refl : 2 * -3 = -6). +Check (eq_refl (-6) <: 2 * -3 = -6). +Check (eq_refl (-6) <<: 2 * -3 = -6). +Definition compute3 := Eval compute in 2 * -3. +Check (eq_refl compute3 : -6 = -6). + +Check (eq_refl : -2 * -3 = 6). +Check (eq_refl 6 <: -2 * -3 = 6). +Check (eq_refl 6 <<: -2 * -3 = 6). +Definition compute4 := Eval compute in -2 * -3. +Check (eq_refl compute4 : 6 = 6). + +Check (eq_refl : 4611686018427387903 * 2 = -2). +Check (eq_refl (-2) <: 4611686018427387903 * 2 = -2). +Check (eq_refl (-2) <<: 4611686018427387903 * 2 = -2). +Definition compute5 := Eval compute in 4611686018427387903 * 2. +Check (eq_refl compute5 : -2 = -2). diff --git a/test-suite/primitive/sint63/signed.v b/test-suite/primitive/sint63/signed.v new file mode 100644 index 0000000000..d8333a8efb --- /dev/null +++ b/test-suite/primitive/sint63/signed.v @@ -0,0 +1,18 @@ +(* This file checks that operations over sint63 are signed. *) +Require Import Sint63. + +Open Scope sint63_scope. + +(* (0-1) must be negative 1 and not the maximum integer value *) + +Check (eq_refl : 1/(0-1) = -1). +Check (eq_refl (-1) <: 1/(0-1) = -1). +Check (eq_refl (-1) <<: 1/(0-1) = -1). +Definition compute1 := Eval compute in 1/(0-1). +Check (eq_refl compute1 : -1 = -1). + +Check (eq_refl : 3 mod (0-1) = 0). +Check (eq_refl 0 <: 3 mod (0-1) = 0). +Check (eq_refl 0 <<: 3 mod (0-1) = 0). +Definition compute2 := Eval compute in 3 mod (0-1). +Check (eq_refl compute2 : 0 = 0). diff --git a/test-suite/primitive/sint63/sub.v b/test-suite/primitive/sint63/sub.v new file mode 100644 index 0000000000..8504177286 --- /dev/null +++ b/test-suite/primitive/sint63/sub.v @@ -0,0 +1,25 @@ +Require Import Sint63. + +Set Implicit Arguments. + +Open Scope sint63_scope. + +Check (eq_refl : 3 - 2 = 1). +Check (eq_refl 1 <: 3 - 2 = 1). +Check (eq_refl 1 <<: 3 - 2 = 1). +Definition compute1 := Eval compute in 3 - 2. +Check (eq_refl compute1 : 1 = 1). + +Check (eq_refl : 0 - 1 = -1). +Check (eq_refl (-1) <: 0 - 1 = -1). +Check (eq_refl (-1) <<: 0 - 1 = -1). +Definition compute2 := Eval compute in 0 - 1. +Check (eq_refl compute2 : -1 = -1). + +Check (eq_refl : -4611686018427387904 - 1 = 4611686018427387903). +Check (eq_refl 4611686018427387903 <: + -4611686018427387904 - 1 = 4611686018427387903). +Check (eq_refl 4611686018427387903 <<: + -4611686018427387904 - 1 = 4611686018427387903). +Definition compute3 := Eval compute in -4611686018427387904 - 1. +Check (eq_refl compute3 : 4611686018427387903 = 4611686018427387903). diff --git a/theories/Classes/EquivDec.v b/theories/Classes/EquivDec.v index 6978fa1ddf..a1a4da6f37 100644 --- a/theories/Classes/EquivDec.v +++ b/theories/Classes/EquivDec.v @@ -87,7 +87,7 @@ Program Instance unit_eqdec : EqDec unit eq := fun x y => in_left. Next Obligation. Proof. - destruct x ; destruct y. + do 2 match goal with [ x : () |- _ ] => destruct x end. reflexivity. Qed. @@ -142,7 +142,10 @@ Program Instance list_eqdec `(eqa : EqDec A eq) : EqDec (list A) eq := | _, _ => in_right end }. - Next Obligation. destruct y ; unfold not in *; eauto. Defined. + Next Obligation. + match goal with y : list _ |- _ => destruct y end ; + unfold not in *; eauto. + Defined. Solve Obligations with unfold equiv, complement in * ; program_simpl ; intuition (discriminate || eauto). diff --git a/theories/Classes/SetoidClass.v b/theories/Classes/SetoidClass.v index 6a98af39aa..3e71a60fa6 100644 --- a/theories/Classes/SetoidClass.v +++ b/theories/Classes/SetoidClass.v @@ -87,7 +87,7 @@ Tactic Notation "clsubst" "*" := clsubst_nofail. Lemma nequiv_equiv_trans : forall `{Setoid A} (x y z : A), x =/= y -> y == z -> x =/= z. Proof with auto. - intros; intro. + intros A ? x y z H H0 H1. assert(z == y) by (symmetry ; auto). assert(x == y) by (transitivity z ; eauto). contradiction. @@ -95,7 +95,7 @@ Qed. Lemma equiv_nequiv_trans : forall `{Setoid A} (x y z : A), x == y -> y =/= z -> x =/= z. Proof. - intros; intro. + intros A ? x y z **; intro. assert(y == x) by (symmetry ; auto). assert(y == z) by (transitivity x ; eauto). contradiction. diff --git a/theories/Classes/SetoidDec.v b/theories/Classes/SetoidDec.v index 2947c4831f..f4220e3aa1 100644 --- a/theories/Classes/SetoidDec.v +++ b/theories/Classes/SetoidDec.v @@ -96,7 +96,7 @@ Program Instance unit_eqdec : EqDec (eq_setoid unit) := Next Obligation. Proof. - destruct x ; destruct y. + do 2 match goal with x : () |- _ => destruct x end. reflexivity. Qed. diff --git a/theories/Lists/SetoidList.v b/theories/Lists/SetoidList.v index 826815410a..69b158a87e 100644 --- a/theories/Lists/SetoidList.v +++ b/theories/Lists/SetoidList.v @@ -71,7 +71,7 @@ Hint Constructors NoDupA : core. Lemma NoDupA_altdef : forall l, NoDupA l <-> ForallOrdPairs (complement eqA) l. Proof. - split; induction 1; constructor; auto. + split; induction 1 as [|a l H rest]; constructor; auto. rewrite Forall_forall. intros b Hb. intro Eq; elim H. rewrite InA_alt. exists b; auto. rewrite InA_alt; intros (a' & Haa' & Ha'). @@ -85,7 +85,7 @@ Definition inclA l l' := forall x, InA x l -> InA x l'. Definition equivlistA l l' := forall x, InA x l <-> InA x l'. Lemma incl_nil l : inclA nil l. -Proof. intro. intros. inversion H. Qed. +Proof. intros a H. inversion H. Qed. #[local] Hint Resolve incl_nil : list. @@ -128,7 +128,7 @@ Qed. Global Instance eqlistA_equiv : Equivalence eqlistA. Proof. constructor; red. - induction x; auto. + intros x; induction x; auto. induction 1; auto. intros x y z H; revert z; induction H; auto. inversion 1; subst; auto. invlist eqlistA; eauto with *. @@ -138,9 +138,9 @@ Qed. Global Instance eqlistA_equivlistA : subrelation eqlistA equivlistA. Proof. - intros x x' H. induction H. + intros x x' H. induction H as [|? ? ? ? H ? IHeqlistA]. intuition. - red; intros. + red; intros x0. rewrite 2 InA_cons. rewrite (IHeqlistA x0), H; intuition. Qed. @@ -165,7 +165,7 @@ Hint Immediate InA_eqA : core. Lemma In_InA : forall l x, In x l -> InA x l. Proof. - simple induction l; simpl; intuition. + intros l; induction l; simpl; intuition. subst; auto. Qed. #[local] @@ -174,8 +174,9 @@ Hint Resolve In_InA : core. Lemma InA_split : forall l x, InA x l -> exists l1 y l2, eqA x y /\ l = l1++y::l2. Proof. -induction l; intros; inv. +intros l; induction l as [|a l IHl]; intros x H; inv. exists (@nil A); exists a; exists l; auto. +match goal with H' : InA x l |- _ => rename H' into H0 end. destruct (IHl x H0) as (l1,(y,(l2,(H1,H2)))). exists (a::l1); exists y; exists l2; auto. split; simpl; f_equal; auto. @@ -184,9 +185,10 @@ Qed. Lemma InA_app : forall l1 l2 x, InA x (l1 ++ l2) -> InA x l1 \/ InA x l2. Proof. - induction l1; simpl in *; intuition. + intros l1; induction l1 as [|a l1 IHl1]; simpl in *; intuition. inv; auto. - elim (IHl1 l2 x H0); auto. + match goal with H0' : InA _ (l1 ++ _) |- _ => rename H0' into H0 end. + elim (IHl1 _ _ H0); auto. Qed. Lemma InA_app_iff : forall l1 l2 x, @@ -194,7 +196,7 @@ Lemma InA_app_iff : forall l1 l2 x, Proof. split. apply InA_app. - destruct 1; generalize H; do 2 rewrite InA_alt. + destruct 1 as [H|H]; generalize H; do 2 rewrite InA_alt. destruct 1 as (y,(H1,H2)); exists y; split; auto. apply in_or_app; auto. destruct 1 as (y,(H1,H2)); exists y; split; auto. @@ -240,11 +242,12 @@ Lemma NoDupA_app : forall l l', NoDupA l -> NoDupA l' -> (forall x, InA x l -> InA x l' -> False) -> NoDupA (l++l'). Proof. -induction l; simpl; auto; intros. +intros l; induction l as [|a l IHl]; simpl; auto; intros l' H H0 H1. inv. constructor. rewrite InA_alt; intros (y,(H4,H5)). destruct (in_app_or _ _ _ H5). +match goal with H2' : ~ InA a l |- _ => rename H2' into H2 end. elim H2. rewrite InA_alt. exists y; auto. @@ -253,13 +256,13 @@ auto. rewrite InA_alt. exists y; auto. apply IHl; auto. -intros. +intros x ? ?. apply (H1 x); auto. Qed. Lemma NoDupA_rev : forall l, NoDupA l -> NoDupA (rev l). Proof. -induction l. +intros l; induction l. simpl; auto. simpl; intros. inv. @@ -270,17 +273,17 @@ intros x. rewrite InA_alt. intros (x1,(H2,H3)). intro; inv. -destruct H0. -rewrite <- H4, H2. +match goal with H0 : ~ InA _ _ |- _ => destruct H0 end. +match goal with H4 : eqA x ?x' |- InA ?x' _ => rewrite <- H4, H2 end. apply In_InA. rewrite In_rev; auto. Qed. Lemma NoDupA_split : forall l l' x, NoDupA (l++x::l') -> NoDupA (l++l'). Proof. - induction l; simpl in *; intros; inv; auto. + intros l; induction l; simpl in *; intros; inv; auto. constructor; eauto. - contradict H0. + match goal with H0 : ~ InA _ _ |- _ => contradict H0 end. rewrite InA_app_iff in *. rewrite InA_cons. intuition. @@ -288,17 +291,17 @@ Qed. Lemma NoDupA_swap : forall l l' x, NoDupA (l++x::l') -> NoDupA (x::l++l'). Proof. - induction l; simpl in *; intros; inv; auto. + intros l; induction l as [|a l IHl]; simpl in *; intros l' x H; inv; auto. constructor; eauto. - assert (H2:=IHl _ _ H1). + match goal with H1 : NoDupA (l ++ x :: l') |- _ => assert (H2:=IHl _ _ H1) end. inv. rewrite InA_cons. red; destruct 1. - apply H0. + match goal with H0 : ~ InA a (l ++ x :: l') |- _ => apply H0 end. rewrite InA_app_iff in *; rewrite InA_cons; auto. - apply H; auto. + auto. constructor. - contradict H0. + match goal with H0 : ~ InA a (l ++ x :: l') |- _ => contradict H0 end. rewrite InA_app_iff in *; rewrite InA_cons; intuition. eapply NoDupA_split; eauto. Qed. @@ -356,19 +359,21 @@ Lemma equivlistA_NoDupA_split l l1 l2 x y : eqA x y -> NoDupA (x::l) -> NoDupA (l1++y::l2) -> equivlistA (x::l) (l1++y::l2) -> equivlistA l (l1++l2). Proof. - intros; intro a. + intros H H0 H1 H2; intro a. generalize (H2 a). rewrite !InA_app_iff, !InA_cons. inv. assert (SW:=NoDupA_swap H1). inv. - rewrite InA_app_iff in H0. + rewrite InA_app_iff in *. split; intros. - assert (~eqA a x) by (contradict H3; rewrite <- H3; auto). + match goal with H3 : ~ InA x l |- _ => + assert (~eqA a x) by (contradict H3; rewrite <- H3; auto) + end. assert (~eqA a y) by (rewrite <- H; auto). tauto. - assert (OR : eqA a x \/ InA a l) by intuition. clear H6. + assert (OR : eqA a x \/ InA a l) by intuition. destruct OR as [EQN|INA]; auto. - elim H0. + match goal with H0 : ~ (InA y l1 \/ InA y l2) |- _ => elim H0 end. rewrite <-H,<-EQN; auto. Qed. @@ -448,7 +453,7 @@ Qed. Lemma ForallOrdPairs_inclA : forall l l', NoDupA l' -> inclA l' l -> ForallOrdPairs R l -> ForallOrdPairs R l'. Proof. -induction l' as [|x l' IH]. +intros l l'. induction l' as [|x l' IH]. constructor. intros ND Incl FOP. apply FOP_cons; inv; unfold inclA in *; auto. rewrite Forall_forall; intros y Hy. @@ -476,7 +481,7 @@ Lemma fold_right_commutes_restr : forall s1 s2 x, ForallOrdPairs R (s1++x::s2) -> eqB (fold_right f i (s1++x::s2)) (f x (fold_right f i (s1++s2))). Proof. -induction s1; simpl; auto; intros. +intros s1; induction s1 as [|a s1 IHs1]; simpl; auto; intros s2 x H. reflexivity. transitivity (f a (f x (fold_right f i (s1++s2)))). apply Comp; auto. @@ -484,7 +489,9 @@ apply IHs1. invlist ForallOrdPairs; auto. apply TraR. invlist ForallOrdPairs; auto. -rewrite Forall_forall in H0; apply H0. +match goal with H0 : Forall (R a) (s1 ++ x :: s2) |- R a x => + rewrite Forall_forall in H0; apply H0 +end. apply in_or_app; simpl; auto. Qed. @@ -492,14 +499,14 @@ Lemma fold_right_equivlistA_restr : forall s s', NoDupA s -> NoDupA s' -> ForallOrdPairs R s -> equivlistA s s' -> eqB (fold_right f i s) (fold_right f i s'). Proof. - simple induction s. - destruct s'; simpl. + intros s; induction s as [|x l Hrec]. + intros s'; destruct s' as [|a s']; simpl. intros; reflexivity. - unfold equivlistA; intros. + unfold equivlistA; intros H H0 H1 H2. destruct (H2 a). assert (InA a nil) by auto; inv. - intros x l Hrec s' N N' F E; simpl in *. - assert (InA x s') by (rewrite <- (E x); auto). + intros s' N N' F E; simpl in *. + assert (InA x s') as H by (rewrite <- (E x); auto). destruct (InA_split H) as (s1,(y,(s2,(H1,H2)))). subst s'. transitivity (f x (fold_right f i (s1++s2))). @@ -520,7 +527,7 @@ Lemma fold_right_add_restr : forall s' s x, NoDupA s -> NoDupA s' -> ForallOrdPairs R s' -> ~ InA x s -> equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f i s)). Proof. - intros; apply (@fold_right_equivlistA_restr s' (x::s)); auto. + intros s' s x **; apply (@fold_right_equivlistA_restr s' (x::s)); auto. Qed. End Fold_With_Restriction. @@ -532,7 +539,7 @@ Variable Tra :transpose f. Lemma fold_right_commutes : forall s1 s2 x, eqB (fold_right f i (s1++x::s2)) (f x (fold_right f i (s1++s2))). Proof. -induction s1; simpl; auto; intros. +intros s1; induction s1 as [|a s1 IHs1]; simpl; auto; intros s2 x. reflexivity. transitivity (f a (f x (fold_right f i (s1++s2)))); auto. apply Comp; auto. @@ -542,7 +549,7 @@ Lemma fold_right_equivlistA : forall s s', NoDupA s -> NoDupA s' -> equivlistA s s' -> eqB (fold_right f i s) (fold_right f i s'). Proof. -intros; apply fold_right_equivlistA_restr with (R:=fun _ _ => True); +intros; apply (fold_right_equivlistA_restr (R:=fun _ _ => True)); repeat red; auto. apply ForallPairs_ForallOrdPairs; try red; auto. Qed. @@ -551,7 +558,7 @@ Lemma fold_right_add : forall s' s x, NoDupA s -> NoDupA s' -> ~ InA x s -> equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f i s)). Proof. - intros; apply (@fold_right_equivlistA s' (x::s)); auto. + intros s' s x **; apply (@fold_right_equivlistA s' (x::s)); auto. Qed. End Fold. @@ -571,7 +578,7 @@ Lemma fold_right_eqlistA2 : eqB (fold_right f i s) (fold_right f j s'). Proof. intros s. - induction s;intros. + induction s as [|a s IHs];intros s' i j heqij heqss'. - inversion heqss'. subst. simpl. @@ -604,7 +611,7 @@ Lemma fold_right_commutes_restr2 : forall s1 s2 x (i j:B) (heqij: eqB i j), ForallOrdPairs R (s1++x::s2) -> eqB (fold_right f i (s1++x::s2)) (f x (fold_right f j (s1++s2))). Proof. -induction s1; simpl; auto; intros. +intros s1; induction s1 as [|a s1 IHs1]; simpl; auto; intros s2 x i j heqij ?. - apply Comp. + destruct eqA_equiv. apply Equivalence_Reflexive. + eapply fold_right_eqlistA2. @@ -617,7 +624,9 @@ induction s1; simpl; auto; intros. invlist ForallOrdPairs; auto. apply TraR. invlist ForallOrdPairs; auto. - rewrite Forall_forall in H0; apply H0. + match goal with H0 : Forall (R a) (s1 ++ x :: s2) |- _ => + rewrite Forall_forall in H0; apply H0 + end. apply in_or_app; simpl; auto. reflexivity. Qed. @@ -628,14 +637,14 @@ Lemma fold_right_equivlistA_restr2 : equivlistA s s' -> eqB i j -> eqB (fold_right f i s) (fold_right f j s'). Proof. - simple induction s. - destruct s'; simpl. + intros s; induction s as [|x l Hrec]. + intros s'; destruct s' as [|a s']; simpl. intros. assumption. - unfold equivlistA; intros. + unfold equivlistA; intros ? ? H H0 H1 H2 **. destruct (H2 a). assert (InA a nil) by auto; inv. - intros x l Hrec s' i j N N' F E eqij; simpl in *. - assert (InA x s') by (rewrite <- (E x); auto). + intros s' i j N N' F E eqij; simpl in *. + assert (InA x s') as H by (rewrite <- (E x); auto). destruct (InA_split H) as (s1,(y,(s2,(H1,H2)))). subst s'. transitivity (f x (fold_right f j (s1++s2))). @@ -663,7 +672,7 @@ Lemma fold_right_add_restr2 : forall s' s i j x, NoDupA s -> NoDupA s' -> eqB i j -> ForallOrdPairs R s' -> ~ InA x s -> equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f j s)). Proof. - intros; apply (@fold_right_equivlistA_restr2 s' (x::s) i j); auto. + intros s' s i j x **; apply (@fold_right_equivlistA_restr2 s' (x::s) i j); auto. Qed. End Fold2_With_Restriction. @@ -674,7 +683,7 @@ Lemma fold_right_commutes2 : forall s1 s2 i x x', eqA x x' -> eqB (fold_right f i (s1++x::s2)) (f x' (fold_right f i (s1++s2))). Proof. - induction s1;simpl;intros. + intros s1; induction s1 as [|a s1 IHs1];simpl;intros s2 i x x' H. - apply Comp;auto. reflexivity. - transitivity (f a (f x' (fold_right f i (s1++s2)))); auto. @@ -688,7 +697,7 @@ Lemma fold_right_equivlistA2 : equivlistA s s' -> eqB (fold_right f i s) (fold_right f j s'). Proof. red in Tra. -intros; apply fold_right_equivlistA_restr2 with (R:=fun _ _ => True); +intros; apply (fold_right_equivlistA_restr2 (R:=fun _ _ => True)); repeat red; auto. apply ForallPairs_ForallOrdPairs; try red; auto. Qed. @@ -697,9 +706,9 @@ Lemma fold_right_add2 : forall s' s i j x, NoDupA s -> NoDupA s' -> eqB i j -> ~ InA x s -> equivlistA s' (x::s) -> eqB (fold_right f i s') (f x (fold_right f j s)). Proof. - intros. + intros s' s i j x **. replace (f x (fold_right f j s)) with (fold_right f j (x::s)) by auto. - eapply fold_right_equivlistA2;auto. + eapply fold_right_equivlistA2;auto. Qed. End Fold2. @@ -710,7 +719,7 @@ Hypothesis eqA_dec : forall x y : A, {eqA x y}+{~(eqA x y)}. Lemma InA_dec : forall x l, { InA x l } + { ~ InA x l }. Proof. -induction l. +intros x l; induction l as [|a l IHl]. right; auto. intro; inv. destruct (eqA_dec x a). @@ -729,28 +738,30 @@ Fixpoint removeA (x : A) (l : list A) : list A := Lemma removeA_filter : forall x l, removeA x l = filter (fun y => if eqA_dec x y then false else true) l. Proof. -induction l; simpl; auto. +intros x l; induction l as [|a l IHl]; simpl; auto. destruct (eqA_dec x a); auto. rewrite IHl; auto. Qed. Lemma removeA_InA : forall l x y, InA y (removeA x l) <-> InA y l /\ ~eqA x y. Proof. -induction l; simpl; auto. -split. +intros l; induction l as [|a l IHl]; simpl; auto. +intros x y; split. intro; inv. destruct 1; inv. -intros. +intros x y. destruct (eqA_dec x a) as [Heq|Hnot]; simpl; auto. rewrite IHl; split; destruct 1; split; auto. inv; auto. -destruct H0; transitivity a; auto. +match goal with H0 : ~ eqA x y |- _ => destruct H0 end; transitivity a; auto. split. intro; inv. split; auto. contradict Hnot. transitivity y; auto. -rewrite (IHl x y) in H0; destruct H0; auto. +match goal with H0 : InA y (removeA x l) |- _ => + rewrite (IHl x y) in H0; destruct H0; auto +end. destruct 1; inv; auto. right; rewrite IHl; auto. Qed. @@ -758,7 +769,7 @@ Qed. Lemma removeA_NoDupA : forall s x, NoDupA s -> NoDupA (removeA x s). Proof. -simple induction s; simpl; intros. +intros s; induction s as [|a s IHs]; simpl; intros x ?. auto. inv. destruct (eqA_dec x a); simpl; auto. @@ -770,16 +781,16 @@ Qed. Lemma removeA_equivlistA : forall l l' x, ~InA x l -> equivlistA (x :: l) l' -> equivlistA l (removeA x l'). Proof. -unfold equivlistA; intros. +unfold equivlistA; intros l l' x H H0 x0. rewrite removeA_InA. -split; intros. +split; intros H1. rewrite <- H0; split; auto. contradict H. apply InA_eqA with x0; auto. rewrite <- (H0 x0) in H1. destruct H1. inv; auto. -elim H2; auto. +match goal with H2 : ~ eqA x x0 |- _ => elim H2; auto end. Qed. End Remove. @@ -806,7 +817,7 @@ Hint Constructors lelistA sort : core. Lemma InfA_ltA : forall l x y, ltA x y -> InfA y l -> InfA x l. Proof. - destruct l; constructor. inv; eauto. + intros l; destruct l; constructor. inv; eauto. Qed. Global Instance InfA_compat : Proper (eqA==>eqlistA==>iff) InfA. @@ -815,8 +826,8 @@ Proof using eqA_equiv ltA_compat. (* and not ltA_strorder *) inversion_clear Hll'. intuition. split; intro; inv; constructor. - rewrite <- Hxx', <- H; auto. - rewrite Hxx', H; auto. + match goal with H : eqA _ _ |- _ => rewrite <- Hxx', <- H; auto end. + match goal with H : eqA _ _ |- _ => rewrite Hxx', H; auto end. Qed. (** For compatibility, can be deduced from [InfA_compat] *) @@ -830,9 +841,9 @@ Hint Immediate InfA_ltA InfA_eqA : core. Lemma SortA_InfA_InA : forall l x a, SortA l -> InfA a l -> InA x l -> ltA a x. Proof. - simple induction l. - intros. inv. - intros. inv. + intros l; induction l as [|a l IHl]. + intros x a **. inv. + intros x a0 **. inv. setoid_replace x with a; auto. eauto. Qed. @@ -840,13 +851,13 @@ Qed. Lemma In_InfA : forall l x, (forall y, In y l -> ltA x y) -> InfA x l. Proof. - simple induction l; simpl; intros; constructor; auto. + intros l; induction l; simpl; intros; constructor; auto. Qed. Lemma InA_InfA : forall l x, (forall y, InA y l -> ltA x y) -> InfA x l. Proof. - simple induction l; simpl; intros; constructor; auto. + intros l; induction l; simpl; intros; constructor; auto. Qed. (* In fact, this may be used as an alternative definition for InfA: *) @@ -861,7 +872,7 @@ Qed. Lemma InfA_app : forall l1 l2 a, InfA a l1 -> InfA a l2 -> InfA a (l1++l2). Proof. - induction l1; simpl; auto. + intros l1; induction l1; simpl; auto. intros; inv; auto. Qed. @@ -870,7 +881,7 @@ Lemma SortA_app : (forall x y, InA x l1 -> InA y l2 -> ltA x y) -> SortA (l1 ++ l2). Proof. - induction l1; simpl in *; intuition. + intros l1; induction l1; intros l2; simpl in *; intuition. inv. constructor; auto. apply InfA_app; auto. @@ -879,8 +890,8 @@ Qed. Lemma SortA_NoDupA : forall l, SortA l -> NoDupA l. Proof. - simple induction l; auto. - intros x l' H H0. + intros l; induction l as [|x l' H]; auto. + intros H0. inv. constructor; auto. intro. @@ -922,7 +933,7 @@ Qed. Global Instance rev_eqlistA_compat : Proper (eqlistA==>eqlistA) (@rev A). Proof. -repeat red. intros. +repeat red. intros x y ?. rewrite <- (app_nil_r (rev x)), <- (app_nil_r (rev y)). apply eqlistA_rev_app; auto. Qed. @@ -936,15 +947,15 @@ Qed. Lemma SortA_equivlistA_eqlistA : forall l l', SortA l -> SortA l' -> equivlistA l l' -> eqlistA l l'. Proof. -induction l; destruct l'; simpl; intros; auto. -destruct (H1 a); assert (InA a nil) by auto; inv. +intros l; induction l as [|a l IHl]; intros l'; destruct l' as [|a0 l']; simpl; intros H H0 H1; auto. +destruct (H1 a0); assert (InA a0 nil) by auto; inv. destruct (H1 a); assert (InA a nil) by auto; inv. inv. assert (forall y, InA y l -> ltA a y). -intros; eapply SortA_InfA_InA with (l:=l); eauto. +intros; eapply (SortA_InfA_InA (l:=l)); eauto. assert (forall y, InA y l' -> ltA a0 y). -intros; eapply SortA_InfA_InA with (l:=l'); eauto. -clear H3 H4. +intros; eapply (SortA_InfA_InA (l:=l')); eauto. +do 2 match goal with H : InfA _ _ |- _ => clear H end. assert (eqA a a0). destruct (H1 a). destruct (H1 a0). @@ -953,13 +964,19 @@ assert (eqA a a0). elim (StrictOrder_Irreflexive a); eauto. constructor; auto. apply IHl; auto. -split; intros. +intros x; split; intros. destruct (H1 x). assert (InA x (a0::l')) by auto. inv; auto. -rewrite H9,<-H3 in H4. elim (StrictOrder_Irreflexive a); eauto. +match goal with H3 : eqA a a0, H4 : InA x l, H9 : eqA x a0 |- InA x l' => + rewrite H9,<-H3 in H4 +end. +elim (StrictOrder_Irreflexive a); eauto. destruct (H1 x). assert (InA x (a::l)) by auto. inv; auto. -rewrite H9,H3 in H4. elim (StrictOrder_Irreflexive a0); eauto. +match goal with H3 : eqA a a0, H4 : InA x l', H9 : eqA x a |- InA x l => + rewrite H9,H3 in H4 +end. +elim (StrictOrder_Irreflexive a0); eauto. Qed. End EqlistA. @@ -970,12 +987,12 @@ Section Filter. Lemma filter_sort : forall f l, SortA l -> SortA (List.filter f l). Proof. -induction l; simpl; auto. +intros f l; induction l as [|a l IHl]; simpl; auto. intros; inv; auto. destruct (f a); auto. constructor; auto. apply In_InfA; auto. -intros. +intros y H. rewrite filter_In in H; destruct H. eapply SortA_InfA_InA; eauto. Qed. @@ -984,12 +1001,14 @@ Arguments eq {A} x _. Lemma filter_InA : forall f, Proper (eqA==>eq) f -> forall l x, InA x (List.filter f l) <-> InA x l /\ f x = true. Proof. +(* Unset Mangle Names. *) clear sotrans ltA ltA_strorder ltA_compat. -intros; do 2 rewrite InA_alt; intuition. -destruct H0 as (y,(H0,H1)); rewrite filter_In in H1; exists y; intuition. -destruct H0 as (y,(H0,H1)); rewrite filter_In in H1; intuition. +intros f H l x; do 2 rewrite InA_alt; intuition; + match goal with Hex' : exists _, _ |- _ => rename Hex' into Hex end. +destruct Hex as (y,(H0,H1)); rewrite filter_In in H1; exists y; intuition. +destruct Hex as (y,(H0,H1)); rewrite filter_In in H1; intuition. rewrite (H _ _ H0); auto. -destruct H1 as (y,(H0,H1)); exists y; rewrite filter_In; intuition. +destruct Hex as (y,(H0,H1)); exists y; rewrite filter_In; intuition. rewrite <- (H _ _ H0); auto. Qed. @@ -997,19 +1016,20 @@ Lemma filter_split : forall f, (forall x y, f x = true -> f y = false -> ltA x y) -> forall l, SortA l -> l = filter f l ++ filter (fun x=>negb (f x)) l. Proof. -induction l; simpl; intros; auto. +intros f H l; induction l as [|a l IHl]; simpl; intros H0; auto. inv. +match goal with H1' : SortA l, H2' : InfA a l |- _ => rename H1' into H1, H2' into H2 end. rewrite IHl at 1; auto. case_eq (f a); simpl; intros; auto. -assert (forall e, In e l -> f e = false). - intros. +assert (forall e, In e l -> f e = false) as H3. + intros e H3. assert (H4:=SortA_InfA_InA H1 H2 (In_InA H3)). case_eq (f e); simpl; intros; auto. elim (StrictOrder_Irreflexive e). transitivity a; auto. replace (List.filter f l) with (@nil A); auto. -generalize H3; clear; induction l; simpl; auto. -case_eq (f a); auto; intros. +generalize H3; clear; induction l as [|a l IHl]; simpl; auto. +case_eq (f a); auto; intros H H3. rewrite H3 in H; auto; try discriminate. Qed. @@ -1043,23 +1063,24 @@ Lemma findA_NoDupA : Proof. set (eqk := fun p p' : A*B => eqA (fst p) (fst p')). set (eqke := fun p p' : A*B => eqA (fst p) (fst p') /\ snd p = snd p'). -induction l; intros; simpl. -split; intros; try discriminate. +intros l; induction l as [|a l IHl]; intros a0 b H; simpl. +split; intros H0; try discriminate. invlist InA. destruct a as (a',b'); rename a0 into a. invlist NoDupA. split; intros. invlist InA. -compute in H2; destruct H2. subst b'. +match goal with H2 : eqke (a, b) (a', b') |- _ => compute in H2; destruct H2 end. +subst b'. destruct (eqA_dec a a'); intuition. destruct (eqA_dec a a') as [HeqA|]; simpl. -contradict H0. -revert HeqA H2; clear - eqA_equiv. +match goal with H0 : ~ InA eqk (a', b') l |- _ => contradict H0 end. +match goal with H2 : InA eqke (a, b) l |- _ => revert HeqA H2; clear - eqA_equiv end. induction l. intros; invlist InA. intros; invlist InA; auto. -destruct a0. -compute in H; destruct H. +match goal with |- InA eqk _ (?p :: _) => destruct p as [a0 b0] end. +match goal with H : eqke (a, b) (a0, b0) |- _ => compute in H; destruct H end. subst b. left; auto. compute. diff --git a/theories/Logic/ProofIrrelevanceFacts.v b/theories/Logic/ProofIrrelevanceFacts.v index 131668154e..7560ea96b5 100644 --- a/theories/Logic/ProofIrrelevanceFacts.v +++ b/theories/Logic/ProofIrrelevanceFacts.v @@ -27,7 +27,7 @@ Module ProofIrrelevanceTheory (M:ProofIrrelevance). forall (U:Type) (p:U) (Q:U -> Type) (x:Q p) (h:p = p), x = eq_rect p Q x p h. Proof. - intros; rewrite M.proof_irrelevance with (p1:=h) (p2:=eq_refl p). + intros U p Q x h; rewrite (M.proof_irrelevance _ h (eq_refl p)). reflexivity. Qed. End Eq_rect_eq. @@ -45,8 +45,8 @@ Module ProofIrrelevanceTheory (M:ProofIrrelevance). forall (U:Type) (P:U->Prop) (x y:U) (p:P x) (q:P y), x = y -> exist P x p = exist P y q. Proof. - intros. - rewrite M.proof_irrelevance with (p1:=q) (p2:=eq_rect x P p y H). + intros U P x y p q H. + rewrite (M.proof_irrelevance _ q (eq_rect x P p y H)). elim H using eq_indd. reflexivity. Qed. @@ -55,8 +55,8 @@ Module ProofIrrelevanceTheory (M:ProofIrrelevance). forall (U:Type) (P:U->Prop) (x y:U) (p:P x) (q:P y), x = y -> existT P x p = existT P y q. Proof. - intros. - rewrite M.proof_irrelevance with (p1:=q) (p2:=eq_rect x P p y H). + intros U P x y p q H. + rewrite (M.proof_irrelevance _ q (eq_rect x P p y H)). elim H using eq_indd. reflexivity. Qed. diff --git a/theories/Numbers/Cyclic/Int63/Int63.v b/theories/Numbers/Cyclic/Int63/Int63.v index 7bb725538b..a3ebe67325 100644 --- a/theories/Numbers/Cyclic/Int63/Int63.v +++ b/theories/Numbers/Cyclic/Int63/Int63.v @@ -205,6 +205,7 @@ Qed. Corollary to_Z_bounded : forall x, (0 <= φ x < wB)%Z. Proof. apply to_Z_rec_bounded. Qed. + (* =================================================== *) Local Open Scope Z_scope. (* General arithmetic results *) @@ -1904,6 +1905,22 @@ Qed. Lemma lxor0_r i : i lxor 0 = i. Proof. rewrite lxorC; exact (lxor0 i). Qed. +Lemma opp_to_Z_opp (x : int) : + φ x mod wB <> 0 -> + (- φ (- x)) mod wB = (φ x) mod wB. +Proof. + intros neqx0. + rewrite opp_spec. + rewrite (Z_mod_nz_opp_full (φ x%int63)) by assumption. + rewrite (Z.mod_small (φ x%int63)) by apply to_Z_bounded. + rewrite <- Z.add_opp_l. + rewrite Z.opp_add_distr, Z.opp_involutive. + replace (- wB) with (-1 * wB) by easy. + rewrite Z_mod_plus by easy. + now rewrite Z.mod_small by apply to_Z_bounded. +Qed. + + Module Export Int63Notations. Local Open Scope int63_scope. #[deprecated(since="8.13",note="use infix mod instead")] diff --git a/theories/Numbers/Cyclic/Int63/PrimInt63.v b/theories/Numbers/Cyclic/Int63/PrimInt63.v index 64c1b862c7..98127ef0ac 100644 --- a/theories/Numbers/Cyclic/Int63/PrimInt63.v +++ b/theories/Numbers/Cyclic/Int63/PrimInt63.v @@ -17,11 +17,21 @@ Register comparison as kernel.ind_cmp. Primitive int := #int63_type. Register int as num.int63.type. +Variant pos_neg_int63 := Pos (d:int) | Neg (d:int). +Register pos_neg_int63 as num.int63.pos_neg_int63. Declare Scope int63_scope. Definition id_int : int -> int := fun x => x. -Declare ML Module "int63_syntax_plugin". - -Module Export Int63NotationsInternalA. +Record int_wrapper := wrap_int {int_wrap : int}. +Register wrap_int as num.int63.wrap_int. +Definition printer (x : int_wrapper) : pos_neg_int63 := Pos (int_wrap x). +Definition parser (x : pos_neg_int63) : option int := + match x with + | Pos p => Some p + | Neg _ => None + end. +Number Notation int parser printer : int63_scope. + +Module Import Int63NotationsInternalA. Delimit Scope int63_scope with int63. Bind Scope int63_scope with int. End Int63NotationsInternalA. @@ -37,6 +47,9 @@ Primitive lor := #int63_lor. Primitive lxor := #int63_lxor. + +Primitive asr := #int63_asr. + (* Arithmetic modulo operations *) Primitive add := #int63_add. @@ -50,6 +63,10 @@ Primitive div := #int63_div. Primitive mod := #int63_mod. +Primitive divs := #int63_divs. + +Primitive mods := #int63_mods. + (* Comparisons *) Primitive eqb := #int63_eq. @@ -57,6 +74,10 @@ Primitive ltb := #int63_lt. Primitive leb := #int63_le. +Primitive ltsb := #int63_lts. + +Primitive lesb := #int63_les. + (** Exact arithmetic operations *) Primitive addc := #int63_addc. @@ -76,7 +97,13 @@ Primitive addmuldiv := #int63_addmuldiv. (** Comparison *) Primitive compare := #int63_compare. +Primitive compares := #int63_compares. + (** Exotic operations *) Primitive head0 := #int63_head0. Primitive tail0 := #int63_tail0. + +Module Export PrimInt63Notations. + Export Int63NotationsInternalA. +End PrimInt63Notations. diff --git a/theories/Numbers/Cyclic/Int63/Sint63.v b/theories/Numbers/Cyclic/Int63/Sint63.v new file mode 100644 index 0000000000..c0239ae3db --- /dev/null +++ b/theories/Numbers/Cyclic/Int63/Sint63.v @@ -0,0 +1,407 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +Require Import ZArith. +Import Znumtheory. +Require Export Int63. +Require Import Lia. + +Declare Scope sint63_scope. +Definition printer (x : int_wrapper) : pos_neg_int63 := + if (int_wrap x <? 4611686018427387904)%int63 then (* 2^62 *) + Pos (int_wrap x) + else + Neg ((int_wrap x) lxor max_int + 1)%int63. +Definition parser (x : pos_neg_int63) : option int := + match x with + | Pos p => if (p <? 4611686018427387904)%int63 then Some p else None + | Neg n => if (n <=? 4611686018427387904)%int63 + then Some ((n - 1) lxor max_int)%int63 else None + end. +Number Notation int parser printer : sint63_scope. + + +Module Import Sint63NotationsInternalA. +Delimit Scope sint63_scope with sint63. +Bind Scope sint63_scope with int. +End Sint63NotationsInternalA. + + +Module Import Sint63NotationsInternalB. +Infix "<<" := Int63.lsl (at level 30, no associativity) : sint63_scope. +(* TODO do we want >> to be asr or lsr? And is there a notation for the other one? *) +Infix ">>" := asr (at level 30, no associativity) : sint63_scope. +Infix "land" := Int63.land (at level 40, left associativity) : sint63_scope. +Infix "lor" := Int63.lor (at level 40, left associativity) : sint63_scope. +Infix "lxor" := Int63.lxor (at level 40, left associativity) : sint63_scope. +Infix "+" := Int63.add : sint63_scope. +Infix "-" := Int63.sub : sint63_scope. +Infix "*" := Int63.mul : sint63_scope. +Infix "/" := divs : sint63_scope. +Infix "mod" := mods (at level 40, no associativity) : sint63_scope. +Infix "=?" := Int63.eqb (at level 70, no associativity) : sint63_scope. +Infix "<?" := ltsb (at level 70, no associativity) : sint63_scope. +Infix "<=?" := lesb (at level 70, no associativity) : sint63_scope. +Infix "≤?" := lesb (at level 70, no associativity) : sint63_scope. +Notation "- x" := (opp x) : sint63_scope. +Notation "n ?= m" := (compares n m) (at level 70, no associativity) : sint63_scope. +End Sint63NotationsInternalB. + +Definition min_int := Eval vm_compute in (lsl 1 62). +Definition max_int := Eval vm_compute in (min_int - 1)%sint63. + +(** Translation to and from Z *) +Definition to_Z (i:int) := + if (i <? min_int)%int63 then + φ i%int63 + else + (- φ (- i)%int63)%Z. + +Lemma to_Z_0 : to_Z 0 = 0. +Proof. easy. Qed. + +Lemma to_Z_min : to_Z min_int = - (wB / 2). +Proof. easy. Qed. + +Lemma to_Z_max : to_Z max_int = wB / 2 - 1. +Proof. easy. Qed. + +Lemma to_Z_bounded : forall x, (to_Z min_int <= to_Z x <= to_Z max_int)%Z. +Proof. + intros x; unfold to_Z. + case ltbP; [> lia | intros _]. + case (ltbP max_int); [> intros _ | now intros H; exfalso; apply H]. + rewrite opp_spec. + rewrite Z_mod_nz_opp_full by easy. + rewrite Z.mod_small by apply Int63.to_Z_bounded. + case ltbP. + - intros ltxmin; split. + + now transitivity 0%Z; [>| now apply Int63.to_Z_bounded]. + + replace (φ min_int%int63) with (φ max_int%int63 + 1)%Z in ltxmin. + * lia. + * now compute. + - rewrite Z.nlt_ge; intros leminx. + rewrite opp_spec. + rewrite Z_mod_nz_opp_full. + + rewrite Z.mod_small by apply Int63.to_Z_bounded. + split. + * rewrite <- Z.opp_le_mono. + now rewrite <- Z.sub_le_mono_l. + * transitivity 0%Z; [>| now apply Int63.to_Z_bounded]. + rewrite Z.opp_nonpos_nonneg. + apply Zle_minus_le_0. + apply Z.lt_le_incl. + now apply Int63.to_Z_bounded. + + rewrite Z.mod_small by apply Int63.to_Z_bounded. + now intros eqx0; rewrite eqx0 in leminx. +Qed. + +Lemma of_to_Z : forall x, of_Z (to_Z x) = x. +Proof. + unfold to_Z, of_Z. + intros x. + generalize (Int63.to_Z_bounded x). + case ltbP. + - intros ltxmin [leq0x _]. + generalize (Int63.of_to_Z x). + destruct (φ x%int63). + + now intros <-. + + now intros <-; unfold Int63.of_Z. + + now intros _. + - intros nltxmin leq0xltwB. + rewrite (opp_spec x). + rewrite Z_mod_nz_opp_full. + + rewrite Zmod_small by easy. + destruct (wB - φ x%int63) eqn: iswbmx. + * lia. + * simpl. + apply to_Z_inj. + rewrite opp_spec. + generalize (of_Z_spec (Z.pos p)). + simpl Int63.of_Z; intros ->. + rewrite <- iswbmx. + rewrite <- Z.sub_0_l. + rewrite <- (Zmod_0_l wB). + rewrite <- Zminus_mod. + replace (0 - _) with (φ x%int63 - wB) by ring. + rewrite <- Zminus_mod_idemp_r. + rewrite Z_mod_same_full. + rewrite Z.sub_0_r. + now rewrite Z.mod_small. + * lia. + + rewrite Z.mod_small by easy. + intros eqx0; revert nltxmin; rewrite eqx0. + now compute. +Qed. + +Lemma to_Z_inj (x y : int) : to_Z x = to_Z y -> x = y. +Proof. exact (fun e => can_inj of_to_Z e). Qed. + +Lemma to_Z_mod_Int63to_Z (x : int) : to_Z x mod wB = φ x%int63. +Proof. + unfold to_Z. + case ltbP; [> now rewrite Z.mod_small by now apply Int63.to_Z_bounded |]. + rewrite Z.nlt_ge; intros gexmin. + rewrite opp_to_Z_opp; rewrite Z.mod_small by now apply Int63.to_Z_bounded. + - easy. + - now intros neqx0; rewrite neqx0 in gexmin. +Qed. + + +(** Centered modulo *) +Definition cmod (x d : Z) : Z := + (x + d / 2) mod d - (d / 2). + +Lemma cmod_mod (x d : Z) : + cmod (x mod d) d = cmod x d. +Proof. + now unfold cmod; rewrite Zplus_mod_idemp_l. +Qed. + +Lemma cmod_small (x d : Z) : + - (d / 2) <= x < d / 2 -> cmod x d = x. +Proof. + intros bound. + unfold cmod. + rewrite Zmod_small; [> lia |]. + split; [> lia |]. + rewrite Z.lt_add_lt_sub_r. + apply (Z.lt_le_trans _ (d / 2)); [> easy |]. + now rewrite <- Z.le_add_le_sub_r, Z.add_diag, Z.mul_div_le. +Qed. + +Lemma to_Z_cmodwB (x : int) : + to_Z x = cmod (φ x%int63) wB. +Proof. + unfold to_Z, cmod. + case ltbP; change φ (min_int)%int63 with (wB / 2). + - intros ltxmin. + rewrite Z.mod_small; [> lia |]. + split. + + now apply Z.add_nonneg_nonneg; try apply Int63.to_Z_bounded. + + change wB with (wB / 2 + wB / 2) at 2; lia. + - rewrite Z.nlt_ge; intros gexmin. + rewrite Int63.opp_spec. + rewrite Z_mod_nz_opp_full. + + rewrite Z.mod_small by apply Int63.to_Z_bounded. + rewrite <- (Z_mod_plus_full _ (-1)). + change (-1 * wB) with (- (wB / 2) - wB / 2). + rewrite <- Z.add_assoc, Zplus_minus. + rewrite Z.mod_small. + * change wB with (wB / 2 + wB / 2) at 1; lia. + * split; [> lia |]. + apply Z.lt_sub_lt_add_r. + transitivity wB; [>| easy]. + now apply Int63.to_Z_bounded. + + rewrite Z.mod_small by now apply Int63.to_Z_bounded. + now intros not0; rewrite not0 in gexmin. +Qed. + +Lemma of_Z_spec (z : Z) : to_Z (of_Z z) = cmod z wB. +Proof. now rewrite to_Z_cmodwB, Int63.of_Z_spec, cmod_mod. Qed. + +Lemma of_Z_cmod (z : Z) : of_Z (cmod z wB) = of_Z z. +Proof. now rewrite <- of_Z_spec, of_to_Z. Qed. + +Lemma is_int (z : Z) : + to_Z min_int <= z <= to_Z max_int -> + z = to_Z (of_Z z). +Proof. + rewrite to_Z_min, to_Z_max. + intros bound; rewrite of_Z_spec, cmod_small; lia. +Qed. + +(** Specification of operations that differ on signed and unsigned ints *) + +Axiom asr_spec : forall x p, to_Z (x >> p) = (to_Z x) / 2 ^ (to_Z p). + +Axiom div_spec : forall x y, + to_Z x <> to_Z min_int \/ to_Z y <> (-1)%Z -> + to_Z (x / y) = Z.quot (to_Z x) (to_Z y). + +Axiom mod_spec : forall x y, to_Z (x mod y) = Z.rem (to_Z x) (to_Z y). + +Axiom ltb_spec : forall x y, (x <? y)%sint63 = true <-> to_Z x < to_Z y. + +Axiom leb_spec : forall x y, (x <=? y)%sint63 = true <-> to_Z x <= to_Z y. + +Axiom compare_spec : forall x y, (x ?= y)%sint63 = (to_Z x ?= to_Z y). + +(** Specification of operations that coincide on signed and unsigned ints *) + +Lemma add_spec (x y : int) : + to_Z (x + y)%sint63 = cmod (to_Z x + to_Z y) wB. +Proof. + rewrite to_Z_cmodwB, Int63.add_spec. + rewrite <- 2!to_Z_mod_Int63to_Z, <- Z.add_mod by easy. + now rewrite cmod_mod. +Qed. + +Lemma sub_spec (x y : int) : + to_Z (x - y)%sint63 = cmod (to_Z x - to_Z y) wB. +Proof. + rewrite to_Z_cmodwB, Int63.sub_spec. + rewrite <- 2!to_Z_mod_Int63to_Z, <- Zminus_mod by easy. + now rewrite cmod_mod. +Qed. + +Lemma mul_spec (x y : int) : + to_Z (x * y)%sint63 = cmod (to_Z x * to_Z y) wB. +Proof. + rewrite to_Z_cmodwB, Int63.mul_spec. + rewrite <- 2!to_Z_mod_Int63to_Z, <- Zmult_mod by easy. + now rewrite cmod_mod. +Qed. + +Lemma succ_spec (x : int) : + to_Z (succ x)%sint63 = cmod (to_Z x + 1) wB. +Proof. now unfold succ; rewrite add_spec. Qed. + +Lemma pred_spec (x : int) : + to_Z (pred x)%sint63 = cmod (to_Z x - 1) wB. +Proof. now unfold pred; rewrite sub_spec. Qed. + +Lemma opp_spec (x : int) : + to_Z (- x)%sint63 = cmod (- to_Z x) wB. +Proof. + rewrite to_Z_cmodwB, Int63.opp_spec. + rewrite <- Z.sub_0_l, <- to_Z_mod_Int63to_Z, Zminus_mod_idemp_r. + now rewrite cmod_mod. +Qed. + +(** Behaviour when there is no under or overflow *) + +Lemma add_bounded (x y : int) : + to_Z min_int <= to_Z x + to_Z y <= to_Z max_int -> + to_Z (x + y) = to_Z x + to_Z y. +Proof. + rewrite to_Z_min, to_Z_max; intros bound. + now rewrite add_spec, cmod_small; [>| lia]. +Qed. + +Lemma sub_bounded (x y : int) : + to_Z min_int <= to_Z x - to_Z y <= to_Z max_int -> + to_Z (x - y) = to_Z x - to_Z y. +Proof. + rewrite to_Z_min, to_Z_max; intros bound. + now rewrite sub_spec, cmod_small; [>| lia]. +Qed. + +Lemma mul_bounded (x y : int) : + to_Z min_int <= to_Z x * to_Z y <= to_Z max_int -> + to_Z (x * y) = to_Z x * to_Z y. +Proof. + rewrite to_Z_min, to_Z_max; intros bound. + now rewrite mul_spec, cmod_small; [>| lia]. +Qed. + +Lemma succ_bounded (x : int) : + to_Z min_int <= to_Z x + 1 <= to_Z max_int -> + to_Z (succ x) = to_Z x + 1. +Proof. + rewrite to_Z_min, to_Z_max; intros bound. + now rewrite succ_spec, cmod_small; [>| lia]. +Qed. + +Lemma pred_bounded (x : int) : + to_Z min_int <= to_Z x - 1 <= to_Z max_int -> + to_Z (pred x) = to_Z x - 1. +Proof. + rewrite to_Z_min, to_Z_max; intros bound. + now rewrite pred_spec, cmod_small; [>| lia]. +Qed. + +Lemma opp_bounded (x : int) : + to_Z min_int <= - to_Z x <= to_Z max_int -> + to_Z (- x) = - to_Z x. +Proof. + rewrite to_Z_min, to_Z_max; intros bound. + now rewrite opp_spec, cmod_small; [>| lia]. +Qed. + +(** Relationship with of_Z *) + +Lemma add_of_Z (x y : int) : + (x + y)%sint63 = of_Z (to_Z x + to_Z y). +Proof. now rewrite <- of_Z_cmod, <- add_spec, of_to_Z. Qed. + +Lemma sub_of_Z (x y : int) : + (x - y)%sint63 = of_Z (to_Z x - to_Z y). +Proof. now rewrite <- of_Z_cmod, <- sub_spec, of_to_Z. Qed. + +Lemma mul_of_Z (x y : int) : + (x * y)%sint63 = of_Z (to_Z x * to_Z y). +Proof. now rewrite <- of_Z_cmod, <- mul_spec, of_to_Z. Qed. + +Lemma succ_of_Z (x : int) : + (succ x)%sint63 = of_Z (to_Z x + 1). +Proof. now rewrite <- of_Z_cmod, <- succ_spec, of_to_Z. Qed. + +Lemma pred_of_Z (x : int) : + (pred x)%sint63 = of_Z (to_Z x - 1). +Proof. now rewrite <- of_Z_cmod, <- pred_spec, of_to_Z. Qed. + +Lemma opp_of_Z (x : int) : + (- x)%sint63 = of_Z (- to_Z x). +Proof. now rewrite <- of_Z_cmod, <- opp_spec, of_to_Z. Qed. + +(** Comparison *) +Import Bool. + +Lemma eqbP x y : reflect (to_Z x = to_Z y) (x =? y)%sint63. +Proof. + apply iff_reflect; rewrite Int63.eqb_spec. + now split; [> apply to_Z_inj | apply f_equal]. +Qed. + +Lemma ltbP x y : reflect (to_Z x < to_Z y) (x <? y)%sint63. +Proof. now apply iff_reflect; symmetry; apply ltb_spec. Qed. + +Lemma lebP x y : reflect (to_Z x <= to_Z y) (x ≤? y)%sint63. +Proof. now apply iff_reflect; symmetry; apply leb_spec. Qed. + +(** ASR *) +Lemma asr_0 (i : int) : (0 >> i)%sint63 = 0%sint63. +Proof. now apply to_Z_inj; rewrite asr_spec. Qed. + +Lemma asr_0_r (i : int) : (i >> 0)%sint63 = i. +Proof. now apply to_Z_inj; rewrite asr_spec, Zdiv_1_r. Qed. + +Lemma asr_neg_r (i n : int) : to_Z n < 0 -> (i >> n)%sint63 = 0%sint63. +Proof. + intros ltn0. + apply to_Z_inj. + rewrite asr_spec, Z.pow_neg_r by assumption. + now rewrite Zdiv_0_r. +Qed. + +Lemma asr_1 (n : int) : (1 >> n)%sint63 = (n =? 0)%sint63. +Proof. + apply to_Z_inj; rewrite asr_spec. + case eqbP; [> now intros -> | intros neqn0]. + case (lebP 0 n). + - intros le0n. + apply Z.div_1_l; apply Z.pow_gt_1; [> easy |]. + rewrite to_Z_0 in *; lia. + - rewrite Z.nle_gt; intros ltn0. + now rewrite Z.pow_neg_r. +Qed. + +Notation asr := asr (only parsing). +Notation div := divs (only parsing). +Notation rem := mods (only parsing). +Notation ltb := ltsb (only parsing). +Notation leb := lesb (only parsing). +Notation compare := compares (only parsing). + +Module Export Sint63Notations. + Export Sint63NotationsInternalA. + Export Sint63NotationsInternalB. +End Sint63Notations. diff --git a/theories/Program/Subset.v b/theories/Program/Subset.v index 9788ad50dc..9540bc1075 100644 --- a/theories/Program/Subset.v +++ b/theories/Program/Subset.v @@ -68,10 +68,11 @@ Ltac pi := repeat f_equal ; apply proof_irrelevance. Lemma subset_eq : forall A (P : A -> Prop) (n m : sig P), n = m <-> `n = `m. Proof. + intros A P n m. destruct n as (x,p). destruct m as (x',p'). simpl. - split ; intros ; subst. + split ; intros H ; subst. - inversion H. reflexivity. @@ -92,7 +93,7 @@ Lemma match_eq_rewrite : forall (A B : Type) (x : A) (fn : {y : A | y = x} -> B) (y : {y:A | y = x}), match_eq A B x fn = fn y. Proof. - intros. + intros A B x fn y. unfold match_eq. f_equal. destruct y. diff --git a/theories/Reals/Abstract/ConstructiveReals.v b/theories/Reals/Abstract/ConstructiveReals.v index 60fad8795a..5a599587d0 100644 --- a/theories/Reals/Abstract/ConstructiveReals.v +++ b/theories/Reals/Abstract/ConstructiveReals.v @@ -285,14 +285,14 @@ Lemma CRlt_trans : forall {R : ConstructiveReals} (x y z : CRcarrier R), Proof. intros. apply (CRlt_le_trans _ y _ H). apply CRlt_asym. exact H0. -Defined. +Qed. Lemma CRlt_trans_flip : forall {R : ConstructiveReals} (x y z : CRcarrier R), y < z -> x < y -> x < z. Proof. intros. apply (CRlt_le_trans _ y). exact H0. apply CRlt_asym. exact H. -Defined. +Qed. Lemma CReq_refl : forall {R : ConstructiveReals} (x : CRcarrier R), x == x. diff --git a/theories/Reals/Abstract/ConstructiveRealsMorphisms.v b/theories/Reals/Abstract/ConstructiveRealsMorphisms.v index 53b5aca38c..6ed5845440 100644 --- a/theories/Reals/Abstract/ConstructiveRealsMorphisms.v +++ b/theories/Reals/Abstract/ConstructiveRealsMorphisms.v @@ -232,7 +232,7 @@ Proof. apply CRplus_lt_compat_l. apply (CRle_lt_trans _ (CR_of_Q R 0)). apply CRle_refl. apply CR_of_Q_lt. exact H. -Defined. +Qed. Lemma CRplus_neg_rat_lt : forall {R : ConstructiveReals} (x : CRcarrier R) (q : Q), Qlt q 0 -> CRlt R (CRplus R x (CR_of_Q R q)) x. diff --git a/theories/Reals/Alembert.v b/theories/Reals/Alembert.v index 069a1292cd..9a00408de3 100644 --- a/theories/Reals/Alembert.v +++ b/theories/Reals/Alembert.v @@ -112,7 +112,7 @@ Proof. pattern (sum_f_R0 An n) at 1; rewrite <- Rplus_0_r; apply Rplus_le_compat_l; left; apply H | apply H1 ]. -Defined. +Qed. Lemma Alembert_C2 : forall An:nat -> R, @@ -330,7 +330,7 @@ Proof. rewrite <- Rabs_Ropp; apply RRle_abs. rewrite double; pattern (Rabs (An n)) at 1; rewrite <- Rplus_0_r; apply Rplus_lt_compat_l; apply Rabs_pos_lt; apply H. -Defined. +Qed. Lemma AlembertC3_step1 : forall (An:nat -> R) (x:R), @@ -374,7 +374,7 @@ Proof. [ assumption | apply Rinv_0_lt_compat; apply Rabs_pos_lt; assumption ]. intro; unfold Bn; apply prod_neq_R0; [ apply H0 | apply pow_nonzero; assumption ]. -Defined. +Qed. Lemma AlembertC3_step2 : forall (An:nat -> R) (x:R), x = 0 -> { l:R | Pser An x l }. @@ -405,7 +405,7 @@ Proof. cut (x <> 0). intro; apply AlembertC3_step1; assumption. red; intro; rewrite H1 in Hgt; elim (Rlt_irrefl _ Hgt). -Defined. +Qed. Lemma Alembert_C4 : forall (An:nat -> R) (k:R), diff --git a/theories/Reals/Cauchy/ConstructiveCauchyReals.v b/theories/Reals/Cauchy/ConstructiveCauchyReals.v index 8a11c155ce..4fb3846abc 100644 --- a/theories/Reals/Cauchy/ConstructiveCauchyReals.v +++ b/theories/Reals/Cauchy/ConstructiveCauchyReals.v @@ -320,7 +320,6 @@ Proof. - contradiction. - exact Hxltz. Qed. -(* Todo: this was Defined. Why *) Lemma CReal_lt_le_trans : forall x y z : CReal, x < y -> y <= z -> x < z. @@ -330,7 +329,6 @@ Proof. - exact Hxltz. - contradiction. Qed. -(* Todo: this was Defined. Why *) Lemma CReal_le_trans : forall x y z : CReal, x <= y -> y <= z -> x <= z. @@ -347,7 +345,6 @@ Proof. apply (CReal_lt_le_trans _ y _ Hxlty). apply CRealLt_asym; exact Hyltz. Qed. -(* Todo: this was Defined. Why *) Lemma CRealEq_trans : forall x y z : CReal, CRealEq x y -> CRealEq y z -> CRealEq x z. diff --git a/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v b/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v index a180e13444..bc45868244 100644 --- a/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v +++ b/theories/Reals/Cauchy/ConstructiveCauchyRealsMult.v @@ -733,13 +733,11 @@ Definition CReal_inv_pos (x : CReal) (Hxpos : 0 < x) : CReal := bound := CReal_inv_pos_bound x Hxpos |}. -(* ToDo: make this more obviously computing *) - Definition CReal_neg_lt_pos : forall x : CReal, x < 0 -> 0 < -x. Proof. intros x [n nmaj]. exists n. - apply (Qlt_le_trans _ _ _ nmaj). destruct x. simpl. - unfold Qminus. rewrite Qplus_0_l, Qplus_0_r. apply Qle_refl. + simpl in *. unfold CReal_opp_seq, Qminus. + abstract now rewrite Qplus_0_r, <- (Qplus_0_l (- seq x n)). Defined. Definition CReal_inv (x : CReal) (xnz : x # 0) : CReal diff --git a/theories/Reals/Cauchy/ConstructiveRcomplete.v b/theories/Reals/Cauchy/ConstructiveRcomplete.v index 70d2861d17..c2b60e6478 100644 --- a/theories/Reals/Cauchy/ConstructiveRcomplete.v +++ b/theories/Reals/Cauchy/ConstructiveRcomplete.v @@ -75,7 +75,7 @@ Proof. rewrite inject_Q_plus, (opp_inject_Q 2). ring_simplify. exact H. rewrite Qinv_plus_distr. reflexivity. -Defined. +Qed. (* ToDo: Move to ConstructiveCauchyAbs.v *) Lemma Qabs_Rabs : forall q : Q, @@ -688,21 +688,7 @@ Proof. exact (a i j H0 H1). exists l. intros p. destruct (cv p). exists x. exact c. -Defined. - -(* ToDO: Belongs into sumbool.v *) -Section connectives. - - Variables A B : Prop. - - Hypothesis H1 : {A} + {~A}. - Hypothesis H2 : {B} + {~B}. - - Definition sumbool_or_not_or : {A \/ B} + {~(A \/ B)}. - case H1; case H2; tauto. - Defined. - -End connectives. +Qed. Lemma Qnot_le_iff_lt: forall x y : Q, ~ (x <= y)%Q <-> (y < x)%Q. @@ -740,13 +726,11 @@ Proof. clear maj. right. exists n. apply H0. - clear H0 H. intro n. - apply sumbool_or_not_or. - + destruct (Qlt_le_dec (2 * 2 ^ n)%Q (seq b n - seq a n)%Q). - * left; assumption. - * right; apply Qle_not_lt; assumption. - + destruct (Qlt_le_dec (2 * 2 ^ n)%Q (seq d n - seq c n)%Q). - * left; assumption. - * right; apply Qle_not_lt; assumption. + destruct (Qlt_le_dec (2 * 2 ^ n)%Q (seq b n - seq a n)%Q) as [H1|H1]. + + now left; left. + + destruct (Qlt_le_dec (2 * 2 ^ n)%Q (seq d n - seq c n)%Q) as [H2|H2]. + * now left; right. + * now right; intros [H3|H3]; apply Qle_not_lt with (2 := H3). Qed. Definition CRealConstructive : ConstructiveReals diff --git a/theories/Reals/ClassicalDedekindReals.v b/theories/Reals/ClassicalDedekindReals.v index 500838ed26..0736b09761 100644 --- a/theories/Reals/ClassicalDedekindReals.v +++ b/theories/Reals/ClassicalDedekindReals.v @@ -233,17 +233,12 @@ Qed. (** *** Conversion from CReal to DReal *) -Definition DRealAbstr : CReal -> DReal. +Lemma DRealAbstr_aux : + forall x H, + isLowerCut (fun q : Q => + if sig_forall_dec (fun n : nat => seq x (- Z.of_nat n) <= q + 2 ^ (- Z.of_nat n)) (H q) + then true else false). Proof. - intro x. - assert (forall (q : Q) (n : nat), - {(fun n0 : nat => (seq x (-Z.of_nat n0) <= q + (2^-Z.of_nat n0))%Q) n} + - {~ (fun n0 : nat => (seq x (-Z.of_nat n0) <= q + (2^-Z.of_nat n0))%Q) n}). - { intros. destruct (Qlt_le_dec (q + (2^-Z.of_nat n)) (seq x (-Z.of_nat n))). - right. apply (Qlt_not_le _ _ q0). left. exact q0. } - - exists (fun q:Q => if sig_forall_dec (fun n:nat => Qle (seq x (-Z.of_nat n)) (q + (2^-Z.of_nat n))) (H q) - then true else false). repeat split. - intros. destruct (sig_forall_dec (fun n : nat => (seq x (-Z.of_nat n) <= q + (2^-Z.of_nat n))%Q) @@ -303,6 +298,20 @@ Proof. apply (Qmult_le_l _ _ 2) in q0. field_simplify in q0. apply (Qplus_le_l _ _ (-seq x (-Z.of_nat n))) in q0. ring_simplify in q0. contradiction. reflexivity. +Qed. + +Definition DRealAbstr : CReal -> DReal. +Proof. + intro x. + assert (forall (q : Q) (n : nat), + {(fun n0 : nat => (seq x (-Z.of_nat n0) <= q + (2^-Z.of_nat n0))%Q) n} + + {~ (fun n0 : nat => (seq x (-Z.of_nat n0) <= q + (2^-Z.of_nat n0))%Q) n}). + { intros. destruct (Qlt_le_dec (q + (2^-Z.of_nat n)) (seq x (-Z.of_nat n))). + right. apply (Qlt_not_le _ _ q0). left. exact q0. } + + exists (fun q:Q => if sig_forall_dec (fun n:nat => Qle (seq x (-Z.of_nat n)) (q + (2^-Z.of_nat n))) (H q) + then true else false). + apply DRealAbstr_aux. Defined. (** *** Conversion from DReal to CReal *) diff --git a/theories/Reals/NewtonInt.v b/theories/Reals/NewtonInt.v index 6692119738..6107775003 100644 --- a/theories/Reals/NewtonInt.v +++ b/theories/Reals/NewtonInt.v @@ -170,7 +170,7 @@ Proof. reg. exists H5; symmetry ; reg; rewrite <- H3; rewrite <- H4; reflexivity. assumption. -Defined. +Qed. (**********) Lemma antiderivative_P1 : diff --git a/theories/Reals/Rtrigo_def.v b/theories/Reals/Rtrigo_def.v index 7f5a859c81..2004f40f00 100644 --- a/theories/Reals/Rtrigo_def.v +++ b/theories/Reals/Rtrigo_def.v @@ -41,9 +41,13 @@ Proof. red; intro; rewrite H0 in H; elim (lt_irrefl _ H). Qed. -Lemma exist_exp0 : { l:R | exp_in 0 l }. +(* Value of [exp 0] *) +Lemma exp_0 : exp 0 = 1. Proof. - exists 1. + cut (exp_in 0 1). + cut (exp_in 0 (exp 0)). + apply uniqueness_sum. + exact (proj2_sig (exist_exp 0)). unfold exp_in; unfold infinite_sum; intros. exists 0%nat. intros; replace (sum_f_R0 (fun i:nat => / INR (fact i) * 0 ^ i) n) with 1. @@ -56,18 +60,6 @@ Proof. simpl. ring. unfold ge; apply le_O_n. -Defined. - -(* Value of [exp 0] *) -Lemma exp_0 : exp 0 = 1. -Proof. - cut (exp_in 0 (exp 0)). - cut (exp_in 0 1). - unfold exp_in; intros; eapply uniqueness_sum. - apply H0. - apply H. - exact (proj2_sig exist_exp0). - exact (proj2_sig (exist_exp 0)). Qed. (*****************************************) @@ -384,9 +376,14 @@ Proof. intros; ring. Qed. -Lemma exist_cos0 : { l:R | cos_in 0 l }. +(* Value of [cos 0] *) +Lemma cos_0 : cos 0 = 1. Proof. - exists 1. + cut (cos_in 0 1). + cut (cos_in 0 (cos 0)). + apply uniqueness_sum. + rewrite <- Rsqr_0 at 1. + exact (proj2_sig (exist_cos (Rsqr 0))). unfold cos_in; unfold infinite_sum; intros; exists 0%nat. intros. unfold R_dist. @@ -400,17 +397,4 @@ Proof. rewrite Rplus_0_r. apply Hrecn; unfold ge; apply le_O_n. simpl; ring. -Defined. - -(* Value of [cos 0] *) -Lemma cos_0 : cos 0 = 1. -Proof. - cut (cos_in 0 (cos 0)). - cut (cos_in 0 1). - unfold cos_in; intros; eapply uniqueness_sum. - apply H0. - apply H. - exact (proj2_sig exist_cos0). - assert (H := proj2_sig (exist_cos (Rsqr 0))); unfold cos; - pattern 0 at 1; replace 0 with (Rsqr 0); [ exact H | apply Rsqr_0 ]. Qed. diff --git a/theories/Sorting/Sorted.v b/theories/Sorting/Sorted.v index 206eb606d2..422316d879 100644 --- a/theories/Sorting/Sorted.v +++ b/theories/Sorting/Sorted.v @@ -71,6 +71,7 @@ Section defs. (forall a l, Sorted l -> P l -> HdRel a l -> P (a :: l)) -> forall l:list A, Sorted l -> P l. Proof. + intros P ? ? l. induction l. firstorder using Sorted_inv. firstorder using Sorted_inv. Qed. @@ -78,7 +79,8 @@ Section defs. Proof. split; [induction 1 as [|a l [|]]| induction 1]; auto using Sorted, LocallySorted, HdRel. - inversion H1; subst; auto using LocallySorted. + match goal with H1 : HdRel a (_ :: _) |- _ => inversion H1 end. + subst; auto using LocallySorted. Qed. (** Strongly sorted: elements of the list are pairwise ordered *) @@ -90,7 +92,7 @@ Section defs. Lemma StronglySorted_inv : forall a l, StronglySorted (a :: l) -> StronglySorted l /\ Forall (R a) l. Proof. - intros; inversion H; auto. + intros a l H; inversion H; auto. Defined. Lemma StronglySorted_rect : @@ -99,7 +101,7 @@ Section defs. (forall a l, StronglySorted l -> P l -> Forall (R a) l -> P (a :: l)) -> forall l, StronglySorted l -> P l. Proof. - induction l; firstorder using StronglySorted_inv. + intros P ? ? l; induction l; firstorder using StronglySorted_inv. Defined. Lemma StronglySorted_rec : @@ -120,7 +122,8 @@ Section defs. Lemma Sorted_extends : Transitive R -> forall a l, Sorted (a::l) -> Forall (R a) l. Proof. - intros. change match a :: l with [] => True | a :: l => Forall (R a) l end. + intros H a l H0. + change match a :: l with [] => True | a :: l => Forall (R a) l end. induction H0 as [|? ? ? ? H1]; [trivial|]. destruct H1; constructor; trivial. eapply Forall_impl; [|eassumption]. diff --git a/theories/Strings/Ascii.v b/theories/Strings/Ascii.v index 06b02ab211..37d30a282c 100644 --- a/theories/Strings/Ascii.v +++ b/theories/Strings/Ascii.v @@ -173,6 +173,14 @@ Proof. apply N_ascii_bounded. Qed. +Definition ltb (a b : ascii) : bool := + (N_of_ascii a <? N_of_ascii b)%N. + +Definition leb (a b : ascii) : bool := + (N_of_ascii a <=? N_of_ascii b)%N. + +Infix "<?" := ltb : char_scope. +Infix "<=?" := leb : char_scope. (** * Concrete syntax *) diff --git a/theories/Structures/DecidableType.v b/theories/Structures/DecidableType.v index c923b503a7..a49e21fa92 100644 --- a/theories/Structures/DecidableType.v +++ b/theories/Structures/DecidableType.v @@ -93,7 +93,7 @@ Module KeyDecidableType(D:DecidableType). Lemma InA_eqk : forall p q m, eqk p q -> InA eqk p m -> InA eqk q m. Proof. - intros; apply InA_eqA with p; auto using eqk_equiv. + intros p q m **; apply InA_eqA with p; auto using eqk_equiv. Qed. Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). @@ -106,18 +106,18 @@ Module KeyDecidableType(D:DecidableType). Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l. Proof. - firstorder. - exists x; auto. - induction H. - destruct y. - exists e; auto. - destruct IHInA as [e H0]. + intros k l; split; intros [y H]. + exists y; auto. + induction H as [a l eq|a l H IH]. + destruct a as [k' y']. + exists y'; auto. + destruct IH as [e H0]. exists e; auto. Qed. Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l. Proof. - intros; unfold MapsTo in *; apply InA_eqA with (x,e); auto using eqke_equiv. + intros l x y e **; unfold MapsTo in *; apply InA_eqA with (x,e); auto using eqke_equiv. Qed. Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. @@ -127,21 +127,21 @@ Module KeyDecidableType(D:DecidableType). Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l. Proof. - inversion 1. - inversion_clear H0; eauto. + inversion 1 as [? H0]. + inversion_clear H0 as [? ? H1|]; eauto. destruct H1; simpl in *; intuition. Qed. Lemma In_inv_2 : forall k k' e e' l, InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l. Proof. - inversion_clear 1; compute in H0; intuition. + inversion_clear 1 as [? ? H0|? ? H0]; compute in H0; intuition. Qed. Lemma In_inv_3 : forall x x' l, InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l. Proof. - inversion_clear 1; compute in H0; intuition. + inversion_clear 1 as [? ? H0|? ? H0]; compute in H0; intuition. Qed. End Elt. diff --git a/theories/Structures/OrderedType.v b/theories/Structures/OrderedType.v index dc7a48cd6b..7bc9f97e2b 100644 --- a/theories/Structures/OrderedType.v +++ b/theories/Structures/OrderedType.v @@ -65,7 +65,7 @@ Module MOT_to_OT (Import O : MiniOrderedType) <: OrderedType. Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}. Proof with auto with ordered_type. - intros; elim (compare x y); intro H; [ right | left | right ]... + intros x y; elim (compare x y); intro H; [ right | left | right ]... assert (~ eq y x)... Defined. @@ -83,7 +83,7 @@ Module OrderedTypeFacts (Import O: OrderedType). Lemma lt_antirefl : forall x, ~ lt x x. Proof. - intros; intro; absurd (eq x x); auto with ordered_type. + intros x; intro; absurd (eq x x); auto with ordered_type. Qed. Instance lt_strorder : StrictOrder lt. @@ -91,14 +91,14 @@ Module OrderedTypeFacts (Import O: OrderedType). Lemma lt_eq : forall x y z, lt x y -> eq y z -> lt x z. Proof with auto with ordered_type. - intros; destruct (compare x z) as [Hlt|Heq|Hlt]; auto. + intros x y z H ?; destruct (compare x z) as [Hlt|Heq|Hlt]; auto. elim (lt_not_eq H); apply eq_trans with z... elim (lt_not_eq (lt_trans Hlt H))... Qed. Lemma eq_lt : forall x y z, eq x y -> lt y z -> lt x z. Proof with auto with ordered_type. - intros; destruct (compare x z) as [Hlt|Heq|Hlt]; auto. + intros x y z H H0; destruct (compare x z) as [Hlt|Heq|Hlt]; auto. elim (lt_not_eq H0); apply eq_trans with x... elim (lt_not_eq (lt_trans H0 Hlt))... Qed. @@ -111,7 +111,7 @@ Module OrderedTypeFacts (Import O: OrderedType). Qed. Lemma lt_total : forall x y, lt x y \/ eq x y \/ lt y x. - Proof. intros; destruct (compare x y); auto. Qed. + Proof. intros x y; destruct (compare x y); auto. Qed. Module TO. Definition t := t. @@ -157,7 +157,7 @@ Module OrderedTypeFacts (Import O: OrderedType). forall x y : t, eq x y -> exists H : eq x y, compare x y = EQ H. Proof. - intros; case (compare x y); intros H'; try (exfalso; order). + intros x y H; case (compare x y); intros H'; try (exfalso; order). exists H'; auto. Qed. @@ -165,7 +165,7 @@ Module OrderedTypeFacts (Import O: OrderedType). forall x y : t, lt x y -> exists H : lt x y, compare x y = LT H. Proof. - intros; case (compare x y); intros H'; try (exfalso; order). + intros x y H; case (compare x y); intros H'; try (exfalso; order). exists H'; auto. Qed. @@ -173,7 +173,7 @@ Module OrderedTypeFacts (Import O: OrderedType). forall x y : t, lt y x -> exists H : lt y x, compare x y = GT H. Proof. - intros; case (compare x y); intros H'; try (exfalso; order). + intros x y H; case (compare x y); intros H'; try (exfalso; order). exists H'; auto. Qed. @@ -203,7 +203,7 @@ Module OrderedTypeFacts (Import O: OrderedType). Lemma lt_dec : forall x y : t, {lt x y} + {~ lt x y}. Proof. - intros; elim (compare x y); [ left | right | right ]; auto with ordered_type. + intros x y; elim (compare x y); [ left | right | right ]; auto with ordered_type. Defined. Definition eqb x y : bool := if eq_dec x y then true else false. @@ -211,7 +211,7 @@ Module OrderedTypeFacts (Import O: OrderedType). Lemma eqb_alt : forall x y, eqb x y = match compare x y with EQ _ => true | _ => false end. Proof. - unfold eqb; intros; destruct (eq_dec x y); elim_comp; auto. + unfold eqb; intros x y; destruct (eq_dec x y); elim_comp; auto. Qed. (* Specialization of results about lists modulo. *) @@ -327,7 +327,7 @@ Module KeyOrderedType(O:OrderedType). Lemma ltk_not_eqke : forall e e', ltk e e' -> ~eqke e e'. Proof. unfold eqke, ltk; intuition; simpl in *; subst. - exact (lt_not_eq H H1). + match goal with H : lt _ _, H1 : eq _ _ |- _ => exact (lt_not_eq H H1) end. Qed. #[local] @@ -398,18 +398,18 @@ Module KeyOrderedType(O:OrderedType). Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l. Proof with auto with ordered_type. - firstorder. - exists x... - induction H. - destruct y. - exists e... - destruct IHInA as [e H0]. + intros k l; split; intros [y H]. + exists y... + induction H as [a l eq|a l H IH]. + destruct a as [k' y']. + exists y'... + destruct IH as [e H0]. exists e... Qed. Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l. Proof. - intros; unfold MapsTo in *; apply InA_eqA with (x,e); eauto with *. + intros l x y e **; unfold MapsTo in *; apply InA_eqA with (x,e); eauto with *. Qed. Lemma In_eq : forall l x y, eq x y -> In x l -> In y l. @@ -437,7 +437,7 @@ Module KeyOrderedType(O:OrderedType). Lemma Sort_Inf_NotIn : forall l k e, Sort l -> Inf (k,e) l -> ~In k l. Proof. - intros; red; intros. + intros l k e H H0; red; intros H1. destruct H1 as [e' H2]. elim (@ltk_not_eqk (k,e) (k,e')). eapply Sort_Inf_In; eauto with ordered_type. @@ -457,34 +457,34 @@ Module KeyOrderedType(O:OrderedType). Lemma Sort_In_cons_2 : forall l e e', Sort (e::l) -> InA eqk e' (e::l) -> ltk e e' \/ eqk e e'. Proof. - inversion_clear 2; auto with ordered_type. + intros l; inversion_clear 2; auto with ordered_type. left; apply Sort_In_cons_1 with l; auto. Qed. Lemma Sort_In_cons_3 : forall x l k e, Sort ((k,e)::l) -> In x l -> ~eq x k. Proof. - inversion_clear 1; red; intros. + inversion_clear 1 as [|? ? H0 H1]; red; intros H H2. destruct (Sort_Inf_NotIn H0 H1 (In_eq H2 H)). Qed. Lemma In_inv : forall k k' e l, In k ((k',e) :: l) -> eq k k' \/ In k l. Proof. - inversion 1. - inversion_clear H0; eauto with ordered_type. + inversion 1 as [? H0]. + inversion_clear H0 as [? ? H1|]; eauto with ordered_type. destruct H1; simpl in *; intuition. Qed. Lemma In_inv_2 : forall k k' e e' l, InA eqk (k, e) ((k', e') :: l) -> ~ eq k k' -> InA eqk (k, e) l. Proof. - inversion_clear 1; compute in H0; intuition. + inversion_clear 1 as [? ? H0|? ? H0]; compute in H0; intuition. Qed. Lemma In_inv_3 : forall x x' l, InA eqke x (x' :: l) -> ~ eqk x x' -> InA eqke x l. Proof. - inversion_clear 1; compute in H0; intuition. + inversion_clear 1 as [? ? H0|? ? H0]; compute in H0; intuition. Qed. End Elt. diff --git a/theories/dune b/theories/dune index 18e000cfe1..1cd3d8c119 100644 --- a/theories/dune +++ b/theories/dune @@ -1,6 +1,6 @@ (coq.theory (name Coq) - (package coq) + (package coq-stdlib) (synopsis "Coq's Standard Library") (flags -q) ; (mode native) @@ -8,30 +8,29 @@ ; (per_file ; (Init/*.v -> -boot)) (libraries - coq.plugins.ltac - coq.plugins.tauto + coq-core.plugins.ltac + coq-core.plugins.tauto - coq.plugins.cc - coq.plugins.firstorder + coq-core.plugins.cc + coq-core.plugins.firstorder - coq.plugins.number_string_notation - coq.plugins.int63_syntax - coq.plugins.float_syntax + coq-core.plugins.number_string_notation + coq-core.plugins.float_syntax - coq.plugins.btauto - coq.plugins.rtauto + coq-core.plugins.btauto + coq-core.plugins.rtauto - coq.plugins.ring - coq.plugins.nsatz - coq.plugins.omega + coq-core.plugins.ring + coq-core.plugins.nsatz + coq-core.plugins.omega - coq.plugins.zify - coq.plugins.micromega + coq-core.plugins.zify + coq-core.plugins.micromega - coq.plugins.funind + coq-core.plugins.funind - coq.plugins.ssreflect - coq.plugins.ssrsearch - coq.plugins.derive)) + coq-core.plugins.ssreflect + coq-core.plugins.ssrsearch + coq-core.plugins.derive)) (include_subdirs qualified) diff --git a/theories/extraction/ExtrOCamlInt63.v b/theories/extraction/ExtrOCamlInt63.v index 7f7b4af98d..1949a1a9d8 100644 --- a/theories/extraction/ExtrOCamlInt63.v +++ b/theories/extraction/ExtrOCamlInt63.v @@ -10,7 +10,7 @@ (** Extraction to OCaml of native 63-bit machine integers. *) -From Coq Require Int63 Extraction. +From Coq Require Int63 Sint63 Extraction. (** Basic data types used by some primitive operators. *) @@ -26,6 +26,7 @@ Extraction Inline Int63.int. Extract Constant Int63.lsl => "Uint63.l_sl". Extract Constant Int63.lsr => "Uint63.l_sr". +Extract Constant Sint63.asr => "Uint63.a_sr". Extract Constant Int63.land => "Uint63.l_and". Extract Constant Int63.lor => "Uint63.l_or". Extract Constant Int63.lxor => "Uint63.l_xor". @@ -36,10 +37,15 @@ Extract Constant Int63.mul => "Uint63.mul". Extract Constant Int63.mulc => "Uint63.mulc". Extract Constant Int63.div => "Uint63.div". Extract Constant Int63.mod => "Uint63.rem". +Extract Constant Sint63.div => "Uint63.divs". +Extract Constant Sint63.rem => "Uint63.rems". + Extract Constant Int63.eqb => "Uint63.equal". Extract Constant Int63.ltb => "Uint63.lt". Extract Constant Int63.leb => "Uint63.le". +Extract Constant Sint63.ltb => "Uint63.lts". +Extract Constant Sint63.leb => "Uint63.les". Extract Constant Int63.addc => "Uint63.addc". Extract Constant Int63.addcarryc => "Uint63.addcarryc". @@ -51,6 +57,7 @@ Extract Constant Int63.diveucl_21 => "Uint63.div21". Extract Constant Int63.addmuldiv => "Uint63.addmuldiv". Extract Constant Int63.compare => "Uint63.compare". +Extract Constant Sint63.compare => "Uint63.compares". Extract Constant Int63.head0 => "Uint63.head0". Extract Constant Int63.tail0 => "Uint63.tail0". diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in index 0ebb97d0bf..f2f2111fae 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -37,6 +37,7 @@ COQLIBS_NOML := $(COQMF_COQLIBS_NOML) CMDLINE_COQLIBS := $(COQMF_CMDLINE_COQLIBS) LOCAL := $(COQMF_LOCAL) COQLIB := $(COQMF_COQLIB) +COQCORELIB := $(COQMF_COQCORELIB) DOCDIR := $(COQMF_DOCDIR) OCAMLFIND := $(COQMF_OCAMLFIND) CAMLFLAGS := $(COQMF_CAMLFLAGS) @@ -97,9 +98,9 @@ COQMKFILE ?= "$(COQBIN)coq_makefile" OCAMLLIBDEP ?= "$(COQBIN)ocamllibdep" # Timing scripts -COQMAKE_ONE_TIME_FILE ?= "$(COQLIB)/tools/make-one-time-file.py" -COQMAKE_BOTH_TIME_FILES ?= "$(COQLIB)/tools/make-both-time-files.py" -COQMAKE_BOTH_SINGLE_TIMING_FILES ?= "$(COQLIB)/tools/make-both-single-timing-files.py" +COQMAKE_ONE_TIME_FILE ?= "$(COQCORELIB)/tools/make-one-time-file.py" +COQMAKE_BOTH_TIME_FILES ?= "$(COQCORELIB)/tools/make-both-time-files.py" +COQMAKE_BOTH_SINGLE_TIMING_FILES ?= "$(COQCORELIB)/tools/make-both-single-timing-files.py" BEFORE ?= AFTER ?= @@ -220,7 +221,7 @@ COQDOCLIBS?=$(COQLIBS_NOML) COQ_VERSION:=$(shell $(COQC) --print-version | cut -d " " -f 1) COQMAKEFILE_VERSION:=@COQ_VERSION@ -COQSRCLIBS?= $(foreach d,$(COQ_SRC_SUBDIRS), -I "$(COQLIB)/$(d)") +COQSRCLIBS?= $(foreach d,$(COQ_SRC_SUBDIRS), -I "$(COQCORELIB)/$(d)") CAMLFLAGS+=$(OCAMLLIBS) $(COQSRCLIBS) # ocamldoc fails with unknown argument otherwise @@ -822,6 +823,7 @@ printenv:: $(warning write extensions in @LOCAL_FILE@ or include @CONF_FILE@) @echo 'LOCAL = $(LOCAL)' @echo 'COQLIB = $(COQLIB)' + @echo 'COQCORELIB = $(COQCORELIB)' @echo 'DOCDIR = $(DOCDIR)' @echo 'OCAMLFIND = $(OCAMLFIND)' @echo 'HASNATDYNLINK = $(HASNATDYNLINK)' @@ -840,12 +842,12 @@ printenv:: .merlin: $(SHOW)'FILL .merlin' $(HIDE)echo 'FLG $(COQMF_CAMLFLAGS)' > .merlin - $(HIDE)echo 'B $(COQLIB)' >> .merlin - $(HIDE)echo 'S $(COQLIB)' >> .merlin + $(HIDE)echo 'B $(COQCORELIB)' >> .merlin + $(HIDE)echo 'S $(COQCORELIB)' >> .merlin $(HIDE)$(foreach d,$(COQ_SRC_SUBDIRS), \ - echo 'B $(COQLIB)$(d)' >> .merlin;) + echo 'B $(COQCORELIB)$(d)' >> .merlin;) $(HIDE)$(foreach d,$(COQ_SRC_SUBDIRS), \ - echo 'S $(COQLIB)$(d)' >> .merlin;) + echo 'S $(COQCORELIB)$(d)' >> .merlin;) $(HIDE)$(foreach d,$(SRC_SUBDIRS), echo 'B $(d)' >> .merlin;) $(HIDE)$(foreach d,$(SRC_SUBDIRS), echo 'S $(d)' >> .merlin;) $(HIDE)$(MAKE) merlin-hook -f "$(SELF)" diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index 07550b67e3..cddb840693 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -125,8 +125,17 @@ let quote s = if String.contains s ' ' || CString.is_empty s then "'" ^ s ^ "'" let generate_makefile oc conf_file local_file dep_file args project = let coqlib = Envars.coqlib () in let makefile_template = - let template = Filename.concat "tools" "CoqMakefile.in" in - Filename.concat coqlib template in + CPath.choose_existing + [ CPath.make [ coqlib; "tools"; "CoqMakefile.in" ] + ; CPath.make [ coqlib; ".."; "coq-core"; "tools"; "CoqMakefile.in" ] + ] + in + let makefile_template = match makefile_template with + | None -> + Format.eprintf "Error: cannot find CoqMakefile.in"; + exit 1 + | Some v -> (v :> string) + in let s = read_whole_file makefile_template in let s = List.fold_left (* We use global_substitute to avoid running into backslash issues due to \1 etc. *) diff --git a/tools/coqdep.ml b/tools/coqdep.ml index 2177da0c75..f1dbac889b 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -97,8 +97,16 @@ let coqdep () = if not !option_boot then begin Envars.set_coqlib ~fail:(fun msg -> raise (CoqlibError msg)); let coqlib = Envars.coqlib () in + let coq_plugins_dir = CPath.choose_existing + [ CPath.make [ coqlib; "plugins" ] + ; CPath.make [ coqlib; ".."; "coq-core"; "plugins" ] + ] |> function + | None -> + CErrors.user_err (Pp.str "coqdep: cannot find plugins directory\n"); + | Some f -> (f :> string) + in add_rec_dir_import add_coqlib_known (coqlib//"theories") ["Coq"]; - add_rec_dir_import add_coqlib_known (coqlib//"plugins") ["Coq"]; + add_rec_dir_import add_coqlib_known (coq_plugins_dir) ["Coq"]; let user = coqlib//"user-contrib" in if Sys.file_exists user then add_rec_dir_no_import add_coqlib_known user []; List.iter (fun s -> add_rec_dir_no_import add_coqlib_known s []) diff --git a/tools/coqdoc/dune b/tools/coqdoc/dune index e3c792f277..cc888a959f 100644 --- a/tools/coqdoc/dune +++ b/tools/coqdoc/dune @@ -1,6 +1,6 @@ (install (section lib) - (package coq) + (package coq-core) (files (coqdoc.css as tools/coqdoc/coqdoc.css) (coqdoc.sty as tools/coqdoc/coqdoc.sty))) @@ -8,7 +8,7 @@ (executable (name main) (public_name coqdoc) - (package coq) - (libraries str coq.config coq.clib)) + (package coq-core) + (libraries str coq-core.config coq-core.clib)) (ocamllex cpretty) diff --git a/tools/coqdoc/main.ml b/tools/coqdoc/main.ml index 6ebf9b71d6..c95d1ee7db 100644 --- a/tools/coqdoc/main.ml +++ b/tools/coqdoc/main.ml @@ -87,8 +87,7 @@ let obsolete s = course). *) let banner () = - eprintf "This is coqdoc version %s, compiled on %s\n" - Coq_config.version Coq_config.compile_date; + eprintf "This is coqdoc version %s\n" Coq_config.version; flush stderr let target_full_name f = @@ -472,9 +471,17 @@ let index_module = function | Latex_file _ -> () let copy_style_file file = - let src = - List.fold_left - Filename.concat !Cdglobals.coqlib_path ["tools";"coqdoc";file] in + (* We give preference to coqlib in case it is overriden *) + let src_dir = CPath.choose_existing + [ CPath.make [ !Cdglobals.coqlib_path; "tools"; "coqdoc" ] + ; CPath.make [ !Cdglobals.coqlib_path; ".."; "coq-core"; "tools"; "coqdoc" ] + ] |> function + | None -> + eprintf "coqdoc: cannot find coqdoc style files\n"; + exit 1 + | Some f -> f + in + let src = (CPath.relative src_dir file :> string) in let dst = coqdoc_out file in if Sys.file_exists src then copy src dst else eprintf "Warning: file %s does not exist\n" src diff --git a/tools/dune b/tools/dune index d591bb0c37..703342b15c 100644 --- a/tools/dune +++ b/tools/dune @@ -1,6 +1,6 @@ (install (section lib) - (package coq) + (package coq-core) (files (CoqMakefile.in as tools/CoqMakefile.in) (TimeFileMaker.py as tools/TimeFileMaker.py) @@ -11,30 +11,30 @@ (executable (name coq_makefile) (public_name coq_makefile) - (package coq) + (package coq-core) (modules coq_makefile) - (libraries coq.lib)) + (libraries coq-core.lib)) (executable (name coqworkmgr) (public_name coqworkmgr) - (package coq) + (package coq-core) (modules coqworkmgr) - (libraries coq.stm)) + (libraries coq-core.stm)) (executable (name coqdep) (public_name coqdep) - (package coq) + (package coq-core) (modules coqdep_lexer coqdep_common coqdep) - (libraries coq.lib)) + (libraries coq-core.lib)) ; Bare-bones mllib/mlpack parser (executable (name ocamllibdep) (public_name ocamllibdep) (modules ocamllibdep) - (package coq) + (package coq-core) (libraries unix)) (ocamllex coqdep_lexer ocamllibdep) @@ -42,7 +42,7 @@ (executable (name coqwc) (public_name coqwc) - (package coq) + (package coq-core) (modules coqwc) (libraries)) @@ -51,6 +51,6 @@ (executables (names coq_tex) (public_names coq-tex) - (package coq) + (package coq-core) (modules coq_tex) (libraries str)) diff --git a/topbin/dune b/topbin/dune index 46052c81e5..5fcb3415f0 100644 --- a/topbin/dune +++ b/topbin/dune @@ -1,31 +1,31 @@ (install (section bin) - (package coq) + (package coq-core) (files (coqtop_bin.exe as coqtop))) (executable (name coqtop_bin) (public_name coqtop.opt) - (package coq) + (package coq-core) (modules coqtop_bin) - (libraries coq.toplevel) + (libraries coq-core.toplevel) (link_flags -linkall)) (executable (name coqtop_byte_bin) (public_name coqtop.byte) - (package coq) + (package coq-core) (modules coqtop_byte_bin) - (libraries compiler-libs.toplevel coq.toplevel) + (libraries compiler-libs.toplevel coq-core.toplevel) (modes byte) (link_flags -linkall)) (executable (name coqc_bin) (public_name coqc) - (package coq) + (package coq-core) (modules coqc_bin) - (libraries coq.toplevel) + (libraries coq-core.toplevel) (modes native byte) ; Adding -ccopt -flto to links options could be interesting, however, ; it doesn't work on Windows @@ -33,16 +33,16 @@ (install (section bin) - (package coq) + (package coq-core) (files (coqc_bin.bc as coqc.byte))) ; Workers (executables (names coqqueryworker_bin coqtacticworker_bin coqproofworker_bin) (public_names coqqueryworker.opt coqtacticworker.opt coqproofworker.opt) - (package coq) + (package coq-core) (modules :standard \ coqtop_byte_bin coqtop_bin coqc_bin) - (libraries coq.toplevel) + (libraries coq-core.toplevel) (link_flags -linkall)) ; Workers installed targets diff --git a/toplevel/ccompile.ml b/toplevel/ccompile.ml index ca09bad441..041097d2d3 100644 --- a/toplevel/ccompile.ml +++ b/toplevel/ccompile.ml @@ -216,9 +216,8 @@ let compile_file opts stm_opts copts injections (f_in, echo) = else compile opts stm_opts copts injections ~echo ~f_in ~f_out -let compile_files (opts, stm_opts) copts injections = - let compile_list = copts.compile_list in - List.iter (compile_file opts stm_opts copts injections) compile_list +let compile_file opts stm_opts copts injections = + Option.iter (compile_file opts stm_opts copts injections) copts.compile_file (******************************************************************************) (* VIO Dispatching *) diff --git a/toplevel/ccompile.mli b/toplevel/ccompile.mli index 9f3783f32e..e9e83af3ad 100644 --- a/toplevel/ccompile.mli +++ b/toplevel/ccompile.mli @@ -12,8 +12,8 @@ the init (rc) file *) val load_init_vernaculars : Coqargs.t -> state:Vernac.State.t-> Vernac.State.t -(** [compile_files opts] compile files specified in [opts] *) -val compile_files : Coqargs.t * Stm.AsyncOpts.stm_opt -> Coqcargs.t -> Coqargs.injection_command list -> unit +(** [compile_file opts] compile file specified in [opts] *) +val compile_file : Coqargs.t -> Stm.AsyncOpts.stm_opt -> Coqcargs.t -> Coqargs.injection_command list -> unit (** [do_vio opts] process [.vio] files in [opts] *) val do_vio : Coqargs.t -> Coqcargs.t -> Coqargs.injection_command list -> unit diff --git a/toplevel/coqc.ml b/toplevel/coqc.ml index a403640149..b78bcce6db 100644 --- a/toplevel/coqc.ml +++ b/toplevel/coqc.ml @@ -26,6 +26,8 @@ let coqc_specific_usage = Usage.{ coqc specific options:\ \n -o f.vo use f.vo as the output file name\ \n -verbose compile and output the input file\ +\n -noglob do not dump globalizations\ +\n -dump-glob f dump globalizations in file f (to be used by coqdoc)\ \n -schedule-vio2vo j f1..fn run up to j instances of Coq to turn each fi.vio\ \n into fi.vo\ \n -schedule-vio-checking j f1..fn run up to j instances of Coq to check all\ @@ -44,7 +46,7 @@ coqc specific options:\ let coqc_main ((copts,_),stm_opts) injections ~opts = Topfmt.(in_phase ~phase:CompilationPhase) - Ccompile.compile_files (opts,stm_opts) copts injections; + Ccompile.compile_file opts stm_opts copts injections; (* Careful this will modify the load-path and state so after this point some stuff may not be safe anymore. *) diff --git a/toplevel/coqcargs.ml b/toplevel/coqcargs.ml index f84d73ed17..efd8a79e18 100644 --- a/toplevel/coqcargs.ml +++ b/toplevel/coqcargs.ml @@ -13,7 +13,7 @@ type compilation_mode = BuildVo | BuildVio | Vio2Vo | BuildVos | BuildVok type t = { compilation_mode : compilation_mode - ; compile_list: (string * bool) list (* bool is verbosity *) + ; compile_file: (string * bool) option (* bool is verbosity *) ; compilation_output_name : string option ; vio_checking : bool @@ -32,7 +32,7 @@ type t = let default = { compilation_mode = BuildVo - ; compile_list = [] + ; compile_file = None ; compilation_output_name = None ; vio_checking = false @@ -62,17 +62,13 @@ let error_missing_arg s = prerr_endline "See -help for the syntax of supported options"; exit 1 -let check_compilation_output_name_consistency args = - match args.compilation_output_name, args.compile_list with - | Some _, _::_::_ -> - prerr_endline ("Error: option -o is not valid when more than one"); - prerr_endline ("file have to be compiled") - | _ -> () +let arg_error msg = CErrors.user_err msg let is_dash_argument s = String.length s > 0 && s.[0] = '-' let add_compile ?echo copts s = - if is_dash_argument s then (prerr_endline ("Unknown option " ^ s); exit 1); + if is_dash_argument s then + arg_error Pp.(str "Unknown option " ++ str s); (* make the file name explicit; needed not to break up Coq loadpath stuff. *) let echo = Option.default copts.echo echo in let s = @@ -81,7 +77,14 @@ let add_compile ?echo copts s = then concat current_dir_name s else s in - { copts with compile_list = (s,echo) :: copts.compile_list } + { copts with compile_file = Some (s,echo) } + +let add_compile ?echo copts v_file = + match copts.compile_file with + | Some _ -> + arg_error Pp.(str "More than one file to compile: " ++ str v_file) + | None -> + add_compile ?echo copts v_file let add_vio_task opts f = { opts with vio_tasks = f :: opts.vio_tasks } @@ -230,14 +233,12 @@ let parse arglist : t = try let opts, extra = parse default in let args = List.fold_left add_compile opts extra in - check_compilation_output_name_consistency args; args with any -> fatal_error any let parse args = let opts = parse args in { opts with - compile_list = List.rev opts.compile_list - ; vio_tasks = List.rev opts.vio_tasks + vio_tasks = List.rev opts.vio_tasks ; vio_files = List.rev opts.vio_files } diff --git a/toplevel/coqcargs.mli b/toplevel/coqcargs.mli index 905250e363..96895568ea 100644 --- a/toplevel/coqcargs.mli +++ b/toplevel/coqcargs.mli @@ -27,7 +27,7 @@ type compilation_mode = BuildVo | BuildVio | Vio2Vo | BuildVos | BuildVok type t = { compilation_mode : compilation_mode - ; compile_list: (string * bool) list (* bool is verbosity *) + ; compile_file: (string * bool) option (* bool is verbosity *) ; compilation_output_name : string option ; vio_checking : bool diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 6460378edc..4faecd2e62 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -480,6 +480,11 @@ let drop_args = ref None (* Initialises the Ocaml toplevel before launching it, so that it can find the "include" file in the *source* directory *) let init_ocaml_path ~coqlib = + let coqlib : string = + if Sys.file_exists (CPath.make [coqlib; "plugins"] :> string) + then coqlib + else (CPath.make [ coqlib ; ".."; "coq-core" ] :> string) + in let add_subdir dl = Mltop.add_ml_dir (Filename.concat coqlib dl) in List.iter add_subdir ("dev" :: Coq_config.all_src_dirs) diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index caf86ef870..bb44d9cdee 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -18,31 +18,21 @@ let () = at_exit flush_all let ( / ) = Filename.concat -let get_version_date () = +let get_version () = try let ch = open_in (Envars.coqlib () / "revision") in let ver = input_line ch in let rev = input_line ch in let () = close_in ch in - (ver,rev) - with e when CErrors.noncritical e -> - (Coq_config.version,Coq_config.date) + Printf.sprintf "%s (%s)" ver rev + with _ -> Coq_config.version let print_header () = - let (ver,rev) = get_version_date () in - Feedback.msg_info (str "Welcome to Coq " ++ str ver ++ str " (" ++ str rev ++ str ")"); + Feedback.msg_info (str "Welcome to Coq " ++ str (get_version ())); flush_all () (******************************************************************************) -(* Input/Output State *) -(******************************************************************************) -let inputstate opts = - Option.iter (fun istate_file -> - let fname = Loadpath.locate_file (CUnix.make_suffix istate_file ".coq") in - Vernacstate.System.load fname) opts.inputstate - -(******************************************************************************) (* Fatal Errors *) (******************************************************************************) @@ -70,8 +60,6 @@ let init_toplevel { parse_extra; init_extra; usage; initial_args } = let opts, customopts = Coqinit.parse_arguments ~parse_extra ~usage ~initial_args () in Stm.init_process (snd customopts); let injections = Coqinit.init_runtime opts in - (* Allow the user to load an arbitrary state here *) - inputstate opts.pre; (* This state will be shared by all the documents *) Stm.init_core (); let customstate = init_extra ~opts customopts injections in @@ -174,7 +162,7 @@ let init_toploop opts stm_opts injections = state let coqtop_init ({ run_mode; color_mode }, async_opts) injections ~opts = - if run_mode = Batch then Flags.quiet := true; + if run_mode != Interactive then Flags.quiet := true; init_color (if opts.config.print_emacs then `EMACS else color_mode); Flags.if_verbose print_header (); init_toploop opts async_opts injections diff --git a/toplevel/dune b/toplevel/dune index 98f4ba2edf..9d5a08dde7 100644 --- a/toplevel/dune +++ b/toplevel/dune @@ -1,9 +1,9 @@ (library (name toplevel) - (public_name coq.toplevel) + (public_name coq-core.toplevel) (synopsis "Coq's Interactive Shell [terminal-based]") (wrapped false) - (libraries coq.stm)) + (libraries coq-core.stm)) ; Interp provides the `zarith` library to plugins, we could also use ; -linkall in the plugins file, to be discussed. diff --git a/user-contrib/Ltac2/Ind.v b/user-contrib/Ltac2/Ind.v new file mode 100644 index 0000000000..f397a0e2c8 --- /dev/null +++ b/user-contrib/Ltac2/Ind.v @@ -0,0 +1,45 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +From Ltac2 Require Import Init. + +Ltac2 Type t := inductive. + +Ltac2 @ external equal : t -> t -> bool := "ltac2" "ind_equal". +(** Equality test. *) + +Ltac2 Type data. +(** Type of data representing inductive blocks. *) + +Ltac2 @ external data : t -> data := "ltac2" "ind_data". +(** Get the mutual blocks corresponding to an inductive type in the current + environment. Panics if there is no such inductive. *) + +Ltac2 @ external repr : data -> t := "ltac2" "ind_repr". +(** Returns the inductive corresponding to the block. Inverse of [data]. *) + +Ltac2 @ external index : t -> int := "ltac2" "ind_index". +(** Returns the index of the inductive type inside its mutual block. Guaranteed + to range between [0] and [nblocks data - 1] where [data] was retrieved + using the above function. *) + +Ltac2 @ external nblocks : data -> int := "ltac2" "ind_nblocks". +(** Returns the number of inductive types appearing in a mutual block. *) + +Ltac2 @ external nconstructors : data -> int := "ltac2" "ind_nconstructors". +(** Returns the number of constructors appearing in the current block. *) + +Ltac2 @ external get_block : data -> int -> data := "ltac2" "ind_get_block". +(** Returns the block corresponding to the nth inductive type. Index must range + between [0] and [nblocks data - 1], otherwise the function panics. *) + +Ltac2 @ external get_constructor : data -> int -> constructor := "ltac2" "ind_get_constructor". +(** Returns the nth constructor of the inductive type. Index must range between + [0] and [nconstructors data - 1], otherwise the function panics. *) diff --git a/user-contrib/Ltac2/Init.v b/user-contrib/Ltac2/Init.v index a4f6d497df..097a0ca25f 100644 --- a/user-contrib/Ltac2/Init.v +++ b/user-contrib/Ltac2/Init.v @@ -35,6 +35,7 @@ Ltac2 Type preterm. Ltac2 Type binder. Ltac2 Type message. +Ltac2 Type ('a, 'b, 'c, 'd) format. Ltac2 Type exn := [ .. ]. Ltac2 Type 'a array. diff --git a/user-contrib/Ltac2/Ltac2.v b/user-contrib/Ltac2/Ltac2.v index d3bf3c10ea..e55c6c13d3 100644 --- a/user-contrib/Ltac2/Ltac2.v +++ b/user-contrib/Ltac2/Ltac2.v @@ -22,5 +22,7 @@ Require Ltac2.Fresh. Require Ltac2.Pattern. Require Ltac2.Std. Require Ltac2.Env. +Require Ltac2.Ind. +Require Ltac2.Printf. Require Ltac2.Ltac1. Require Export Ltac2.Notations. diff --git a/user-contrib/Ltac2/Message.v b/user-contrib/Ltac2/Message.v index 4a4d1d815c..39d39562cf 100644 --- a/user-contrib/Ltac2/Message.v +++ b/user-contrib/Ltac2/Message.v @@ -25,3 +25,32 @@ Ltac2 @ external of_exn : exn -> message := "ltac2" "message_of_exn". (** Panics if there is more than one goal under focus. *) Ltac2 @ external concat : message -> message -> message := "ltac2" "message_concat". + +Module Format. + +(** Only for internal use. *) + +Ltac2 @ external stop : unit -> ('a, 'b, 'c, 'a) format := "ltac2" "format_stop". + +Ltac2 @ external string : ('a, 'b, 'c, 'd) format -> + (string -> 'a, 'b, 'c, 'd) format := "ltac2" "format_string". + +Ltac2 @ external int : ('a, 'b, 'c, 'd) format -> + (int -> 'a, 'b, 'c, 'd) format := "ltac2" "format_int". + +Ltac2 @ external constr : ('a, 'b, 'c, 'd) format -> + (constr -> 'a, 'b, 'c, 'd) format := "ltac2" "format_constr". + +Ltac2 @ external ident : ('a, 'b, 'c, 'd) format -> + (ident -> 'a, 'b, 'c, 'd) format := "ltac2" "format_ident". + +Ltac2 @ external literal : string -> ('a, 'b, 'c, 'd) format -> + ('a, 'b, 'c, 'd) format := "ltac2" "format_literal". + +Ltac2 @ external alpha : ('a, 'b, 'c, 'd) format -> + (('b -> 'r -> 'c) -> 'r -> 'a, 'b, 'c, 'd) format := "ltac2" "format_alpha". + +Ltac2 @ external kfprintf : (message -> 'r) -> ('a, unit, message, 'r) format -> 'a := + "ltac2" "format_kfprintf". + +End Format. diff --git a/user-contrib/Ltac2/Printf.v b/user-contrib/Ltac2/Printf.v new file mode 100644 index 0000000000..e2470ed1c3 --- /dev/null +++ b/user-contrib/Ltac2/Printf.v @@ -0,0 +1,56 @@ +(************************************************************************) +(* * 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) *) +(************************************************************************) + +Require Import Ltac2.Message. + +(** This file defines a printf notation for easiness of writing messages *) + +(** + + The built-in "format" notation scope can be used to create well-typed variadic + printing commands following a printf-like syntax. The "format" scope parses + quoted strings which contain either raw string data or printing + specifications. Raw strings will be output verbatim as if they were passed + to Ltac2.Message.of_string. + + Printing specifications are of the form + + << '%' type >> + + where the type value defines which kind of arguments will be accepted and + how they will be printed. They can take the following values. + + - << i >>: takes an argument of type int and behaves as Message.of_int + - << I >>: takes an argument of type ident and behaves as Message.of_ident + - << s >>: takes an argument of type string and behaves as Message.of_string + - << t >>: takes an argument of type constr and behaves as Message.of_constr + - << a >>: takes two arguments << f >> of type << (unit -> 'a -> message) >> + and << x >> of type << 'a >> and behaves as << f () x >> + - << % >>: outputs << % >> verbatim + + TODO: add printing modifiers. + +*) + +Ltac2 printf fmt := Format.kfprintf print fmt. +Ltac2 fprintf fmt := Format.kfprintf (fun x => x) fmt. + +(** The two following notations are made available when this module is imported. + + - printf will parse a format and generate a function taking the + corresponding arguments ant printing the resulting message as per + Message.print. In particular when fully applied it has type unit. + - fprintf behaves similarly but return the message as a value instead of + printing it. + +*) + +Ltac2 Notation "printf" fmt(format) := printf fmt. +Ltac2 Notation "fprintf" fmt(format) := fprintf fmt. diff --git a/user-contrib/Ltac2/dune b/user-contrib/Ltac2/dune index 90869a46a0..b90bae10a3 100644 --- a/user-contrib/Ltac2/dune +++ b/user-contrib/Ltac2/dune @@ -1,14 +1,14 @@ (coq.theory (name Ltac2) - (package coq) + (package coq-stdlib) (synopsis "Ltac2 tactic language") - (libraries coq.plugins.ltac2)) + (libraries coq-core.plugins.ltac2)) (library (name ltac2_plugin) - (public_name coq.plugins.ltac2) + (public_name coq-core.plugins.ltac2) (synopsis "Ltac2 plugin") (modules_without_implementation tac2expr tac2qexpr tac2types) - (libraries coq.plugins.ltac)) + (libraries coq-core.plugins.ltac)) (coq.pp (modules g_ltac2)) diff --git a/user-contrib/Ltac2/plugin_base.dune b/user-contrib/Ltac2/plugin_base.dune deleted file mode 100644 index 711e9b95d3..0000000000 --- a/user-contrib/Ltac2/plugin_base.dune +++ /dev/null @@ -1,6 +0,0 @@ -(library - (name ltac2_plugin) - (public_name coq.plugins.ltac2) - (synopsis "Coq's Ltac2 plugin") - (modules_without_implementation tac2expr tac2qexpr tac2types) - (libraries coq.plugins.ltac)) diff --git a/user-contrib/Ltac2/tac2core.ml b/user-contrib/Ltac2/tac2core.ml index 241ca7ad66..bcf9ece7c8 100644 --- a/user-contrib/Ltac2/tac2core.ml +++ b/user-contrib/Ltac2/tac2core.ml @@ -44,6 +44,9 @@ let open_constr_no_classes_flags = module Value = Tac2ffi open Value +let val_format = Tac2print.val_format +let format = repr_ext val_format + let core_prefix path n = KerName.make path (Label.of_id (Id.of_string_soft n)) let std_core n = core_prefix Tac2env.std_prefix n @@ -250,6 +253,79 @@ let () = define2 "message_concat" pp pp begin fun m1 m2 -> return (Value.of_pp (Pp.app m1 m2)) end +let () = define0 "format_stop" begin + return (Value.of_ext val_format []) +end + +let () = define1 "format_string" format begin fun s -> + return (Value.of_ext val_format (Tac2print.FmtString :: s)) +end + +let () = define1 "format_int" format begin fun s -> + return (Value.of_ext val_format (Tac2print.FmtInt :: s)) +end + +let () = define1 "format_constr" format begin fun s -> + return (Value.of_ext val_format (Tac2print.FmtConstr :: s)) +end + +let () = define1 "format_ident" format begin fun s -> + return (Value.of_ext val_format (Tac2print.FmtIdent :: s)) +end + +let () = define2 "format_literal" string format begin fun lit s -> + return (Value.of_ext val_format (Tac2print.FmtLiteral (Bytes.to_string lit) :: s)) +end + +let () = define1 "format_alpha" format begin fun s -> + return (Value.of_ext val_format (Tac2print.FmtAlpha :: s)) +end + +let () = define2 "format_kfprintf" closure format begin fun k fmt -> + let open Tac2print in + let fold accu = function + | FmtLiteral _ -> accu + | FmtString | FmtInt | FmtConstr | FmtIdent -> 1 + accu + | FmtAlpha -> 2 + accu + in + let pop1 l = match l with [] -> assert false | x :: l -> (x, l) in + let pop2 l = match l with [] | [_] -> assert false | x :: y :: l -> (x, y, l) in + let arity = List.fold_left fold 0 fmt in + let rec eval accu args fmt = match fmt with + | [] -> apply k [of_pp accu] + | tag :: fmt -> + match tag with + | FmtLiteral s -> + eval (Pp.app accu (Pp.str s)) args fmt + | FmtString -> + let (s, args) = pop1 args in + let pp = Pp.str (Bytes.to_string (to_string s)) in + eval (Pp.app accu pp) args fmt + | FmtInt -> + let (i, args) = pop1 args in + let pp = Pp.int (to_int i) in + eval (Pp.app accu pp) args fmt + | FmtConstr -> + let (c, args) = pop1 args in + let c = to_constr c in + pf_apply begin fun env sigma -> + let pp = Printer.pr_econstr_env env sigma c in + eval (Pp.app accu pp) args fmt + end + | FmtIdent -> + let (i, args) = pop1 args in + let pp = Id.print (to_ident i) in + eval (Pp.app accu pp) args fmt + | FmtAlpha -> + let (f, x, args) = pop2 args in + Tac2ffi.apply (to_closure f) [of_unit (); x] >>= fun pp -> + eval (Pp.app accu (to_pp pp)) args fmt + in + let eval v = eval (Pp.mt ()) v fmt in + if Int.equal arity 0 then eval [] + else return (Tac2ffi.of_closure (Tac2ffi.abstract arity eval)) +end + (** Array *) let () = define0 "array_empty" begin @@ -999,6 +1075,54 @@ let () = define1 "env_instantiate" reference begin fun r -> return (Value.of_constr c) end +(** Ind *) + +let () = define2 "ind_equal" (repr_ext val_inductive) (repr_ext val_inductive) begin fun ind1 ind2 -> + return (Value.of_bool (Ind.UserOrd.equal ind1 ind2)) +end + +let () = define1 "ind_data" (repr_ext val_inductive) begin fun ind -> + Proofview.tclENV >>= fun env -> + if Environ.mem_mind (fst ind) env then + let mib = Environ.lookup_mind (fst ind) env in + return (Value.of_ext val_ind_data (ind, mib)) + else + throw err_notfound +end + +let () = define1 "ind_repr" (repr_ext val_ind_data) begin fun (ind, _) -> + return (Value.of_ext val_inductive ind) +end + +let () = define1 "ind_index" (repr_ext val_inductive) begin fun (ind, n) -> + return (Value.of_int n) +end + +let () = define1 "ind_nblocks" (repr_ext val_ind_data) begin fun (ind, mib) -> + return (Value.of_int (Array.length mib.Declarations.mind_packets)) +end + +let () = define1 "ind_nconstructors" (repr_ext val_ind_data) begin fun ((_, n), mib) -> + let open Declarations in + return (Value.of_int (Array.length mib.mind_packets.(n).mind_consnames)) +end + +let () = define2 "ind_get_block" (repr_ext val_ind_data) int begin fun (ind, mib) n -> + if 0 <= n && n < Array.length mib.Declarations.mind_packets then + return (Value.of_ext val_ind_data ((fst ind, n), mib)) + else throw err_notfound +end + +let () = define2 "ind_get_constructor" (repr_ext val_ind_data) int begin fun ((mind, n), mib) i -> + let open Declarations in + let ncons = Array.length mib.mind_packets.(n).mind_consnames in + if 0 <= i && i < ncons then + (* WARNING: In the ML API constructors are indexed from 1 for historical + reasons, but Ltac2 uses 0-indexing instead. *) + return (Value.of_ext val_constructor ((mind, n), i + 1)) + else throw err_notfound +end + (** Ltac1 in Ltac2 *) let ltac1 = Tac2ffi.repr_ext Value.val_ltac1 @@ -1312,24 +1436,35 @@ let () = (** Ltac2 in terms *) let () = - let interp ist poly env sigma concl (ids, tac) = + let interp ?loc ~poly env sigma tycon (ids, tac) = (* Syntax prevents bound notation variables in constr quotations *) let () = assert (Id.Set.is_empty ids) in - let ist = Tac2interp.get_env ist in + let ist = Tac2interp.get_env @@ GlobEnv.lfun env in let tac = Proofview.tclIGNORE (Tac2interp.interp ist tac) in let name, poly = Id.of_string "ltac2", poly in - let c, sigma = Proof.refine_by_tactic ~name ~poly env sigma concl tac in - (EConstr.of_constr c, sigma) + let sigma, concl = match tycon with + | Some ty -> sigma, ty + | None -> GlobEnv.new_type_evar env sigma ~src:(loc,Evar_kinds.InternalHole) + in + let c, sigma = Proof.refine_by_tactic ~name ~poly (GlobEnv.renamed_env env) sigma concl tac in + let j = { Environ.uj_val = EConstr.of_constr c; Environ.uj_type = concl } in + (j, sigma) in GlobEnv.register_constr_interp0 wit_ltac2_constr interp let () = - let interp ist poly env sigma concl id = - let ist = Tac2interp.get_env ist in + let interp ?loc ~poly env sigma tycon id = + let ist = Tac2interp.get_env @@ GlobEnv.lfun env in let c = Id.Map.find id ist.env_ist in let c = Value.to_constr c in - let sigma = Typing.check env sigma c concl in - (c, sigma) + let t = Retyping.get_type_of (GlobEnv.renamed_env env) sigma c in + match tycon with + | None -> + { Environ.uj_val = c; Environ.uj_type = t }, sigma + | Some ty -> + let sigma = Evarconv.unify_leq_delay (GlobEnv.renamed_env env) sigma t ty in + let j = { Environ.uj_val = c; Environ.uj_type = ty } in + j, sigma in GlobEnv.register_constr_interp0 wit_ltac2_quotation interp @@ -1629,6 +1764,7 @@ let () = add_expr_scope "pose" q_pose Tac2quote.of_pose let () = add_expr_scope "assert" q_assert Tac2quote.of_assertion let () = add_expr_scope "constr_matching" q_constr_matching Tac2quote.of_constr_matching let () = add_expr_scope "goal_matching" q_goal_matching Tac2quote.of_goal_matching +let () = add_expr_scope "format" Pcoq.Prim.lstring Tac2quote.of_format let () = add_generic_scope "open_constr" Pcoq.Constr.constr Tac2quote.wit_open_constr let () = add_generic_scope "pattern" Pcoq.Constr.constr Tac2quote.wit_pattern diff --git a/user-contrib/Ltac2/tac2entries.ml b/user-contrib/Ltac2/tac2entries.ml index d0655890a7..faa1e74728 100644 --- a/user-contrib/Ltac2/tac2entries.ml +++ b/user-contrib/Ltac2/tac2entries.ml @@ -816,7 +816,18 @@ let perform_eval ~pstate e = | Goal_select.SelectList l -> Proofview.tclFOCUSLIST l v | Goal_select.SelectId id -> Proofview.tclFOCUSID id v | Goal_select.SelectAll -> v - | Goal_select.SelectAlreadyFocused -> assert false (* TODO **) + | Goal_select.SelectAlreadyFocused -> + let open Proofview.Notations in + Proofview.numgoals >>= fun n -> + if Int.equal n 1 then v + else + let e = CErrors.UserError + (None, + Pp.(str "Expected a single focused goal but " ++ + int n ++ str " goals are focused.")) + in + let info = Exninfo.reify () in + Proofview.tclZERO ~info e in let (proof, _, ans) = Proof.run_tactic (Global.env ()) v proof in let { Proof.sigma } = Proof.data proof in diff --git a/user-contrib/Ltac2/tac2ffi.ml b/user-contrib/Ltac2/tac2ffi.ml index a09438c6bf..5f9fbc4e41 100644 --- a/user-contrib/Ltac2/tac2ffi.ml +++ b/user-contrib/Ltac2/tac2ffi.ml @@ -104,6 +104,7 @@ let val_binder = Val.create "binder" let val_univ = Val.create "universe" let val_free : Names.Id.Set.t Val.tag = Val.create "free" let val_ltac1 : Geninterp.Val.t Val.tag = Val.create "ltac1" +let val_ind_data : (Names.Ind.t * Declarations.mutual_inductive_body) Val.tag = Val.create "ind_data" let extract_val (type a) (type b) (tag : a Val.tag) (tag' : b Val.tag) (v : b) : a = match Val.eq tag tag' with diff --git a/user-contrib/Ltac2/tac2ffi.mli b/user-contrib/Ltac2/tac2ffi.mli index c9aa50389e..e87ad7139c 100644 --- a/user-contrib/Ltac2/tac2ffi.mli +++ b/user-contrib/Ltac2/tac2ffi.mli @@ -184,6 +184,7 @@ val val_binder : (Name.t Context.binder_annot * types) Val.tag val val_univ : Univ.Level.t Val.tag val val_free : Id.Set.t Val.tag val val_ltac1 : Geninterp.Val.t Val.tag +val val_ind_data : (Names.Ind.t * Declarations.mutual_inductive_body) Val.tag val val_exn : Exninfo.iexn Tac2dyn.Val.tag (** Toplevel representation of OCaml exceptions. Invariant: no [LtacError] diff --git a/user-contrib/Ltac2/tac2print.ml b/user-contrib/Ltac2/tac2print.ml index a54eb45f61..7a53b577b6 100644 --- a/user-contrib/Ltac2/tac2print.ml +++ b/user-contrib/Ltac2/tac2print.ml @@ -489,3 +489,51 @@ let () = | _ -> assert false in register_val_printer kn { val_printer } + +(** {5 Ltac2 primitive} *) + +type format = +| FmtString +| FmtInt +| FmtConstr +| FmtIdent +| FmtLiteral of string +| FmtAlpha + +let val_format = Tac2dyn.Val.create "format" + +exception InvalidFormat + +let parse_format (s : string) : format list = + let len = String.length s in + let buf = Buffer.create len in + let rec parse i accu = + if len <= i then accu + else match s.[i] with + | '%' -> parse_argument (i + 1) accu + | _ -> + let i' = parse_literal i in + if Int.equal i i' then parse i' accu + else + let lit = Buffer.contents buf in + let () = Buffer.clear buf in + parse i' (FmtLiteral lit :: accu) + and parse_literal i = + if len <= i then i + else match s.[i] with + | '%' -> i + | c -> + let () = Buffer.add_char buf c in + parse_literal (i + 1) + and parse_argument i accu = + if len <= i then raise InvalidFormat + else match s.[i] with + | '%' -> parse (i + 1) (FmtLiteral "%" :: accu) + | 's' -> parse (i + 1) (FmtString :: accu) + | 'i' -> parse (i + 1) (FmtInt :: accu) + | 'I' -> parse (i + 1) (FmtIdent :: accu) + | 't' -> parse (i + 1) (FmtConstr :: accu) + | 'a' -> parse (i + 1) (FmtAlpha :: accu) + | _ -> raise InvalidFormat + in + parse 0 [] diff --git a/user-contrib/Ltac2/tac2print.mli b/user-contrib/Ltac2/tac2print.mli index df5b03f82a..6bb4884666 100644 --- a/user-contrib/Ltac2/tac2print.mli +++ b/user-contrib/Ltac2/tac2print.mli @@ -46,3 +46,19 @@ val pr_valexpr : Environ.env -> Evd.evar_map -> valexpr -> 'a glb_typexpr -> Pp. val int_name : unit -> (int -> string) (** Create a function that give names to integers. The names are generated on the fly, in the order they are encountered. *) + +(** {5 Ltac2 primitives}*) + +type format = +| FmtString +| FmtInt +| FmtConstr +| FmtIdent +| FmtLiteral of string +| FmtAlpha + +val val_format : format list Tac2dyn.Val.tag + +exception InvalidFormat + +val parse_format : string -> format list diff --git a/user-contrib/Ltac2/tac2quote.ml b/user-contrib/Ltac2/tac2quote.ml index 90f8008dc2..d1a72fcfd1 100644 --- a/user-contrib/Ltac2/tac2quote.ml +++ b/user-contrib/Ltac2/tac2quote.ml @@ -35,6 +35,7 @@ let prefix_gen n = let control_prefix = prefix_gen "Control" let pattern_prefix = prefix_gen "Pattern" let array_prefix = prefix_gen "Array" +let format_prefix = MPdot (prefix_gen "Message", Label.make "Format") let kername prefix n = KerName.make prefix (Label.of_id (Id.of_string_soft n)) let std_core n = kername Tac2env.std_prefix n @@ -75,6 +76,9 @@ let of_tuple ?loc el = match el with let len = List.length el in CAst.make ?loc @@ CTacApp (CAst.make ?loc @@ CTacCst (AbsKn (Tuple len)), el) +let of_string {loc;v=n} = + CAst.make ?loc @@ CTacAtm (AtmStr n) + let of_int {loc;v=n} = CAst.make ?loc @@ CTacAtm (AtmInt n) @@ -489,3 +493,27 @@ let of_assertion {loc;v=ast} = match ast with let id = of_anti of_ident id in let c = of_constr c in std_constructor ?loc "AssertValue" [id; c] + +let of_format accu = function +| Tac2print.FmtString -> + CAst.make @@ CTacApp (global_ref (kername format_prefix "string"), [accu]) +| Tac2print.FmtInt -> + CAst.make @@ CTacApp (global_ref (kername format_prefix "int"), [accu]) +| Tac2print.FmtConstr -> + CAst.make @@ CTacApp (global_ref (kername format_prefix "constr"), [accu]) +| Tac2print.FmtIdent -> + CAst.make @@ CTacApp (global_ref (kername format_prefix "ident"), [accu]) +| Tac2print.FmtLiteral lit -> + let s = of_string (CAst.make lit) in + CAst.make @@ CTacApp (global_ref (kername format_prefix "literal"), [s; accu]) +| Tac2print.FmtAlpha -> + CAst.make @@ CTacApp (global_ref (kername format_prefix "alpha"), [accu]) + +let of_format { v = fmt; loc } = + let fmt = + try Tac2print.parse_format fmt + with Tac2print.InvalidFormat -> + CErrors.user_err ?loc (str "Invalid format") + in + let stop = CAst.make @@ CTacApp (global_ref (kername format_prefix "stop"), [of_tuple []]) in + List.fold_left of_format stop fmt diff --git a/user-contrib/Ltac2/tac2quote.mli b/user-contrib/Ltac2/tac2quote.mli index f9c41b57dc..fcd1339cd7 100644 --- a/user-contrib/Ltac2/tac2quote.mli +++ b/user-contrib/Ltac2/tac2quote.mli @@ -85,6 +85,8 @@ val of_constr_matching : constr_matching -> raw_tacexpr val of_goal_matching : goal_matching -> raw_tacexpr +val of_format : lstring -> raw_tacexpr + (** {5 Generic arguments} *) val wit_pattern : (Constrexpr.constr_expr, Pattern.constr_pattern) Arg.tag diff --git a/vernac/auto_ind_decl.ml b/vernac/auto_ind_decl.ml index cc59a96834..f600432c80 100644 --- a/vernac/auto_ind_decl.ml +++ b/vernac/auto_ind_decl.ml @@ -193,48 +193,48 @@ let build_beq_scheme mode kn = let create_input c = let myArrow u v = mkArrow u Sorts.Relevant (lift 1 v) and eqName = function - | Name s -> Id.of_string ("eq_"^(Id.to_string s)) - | Anonymous -> Id.of_string "eq_A" + | Name s -> Id.of_string ("eq_"^(Id.to_string s)) + | Anonymous -> Id.of_string "eq_A" in let ext_rel_list = Context.Rel.to_extended_list mkRel 0 lnamesparrec in - let lift_cnt = ref 0 in - let eqs_typ = List.map (fun aa -> - let a = lift !lift_cnt aa in - incr lift_cnt; - myArrow a (myArrow a (bb ())) - ) ext_rel_list in - - let eq_input = List.fold_left2 - ( fun a b decl -> (* mkLambda(n,b,a) ) *) - (* here I leave the Naming thingy so that the type of + let lift_cnt = ref 0 in + let eqs_typ = List.map (fun aa -> + let a = lift !lift_cnt aa in + incr lift_cnt; + myArrow a (myArrow a (bb ())) + ) ext_rel_list in + + let eq_input = List.fold_left2 + ( fun a b decl -> (* mkLambda(n,b,a) ) *) + (* here I leave the Naming thingy so that the type of the function is more readable for the user *) - mkNamedLambda (map_annot eqName (RelDecl.get_annot decl)) b a ) - c (List.rev eqs_typ) lnamesparrec - in - List.fold_left (fun a decl ->(* mkLambda(n,t,a)) eq_input rel_list *) - (* Same here , hoping the auto renaming will do something good ;) *) - let x = map_annot - (function Name s -> s | Anonymous -> Id.of_string "A") - (RelDecl.get_annot decl) - in - mkNamedLambda x (RelDecl.get_type decl) a) eq_input lnamesparrec - in - let make_one_eq cur = - let u = Univ.Instance.empty in - let ind = (kn,cur),u (* FIXME *) in - (* current inductive we are working on *) - let cur_packet = mib.mind_packets.(snd (fst ind)) in - (* Inductive toto : [rettyp] := *) - let rettyp = Inductive.type_of_inductive ((mib,cur_packet),u) in - (* split rettyp in a list without the non rec params and the last -> + mkNamedLambda (map_annot eqName (RelDecl.get_annot decl)) b a ) + c (List.rev eqs_typ) lnamesparrec + in + List.fold_left (fun a decl ->(* mkLambda(n,t,a)) eq_input rel_list *) + (* Same here , hoping the auto renaming will do something good ;) *) + let x = map_annot + (function Name s -> s | Anonymous -> Id.of_string "A") + (RelDecl.get_annot decl) + in + mkNamedLambda x (RelDecl.get_type decl) a) eq_input lnamesparrec + in + let make_one_eq cur = + let u = Univ.Instance.empty in + let ind = (kn,cur),u (* FIXME *) in + (* current inductive we are working on *) + let cur_packet = mib.mind_packets.(snd (fst ind)) in + (* Inductive toto : [rettyp] := *) + let rettyp = Inductive.type_of_inductive ((mib,cur_packet),u) in + (* split rettyp in a list without the non rec params and the last -> e.g. Inductive vec (A:Set) : nat -> Set := ... will do [nat] *) - let rettyp_l = quick_chop nparrec (deconstruct_type rettyp) in + let rettyp_l = quick_chop nparrec (deconstruct_type rettyp) in (* give a type A, this function tries to find the equality on A declared previously *) (* nlist = the number of args (A , B , ... ) eqA = the de Bruijn index of the first eq param ndx = how much to translate due to the 2nd Case - *) + *) let compute_A_equality rel_list nlist eqA ndx t = let lifti = ndx in let rec aux c = @@ -243,47 +243,47 @@ let build_beq_scheme mode kn = match Constr.kind c with | Rel x -> mkRel (x-nlist+ndx) | Var x -> - (* Support for working in a context with "eq_x : x -> x -> bool" *) - let eid = Id.of_string ("eq_"^(Id.to_string x)) in - let () = - try ignore (Environ.lookup_named eid env) - with Not_found -> raise (ParameterWithoutEquality (GlobRef.VarRef x)) - in - mkVar eid + (* Support for working in a context with "eq_x : x -> x -> bool" *) + let eid = Id.of_string ("eq_"^(Id.to_string x)) in + let () = + try ignore (Environ.lookup_named eid env) + with Not_found -> raise (ParameterWithoutEquality (GlobRef.VarRef x)) + in + mkVar eid | Cast (x,_,_) -> aux (Term.applist (x,a)) | App _ -> assert false | Ind ((kn',i as ind'),u) (*FIXME: universes *) -> - if Environ.QMutInd.equal env kn kn' then mkRel(eqA-nlist-i+nb_ind-1) - else begin - try - let eq = match lookup_scheme (!beq_scheme_kind_aux()) ind' with - | Some c -> mkConst c - | None -> assert false - in - let eqa = Array.of_list @@ List.map aux a in - let args = - Array.append - (Array.of_list (List.map (fun x -> lift lifti x) a)) eqa in - if Int.equal (Array.length args) 0 then eq - else mkApp (eq, args) - with Not_found -> raise(EqNotFound (ind', fst ind)) - end + if Environ.QMutInd.equal env kn kn' then mkRel(eqA-nlist-i+nb_ind-1) + else begin + try + let eq = match lookup_scheme (!beq_scheme_kind_aux()) ind' with + | Some c -> mkConst c + | None -> assert false + in + let eqa = Array.of_list @@ List.map aux a in + let args = + Array.append + (Array.of_list (List.map (fun x -> lift lifti x) a)) eqa in + if Int.equal (Array.length args) 0 then eq + else mkApp (eq, args) + with Not_found -> raise(EqNotFound (ind', fst ind)) + end | Sort _ -> raise InductiveWithSort | Prod _ -> raise InductiveWithProduct | Lambda _-> raise (EqUnknown "abstraction") | LetIn _ -> raise (EqUnknown "let-in") | Const (kn, u) -> - (match Environ.constant_opt_value_in env (kn, u) with - | Some c -> aux (Term.applist (c,a)) - | None -> - (* Support for working in a context with "eq_x : x -> x -> bool" *) - (* Needs Hints, see test suite *) - let eq_lbl = Label.make ("eq_" ^ Label.to_string (Constant.label kn)) in - let kneq = Constant.change_label kn eq_lbl in - if Environ.mem_constant kneq env then - let _ = Environ.constant_opt_value_in env (kneq, u) in - Term.applist (mkConst kneq,a) - else raise (ParameterWithoutEquality (GlobRef.ConstRef kn))) + (match Environ.constant_opt_value_in env (kn, u) with + | Some c -> aux (Term.applist (c,a)) + | None -> + (* Support for working in a context with "eq_x : x -> x -> bool" *) + (* Needs Hints, see test suite *) + let eq_lbl = Label.make ("eq_" ^ Label.to_string (Constant.label kn)) in + let kneq = Constant.change_label kn eq_lbl in + if Environ.mem_constant kneq env then + let _ = Environ.constant_opt_value_in env (kneq, u) in + Term.applist (mkConst kneq,a) + else raise (ParameterWithoutEquality (GlobRef.ConstRef kn))) | Proj _ -> raise (EqUnknown "projection") | Construct _ -> raise (EqUnknown "constructor") | Case _ -> raise (EqUnknown "match") @@ -293,100 +293,112 @@ let build_beq_scheme mode kn = | Evar _ -> raise (EqUnknown "existential variable") | Int _ -> raise (EqUnknown "int") | Float _ -> raise (EqUnknown "float") - | Array _ -> raise (EqUnknown "array") - in + | Array _ -> raise (EqUnknown "array") + in aux t - in - (* construct the predicate for the Case part*) - let do_predicate rel_list n = - List.fold_left (fun a b -> mkLambda(make_annot Anonymous Sorts.Relevant,b,a)) - (mkLambda (make_annot Anonymous Sorts.Relevant, - mkFullInd ind (n+3+(List.length rettyp_l)+nb_ind-1), - (bb ()))) - (List.rev rettyp_l) in - (* make_one_eq *) - (* do the [| C1 ... => match Y with ... end + in + (* construct the predicate for the Case part*) + let do_predicate rel_list n = + List.fold_left (fun a b -> mkLambda(make_annot Anonymous Sorts.Relevant,b,a)) + (mkLambda (make_annot Anonymous Sorts.Relevant, + mkFullInd ind (n+3+(List.length rettyp_l)+nb_ind-1), + (bb ()))) + (List.rev rettyp_l) in + (* make_one_eq *) + (* do the [| C1 ... => match Y with ... end ... Cn => match Y with ... end |] part *) let rci = Sorts.Relevant in (* TODO relevance *) let ci = make_case_info env (fst ind) rci MatchStyle in - let constrs n = get_constructors env (make_ind_family (ind, - Context.Rel.to_extended_list mkRel (n+nb_ind-1) mib.mind_params_ctxt)) in + let constrs n = + let params = Context.Rel.to_extended_list mkRel (n+nb_ind-1) mib.mind_params_ctxt in + get_constructors env (make_ind_family (ind, params)) + in let constrsi = constrs (3+nparrec) in let n = Array.length constrsi in - let ar = Array.make n (ff ()) in - for i=0 to n-1 do - let nb_cstr_args = List.length constrsi.(i).cs_args in - let ar2 = Array.make n (ff ()) in - let constrsj = constrs (3+nparrec+nb_cstr_args) in - for j=0 to n-1 do - if Int.equal i j then - ar2.(j) <- let cc = (match nb_cstr_args with - | 0 -> tt () - | _ -> let eqs = Array.make nb_cstr_args (tt ()) in - for ndx = 0 to nb_cstr_args-1 do - let cc = RelDecl.get_type (List.nth constrsi.(i).cs_args ndx) in - let eqA = compute_A_equality rel_list - nparrec - (nparrec+3+2*nb_cstr_args) - (nb_cstr_args+ndx+1) - cc - in - Array.set eqs ndx - (mkApp (eqA, - [|mkRel (ndx+1+nb_cstr_args);mkRel (ndx+1)|] - )) - done; - Array.fold_left - (fun a b -> mkApp (andb(),[|b;a|])) - (eqs.(0)) - (Array.sub eqs 1 (nb_cstr_args - 1)) - ) - in - (List.fold_left (fun a decl -> mkLambda (RelDecl.get_annot decl, RelDecl.get_type decl, a)) cc - (constrsj.(j).cs_args) - ) - else ar2.(j) <- (List.fold_left (fun a decl -> - mkLambda (RelDecl.get_annot decl, RelDecl.get_type decl, a)) (ff ()) (constrsj.(j).cs_args) ) - done; - - ar.(i) <- (List.fold_left (fun a decl -> mkLambda (RelDecl.get_annot decl, RelDecl.get_type decl, a)) - (mkCase (Inductive.contract_case env ((ci,do_predicate rel_list nb_cstr_args, - NoInvert, mkVar (Id.of_string "Y") ,ar2)))) - (constrsi.(i).cs_args)) - done; - mkNamedLambda (make_annot (Id.of_string "X") Sorts.Relevant) (mkFullInd ind (nb_ind-1+1)) ( - mkNamedLambda (make_annot (Id.of_string "Y") Sorts.Relevant) (mkFullInd ind (nb_ind-1+2)) ( - mkCase (Inductive.contract_case env (ci, do_predicate rel_list 0,NoInvert,mkVar (Id.of_string "X"),ar)))) - in (* build_beq_scheme *) - let names = Array.make nb_ind (make_annot Anonymous Sorts.Relevant) and - types = Array.make nb_ind mkSet and - cores = Array.make nb_ind mkSet in - let u = Univ.Instance.empty in - for i=0 to (nb_ind-1) do - names.(i) <- make_annot (Name (Id.of_string (rec_name i))) Sorts.Relevant; - types.(i) <- mkArrow (mkFullInd ((kn,i),u) 0) Sorts.Relevant - (mkArrow (mkFullInd ((kn,i),u) 1) Sorts.Relevant (bb ())); - let c = make_one_eq i in - cores.(i) <- c; - done; - (Array.init nb_ind (fun i -> - let kelim = Inductive.elim_sort (mib,mib.mind_packets.(i)) in - if not (Sorts.family_leq InSet kelim) then - raise (NonSingletonProp (kn,i)); - let fix = match mib.mind_finite with - | CoFinite -> - raise NoDecidabilityCoInductive; - | Finite -> - mkFix (((Array.make nb_ind 0),i),(names,types,cores)) - | BiFinite -> - (* If the inductive type is not recursive, the fixpoint is + let ar = Array.init n (fun i -> + let nb_cstr_args = List.length constrsi.(i).cs_args in + let constrsj = constrs (3+nparrec+nb_cstr_args) in + let ar2 = Array.init n (fun j -> + if Int.equal i j then + let cc = match nb_cstr_args with + | 0 -> tt () + | _ -> + let eqs = Array.init nb_cstr_args (fun ndx -> + let cc = RelDecl.get_type (List.nth constrsi.(i).cs_args ndx) in + let eqA = compute_A_equality rel_list + nparrec + (nparrec+3+2*nb_cstr_args) + (nb_cstr_args+ndx+1) + cc + in + mkApp (eqA, [|mkRel (ndx+1+nb_cstr_args);mkRel (ndx+1)|])) + in + Array.fold_left + (fun a b -> mkApp (andb(),[|b;a|])) + eqs.(0) + (Array.sub eqs 1 (nb_cstr_args - 1)) + in + List.fold_left (fun a decl -> + mkLambda (RelDecl.get_annot decl, RelDecl.get_type decl, a)) + cc + constrsj.(j).cs_args + else + List.fold_left (fun a decl -> + mkLambda (RelDecl.get_annot decl, RelDecl.get_type decl, a)) + (ff ()) + (constrsj.(j).cs_args)) + in + let pred = EConstr.of_constr (do_predicate rel_list nb_cstr_args) in + let case = + simple_make_case_or_project env (Evd.from_env env) + ci pred NoInvert (EConstr.mkVar (Id.of_string "Y")) + (EConstr.of_constr_array ar2) + in + List.fold_left (fun a decl -> mkLambda (RelDecl.get_annot decl, RelDecl.get_type decl, a)) + (EConstr.Unsafe.to_constr case) + (constrsi.(i).cs_args)) + in + let pred = EConstr.of_constr (do_predicate rel_list 0) in + let case = + simple_make_case_or_project env (Evd.from_env env) + ci pred NoInvert (EConstr.mkVar (Id.of_string "X")) + (EConstr.of_constr_array ar) + in + mkNamedLambda (make_annot (Id.of_string "X") Sorts.Relevant) (mkFullInd ind (nb_ind-1+1)) ( + mkNamedLambda (make_annot (Id.of_string "Y") Sorts.Relevant) (mkFullInd ind (nb_ind-1+2)) ( + (EConstr.Unsafe.to_constr case))) + in (* build_beq_scheme *) + + let names = Array.make nb_ind (make_annot Anonymous Sorts.Relevant) and + types = Array.make nb_ind mkSet and + cores = Array.make nb_ind mkSet in + let u = Univ.Instance.empty in + for i=0 to (nb_ind-1) do + names.(i) <- make_annot (Name (Id.of_string (rec_name i))) Sorts.Relevant; + types.(i) <- mkArrow (mkFullInd ((kn,i),u) 0) Sorts.Relevant + (mkArrow (mkFullInd ((kn,i),u) 1) Sorts.Relevant (bb ())); + let c = make_one_eq i in + cores.(i) <- c; + done; + let res = Array.init nb_ind (fun i -> + let kelim = Inductive.elim_sort (mib,mib.mind_packets.(i)) in + if not (Sorts.family_leq InSet kelim) then + raise (NonSingletonProp (kn,i)); + let fix = match mib.mind_finite with + | CoFinite -> + raise NoDecidabilityCoInductive; + | Finite -> + mkFix (((Array.make nb_ind 0),i),(names,types,cores)) + | BiFinite -> + (* If the inductive type is not recursive, the fixpoint is not used, so let's replace it with garbage *) - let subst = List.init nb_ind (fun _ -> mkProp) in - Vars.substl subst cores.(i) - in - create_input fix), - UState.from_env (Global.env ())) + let subst = List.init nb_ind (fun _ -> mkProp) in + Vars.substl subst cores.(i) + in + create_input fix) + in + res, UState.from_env (Global.env ()) let beq_scheme_kind = declare_mutual_scheme_object "_beq" diff --git a/vernac/comCoercion.ml b/vernac/comCoercion.ml index 15d8ebc4b5..86b15739f9 100644 --- a/vernac/comCoercion.ml +++ b/vernac/comCoercion.ml @@ -237,24 +237,24 @@ let open_coercion i o = cache_coercion o let discharge_coercion (_, c) = - if c.coercion_local then None + if c.coe_local then None else let n = try - let ins = Lib.section_instance c.coercion_type in + let ins = Lib.section_instance c.coe_value in Array.length (snd ins) with Not_found -> 0 in let nc = { c with - coercion_params = n + c.coercion_params; - coercion_is_proj = Option.map Lib.discharge_proj_repr c.coercion_is_proj; + coe_param = n + c.coe_param; + coe_is_projection = Option.map Lib.discharge_proj_repr c.coe_is_projection; } in Some nc let classify_coercion obj = - if obj.coercion_local then Dispose else Substitute obj + if obj.coe_local then Dispose else Substitute obj -let inCoercion : coercion -> obj = +let inCoercion : coe_info_typ -> obj = declare_object {(default_object "COERCION") with open_function = simple_open open_coercion; cache_function = cache_coercion; @@ -269,13 +269,13 @@ let declare_coercion coef ?(local = false) ~isid ~src:cls ~target:clt ~params:ps | _ -> None in let c = { - coercion_type = coef; - coercion_local = local; - coercion_is_id = isid; - coercion_is_proj = isproj; - coercion_source = cls; - coercion_target = clt; - coercion_params = ps; + coe_value = coef; + coe_local = local; + coe_is_identity = isid; + coe_is_projection = isproj; + coe_source = cls; + coe_target = clt; + coe_param = ps; } in Lib.add_anonymous_leaf (inCoercion c) diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index b3ffb864f2..2e48313630 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -111,6 +111,10 @@ let interp_definition ~program_mode env evd impl_env bl red_option c ctypopt = let tyopt = Option.map (fun ty -> EConstr.it_mkProd_or_LetIn ty ctx) tyopt in evd, (c, tyopt), imps +let definition_using env evd ~body ~types ~using = + let terms = Option.List.cons types [body] in + Option.map (fun using -> Proof_using.definition_using env evd ~using ~terms) using + let do_definition ?hook ~name ~scope ~poly ?typing_flags ~kind ?using udecl bl red_option c ctypopt = let program_mode = false in let env = Global.env() in @@ -120,11 +124,7 @@ let do_definition ?hook ~name ~scope ~poly ?typing_flags ~kind ?using udecl bl r let evd, (body, types), impargs = interp_definition ~program_mode env evd empty_internalization_env bl red_option c ctypopt in - let using = using |> Option.map (fun expr -> - let terms = body :: match types with Some x -> [x] | None -> [] in - let l = Proof_using.process_expr (Global.env()) evd expr terms in - Names.Id.Set.(List.fold_right add l empty)) - in + let using = definition_using env evd ~body ~types ~using in let kind = Decls.IsDefinition kind in let cinfo = Declare.CInfo.make ~name ~impargs ~typ:types ?using () in let info = Declare.Info.make ~scope ~kind ?hook ~udecl ~poly ?typing_flags () in @@ -141,11 +141,7 @@ let do_definition_program ?hook ~pm ~name ~scope ~poly ?typing_flags ~kind ?usin let evd, (body, types), impargs = interp_definition ~program_mode env evd empty_internalization_env bl red_option c ctypopt in - let using = using |> Option.map (fun expr -> - let terms = body :: match types with Some x -> [x] | None -> [] in - let l = Proof_using.process_expr (Global.env()) evd expr terms in - Names.Id.Set.(List.fold_right add l empty)) - in + let using = definition_using env evd ~body ~types ~using in let term, typ, uctx, obls = Declare.Obls.prepare_obligation ~name ~body ~types evd in let pm, _ = let cinfo = Declare.CInfo.make ~name ~typ ~impargs ?using () in diff --git a/vernac/comFixpoint.ml b/vernac/comFixpoint.ml index 0cf0b07822..0f817ffbd1 100644 --- a/vernac/comFixpoint.ml +++ b/vernac/comFixpoint.ml @@ -259,13 +259,10 @@ let build_recthms ~indexes ?using fixnames fixtypes fiximps = in let thms = List.map3 (fun name typ (ctx,impargs,_) -> - let using = using |> Option.map (fun expr -> - let terms = [EConstr.of_constr typ] in - let env = Global.env() in - let sigma = Evd.from_env env in - let l = Proof_using.process_expr env sigma expr terms in - Names.Id.Set.(List.fold_right add l empty)) - in + let env = Global.env() in + let evd = Evd.from_env env in + let terms = [EConstr.of_constr typ] in + let using = Option.map (fun using -> Proof_using.definition_using env evd ~using ~terms) using in let args = List.map Context.Rel.Declaration.get_name ctx in Declare.CInfo.make ~name ~typ ~args ~impargs ?using () ) fixnames fixtypes fiximps diff --git a/vernac/comProgramFixpoint.ml b/vernac/comProgramFixpoint.ml index 3c4a651cf5..0651f3330e 100644 --- a/vernac/comProgramFixpoint.ml +++ b/vernac/comProgramFixpoint.ml @@ -259,10 +259,9 @@ let build_wellfounded pm (recname,pl,bl,arityc,body) poly ?typing_flags ?using r let evars, _, evars_def, evars_typ = RetrieveObl.retrieve_obligations env recname sigma 0 def typ in - let using = using |> Option.map (fun expr -> + let using = let terms = List.map EConstr.of_constr [evars_def; evars_typ] in - let l = Proof_using.process_expr env sigma expr terms in - Names.Id.Set.(List.fold_right add l empty)) + Option.map (fun using -> Proof_using.definition_using env sigma ~using ~terms) using in let uctx = Evd.evar_universe_context sigma in let cinfo = Declare.CInfo.make ~name:recname ~typ:evars_typ ?using () in @@ -294,11 +293,8 @@ let do_program_recursive ~pm ~scope ~poly ?typing_flags ?using fixkind fixl = let evd = nf_evar_map_undefined evd in let collect_evars name def typ impargs = (* Generalize by the recursive prototypes *) - let using = using |> Option.map (fun expr -> - let terms = [def; typ] in - let l = Proof_using.process_expr env evd expr terms in - Names.Id.Set.(List.fold_right add l empty)) - in + let terms = [def; typ] in + let using = Option.map (fun using -> Proof_using.definition_using env evd ~using ~terms) using in let def = nf_evar evd (Termops.it_mkNamedLambda_or_LetIn def rec_sign) in let typ = nf_evar evd (Termops.it_mkNamedProd_or_LetIn typ rec_sign) in let evm = collect_evars_of_term evd def typ in diff --git a/vernac/declare.ml b/vernac/declare.ml index 48aa329e5e..607ba18a95 100644 --- a/vernac/declare.ml +++ b/vernac/declare.ml @@ -57,7 +57,7 @@ module CInfo = struct (** Names to pre-introduce *) ; impargs : Impargs.manual_implicits (** Explicitily declared implicit arguments *) - ; using : Names.Id.Set.t option + ; using : Proof_using.t option (** Explicit declaration of section variables used by the constant *) } @@ -1478,11 +1478,10 @@ let start_mutual_with_initialization ~info ~cinfo ~mutual_info sigma snl = let get_used_variables pf = pf.using let get_universe_decl pf = pf.pinfo.Proof_info.info.Info.udecl -let set_used_variables ps l = +let set_used_variables ps ~using = let open Context.Named.Declaration in let env = Global.env () in - let ids = List.fold_right Id.Set.add l Id.Set.empty in - let ctx = Environ.keep_hyps env ids in + let ctx = Environ.keep_hyps env using in let ctx_set = List.fold_right Id.Set.add (List.map NamedDecl.get_id ctx) Id.Set.empty in let vars_of = Environ.global_vars_set in diff --git a/vernac/declare.mli b/vernac/declare.mli index 37a61cc4f0..81558e6f6b 100644 --- a/vernac/declare.mli +++ b/vernac/declare.mli @@ -79,7 +79,7 @@ module CInfo : sig -> typ:'constr -> ?args:Name.t list -> ?impargs:Impargs.manual_implicits - -> ?using:Names.Id.Set.t + -> ?using:Proof_using.t -> unit -> 'constr t @@ -244,7 +244,7 @@ module Proof : sig (** Sets the section variables assumed by the proof, returns its closure * (w.r.t. type dependencies and let-ins covered by it) *) - val set_used_variables : t -> Names.Id.t list -> Constr.named_context * t + val set_used_variables : t -> using:Proof_using.t -> Constr.named_context * t (** Gets the set of variables declared to be used by the proof. None means no "Proof using" or #[using] was given *) diff --git a/vernac/declaremods.ml b/vernac/declaremods.ml index d2eeebc246..15e6d4ef37 100644 --- a/vernac/declaremods.ml +++ b/vernac/declaremods.ml @@ -301,7 +301,10 @@ and load_keep i ((sp,kn),kobjs) = let mark_object f obj (exports,acc) = (exports, (f,obj)::acc) -let rec collect_module_objects (f,mp) acc = +let rec collect_modules mpl acc = + List.fold_left (fun acc fmp -> collect_module fmp acc) acc (List.rev mpl) + +and collect_module (f,mp) acc = (* May raise Not_found for unknown module and for functors *) let modobjs = ModObjs.get mp in let prefix = modobjs.module_prefix in @@ -310,14 +313,16 @@ let rec collect_module_objects (f,mp) acc = and collect_object f i (name, obj as o) acc = match obj with - | ExportObject { mpl } -> collect_export f i mpl acc + | ExportObject { mpl } -> collect_exports f i mpl acc | AtomicObject _ | IncludeObject _ | KeepObject _ | ModuleObject _ | ModuleTypeObject _ -> mark_object f o acc and collect_objects f i prefix objs acc = - List.fold_right (fun (id, obj) acc -> collect_object f i (Lib.make_oname prefix id, obj) acc) objs acc + List.fold_left (fun acc (id, obj) -> + collect_object f i (Lib.make_oname prefix id, obj) acc + ) acc (List.rev objs) -and collect_one_export f (f',mp) (exports,objs as acc) = +and collect_export f (f',mp) (exports,objs as acc) = match filter_and f f' with | None -> acc | Some f -> @@ -334,12 +339,12 @@ and collect_one_export f (f',mp) (exports,objs as acc) = *) if exports == exports' then acc else - collect_module_objects (f,mp) (exports', objs) + collect_module (f,mp) (exports', objs) -and collect_export f i mpl acc = +and collect_exports f i mpl acc = if Int.equal i 1 then - List.fold_right (collect_one_export f) mpl acc + List.fold_left (fun acc fmp -> collect_export f fmp acc) acc (List.rev mpl) else acc let open_modtype i ((sp,kn),_) = @@ -388,7 +393,7 @@ and open_include f i ((sp,kn), aobjs) = open_objects f i prefix o and open_export f i mpl = - let _,objs = collect_export f i mpl (MPmap.empty, []) in + let _,objs = collect_exports f i mpl (MPmap.empty, []) in List.iter (fun (f,o) -> open_object f 1 o) objs and open_keep f i ((sp,kn),kobjs) = @@ -1056,7 +1061,7 @@ let end_library ?except ~output_native_objects dir = cenv,(substitute,keep),ast let import_modules ~export mpl = - let _,objs = List.fold_right collect_module_objects mpl (MPmap.empty, []) in + let _,objs = collect_modules mpl (MPmap.empty, []) in List.iter (fun (f,o) -> open_object f 1 o) objs; if export then Lib.add_anonymous_entry (Lib.Leaf (ExportObject { mpl })) diff --git a/vernac/dune b/vernac/dune index ba361b1377..7319b1353c 100644 --- a/vernac/dune +++ b/vernac/dune @@ -1,7 +1,7 @@ (library (name vernac) (synopsis "Coq's Vernacular Language") - (public_name coq.vernac) + (public_name coq-core.vernac) (wrapped false) (libraries tactics parsing)) diff --git a/vernac/library.ml b/vernac/library.ml index 8a9b1fd68d..cc9e3c3c44 100644 --- a/vernac/library.ml +++ b/vernac/library.ml @@ -155,17 +155,13 @@ let library_is_loaded dir = let register_loaded_library m = let libname = m.libsum_name in - let link () = - let dirname = Filename.dirname (library_full_filename libname) in - let prefix = Nativecode.mod_uid_of_dirpath libname ^ "." in - let f = prefix ^ "cmo" in - let f = Dynlink.adapt_filename f in - Nativelib.link_library ~prefix ~dirname ~basename:f - in let rec aux = function | [] -> - let () = if Flags.get_native_compiler () then link () in - [libname] + if Flags.get_native_compiler () then begin + let dirname = Filename.dirname (library_full_filename libname) in + Nativelib.enable_library dirname libname + end; + [libname] | m'::_ as l when DirPath.equal m' libname -> l | m'::l' -> m' :: aux l' in libraries_loaded_list := aux !libraries_loaded_list; diff --git a/vernac/prettyp.ml b/vernac/prettyp.ml index 79a0cdf8d1..ec6e3b44ba 100644 --- a/vernac/prettyp.ml +++ b/vernac/prettyp.ml @@ -976,15 +976,11 @@ open Coercionops let print_coercion_value v = Printer.pr_global v.coe_value -let print_class i = - let cl,_ = class_info_from_index i in - pr_class cl - let print_path ((i,j),p) = hov 2 ( str"[" ++ hov 0 (prlist_with_sep pr_semicolon print_coercion_value p) ++ str"] : ") ++ - print_class i ++ str" >-> " ++ print_class j + pr_class i ++ str" >-> " ++ pr_class j let _ = Coercionops.install_path_printer print_path @@ -997,25 +993,16 @@ let print_classes () = let print_coercions () = pr_sequence print_coercion_value (coercions()) -let index_of_class cl = - try - fst (class_info cl) - with Not_found -> - user_err ~hdr:"index_of_class" - (pr_class cl ++ spc() ++ str "not a defined class.") - let print_path_between cls clt = - let i = index_of_class cls in - let j = index_of_class clt in let p = try - lookup_path_between_class (i,j) + lookup_path_between_class (cls, clt) with Not_found -> user_err ~hdr:"index_cl_of_id" (str"No path between " ++ pr_class cls ++ str" and " ++ pr_class clt ++ str ".") in - print_path ((i,j),p) + print_path ((cls, clt), p) let print_canonical_projections env sigma grefs = let match_proj_gref ((x,y),c) gr = diff --git a/vernac/proof_using.ml b/vernac/proof_using.ml index bdb0cabacf..01e7b7cc3d 100644 --- a/vernac/proof_using.ml +++ b/vernac/proof_using.ml @@ -64,6 +64,12 @@ let process_expr env sigma e ty = let s = Id.Set.union v_ty (process_expr env sigma e v_ty) in Id.Set.elements s +type t = Names.Id.Set.t + +let definition_using env evd ~using ~terms = + let l = process_expr env evd using terms in + Names.Id.Set.(List.fold_right add l empty) + let name_set id expr = known_names := (id,expr) :: !known_names let minimize_hyps env ids = @@ -91,13 +97,14 @@ let remove_ids_and_lets env s ids = let record_proof_using expr = Aux_file.record_in_aux "suggest_proof_using" expr +let debug_proof_using = CDebug.create ~name:"proof-using" () + (* Variables in [skip] come from after the definition, so don't count for "All". Used in the variable case since the env contains the variable itself. *) let suggest_common env ppid used ids_typ skip = let module S = Id.Set in let open Pp in - let print x = Feedback.msg_debug x in let pr_set parens s = let wrap ppcmds = if parens && S.cardinal s > 1 then str "(" ++ ppcmds ++ str ")" @@ -111,13 +118,13 @@ let suggest_common env ppid used ids_typ skip = in let all = S.diff all skip in let fwd_typ = close_fwd env (Evd.from_env env) ids_typ in - if !Flags.debug then begin - print (str "All " ++ pr_set false all); - print (str "Type " ++ pr_set false ids_typ); - print (str "needed " ++ pr_set false needed); - print (str "all_needed " ++ pr_set false all_needed); - print (str "Type* " ++ pr_set false fwd_typ); - end; + let () = debug_proof_using (fun () -> + str "All " ++ pr_set false all ++ fnl() ++ + str "Type " ++ pr_set false ids_typ ++ fnl() ++ + str "needed " ++ pr_set false needed ++ fnl() ++ + str "all_needed " ++ pr_set false all_needed ++ fnl() ++ + str "Type* " ++ pr_set false fwd_typ) + in let valid_exprs = ref [] in let valid e = valid_exprs := e :: !valid_exprs in if S.is_empty needed then valid (str "Type"); diff --git a/vernac/proof_using.mli b/vernac/proof_using.mli index 93dbd33ae4..60db4d60e6 100644 --- a/vernac/proof_using.mli +++ b/vernac/proof_using.mli @@ -10,10 +10,17 @@ (** Utility code for section variables handling in Proof using... *) -val process_expr : - Environ.env -> Evd.evar_map -> - Vernacexpr.section_subset_expr -> EConstr.types list -> - Names.Id.t list +(** At some point it would be good to make this abstract *) +type t = Names.Id.Set.t + +(** Process a [using] expression in definitions to provide the list of + used terms *) +val definition_using + : Environ.env + -> Evd.evar_map + -> using:Vernacexpr.section_subset_expr + -> terms:EConstr.constr list + -> t val name_set : Names.Id.t -> Vernacexpr.section_subset_expr -> unit diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index 481bc3071b..e8d84a67a3 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -563,19 +563,19 @@ let program_inference_hook env sigma ev = user_err Pp.(str "The statement obligations could not be resolved \ automatically, write a statement definition first.") -let vernac_set_used_variables ~pstate e : Declare.Proof.t = +let vernac_set_used_variables ~pstate using : Declare.Proof.t = let env = Global.env () in let sigma, _ = Declare.Proof.get_current_context pstate in let initial_goals pf = Proofview.initial_goals Proof.((data pf).entry) in - let tys = List.map snd (initial_goals (Declare.Proof.get pstate)) in - let l = Proof_using.process_expr env sigma e tys in + let terms = List.map snd (initial_goals (Declare.Proof.get pstate)) in + let using = Proof_using.definition_using env sigma ~using ~terms in let vars = Environ.named_context env in - List.iter (fun id -> - if not (List.exists (NamedDecl.get_id %> Id.equal id) vars) then - user_err ~hdr:"vernac_set_used_variables" - (str "Unknown variable: " ++ Id.print id)) - l; - let _, pstate = Declare.Proof.set_used_variables pstate l in + Names.Id.Set.iter (fun id -> + if not (List.exists (NamedDecl.get_id %> Id.equal id) vars) then + user_err ~hdr:"vernac_set_used_variables" + (str "Unknown variable: " ++ Id.print id)) + using; + let _, pstate = Declare.Proof.set_used_variables pstate ~using in pstate let vernac_set_used_variables_opt ?using pstate = @@ -1438,7 +1438,10 @@ let vernac_reserve bl = let env = Global.env() in let sigma = Evd.from_env env in let t,ctx = Constrintern.interp_type env sigma c in - let t = Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_ctx ctx) t in + let t = Flags.without_option Detyping.print_universes (fun () -> + Detyping.detype Detyping.Now false Id.Set.empty env (Evd.from_ctx ctx) t) + () + in let t,_ = Notation_ops.notation_constr_of_glob_constr (default_env ()) t in Reserve.declare_reserved_type idl t) in List.iter sb_decl bl @@ -1565,6 +1568,13 @@ let () = let () = declare_bool_option { optdepr = false; + optkey = ["Printing";"Raw";"Literals"]; + optread = (fun () -> !Constrextern.print_raw_literal); + optwrite = (fun b -> Constrextern.print_raw_literal := b) } + +let () = + declare_bool_option + { optdepr = false; optkey = ["Printing";"All"]; optread = (fun () -> !Flags.raw_print); optwrite = (fun b -> Flags.raw_print := b) } @@ -1642,6 +1652,13 @@ let () = optwrite = CWarnings.set_flags } let () = + declare_string_option + { optdepr = false; + optkey = ["Debug"]; + optread = CDebug.get_flags; + optwrite = CDebug.set_flags } + +let () = declare_bool_option { optdepr = false; optkey = ["Guard"; "Checking"]; @@ -1707,9 +1724,9 @@ let vernac_set_append_option ~locality key s = let vernac_set_option ~locality table v = match v with | OptionSetString s -> - (* We make a special case for warnings because appending is their - natural semantics *) - if CString.List.equal table ["Warnings"] then + (* We make a special case for warnings and debug flags because appending is + their natural semantics *) + if CString.List.equal table ["Warnings"] || CString.List.equal table ["Debug"] then vernac_set_append_option ~locality table s else let (last, prefix) = List.sep_last table in @@ -2064,7 +2081,7 @@ let vernac_check_guard ~pstate = (* We interpret vernacular commands to a DSL that specifies their allowed actions on proof states *) -let translate_vernac ~atts v = let open Vernacextend in match v with +let translate_vernac ?loc ~atts v = let open Vernacextend in match v with | VernacAbortAll | VernacRestart | VernacUndo _ @@ -2389,4 +2406,4 @@ let translate_vernac ~atts v = let open Vernacextend in match v with (* Extensions *) | VernacExtend (opn,args) -> - Vernacextend.type_vernac ~atts opn args + Vernacextend.type_vernac ?loc ~atts opn args diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index cf233248d7..b30bbc3ce7 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -10,7 +10,8 @@ (** Vernac Translation into the Vernac DSL *) val translate_vernac - : atts:Attributes.vernac_flags + : ?loc:Loc.t + -> atts:Attributes.vernac_flags -> Vernacexpr.vernac_expr -> Vernacextend.typed_vernac @@ -26,4 +27,3 @@ val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Genredexpr.raw_red_expr val command_focus : unit Proof.focus_kind val allow_sprop_opt_name : string list -val cumul_sprop_opt_name : string list diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index f320b65954..df82382041 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -64,7 +64,7 @@ type typed_vernac = | VtDeclareProgram of (pm:Declare.OblState.t -> Declare.Proof.t) | VtOpenProofProgram of (pm:Declare.OblState.t -> Declare.OblState.t * Declare.Proof.t) -type vernac_command = atts:Attributes.vernac_flags -> typed_vernac +type vernac_command = ?loc:Loc.t -> atts:Attributes.vernac_flags -> typed_vernac type plugin_args = Genarg.raw_generic_argument list @@ -94,7 +94,7 @@ let warn_deprecated_command = (* Interpretation of a vernac command *) -let type_vernac opn converted_args ~atts = +let type_vernac opn converted_args ?loc ~atts = let depr, callback = vinterp_map opn in let () = if depr then let rules = Egramml.get_extend_vernac_rule opn in @@ -106,7 +106,7 @@ let type_vernac opn converted_args ~atts = warn_deprecated_command pr; in let hunk = callback converted_args in - hunk ~atts + hunk ?loc ~atts (** VERNAC EXTEND registering *) diff --git a/vernac/vernacextend.mli b/vernac/vernacextend.mli index 070c737882..27f6930dec 100644 --- a/vernac/vernacextend.mli +++ b/vernac/vernacextend.mli @@ -82,7 +82,7 @@ type typed_vernac = | VtDeclareProgram of (pm:Declare.OblState.t -> Declare.Proof.t) | VtOpenProofProgram of (pm:Declare.OblState.t -> Declare.OblState.t * Declare.Proof.t) -type vernac_command = atts:Attributes.vernac_flags -> typed_vernac +type vernac_command = ?loc:Loc.t -> atts:Attributes.vernac_flags -> typed_vernac type plugin_args = Genarg.raw_generic_argument list diff --git a/vernac/vernacinterp.ml b/vernac/vernacinterp.ml index e42775b76c..4098401bf0 100644 --- a/vernac/vernacinterp.ml +++ b/vernac/vernacinterp.ml @@ -151,7 +151,7 @@ let interp_control_flag ~time_header (f : control_flag) ~st * is the outdated/deprecated "Local" attribute of some vernacular commands * still parsed as the obsolete_locality grammar entry for retrocompatibility. * loc is the Loc.t of the vernacular command being interpreted. *) -let rec interp_expr ~atts ~st c = +let rec interp_expr ?loc ~atts ~st c = let stack = st.Vernacstate.lemmas in let program = st.Vernacstate.program in vernac_pperr_endline Pp.(fun () -> str "interpreting: " ++ Ppvernac.pr_vernac_expr c); @@ -174,7 +174,7 @@ let rec interp_expr ~atts ~st c = Attributes.unsupported_attributes atts; vernac_load ~verbosely fname | v -> - let fv = Vernacentries.translate_vernac ~atts v in + let fv = Vernacentries.translate_vernac ?loc ~atts v in interp_typed_vernac ~pm:program ~stack fv and vernac_load ~verbosely fname = @@ -206,13 +206,13 @@ and vernac_load ~verbosely fname = CErrors.user_err Pp.(str "Files processed by Load cannot leave open proofs."); stack, pm -and interp_control ~st ({ CAst.v = cmd } as vernac) = +and interp_control ~st ({ CAst.v = cmd; loc } as vernac) = let time_header = mk_time_header vernac in List.fold_right (fun flag fn -> interp_control_flag ~time_header flag fn) cmd.control (fun ~st -> let before_univs = Global.universes () in - let pstack, pm = interp_expr ~atts:cmd.attrs ~st cmd.expr in + let pstack, pm = interp_expr ?loc ~atts:cmd.attrs ~st cmd.expr in let after_univs = Global.universes () in if before_univs == after_univs then pstack, pm else |