diff options
207 files changed, 3785 insertions, 2495 deletions
diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index 6c7b7a9a1c..6c6e4bdfcb 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -320,6 +320,8 @@ azure-pipelines.yml @coq/ci-maintainers /test-suite/unit-tests/src/ @jfehrle # Secondary maintainer @SkySkimmer +/test-suite/success/Compat*.v @JasonGross + ########## Developer tools ########## /dev/tools/backport-pr.sh @Zimmi48 @@ -333,6 +335,9 @@ azure-pipelines.yml @coq/ci-maintainers /dev/tools/github-check-prs.py @SkySkimmer +/dev/tools/make-changelog.sh @SkySkimmer +# Secondary maintainer @Zimmi48 + /dev/tools/merge-pr.sh @maximedenes # Secondary maintainer @gares diff --git a/.gitignore b/.gitignore index 587a6191ab..ad5204847c 100644 --- a/.gitignore +++ b/.gitignore @@ -135,7 +135,7 @@ ide/protocol/xml_lexer.ml coqpp/coqpp_parse.ml coqpp/coqpp_parse.mli -# .ml4 / .mlp files +# .mlg / .mlp files g_*.ml diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index f0403a7318..0ebf69f50f 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -70,8 +70,6 @@ before_script: - config/coq_config.py - test-suite/misc/universes/all_stdlib.v expire_in: 1 week - variables: - timeout: "" script: - set -e @@ -84,8 +82,8 @@ before_script: - echo 'end:coq.config' - echo 'start:coq.build' - - $timeout make -j "$NJOBS" byte - - $timeout make -j "$NJOBS" world $EXTRA_TARGET + - make -j "$NJOBS" byte + - make -j "$NJOBS" world $EXTRA_TARGET - make test-suite/misc/universes/all_stdlib.v - echo 'end:coq:build' @@ -164,7 +162,7 @@ before_script: - BIN=$(readlink -f ../_install_ci/bin)/ - LIB=$(readlink -f ../_install_ci/lib/coq)/ - export OCAMLPATH=$(readlink -f ../_install_ci/lib/):"$OCAMLPATH" - - $timeout make -j "$NJOBS" BIN="$BIN" COQLIB="$LIB" COQFLAGS="${COQFLAGS}" all + - make -j "$NJOBS" BIN="$BIN" COQLIB="$LIB" COQFLAGS="${COQFLAGS}" all artifacts: name: "$CI_JOB_NAME.logs" when: on_failure @@ -172,8 +170,6 @@ before_script: - test-suite/logs # Gitlab doesn't support yet "expire_in: never" so we use the instance default # expire_in: never - variables: - timeout: "" # set dependencies when using .validate-template: @@ -279,7 +275,7 @@ build:base+async: variables: COQ_EXTRA_CONF: "-native-compiler yes -coqide opt" COQUSERFLAGS: "-async-proofs on" - timeout: "timeout 100m" + timeout: 100m allow_failure: true # See https://github.com/coq/coq/issues/9658 only: variables: @@ -290,7 +286,7 @@ build:quick: variables: COQ_EXTRA_CONF: "-native-compiler no" QUICK: "1" - timeout: "timeout 100m" + timeout: 100m allow_failure: true # See https://github.com/coq/coq/issues/9637 only: variables: @@ -327,7 +323,7 @@ pkg:opam: - opam pin add --kind=path coqide.$COQ_VERSION . - set +e variables: - COQ_VERSION: "8.10" + COQ_VERSION: "8.11" OPAM_SWITCH: "edge" OPAM_VARIANT: "+flambda" only: *full-ci @@ -515,7 +511,7 @@ test-suite:base+async: - build:base variables: COQFLAGS: "-async-proofs on -async-proofs-cache force" - timeout: "timeout 100m" + timeout: 100m allow_failure: true only: variables: @@ -685,6 +681,9 @@ plugin:ci-mtac2: plugin:ci-paramcoq: extends: .ci-template +plugin:ci-perennial: + extends: .ci-template-flambda + plugin:plugin-tutorial: stage: stage-1 dependencies: [] @@ -101,6 +101,7 @@ of the Coq Proof assistant during the indicated time: Daniel de Rauglaudre (INRIA, 1996-1998, 2012, 2016) Olivier Desmettre (INRIA, 2001-2003) Gilles Dowek (INRIA, 1991-1994) + Jim Fehrle (2018-now) Amy Felty (INRIA, 1993) Jean-Christophe Filliâtre (ENS Lyon, 1994-1997, LRI, 1997-2008) Emilio Jesús Gallego Arias (MINES ParisTech 2015-now) @@ -116,12 +117,13 @@ of the Coq Proof assistant during the indicated time: Matej Košík (INRIA, 2015-2017) Leonidas Lampropoulos (University of Pennsylvania, 2018) Pierre Letouzey (LRI, 2000-2004, PPS, 2005-2008, - INRIA-PPS then IRIF, 2009-now) + INRIA-PPS then IRIF, 2009-2018) Yao Li (ORCID: https://orcid.org/0000-0001-8720-883X, University of Pennsylvania, 2018) Yishuai Li (ORCID: https://orcid.org/0000-0002-5728-5903 U. Penn, 2018-2019) Patrick Loiseleur (Paris Sud, 1997-1999) + Andreas Lynge (Aarhus University, 2019) Evgeny Makarov (INRIA, 2007) Gregory Malecha (Harvard University 2013-2015, University of California, San Diego 2016) @@ -140,16 +142,15 @@ of the Coq Proof assistant during the indicated time: LRI, 1997-2006) Pierre-Marie Pédrot (INRIA-PPS, 2011-2015, INRIA-Ascola, 2015-2016, University of Ljubljana, 2016-2017, - MPI-SWS, 2017-2018) - Clément Pit-Claudel (MIT, 2015-2018) + MPI-SWS, 2017-2018, INRIA 2018-now) + Clément Pit-Claudel (MIT, 2015-now) Matthias Puech (INRIA-Bologna, 2008-2011) - Yann Régis-Gianas (INRIA-PPS then IRIF, 2009-now) + Yann Régis-Gianas (INRIA-PPS then IRIF, 2009-2016) Clément Renard (INRIA, 2001-2004) Talia Ringer (University of Washington, 2019) - Andreas Lynge (Aarhus University, 2019) Claudio Sacerdoti Coen (INRIA, 2004-2005) Amokrane Saïbi (INRIA, 1993-1998) - Vincent Semeria (2018) + Vincent Semeria (2018-now) Vincent Siles (INRIA, 2007) Élie Soubiran (INRIA, 2007-2010) Matthieu Sozeau (INRIA, 2005-now) diff --git a/META.coq.in b/META.coq.in index f7922e0ac2..5819985499 100644 --- a/META.coq.in +++ b/META.coq.in @@ -1,7 +1,7 @@ # TODO: Generate automatically with Dune description = "The Coq Proof Assistant Plugin API" -version = "8.10" +version = "8.11" directory = "" requires = "" @@ -9,7 +9,7 @@ requires = "" package "config" ( description = "Coq Configuration Variables" - version = "8.10" + version = "8.11" directory = "config" @@ -19,7 +19,7 @@ package "config" ( package "clib" ( description = "Base General Coq Library" - version = "8.10" + version = "8.11" directory = "clib" requires = "str, unix, threads" @@ -31,7 +31,7 @@ package "clib" ( package "lib" ( description = "Base Coq-Specific Library" - version = "8.10" + version = "8.11" directory = "lib" @@ -45,7 +45,7 @@ package "lib" ( package "vm" ( description = "Coq VM" - version = "8.10" + version = "8.11" directory = "kernel/byterun" @@ -64,7 +64,7 @@ package "vm" ( package "kernel" ( description = "Coq's Kernel" - version = "8.10" + version = "8.11" directory = "kernel" @@ -78,7 +78,7 @@ package "kernel" ( package "library" ( description = "Coq Libraries (vo) support" - version = "8.10" + version = "8.11" requires = "coq.kernel" @@ -92,7 +92,7 @@ package "library" ( package "engine" ( description = "Coq Tactic Engine" - version = "8.10" + version = "8.11" requires = "coq.library" directory = "engine" @@ -105,7 +105,7 @@ package "engine" ( package "pretyping" ( description = "Coq Pretyper" - version = "8.10" + version = "8.11" requires = "coq.engine" directory = "pretyping" @@ -118,7 +118,7 @@ package "pretyping" ( package "interp" ( description = "Coq Term Interpretation" - version = "8.10" + version = "8.11" requires = "coq.pretyping" directory = "interp" @@ -131,7 +131,7 @@ package "interp" ( package "proofs" ( description = "Coq Proof Engine" - version = "8.10" + version = "8.11" requires = "coq.interp" directory = "proofs" @@ -144,7 +144,7 @@ package "proofs" ( package "gramlib" ( description = "Coq Grammar Engine" - version = "8.10" + version = "8.11" requires = "coq.lib" directory = "gramlib/.pack" @@ -156,7 +156,7 @@ package "gramlib" ( package "parsing" ( description = "Coq Parsing Engine" - version = "8.10" + version = "8.11" requires = "coq.gramlib, coq.proofs" directory = "parsing" @@ -169,7 +169,7 @@ package "parsing" ( package "printing" ( description = "Coq Printing Engine" - version = "8.10" + version = "8.11" requires = "coq.parsing" directory = "printing" @@ -182,7 +182,7 @@ package "printing" ( package "tactics" ( description = "Coq Basic Tactics" - version = "8.10" + version = "8.11" requires = "coq.printing" directory = "tactics" @@ -195,7 +195,7 @@ package "tactics" ( package "vernac" ( description = "Coq Vernacular Interpreter" - version = "8.10" + version = "8.11" requires = "coq.tactics" directory = "vernac" @@ -208,7 +208,7 @@ package "vernac" ( package "stm" ( description = "Coq State Transactional Machine" - version = "8.10" + version = "8.11" requires = "coq.vernac" directory = "stm" @@ -221,7 +221,7 @@ package "stm" ( package "toplevel" ( description = "Coq Toplevel" - version = "8.10" + version = "8.11" requires = "num, coq.stm" directory = "toplevel" @@ -234,7 +234,7 @@ package "toplevel" ( package "idetop" ( description = "Coq IDE Libraries" - version = "8.10" + version = "8.11" requires = "coq.toplevel" directory = "ide" @@ -247,7 +247,7 @@ package "idetop" ( package "ide" ( description = "Coq IDE Libraries" - version = "8.10" + version = "8.11" requires = "coq.lib, coq.ideprotocol, lablgtk3, lablgtk3-sourceview3" directory = "ide" @@ -260,7 +260,7 @@ package "ide" ( package "ideprotocol" ( description = "Coq IDE protocol" - version = "8.10" + version = "8.11" requires = "coq.toplevel" directory = "ide/protocol" @@ -273,14 +273,14 @@ package "ideprotocol" ( package "plugins" ( description = "Coq built-in plugins" - version = "8.10" + version = "8.11" directory = "plugins" package "ltac" ( description = "Coq LTAC Plugin" - version = "8.10" + version = "8.11" requires = "coq.stm" directory = "ltac" @@ -288,209 +288,262 @@ package "plugins" ( archive(byte) = "ltac_plugin.cmo" archive(native) = "ltac_plugin.cmx" + plugin(byte) = "ltac_plugin.cmo" + plugin(native) = "ltac_plugin.cmxs" ) package "tauto" ( description = "Coq tauto plugin" - version = "8.10" + version = "8.11" requires = "coq.plugins.ltac" directory = "ltac" archive(byte) = "tauto_plugin.cmo" archive(native) = "tauto_plugin.cmx" + + plugin(byte) = "tauto_plugin.cmo" + plugin(native) = "tauto_plugin.cmxs" ) package "omega" ( description = "Coq omega plugin" - version = "8.10" + version = "8.11" requires = "coq.plugins.ltac" directory = "omega" archive(byte) = "omega_plugin.cmo" archive(native) = "omega_plugin.cmx" + + plugin(byte) = "omega_plugin.cmo" + plugin(native) = "omega_plugin.cmxs" ) package "micromega" ( description = "Coq micromega plugin" - version = "8.10" + version = "8.11" requires = "num,coq.plugins.ltac" directory = "micromega" archive(byte) = "micromega_plugin.cmo" archive(native) = "micromega_plugin.cmx" + + plugin(byte) = "micromega_plugin.cmo" + plugin(native) = "micromega_plugin.cmxs" ) package "setoid_ring" ( description = "Coq newring plugin" - version = "8.10" + version = "8.11" requires = "" directory = "setoid_ring" archive(byte) = "newring_plugin.cmo" archive(native) = "newring_plugin.cmx" + + plugin(byte) = "newring_plugin.cmo" + plugin(native) = "newring_plugin.cmxs" ) package "extraction" ( description = "Coq extraction plugin" - version = "8.10" + version = "8.11" requires = "coq.plugins.ltac" directory = "extraction" archive(byte) = "extraction_plugin.cmo" archive(native) = "extraction_plugin.cmx" + + plugin(byte) = "extraction_plugin.cmo" + plugin(native) = "extraction_plugin.cmxs" ) package "cc" ( description = "Coq cc plugin" - version = "8.10" + version = "8.11" requires = "coq.plugins.ltac" directory = "cc" archive(byte) = "cc_plugin.cmo" archive(native) = "cc_plugin.cmx" + + plugin(byte) = "cc_plugin.cmo" + plugin(native) = "cc_plugin.cmxs" ) package "firstorder" ( description = "Coq ground plugin" - version = "8.10" + version = "8.11" requires = "coq.plugins.ltac" directory = "firstorder" archive(byte) = "ground_plugin.cmo" archive(native) = "ground_plugin.cmx" + + plugin(byte) = "ground_plugin.cmo" + plugin(native) = "ground_plugin.cmxs" ) package "rtauto" ( description = "Coq rtauto plugin" - version = "8.10" + version = "8.11" requires = "coq.plugins.ltac" directory = "rtauto" archive(byte) = "rtauto_plugin.cmo" archive(native) = "rtauto_plugin.cmx" + + plugin(byte) = "rtauto_plugin.cmo" + plugin(native) = "rtauto_plugin.cmxs" ) package "btauto" ( description = "Coq btauto plugin" - version = "8.10" + version = "8.11" requires = "coq.plugins.ltac" directory = "btauto" archive(byte) = "btauto_plugin.cmo" archive(native) = "btauto_plugin.cmx" + + plugin(byte) = "btauto_plugin.cmo" + plugin(native) = "btauto_plugin.cmxs" ) package "funind" ( description = "Coq recdef plugin" - version = "8.10" + version = "8.11" requires = "coq.plugins.extraction" directory = "funind" archive(byte) = "recdef_plugin.cmo" archive(native) = "recdef_plugin.cmx" + + plugin(byte) = "recdef_plugin.cmo" + plugin(native) = "recdef_plugin.cmxs" ) package "nsatz" ( description = "Coq nsatz plugin" - version = "8.10" + version = "8.11" requires = "num,coq.plugins.ltac" directory = "nsatz" archive(byte) = "nsatz_plugin.cmo" archive(native) = "nsatz_plugin.cmx" + + plugin(byte) = "nsatz_plugin.cmo" + plugin(native) = "nsatz_plugin.cmxs" ) package "rsyntax" ( description = "Coq rsyntax plugin" - version = "8.10" + version = "8.11" requires = "" directory = "syntax" archive(byte) = "r_syntax_plugin.cmo" archive(native) = "r_syntax_plugin.cmx" + + plugin(byte) = "r_syntax_plugin.cmo" + plugin(native) = "r_syntax_plugin.cmxs" ) package "int63syntax" ( description = "Coq int63syntax plugin" - version = "8.10" + version = "8.11" 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.10" + version = "8.11" requires = "" directory = "syntax" archive(byte) = "string_notation_plugin.cmo" archive(native) = "string_notation_plugin.cmx" + + plugin(byte) = "string_notation_plugin.cmo" + plugin(native) = "string_notation_plugin.cmxs" ) package "derive" ( description = "Coq derive plugin" - version = "8.10" + version = "8.11" requires = "" directory = "derive" archive(byte) = "derive_plugin.cmo" archive(native) = "derive_plugin.cmx" + + plugin(byte) = "derive_plugin.cmo" + plugin(native) = "derive_plugin.cmxs" ) package "ssrmatching" ( description = "Coq ssrmatching plugin" - version = "8.10" + version = "8.11" requires = "coq.plugins.ltac" directory = "ssrmatching" archive(byte) = "ssrmatching_plugin.cmo" archive(native) = "ssrmatching_plugin.cmx" + + plugin(byte) = "ssrmatching_plugin.cmo" + plugin(native) = "ssrmatching_plugin.cmxs" ) package "ssreflect" ( description = "Coq ssreflect plugin" - version = "8.10" + version = "8.11" requires = "coq.plugins.ssrmatching" directory = "ssr" archive(byte) = "ssreflect_plugin.cmo" archive(native) = "ssreflect_plugin.cmx" + + plugin(byte) = "ssreflect_plugin.cmo" + plugin(native) = "ssreflect_plugin.cmxs" ) ) @@ -101,15 +101,18 @@ EXISTINGMLI := $(call find, '*.mli') ## Files that will be generated -GENMLGFILES:= $(MLGFILES:.mlg=.ml) # GRAMFILES must be in linking order GRAMFILES=$(addprefix gramlib/.pack/gramlib__,Ploc Plexing Gramext Grammar) -GRAMMLFILES := $(addsuffix .ml, $(GRAMFILES)) $(addsuffix .mli, $(GRAMFILES)) -GENGRAMFILES := $(GRAMMLFILES) gramlib/.pack/gramlib.ml -GENMLFILES:=$(LEXFILES:.mll=.ml) $(YACCFILES:.mly=.ml) $(GENMLGFILES) ide/coqide_os_specific.ml kernel/copcodes.ml kernel/uint63.ml +GRAMMLFILES := $(addsuffix .ml, $(GRAMFILES)) +GRAMMLIFILES := $(addsuffix .mli, $(GRAMFILES)) +GENGRAMMLFILES := $(GRAMMLFILES) gramlib/.pack/gramlib.ml # why is gramlib.ml not in GRAMMLFILES? + +GENMLGFILES:= $(MLGFILES:.mlg=.ml) +GENMLFILES:=$(LEXFILES:.mll=.ml) $(YACCFILES:.mly=.ml) $(GENMLGFILES) $(GENGRAMMLFILES) ide/coqide_os_specific.ml kernel/copcodes.ml kernel/uint63.ml +GENMLIFILES:=$(GRAMMLIFILES) GENHFILES:=kernel/byterun/coq_instruct.h kernel/byterun/coq_jumptbl.h GENFILES:=$(GENMLFILES) $(GENMLIFILES) $(GENHFILES) kernel/genOpcodeFiles.exe -COQ_EXPORTED += GRAMFILES GRAMMLFILES GENGRAMFILES GENMLFILES GENHFILES GENFILES +COQ_EXPORTED += GRAMFILES GRAMMLFILES GRAMMLIFILES GENMLFILES GENHFILES GENFILES ## More complex file lists diff --git a/Makefile.build b/Makefile.build index f2e1ca4ea0..ed4cde2b16 100644 --- a/Makefile.build +++ b/Makefile.build @@ -81,7 +81,7 @@ coq.timing.diff: coqlib.timing.diff # shouldn't be done in a same make -j... run, otherwise both ocamlc and # ocamlopt might race for access to the same .cmi files. -byte: coqbyte coqide-byte pluginsbyte printers +byte: coqbyte coqide-byte pluginsbyte printers bin/votour.byte .PHONY: world coq byte world.timing.diff coq.timing.diff @@ -203,7 +203,7 @@ TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD)) # the output format of the unix command time. For instance: # TIME="%C (%U user, %S sys, %e total, %M maxres)" -COQOPTS=$(NATIVECOMPUTE) $(COQWARNERROR) $(COQUSERFLAGS) -allow-sprop +COQOPTS=$(NATIVECOMPUTE) $(COQWARNERROR) $(COQUSERFLAGS) # Beware this depends on the makefile being in a particular dir, we # should pass an absolute path here but windows is tricky # c.f. https://github.com/coq/coq/pull/9560 @@ -807,9 +807,9 @@ OCAMLDEP = $(OCAMLFIND) ocamldep -slash -ml-synonym .mlpack MAINMLFILES := $(filter-out gramlib/.pack/% checker/% plugins/% user-contrib/%, $(MLFILES) $(MLIFILES)) MAINMLLIBFILES := $(filter-out gramlib/.pack/% checker/% plugins/% user-contrib/%, $(MLLIBFILES) $(MLPACKFILES)) -$(MLDFILE).d: $(D_DEPEND_BEFORE_SRC) $(MAINMLFILES) $(D_DEPEND_AFTER_SRC) $(GENFILES) $(GENGRAMFILES) +$(MLDFILE).d: $(D_DEPEND_BEFORE_SRC) $(MAINMLFILES) $(D_DEPEND_AFTER_SRC) $(GENFILES) $(SHOW)'OCAMLDEP MLFILES MLIFILES' - $(HIDE)$(OCAMLDEP) $(DEPFLAGS) -passrest $(MAINMLFILES) -open Gramlib $(GRAMMLFILES) $(TOTARGET) + $(HIDE)$(OCAMLDEP) $(DEPFLAGS) -passrest $(MAINMLFILES) -open Gramlib $(GRAMMLFILES) $(GRAMMLIFILES) $(TOTARGET) #NB: -passrest is needed to avoid ocamlfind reordering the -open Gramlib $(MLLIBDFILE).d: $(D_DEPEND_BEFORE_SRC) $(MAINMLLIBFILES) $(D_DEPEND_AFTER_SRC) $(OCAMLLIBDEP) $(GENFILES) diff --git a/Makefile.ci b/Makefile.ci index de03ee8e84..60d4b68f53 100644 --- a/Makefile.ci +++ b/Makefile.ci @@ -35,6 +35,7 @@ CI_TARGETS= \ ci-math-comp \ ci-mtac2 \ ci-paramcoq \ + ci-perennial \ ci-quickchick \ ci-relation_algebra \ ci-sf \ diff --git a/Makefile.common b/Makefile.common index 2d1200c071..1ad255d156 100644 --- a/Makefile.common +++ b/Makefile.common @@ -41,9 +41,10 @@ COQMAKE_ONE_TIME_FILE:=tools/make-one-time-file.py COQTIME_FILE_MAKER:=tools/TimeFileMaker.py COQMAKE_BOTH_TIME_FILES:=tools/make-both-time-files.py COQMAKE_BOTH_SINGLE_TIMING_FILES:=tools/make-both-single-timing-files.py +VOTOUR:=bin/votour TOOLS:=$(COQDEP) $(COQMAKEFILE) $(COQTEX) $(COQWC) $(COQDOC) $(COQC)\ - $(COQWORKMGR) $(COQPP) $(DOC_GRAM) + $(COQWORKMGR) $(COQPP) $(DOC_GRAM) $(VOTOUR) TOOLS_HELPERS:=tools/CoqMakefile.in $(COQMAKE_ONE_TIME_FILE) $(COQTIME_FILE_MAKER)\ $(COQMAKE_BOTH_TIME_FILES) $(COQMAKE_BOTH_SINGLE_TIMING_FILES) diff --git a/Makefile.ide b/Makefile.ide index 081d15a1a2..39c6c8ad1e 100644 --- a/Makefile.ide +++ b/Makefile.ide @@ -264,7 +264,7 @@ $(COQIDEAPP)/Contents/Resources/loaders: $(COQIDEAPP)/Contents $(COQIDEAPP)/Contents/Resources/immodules: $(COQIDEAPP)/Contents $(MKDIR) $@ - $(INSTALLLIB) "$(GTKLIBS)/gtk-3.0/3.0.0/immodules/"*.so $@ + $(INSTALLLIB) "$(GTKLIBS)/gtk-3.0/3.0.0/immodules/"*.dylib $@ $(COQIDEAPP)/Contents/Resources/etc: $(COQIDEAPP)/Contents/Resources/lib @@ -273,8 +273,8 @@ $(COQIDEAPP)/Contents/Resources/etc: $(COQIDEAPP)/Contents/Resources/lib { "$(PIXBUFBIN)/gdk-pixbuf-query-loaders" $@/../loaders/*.so |\ sed -e "s!/.*\(/loaders/.*.so\)!@executable_path/../Resources/\1!"; } \ > $@/gtk-3.0/gdk-pixbuf.loaders - { "$(GTKBIN)/gtk-query-immodules-3.0" $@/../immodules/*.so |\ - sed -e "s!/.*\(/immodules/.*.so\)!@executable_path/../Resources/\1!" |\ + { "$(GTKBIN)/gtk-query-immodules-3.0" $@/../immodules/*.dylib |\ + sed -e "s!/.*\(/immodules/.*.dylib\)!@executable_path/../Resources/\1!" |\ sed -e "s!/.*\(/share/locale\)!@executable_path/../Resources/\1!"; } \ > $@/gtk-3.0/gtk-immodules.loaders $(MKDIR) $@/pango @@ -283,7 +283,7 @@ $(COQIDEAPP)/Contents/Resources/etc: $(COQIDEAPP)/Contents/Resources/lib $(COQIDEAPP)/Contents/Resources/lib: $(COQIDEAPP)/Contents/Resources/immodules $(COQIDEAPP)/Contents/Resources/loaders $(COQIDEAPP)/Contents $(COQIDEINAPP) $(MKDIR) $@ macpack -d ../Resources/lib $(COQIDEINAPP) - for i in $@/../loaders/*.so $@/../immodules/*.so; \ + for i in $@/../loaders/*.so $@/../immodules/*.dylib; \ do \ macpack -d ../lib $$i; \ done diff --git a/Makefile.install b/Makefile.install index 608e8a3c8e..456c391fd9 100644 --- a/Makefile.install +++ b/Makefile.install @@ -92,13 +92,13 @@ install-tools: INSTALLCMI = $(sort \ $(filter-out checker/% ide/% tools/%, $(MLIFILES:.mli=.cmi)) \ - $(filter %.cmi, $(GRAMMLFILES:.mli=.cmi)) gramlib/.pack/gramlib.cmi \ + $(GRAMMLIFILES:.mli=.cmi) gramlib/.pack/gramlib.cmi \ $(foreach lib,$(CORECMA), $(addsuffix .cmi,$($(lib:.cma=_MLLIB_DEPENDENCIES))))) \ $(PLUGINS:.cmo=.cmi) INSTALLCMX = $(sort $(filter-out checker/% ide/% tools/% dev/% \ configure.cmx toplevel/coqtop_byte_bin.cmx plugins/extraction/big.cmx, \ - $(filter %.cmx, $(GRAMMLFILES:.ml=.cmx)) $(MLFILES:.ml=.cmx))) + $(GRAMMLFILES:.ml=.cmx) $(MLFILES:.ml=.cmx))) install-devfiles: $(MKDIR) $(FULLBINDIR) diff --git a/azure-pipelines.yml b/azure-pipelines.yml index 38ea915f3c..31dcae0f82 100644 --- a/azure-pipelines.yml +++ b/azure-pipelines.yml @@ -58,8 +58,8 @@ jobs: displayName: 'Install system dependencies' env: HOMEBREW_NO_AUTO_UPDATE: "1" - HBCORE_DATE: "2019-06-16" - HBCORE_REF: "944a5b7d83e4b81c749d93831b514607bdd2b6a1" + HBCORE_DATE: "2019-09-03" + HBCORE_REF: "44ee64cf4b9f2d2bf000758d356db0c77425e42e" - script: | set -e diff --git a/checker/check.ml b/checker/check.ml index 69de2536c5..09ecd675f7 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -359,7 +359,7 @@ let intern_from_file ~intern_mode (dir, f) = (* Verification of the unmarshalled values *) validate !Flags.debug Values.v_libsum sd; validate !Flags.debug Values.v_lib md; - validate !Flags.debug Values.(Opt v_opaques) table; + validate !Flags.debug Values.(Opt v_opaquetable) table; Flags.if_verbose chk_pp (str" done]" ++ fnl ()); let digest = if opaque_csts <> None then Safe_typing.Dvivo (digest,udg) diff --git a/checker/values.ml b/checker/values.ml index 6b340635d7..9a2028a96b 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -187,10 +187,24 @@ let v_substituted v_a = let v_cstr_subst = v_substituted v_constr -(** NB: Second constructor [Direct] isn't supposed to appear in a .vo *) -let v_lazy_constr = - v_sum "lazy_constr" 0 [|[|List v_subst;v_dp;Int|]|] +let v_ndecl = v_sum "named_declaration" 0 + [| [|v_binder_annot v_id; v_constr|]; (* LocalAssum *) + [|v_binder_annot v_id; v_constr; v_constr|] |] (* LocalDef *) + +let v_nctxt = List v_ndecl + +let v_work_list = + let v_abstr = v_pair v_instance (Array v_id) in + Tuple ("work_list", [|v_hmap v_cst v_abstr; v_hmap v_cst v_abstr|]) + +let v_abstract = + Tuple ("abstract", [| v_nctxt; v_instance; v_abs_context |]) +let v_cooking_info = + Tuple ("cooking_info", [|v_work_list; v_abstract|]) + +let v_opaque = + v_sum "opaque" 0 [|[|List v_subst; List v_cooking_info; v_dp; Int|]|] (** kernel/declarations *) @@ -216,7 +230,7 @@ let v_primitive = let v_cst_def = v_sum "constant_def" 0 - [|[|Opt Int|]; [|v_cstr_subst|]; [|v_lazy_constr|]; [|v_primitive|]|] + [|[|Opt Int|]; [|v_cstr_subst|]; [|v_opaque|]; [|v_primitive|]|] let v_typing_flags = v_tuple "typing_flags" [|v_bool; v_bool; v_bool; v_oracle; v_bool; v_bool; v_bool; v_bool; v_bool|] @@ -400,25 +414,9 @@ let v_libsum = let v_lib = Tuple ("library",[|v_compiled_lib;v_libraryobjs|]) -let v_ndecl = v_sum "named_declaration" 0 - [| [|v_binder_annot v_id; v_constr|]; (* LocalAssum *) - [|v_binder_annot v_id; v_constr; v_constr|] |] (* LocalDef *) - -let v_nctxt = List v_ndecl - -let v_work_list = - let v_abstr = v_pair v_instance (Array v_id) in - Tuple ("work_list", [|v_hmap v_cst v_abstr; v_hmap v_cst v_abstr|]) - -let v_abstract = - Tuple ("abstract", [| v_nctxt; v_instance; v_abs_context |]) - -let v_cooking_info = - Tuple ("cooking_info", [|v_work_list; v_abstract|]) - let v_delayed_universes = Sum ("delayed_universes", 0, [| [| v_unit |]; [| Int; v_context_set |] |]) -let v_opaques = Array (Tuple ("opaque", [| List v_cooking_info; Opt (v_pair v_constr v_delayed_universes) |])) +let v_opaquetable = Array (Opt (v_pair v_constr v_delayed_universes)) let v_univopaques = Opt (Tuple ("univopaques",[|v_context_set;v_bool|])) diff --git a/checker/values.mli b/checker/values.mli index 93983eb700..db6b0be250 100644 --- a/checker/values.mli +++ b/checker/values.mli @@ -46,5 +46,5 @@ type value = val v_univopaques : value val v_libsum : value val v_lib : value -val v_opaques : value +val v_opaquetable : value val v_stm_seg : value diff --git a/checker/votour.ml b/checker/votour.ml index f0e0cf22ab..97584831e5 100644 --- a/checker/votour.ml +++ b/checker/votour.ml @@ -364,9 +364,8 @@ let visit_vo f = make_seg "summary" Values.v_libsum; make_seg "library" Values.v_lib; make_seg "univ constraints of opaque proofs" Values.v_univopaques; - make_seg "discharging info" (Opt Any); make_seg "STM tasks" (Opt Values.v_stm_seg); - make_seg "opaque proofs" Values.v_opaques; + make_seg "opaque proofs" Values.v_opaquetable; |] in let repr = if Sys.word_size = 64 then (module ReprMem : S) else (module ReprObj : S) diff --git a/configure.ml b/configure.ml index d7370b28c1..8e04dc46b2 100644 --- a/configure.ml +++ b/configure.ml @@ -12,15 +12,15 @@ #load "str.cma" open Printf -let coq_version = "8.10+alpha" -let coq_macos_version = "8.9.90" (** "[...] should be a string comprised of +let coq_version = "8.11+alpha" +let coq_macos_version = "8.10.90" (** "[...] should be a string comprised of three non-negative, period-separated integers [...]" *) -let vo_magic = 8991 -let state_magic = 58991 +let vo_magic = 81091 +let state_magic = 581091 let is_a_released_version = false let distributed_exec = ["coqtop.opt"; "coqidetop.opt"; "coqqueryworker.opt"; "coqproofworker.opt"; "coqtacticworker.opt"; - "coqc.opt";"coqchk";"coqdoc";"coqworkmgr";"coq_makefile";"coq-tex";"coqwc";"csdpcert";"coqdep"] + "coqc.opt";"coqchk";"coqdoc";"coqworkmgr";"coq_makefile";"coq-tex";"coqwc";"csdpcert";"coqdep";"votour"] let verbose = ref false (* for debugging this script *) diff --git a/default.nix b/default.nix index 2d101eed57..19afc2bd1b 100644 --- a/default.nix +++ b/default.nix @@ -29,7 +29,7 @@ , shell ? false # We don't use lib.inNixShell because that would also apply # when in a nix-shell of some package depending on this one. -, coq-version ? "8.10-git" +, coq-version ? "8.11-git" }: with pkgs; diff --git a/dev/README.md b/dev/README.md index 4cda60a703..0c6b8020f1 100644 --- a/dev/README.md +++ b/dev/README.md @@ -28,7 +28,7 @@ | [`dev/doc/econstr.md`](doc/econstr.md) | Describes `Econstr`, implementation of treatment of `evar` in the engine | | [`dev/doc/primproj.md`](doc/primproj.md) | Describes primitive projections | | [`dev/doc/proof-engine.md`](doc/proof-engine.md) | Tutorial on new proof engine | -| [`dev/doc/xml-protocol.md`](doc/proof-engine.md) | XML protocol that coqtop and IDEs use to communicate | +| [`dev/doc/xml-protocol.md`](doc/xml-protocol.md) | XML protocol that coqtop and IDEs use to communicate | | [`dev/doc/MERGING.md`](doc/MERGING.md) | How pull requests should be merged into `master` | | [`dev/doc/release-process.md`](doc/release-process.md) | Process of creating a new Coq release | diff --git a/dev/build/windows/patches_coq/ocaml-4.07.1.patch b/dev/build/windows/patches_coq/ocaml-4.07.1.patch index 2d61b5b838..2d61b5b838 100755..100644 --- a/dev/build/windows/patches_coq/ocaml-4.07.1.patch +++ b/dev/build/windows/patches_coq/ocaml-4.07.1.patch diff --git a/dev/build/windows/patches_coq/pkg-config.c b/dev/build/windows/patches_coq/pkg-config.c index c4c7ec2bff..c4c7ec2bff 100755..100644 --- a/dev/build/windows/patches_coq/pkg-config.c +++ b/dev/build/windows/patches_coq/pkg-config.c diff --git a/dev/ci/ci-basic-overlay.sh b/dev/ci/ci-basic-overlay.sh index 3923fea30e..8db0087e3c 100755 --- a/dev/ci/ci-basic-overlay.sh +++ b/dev/ci/ci-basic-overlay.sh @@ -311,3 +311,10 @@ : "${argosy_CI_REF:=master}" : "${argosy_CI_GITURL:=https://github.com/mit-pdos/argosy}" : "${argosy_CI_ARCHIVEURL:=${argosy_CI_GITURL}/archive}" + +######################################################################## +# perennial +######################################################################## +: "${perennial_CI_REF:=master}" +: "${perennial_CI_GITURL:=https://github.com/mit-pdos/perennial}" +: "${perennial_CI_ARCHIVEURL:=${perennial_CI_GITURL}/archive}" diff --git a/dev/ci/ci-perennial.sh b/dev/ci/ci-perennial.sh new file mode 100755 index 0000000000..f3be66e814 --- /dev/null +++ b/dev/ci/ci-perennial.sh @@ -0,0 +1,12 @@ +#!/usr/bin/env bash + +ci_dir="$(dirname "$0")" +. "${ci_dir}/ci-common.sh" + +FORCE_GIT=1 +git_download perennial + +# required by Perennial's coqc.py build wrapper +export LC_ALL=C.UTF-8 + +( cd "${CI_BUILD_DIR}/perennial" && git submodule update --init --recursive && make TIMED=false ) diff --git a/dev/ci/user-overlays/10516-ejgallego-proof+dup_save.sh b/dev/ci/user-overlays/10516-ejgallego-proof+dup_save.sh new file mode 100644 index 0000000000..7001c3d0c8 --- /dev/null +++ b/dev/ci/user-overlays/10516-ejgallego-proof+dup_save.sh @@ -0,0 +1,6 @@ +if [ "$CI_PULL_REQUEST" = "10516" ] || [ "$CI_BRANCH" = "proof+dup_save" ]; then + + elpi_CI_REF=proof+dup_save + elpi_CI_GITURL=https://github.com/ejgallego/coq-elpi + +fi diff --git a/dev/ci/user-overlays/10811-SkySkimmer-sprop-default-on.sh b/dev/ci/user-overlays/10811-SkySkimmer-sprop-default-on.sh new file mode 100644 index 0000000000..d7af6b7a36 --- /dev/null +++ b/dev/ci/user-overlays/10811-SkySkimmer-sprop-default-on.sh @@ -0,0 +1,9 @@ +if [ "$CI_PULL_REQUEST" = "10811" ] || [ "$CI_BRANCH" = "sprop-default-on" ]; then + + elpi_CI_REF=sprop-default-on + elpi_CI_GITURL=https://github.com/SkySkimmer/coq-elpi + + coq_dpdgraph_CI_REF=sprop-default-on + coq_dpdgraph_CI_GITURL=https://github.com/SkySkimmer/coq-dpdgraph + +fi diff --git a/dev/doc/build-system.txt b/dev/doc/build-system.txt index a14781a058..b8987b7086 100644 --- a/dev/doc/build-system.txt +++ b/dev/doc/build-system.txt @@ -89,7 +89,7 @@ enables partial recalculation of dependencies (only the dependencies of changed files are recomputed). If you add a dependency to a Coq camlp5 extension (grammar.cma or -q_constr.cmo), then see sections ".ml4 files" and "new files". +q_constr.cmo), then see sections ".mlg files" and "new files". Cleaning Targets ---------------- @@ -113,13 +113,13 @@ Targets for cleaning various parts: - docclean: clean documentation -.ml4/.mlp files +.mlg/.mlp files --------------- There is now two kinds of preprocessed files : - a .mlp do not need grammar.cma (they are in grammar/) - - a .ml4 is now always preprocessed with grammar.cma (and q_constr.cmo), - except coqide_main.ml4 and its specific rule + - a .mlg is now always preprocessed with grammar.cma (and q_constr.cmo), + except coqide_main.mlg and its specific rule This classification replaces the old mechanism of declaring the use of a grammar extension via a line of the form: diff --git a/dev/doc/coq-src-description.txt b/dev/doc/coq-src-description.txt index e5e4f740bd..096ffe6a1c 100644 --- a/dev/doc/coq-src-description.txt +++ b/dev/doc/coq-src-description.txt @@ -20,7 +20,7 @@ Special components grammar : Camlp5 syntax extensions. The file grammar/grammar.cma is used - to pre-process .ml4 files containing EXTEND constructions, + to pre-process .mlg files containing EXTEND constructions, either TACTIC EXTEND, ARGUMENTS EXTEND or VERNAC ... EXTEND. This grammar.cma incorporates many files from other directories (mainly parsing/), plus some specific files in grammar/. diff --git a/dev/doc/critical-bugs b/dev/doc/critical-bugs index 78d7061259..6d90ced12d 100644 --- a/dev/doc/critical-bugs +++ b/dev/doc/critical-bugs @@ -250,6 +250,17 @@ Conversion machines exploit: test-suite/bugs/closed/bug_9684.v GH issue number: #9684 + component: lazy machine + summary: incorrect De Bruijn handling when inferring the relevance mark for a lambda + introduced: 2019-03-15, 23f84f37c674a07e925925b7e0d50d7ee8414093 and 71b9ad8526155020c8451dd326a52e391a9a8585, SkySkimmer + impacted released versions: 8.10.0 + impacted coqchk versions: 8.10.0 + found by: ppedrot investigating unexpected conversion failures with SProp + exploit: test-suite/bugs/closed/bug_10904.v + GH issue number: #10904 + risk: none without using -allow-sprop (off by default in 8.10.0), + otherwise could be exploited by mistake + Conflicts with axioms in library component: library of real numbers diff --git a/dev/doc/release-process.md b/dev/doc/release-process.md index 452160ea5a..1c486b024d 100644 --- a/dev/doc/release-process.md +++ b/dev/doc/release-process.md @@ -2,6 +2,11 @@ ## 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. - [ ] Change the version name to the next major version and the magic @@ -54,25 +59,39 @@ - [ ] 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 to get the list of contributors for this version is - `git shortlog -s -n VX.X+alpha..master | cut -f2 | sort -k 2` - (the ordering is approximative as it will misplace people with middle names). + + 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). - [ ] Remove all remaining unmerged feature PRs from the beta milestone. -- [ ] Start a new project to track PR backporting. The proposed model is to - have a "X.X-only PRs" column for the rare PRs on the stable branch, a - "Request X.X inclusion" column for the PRs that were merged in `master` that - are to be considered for backporting, a "Waiting for CI" column to put the - PRs in the process of being backported, and "Shipped in ..." columns to put - what was backported. (The release manager is the person responsible for - merging PRs that target the version branch and backporting appropriate PRs - that are merged into `master`). - A message to **@coqbot** in the milestone description tells it to - automatically add merged PRs to the "Request X.X inclusion" column. +- [ ] Start a new project to track PR backporting. The project should + have a "Request X.X+beta1 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. + + 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. @@ -80,6 +99,11 @@ ## 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 @@ -120,6 +144,7 @@ ## At the final release time ## +- [ ] Prepare the release notes (see above) - [ ] In a PR: - Change the version name from X.X.0 and the magic numbers (see [#7271](https://github.com/coq/coq/pull/7271/files)). diff --git a/dev/tools/make-changelog.sh b/dev/tools/make-changelog.sh new file mode 100755 index 0000000000..ea96de970a --- /dev/null +++ b/dev/tools/make-changelog.sh @@ -0,0 +1,25 @@ +#!/bin/sh + +echo "PR number" +read -r PR + +echo "Where? (type a prefix)" +(cd doc/changelog && ls -d */) +read -r where + +where=$(echo doc/changelog/"$where"*) +where="$where/$PR-$(git rev-parse --abbrev-ref HEAD).rst" + +# shellcheck disable=SC2016 +# the ` are regular strings, this is intended +# use %s for the leading - to avoid looking like an option (not sure +# if necessary but doesn't hurt) +printf '%s bla bla (`#%s <https://github.com/coq/coq/pull/%s>`_, by %s).' - "$PR" "$PR" "$(git config user.name)" > "$where" + +giteditor=$(git config core.editor) +if [ "$giteditor" ]; then + $giteditor "$where" +elif [ "$EDITOR" ]; then + $EDITOR "$where" +else echo "$where" +fi diff --git a/dev/v8-syntax/syntax-v8.tex b/dev/v8-syntax/syntax-v8.tex index 601d52ddda..2f5c7128e2 100644 --- a/dev/v8-syntax/syntax-v8.tex +++ b/dev/v8-syntax/syntax-v8.tex @@ -727,7 +727,7 @@ Conflicts exists between integers and constrs. \nlsep \TERM{setoid_replace} ~\tacconstr ~\KWD{with} ~\tacconstr \nlsep \TERM{setoid_rewrite} ~\NT{orient} ~\tacconstr \nlsep \TERM{subst} ~\STAR{\NT{ident}} -%% eqdecide.ml4 +%% eqdecide.mlg \nlsep \TERM{decide}~\TERM{equality} ~\OPTGR{\tacconstr~\tacconstr} \nlsep \TERM{compare}~\tacconstr~\tacconstr %% eauto diff --git a/doc/changelog/01-kernel/10811-sprop-default-on.rst b/doc/changelog/01-kernel/10811-sprop-default-on.rst new file mode 100644 index 0000000000..349c44c205 --- /dev/null +++ b/doc/changelog/01-kernel/10811-sprop-default-on.rst @@ -0,0 +1,3 @@ +- Using ``SProp`` is now allowed by default, without needing to pass + ``-allow-sprop`` or use :flag:`Allow StrictProp` (`#10811 + <https://github.com/coq/coq/pull/10811>`_, by Gaëtan Gilbert). diff --git a/doc/changelog/06-ssreflect/10932-void-type-ssr.rst b/doc/changelog/06-ssreflect/10932-void-type-ssr.rst new file mode 100644 index 0000000000..7366ef1190 --- /dev/null +++ b/doc/changelog/06-ssreflect/10932-void-type-ssr.rst @@ -0,0 +1,3 @@ +- Add a :g:`void` notation for the standard library empty type (:g:`Empty_set`) + (`#10932 <https://github.com/coq/coq/pull/10932>`_, by Arthur Azevedo de + Amorim). diff --git a/doc/changelog/07-commands-and-options/10489-print_dependent_evars.rst b/doc/changelog/07-commands-and-options/10489-print_dependent_evars.rst new file mode 100644 index 0000000000..580e808baa --- /dev/null +++ b/doc/changelog/07-commands-and-options/10489-print_dependent_evars.rst @@ -0,0 +1,7 @@ +- Update output generated by :flag:`Printing Dependent Evars Line` flag + used by the Prooftree tool in Proof General. + (`#10489 <https://github.com/coq/coq/pull/10489>`_, + closes `#4504 <https://github.com/coq/coq/issues/4504>`_, + `#10399 <https://github.com/coq/coq/issues/10399>`_ and + `#10400 <https://github.com/coq/coq/issues/10400>`_, + by Jim Fehrle). diff --git a/doc/changelog/10-standard-library/09772-ordered_type-hint-db.rst b/doc/changelog/10-standard-library/09772-ordered_type-hint-db.rst new file mode 100644 index 0000000000..7babcdb6f1 --- /dev/null +++ b/doc/changelog/10-standard-library/09772-ordered_type-hint-db.rst @@ -0,0 +1,4 @@ +- Moved the `auto` hints of the `OrderedType` module into a new `ordered_type` + database + (`#9772 <https://github.com/coq/coq/pull/9772>`_, + by Vincent Laporte). diff --git a/doc/changelog/10-standard-library/10895-master+weak-excluded-middle-de-morgan.rst b/doc/changelog/10-standard-library/10895-master+weak-excluded-middle-de-morgan.rst new file mode 100644 index 0000000000..6e87ff93c7 --- /dev/null +++ b/doc/changelog/10-standard-library/10895-master+weak-excluded-middle-de-morgan.rst @@ -0,0 +1 @@ +- ClassicalFacts: Adding the standard equivalence between weak excluded-middle and the classical instance of De Morgan's law (`#10895 <https://github.com/coq/coq/pull/10895>`_, by Hugo Herbelin). diff --git a/doc/changelog/README.md b/doc/changelog/README.md index 2891eb207e..3e0970a656 100644 --- a/doc/changelog/README.md +++ b/doc/changelog/README.md @@ -7,25 +7,28 @@ otherwise important infrastructure changes, and important bug fixes should get a changelog entry. Compatibility-breaking changes should always get a changelog entry, -which should explain what compatibility-breakage is to expect. +which should explain what compatibility breakage is to expect. Pull requests changing the ML API in significant ways should add an entry in [`dev/doc/changes.md`](../../dev/doc/changes.md). ## How to add an entry? ## -You should create a file in one of the sub-directories. The name of -the file should be `NNNNN-identifier.rst` where `NNNNN` is the number -of the pull request on five digits and `identifier` is whatever you -want. - -This file should use the same format as the reference manual (as it -will be copied in there). You may reference the documentation you just -added with `:ref:`, `:tacn:`, `:cmd:`, `:opt:`, `:token:`, etc. See +Run `./dev/tools/make-changelog.sh`: it will ask you for your PR +number, and to choose among the predefined categories. Afterward, +fill in the automatically generated entry with a short description of +your change (which should describe any compatibility issues in +particular). You may also add a reference to the relevant fixed +issue, and credit reviewers, co-authors, and anyone who helped advance +the PR. + +The format for changelog entries is the same as in the reference +manual. In particular, you may reference the documentation you just +added with `:ref:`, `:tacn:`, `:cmd:`, `:opt:`, `:token:`, etc. See the [documentation of the Sphinx format](../sphinx/README.rst) of the manual for details. -The entry should be written using the following structure: +Here is a summary of the structure of a changelog entry: ``` rst - Description of the changes, with possible link to @@ -35,7 +38,3 @@ The entry should be written using the following structure: [ and `#ISSUE2 <https://github.com/coq/coq/issues/ISSUE2>`_],] by Full Name[, with help / review of Full Name]). ``` - -The description should be kept rather short and the only additional -required meta-information are the link to the pull request and the -full name of the author. diff --git a/doc/plugin_tutorial/tuto1/src/simple_declare.ml b/doc/plugin_tutorial/tuto1/src/simple_declare.ml index 9dd4700db5..307214089f 100644 --- a/doc/plugin_tutorial/tuto1/src/simple_declare.ml +++ b/doc/plugin_tutorial/tuto1/src/simple_declare.ml @@ -9,4 +9,4 @@ let edeclare ?hook ~name ~poly ~scope ~kind ~opaque sigma udecl body tyopt imps let declare_definition ~poly name sigma body = let udecl = UState.default_univ_decl in edeclare ~name ~poly ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) - ~kind:Decls.Definition ~opaque:false sigma udecl body None [] + ~kind:Decls.(IsDefinition Definition) ~opaque:false sigma udecl body None [] diff --git a/doc/sphinx/addendum/sprop.rst b/doc/sphinx/addendum/sprop.rst index 8935ba27e3..9a9ec78edc 100644 --- a/doc/sphinx/addendum/sprop.rst +++ b/doc/sphinx/addendum/sprop.rst @@ -9,15 +9,16 @@ SProp (proof irrelevant propositions) This section describes the extension of |Coq| with definitionally proof irrelevant propositions (types in the sort :math:`\SProp`, also -known as strict propositions). To use :math:`\SProp` you must pass -``-allow-sprop`` to the |Coq| program or use :flag:`Allow StrictProp`. +known as strict propositions). Using :math:`\SProp` may be prevented +by passing ``-disallow-sprop`` to the |Coq| program or using +:flag:`Allow StrictProp`. .. flag:: Allow StrictProp :name: Allow StrictProp Allows using :math:`\SProp` when set and forbids it when unset. The initial value depends on whether you used the command line - ``-allow-sprop``. + ``-disallow-sprop`` and ``-allow-sprop``. .. exn:: SProp not allowed, you need to Set Allow StrictProp or to use the -allow-sprop command-line-flag. :undocumented: diff --git a/doc/sphinx/addendum/universe-polymorphism.rst b/doc/sphinx/addendum/universe-polymorphism.rst index 1d0b732e7d..905068e316 100644 --- a/doc/sphinx/addendum/universe-polymorphism.rst +++ b/doc/sphinx/addendum/universe-polymorphism.rst @@ -507,17 +507,45 @@ underscore or by omitting the annotation to a polymorphic definition. Universe polymorphism and sections ---------------------------------- -The universe polymorphic or monomorphic status is -attached to each individual section, and all term or universe declarations -contained inside must respect it, as described below. It is possible to nest a -polymorphic section inside a monomorphic one, but the converse is not allowed. - -:cmd:`Variables`, :cmd:`Context`, :cmd:`Universe` and :cmd:`Constraint` in a section support -polymorphism. This means that the universe variables and their associated -constraints are discharged polymorphically over definitions that use -them. In other words, two definitions in the section sharing a common -variable will both get parameterized by the universes produced by the -variable declaration. This is in contrast to a “mononorphic” variable -which introduces global universes and constraints, making the two -definitions depend on the *same* global universes associated to the -variable. +:cmd:`Variables`, :cmd:`Context`, :cmd:`Universe` and +:cmd:`Constraint` in a section support polymorphism. This means that +the universe variables and their associated constraints are discharged +polymorphically over definitions that use them. In other words, two +definitions in the section sharing a common variable will both get +parameterized by the universes produced by the variable declaration. +This is in contrast to a “mononorphic” variable which introduces +global universes and constraints, making the two definitions depend on +the *same* global universes associated to the variable. + +It is possible to mix universe polymorphism and monomorphism in +sections, except in the following ways: + +- no monomorphic constraint may refer to a polymorphic universe: + + .. coqtop:: all reset + + Section Foo. + + Polymorphic Universe i. + Fail Constraint i = i. + + This includes constraints implictly declared by commands such as + :cmd:`Variable`, which may as a such need to be used with universe + polymorphism activated (locally by attribute or globally by option): + + .. coqtop:: all + + Fail Variable A : (Type@{i} : Type). + Polymorphic Variable A : (Type@{i} : Type). + + (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 + 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 +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 38b3c34209..80a24b997c 100644 --- a/doc/sphinx/changes.rst +++ b/doc/sphinx/changes.rst @@ -198,21 +198,21 @@ Melquiond, Matthieu Sozeau, Enrico Tassi (who migrated it to opam 2) with contributions from many users. A list of packages is available at https://coq.inria.fr/opam/www/. -The 61 contributors to this version are David A. Dalrymple, Tanaka -Akira, Benjamin Barenblat, Yves Bertot, Frédéric Besson, Lasse -Blaauwbroek, Martin Bodin, Joachim Breitner, Tej Chajed, Frédéric -Chapoton, Arthur Charguéraud, Cyril Cohen, Lukasz Czajka, Christian -Doczkal, Maxime Dénès, Andres Erbsen, Jim Fehrle, Gaëtan Gilbert, Matěj -Grabovský, Simon Gregersen, Jason Gross, Samuel Gruetter, Hugo Herbelin, -Jasper Hugunin, Mirai Ikebuchi, Emilio Jesus Gallego Arias, Chantal -Keller, Matej Košík, Vincent Laporte, Olivier Laurent, Larry Darryl Lee -Jr, Pierre Letouzey, Nick Lewycky, Yao Li, Yishuai Li, Xia Li-yao, Assia -Mahboubi, Simon Marechal, Erik Martin-Dorel, Thierry Martinez, Guillaume -Melquiond, Kayla Ngan, Sam Pablo Kuper, Karl Palmskog, Clément -Pit-Claudel, Pierre-Marie Pédrot, Pierre Roux, Kazuhiko Sakaguchi, Ryan -Scott, Vincent Semeria, Gan Shen, Michael Soegtrop, Matthieu Sozeau, -Enrico Tassi, Laurent Théry, Kamil Trzciński, whitequark, Théo -Winterhalter, Beta Ziliani and Théo Zimmermann. +The 61 contributors to this version are Tanaka Akira, Benjamin +Barenblat, Yves Bertot, Frédéric Besson, Lasse Blaauwbroek, Martin +Bodin, Joachim Breitner, Tej Chajed, Frédéric Chapoton, Arthur +Charguéraud, Cyril Cohen, Lukasz Czajka, David A. Dalrymple, Christian +Doczkal, Maxime Dénès, Andres Erbsen, Jim Fehrle, Emilio Jesus Gallego +Arias, Gaëtan Gilbert, Matěj Grabovský, Simon Gregersen, Jason Gross, +Samuel Gruetter, Hugo Herbelin, Jasper Hugunin, Mirai Ikebuchi, +Chantal Keller, Matej Košík, Sam Pablo Kuper, Vincent Laporte, Olivier +Laurent, Larry Darryl Lee Jr, Nick Lewycky, Yao Li, Yishuai Li, Assia +Mahboubi, Simon Marechal, Erik Martin-Dorel, Thierry Martinez, +Guillaume Melquiond, Kayla Ngan, Karl Palmskog, Pierre-Marie Pédrot, +Clément Pit-Claudel, Pierre Roux, Kazuhiko Sakaguchi, Ryan Scott, +Vincent Semeria, Gan Shen, Michael Soegtrop, Matthieu Sozeau, Enrico +Tassi, Laurent Théry, Kamil Trzciński, whitequark, Théo Winterhalter, +Xia Li-yao, Beta Ziliani and Théo Zimmermann. Many power users helped to improve the design of the new features via the issue and pull request system, the |Coq| development mailing list, @@ -718,6 +718,53 @@ Changes in 8.10+beta3 follow-up of `#8365 <https://github.com/coq/coq/pull/8365>`_, which added ``uncons`` in 8.10+beta1). +Changes in 8.10.0 +~~~~~~~~~~~~~~~~~ + +- Micromega tactics (:tacn:`lia`, :tacn:`nia`, etc) are no longer confused by + primitive projections (`#10806 <https://github.com/coq/coq/pull/10806>`_, + fixes `#9512 <https://github.com/coq/coq/issues/9512>`_ + by Vincent Laporte). + +Changes in 8.10.1 +~~~~~~~~~~~~~~~~~ + +A few bug fixes and documentation improvements, in particular: + +**Kernel** + +- Fix proof of False when using |SProp| (incorrect De Bruijn handling + when inferring the relevance mark of a function) (`#10904 + <https://github.com/coq/coq/pull/10904>`_, by Pierre-Marie Pédrot). + +**Tactics** + +- Fix an anomaly when unsolved evar in :cmd:`Add Ring` + (`#10891 <https://github.com/coq/coq/pull/10891>`_, + fixes `#9851 <https://github.com/coq/coq/issues/9851>`_, + by Gaëtan Gilbert). + +**Tactic language** + +- Fix Ltac regression in binding free names in uconstr + (`#10899 <https://github.com/coq/coq/pull/10899>`_, + fixes `#10894 <https://github.com/coq/coq/issues/10894>`_, + by Hugo Herbelin). + +**CoqIDE** + +- Fix handling of unicode input before space + (`#10852 <https://github.com/coq/coq/pull/10852>`_, + fixes `#10842 <https://github.com/coq/coq/issues/10842>`_, + by Arthur Charguéraud). + +**Extraction** + +- Fix custom extraction of inductives to JSON + (`#10897 <https://github.com/coq/coq/pull/10897>`_, + fixes `#4741 <https://github.com/coq/coq/issues/4741>`_, + by Helge Bahmann). + Version 8.9 ----------- diff --git a/doc/sphinx/language/cic.rst b/doc/sphinx/language/cic.rst index 1611e9dd52..c08a9ed0e6 100644 --- a/doc/sphinx/language/cic.rst +++ b/doc/sphinx/language/cic.rst @@ -1147,7 +1147,7 @@ Conversion is preserved as any (partial) instance :math:`I_j~q_1 … q_r` or Polymorphism`. An inductive type can be forced to be template polymorphic using the - ``template`` attribute: it should then fullfill the criterion to + ``template`` attribute: it should then fulfill the criterion to be template polymorphic or an error is raised. .. exn:: Inductive @ident cannot be made template polymorphic. diff --git a/doc/sphinx/language/gallina-extensions.rst b/doc/sphinx/language/gallina-extensions.rst index dc4f91e66b..f477bf239d 100644 --- a/doc/sphinx/language/gallina-extensions.rst +++ b/doc/sphinx/language/gallina-extensions.rst @@ -182,7 +182,7 @@ other arguments are the parameters of the inductive type. recursive (references to the record's name in the type of its field raises an error). To define recursive records, one can use the ``Inductive`` and ``CoInductive`` keywords, resulting in an inductive or co-inductive record. - Definition of mutal inductive or co-inductive records are also allowed, as long + Definition of mutually inductive or co-inductive records are also allowed, as long as all of the types in the block are records. .. note:: Induction schemes are automatically generated for inductive records. @@ -638,7 +638,11 @@ the induction principle to easily reason about the function. than like this: - .. coqtop:: reset all + .. coqtop:: reset none + + Require Import FunInd. + + .. coqtop:: all Function plus (n m : nat) {struct n} : nat := match n with @@ -649,17 +653,22 @@ the induction principle to easily reason about the function. *Limitations* -|term_0| must be built as a *pure pattern matching tree* (:g:`match … with`) +:token:`term` must be built as a *pure pattern matching tree* (:g:`match … with`) with applications only *at the end* of each branch. Function does not support partial application of the function being defined. Thus, the following example cannot be accepted due to the presence of partial application of :g:`wrong` in the body of :g:`wrong`: -.. coqtop:: all +.. coqtop:: none + + Require List. + Import List.ListNotations. + +.. coqtop:: all fail - Fail Function wrong (C:nat) : nat := - List.hd 0 (List.map wrong (C::nil)). + Function wrong (C:nat) : nat := + List.hd 0 (List.map wrong (C::nil)). For now, dependent cases are not treated for non structurally terminating functions. @@ -1406,7 +1415,7 @@ is needed. In this translation, names in the file system are called *physical* paths while |Coq| names are contrastingly called *logical* names. -A logical prefix Lib can be associated to a physical pathpath using +A logical prefix Lib can be associated with a physical path using the command line option ``-Q`` `path` ``Lib``. All subfolders of path are recursively associated to the logical path ``Lib`` extended with the corresponding suffix coming from the physical path. For instance, the diff --git a/doc/sphinx/language/gallina-specification-language.rst b/doc/sphinx/language/gallina-specification-language.rst index 2cbd41af8b..ae9d284661 100644 --- a/doc/sphinx/language/gallina-specification-language.rst +++ b/doc/sphinx/language/gallina-specification-language.rst @@ -111,7 +111,7 @@ Other tokens tokens defined at any given time can vary because the :cmd:`Notation` command can define new tokens. A :cmd:`Require` command may load more notation definitions, while the end of a :cmd:`Section` may remove notations. Some notations - are defined in the basic library (see :ref:`thecoqlibrary`) and are normallly + are defined in the basic library (see :ref:`thecoqlibrary`) and are normally loaded automatically at startup time. Here are the character sequences that Coq directly defines as tokens @@ -395,7 +395,7 @@ stands for :n:`let @ident := fun {+ @binder} => @term in @term’`. Definition by case analysis --------------------------- -Objects of inductive types can be destructurated by a case-analysis +Objects of inductive types can be destructured by a case-analysis construction called *pattern matching* expression. A pattern matching expression is used to analyze the structure of an inductive object and to apply specific treatments accordingly. @@ -572,7 +572,7 @@ The Vernacular assertion : `assertion_keyword` `ident` [`binders`] : `term` . assertion_keyword : Theorem | Lemma : Remark | Fact - : Corollary | Proposition + : Corollary | Property | Proposition : Definition | Example proof : Proof . … Qed . : Proof . … Defined . diff --git a/doc/sphinx/practical-tools/utilities.rst b/doc/sphinx/practical-tools/utilities.rst index 47ecfb9db0..e5edd08995 100644 --- a/doc/sphinx/practical-tools/utilities.rst +++ b/doc/sphinx/practical-tools/utilities.rst @@ -62,7 +62,7 @@ A simple example of a ``_CoqProject`` file follows: theories/foo.v theories/bar.v -I src/ - src/baz.ml4 + src/baz.mlg src/bazaux.ml src/qux_plugin.mlpack @@ -111,7 +111,7 @@ decide how to build them. In particular: + |Coq| files must use the ``.v`` extension + |OCaml| files must use the ``.ml`` or ``.mli`` extension + |OCaml| files that require pre processing for syntax - extensions (like ``VERNAC EXTEND``) must use the ``.ml4`` extension + extensions (like ``VERNAC EXTEND``) must use the ``.mlg`` extension + In order to generate a plugin one has to list all |OCaml| modules (i.e. ``Baz`` for ``baz.ml``) in a ``.mlpack`` file (or ``.mllib`` file). @@ -359,7 +359,7 @@ line timing data: pass ``TIMING=before`` or ``TIMING=after`` rather than ``TIMING=1``. .. note:: - The sorting used here is the same as in the ``print-pretty-timed -diff`` target. + The sorting used here is the same as in the ``print-pretty-timed-diff`` target. .. note:: This target requires python to build the table. diff --git a/doc/sphinx/proof-engine/ltac.rst b/doc/sphinx/proof-engine/ltac.rst index 362c3da6cb..79eddbd3b5 100644 --- a/doc/sphinx/proof-engine/ltac.rst +++ b/doc/sphinx/proof-engine/ltac.rst @@ -368,7 +368,7 @@ We can check if a tactic made progress with: :name: progress :n:`@ltac_expr` is evaluated to v which must be a tactic value. The tactic value ``v`` - is applied to each focued subgoal independently. If the application of ``v`` + is applied to each focused subgoal independently. If the application of ``v`` to one of the focused subgoal produced subgoals equal to the initial goals (up to syntactical equality), then an error of level 0 is raised. diff --git a/doc/sphinx/proof-engine/ltac2.rst b/doc/sphinx/proof-engine/ltac2.rst index 045d028d02..18d2c79461 100644 --- a/doc/sphinx/proof-engine/ltac2.rst +++ b/doc/sphinx/proof-engine/ltac2.rst @@ -853,6 +853,9 @@ a Ltac1 expression, and semantics of this quotation is the evaluation of the corresponding code for its side effects. In particular, it cannot return values, and the quotation has type :n:`unit`. +.. productionlist:: coq + ltac2_term : ltac1 : ( `ltac_expr` ) + Ltac1 **cannot** implicitly access variables from the Ltac2 scope, but this can be done with an explicit annotation on the :n:`ltac1` quotation. @@ -890,10 +893,19 @@ Ltac2 from Ltac1 Same as above by switching Ltac1 by Ltac2 and using the `ltac2` quotation instead. -Note that the tactic expression is evaluated eagerly, if one wants to use it as -an argument to a Ltac1 function, one has to resort to the good old -:n:`idtac; ltac2:(foo)` trick. For instance, the code below will fail immediately -and won't print anything. +.. productionlist:: coq + ltac_expr : ltac2 : ( `ltac2_term` ) + : ltac2 : ( `ident` ... `ident` |- `ltac2_term` ) + +The typing rules are dual, that is, the optional identifiers are bound +with type `Ltac2.Ltac1.t` in the Ltac2 expression, which is expected to have +type unit. The value returned by this quotation is an Ltac1 function with the +same arity as the number of bound variables. + +Note that when no variables are bound, the inner tactic expression is evaluated +eagerly, if one wants to use it as an argument to a Ltac1 function, one has to +resort to the good old :n:`idtac; ltac2:(foo)` trick. For instance, the code +below will fail immediately and won't print anything. .. coqtop:: in @@ -902,11 +914,17 @@ and won't print anything. .. coqtop:: all - Ltac mytac tac := idtac "wow"; tac. + Ltac mytac tac := idtac "I am being evaluated"; tac. Goal True. Proof. + (* Doesn't print anything *) Fail mytac ltac2:(fail). + (* Prints and fails *) + Fail mytac ltac:(idtac; ltac2:(fail)). + +In any case, the value returned by the fully applied quotation is an +unspecified dummy Ltac1 closure and should not be further used. Transition from Ltac1 --------------------- diff --git a/doc/sphinx/proof-engine/proof-handling.rst b/doc/sphinx/proof-engine/proof-handling.rst index 03b30d5d97..57a54bc0ad 100644 --- a/doc/sphinx/proof-engine/proof-handling.rst +++ b/doc/sphinx/proof-engine/proof-handling.rst @@ -538,13 +538,11 @@ Requesting information .. cmdv:: Show Proof :name: Show Proof - It displays the proof term generated by the tactics - that have been applied. If the proof is not completed, this term - contain holes, which correspond to the sub-terms which are still to be - constructed. These holes appear as a question mark indexed by an - integer, and applied to the list of variables in the context, since it - may depend on them. The types obtained by abstracting away the context - from the type of each placeholder are also printed. + Displays the proof term generated by the tactics + that have been applied so far. If the proof is incomplete, the term + will contain holes, which correspond to subterms which are still to be + constructed. Each hole is an existential variable, which appears as a + question mark followed by an identifier. .. cmdv:: Show Conjectures :name: Show Conjectures @@ -574,9 +572,8 @@ Requesting information .. cmdv:: Show Existentials :name: Show Existentials - It displays the set of all uninstantiated - existential variables in the current proof tree, along with the type - and the context of each variable. + Displays all open goals / existential variables in the current proof + along with the type and the context of each variable. .. cmdv:: Show Match @ident diff --git a/doc/sphinx/proof-engine/ssreflect-proof-language.rst b/doc/sphinx/proof-engine/ssreflect-proof-language.rst index ed980bd4de..75897fec45 100644 --- a/doc/sphinx/proof-engine/ssreflect-proof-language.rst +++ b/doc/sphinx/proof-engine/ssreflect-proof-language.rst @@ -514,7 +514,7 @@ is a valid tactic expression. The pose tactic is also improved for the local definition of higher order terms. Local definitions of functions can use the same syntax as global ones. -For example, the tactic :tacn:`pose <pose (ssreflect)>` supoprts parameters: +For example, the tactic :tacn:`pose <pose (ssreflect)>` supports parameters: .. example:: @@ -684,7 +684,7 @@ conditions: + If this head is a projection of a canonical structure, then canonical structure equations are used for the matching. + If the head of term is *not* a constant, the subterm should have the - same structure (λ abstraction,let…in structure …). + same structure (λ abstraction, let…in structure …). + If the head of :token:`term` is a hole, the subterm should have at least as many arguments as :token:`term`. @@ -1151,7 +1151,7 @@ is basically equivalent to move: a H1 H2; tactic => a H1 H2. -with two differences: the in tactical will preserve the body of a ifa +with two differences: the in tactical will preserve the body of an if a is a defined constant, and if the ``*`` is omitted it will use a temporary abbreviation to hide the statement of the goal from ``tactic``. @@ -1706,7 +1706,7 @@ Intro patterns execution of tactic should thus generate exactly m subgoals, unless the ``[…]`` :token:`i_pattern` comes after an initial ``//`` or ``//=`` :token:`s_item` that closes some of the goals produced by ``tactic``, in - which case exactly m subgoals should remain after thes- item, or we have + which case exactly m subgoals should remain after the :token:`s_item`, or we have the trivial branching :token:`i_pattern` [], which always does nothing, regardless of the number of remaining subgoals. ``[`` :token:`i_item` * ``| … |`` :token:`i_item` * ``]`` @@ -2240,8 +2240,8 @@ then the tactic tactic ; last k [ tactic1 |…| tacticm ] || tacticn. -where natural denotes the integer k as above, applies tactic1 to the n -−k + 1-th goal, … tacticm to the n −k + 2 − m-th goal and tactic n +where natural denotes the integer :math:`k` as above, applies tactic1 to the +:math:`n−k+1`\-th goal, … tacticm to the :math:`n−k+2`\-th goal and tacticn to the others. .. example:: @@ -2631,7 +2631,7 @@ The :token:`i_item` and :token:`s_item` can be used to interpret the asserted hypothesis with views (see section :ref:`views_and_reflection_ssr`) or simplify the resulting goals. -The ``have`` tactic also supports a ``suff`` modifier which allows for +The :tacn:`have` tactic also supports a ``suff`` modifier which allows for asserting that a given statement implies the current goal without copying the goal itself. @@ -2651,7 +2651,7 @@ compatible with the presence of a list of binders. Generating let in context entries with have ``````````````````````````````````````````` -Since |SSR| 1.5 the ``have`` tactic supports a “transparent” modifier +Since |SSR| 1.5 the :tacn:`have` tactic supports a “transparent” modifier to generate let in context entries: the ``@`` symbol in front of the context entry name. @@ -2670,7 +2670,7 @@ context entry name. Lemma test n m (H : m + 1 < n) : True. have @i : 'I_n by apply: (Sub m); omega. -Note that the sub-term produced by ``omega`` is in general huge and +Note that the subterm produced by :tacn:`omega` is in general huge and uninteresting, and hence one may want to hide it. For this purpose the ``[: name ]`` intro pattern and the tactic ``abstract`` (see :ref:`abstract_ssr`) are provided. @@ -2782,7 +2782,7 @@ The ``have`` and ``suff`` tactics are equivalent and have the same syntax but: -+ the order of the generated subgoals is inversed ++ the order of the generated subgoals is inverted + the optional clear item is still performed in the *second* branch. This means that the tactic: @@ -4583,7 +4583,7 @@ The ``elim/`` tactic distinguishes two cases: passed to the eliminator as the last argument (``x`` in ``foo_ind``) and ``en−1 … e1`` are used as patterns to select in the goal the occurrences that will be bound by the predicate ``P``, thus it must be possible to unify - the sub-term of the goal matched by ``en−1`` with ``pm`` , the one matched + the subterm of the goal matched by ``en−1`` with ``pm`` , the one matched by ``en−2`` with ``pm−1`` and so on. :regular eliminator: in all the other cases. Here it must be possible to unify the term matched by ``en`` with ``pm`` , the one matched by @@ -5451,7 +5451,7 @@ equivalences are indeed taken into account, otherwise only single name of an open module. This command returns the list of lemmas: + whose *conclusion* contains a subterm matching the optional first - pattern. A - reverses the test, producing the list of lemmas whose + pattern. A ``-`` reverses the test, producing the list of lemmas whose conclusion does not contain any subterm matching the pattern; + whose name contains the given string. A ``-`` prefix reverses the test, producing the list of lemmas whose name does not contain the string. A diff --git a/doc/sphinx/proof-engine/tactics.rst b/doc/sphinx/proof-engine/tactics.rst index fa6d62ffa2..78753fc053 100644 --- a/doc/sphinx/proof-engine/tactics.rst +++ b/doc/sphinx/proof-engine/tactics.rst @@ -157,10 +157,10 @@ The :n:`eqn:` construct in various tactics uses :n:`@naming_intropattern`. Use these elementary patterns to specify a name: -* :n:`@ident` - use the specified name -* :n:`?` - let Coq choose a name -* :n:`?@ident` - generate a name that begins with :n:`@ident` -* :n:`_` - discard the matched part (unless it is required for another +* :n:`@ident` — use the specified name +* :n:`?` — let Coq choose a name +* :n:`?@ident` — generate a name that begins with :n:`@ident` +* :n:`_` — discard the matched part (unless it is required for another hypothesis) * if a disjunction pattern omits a name, such as :g:`[|H2]`, Coq will choose a name @@ -186,7 +186,7 @@ use the :tacn:`split` tactic to replace the current goal with subgoals :g:`A` an For a goal :g:`A \/ B`, use :tacn:`left` to replace the current goal with :g:`A`, or :tacn:`right` to replace the current goal with :g:`B`. -* :n:`( {+, @simple_intropattern}` ) - matches +* :n:`( {+, @simple_intropattern}` ) — matches a product over an inductive type with a :ref:`single constructor <intropattern_cons_note>`. If the number of patterns @@ -196,7 +196,7 @@ For a goal :g:`A \/ B`, use :tacn:`left` to replace the current goal with :g:`A` If the number of patterns equals the number of constructor arguments plus the number of :n:`let-ins`, the patterns are applied to the arguments and :n:`let-in` variables. -* :n:`( {+& @simple_intropattern} )` - matches a right-hand nested term that consists +* :n:`( {+& @simple_intropattern} )` — matches a right-hand nested term that consists of one or more nested binary inductive types such as :g:`a1 OP1 a2 OP2 ...` (where the :g:`OPn` are right-associative). (If the :g:`OPn` are left-associative, additional parentheses will be needed to make the @@ -207,15 +207,15 @@ For a goal :g:`A \/ B`, use :tacn:`left` to replace the current goal with :g:`A` :ref:`single constructor with two parameters <intropattern_cons_note>`. :ref:`Example <intropattern_ampersand_ex>` -* :n:`[ {+| @intropattern_list} ]` - splits an inductive type that has +* :n:`[ {+| @intropattern_list} ]` — splits an inductive type that has :ref:`multiple constructors <intropattern_cons_note>` such as :n:`A \/ B` into multiple subgoals. The number of :token:`intropattern_list` must be the same as the number of constructors for the matched part. -* :n:`[ {+ @intropattern} ]` - splits an inductive type that has a +* :n:`[ {+ @intropattern} ]` — splits an inductive type that has a :ref:`single constructor with multiple parameters <intropattern_cons_note>` such as :n:`A /\ B` into multiple hypotheses. Use :n:`[H1 [H2 H3]]` to match :g:`A /\ B /\ C`. -* :n:`[]` - splits an inductive type: If the inductive +* :n:`[]` — splits an inductive type: If the inductive type has multiple constructors, such as :n:`A \/ B`, create one subgoal for each constructor. If the inductive type has a single constructor with multiple parameters, such as :n:`A /\ B`, split it into multiple hypotheses. @@ -224,14 +224,14 @@ For a goal :g:`A \/ B`, use :tacn:`left` to replace the current goal with :g:`A` These patterns can be used when the hypothesis is an equality: -* :n:`->` - replaces the right-hand side of the hypothesis with the left-hand +* :n:`->` — replaces the right-hand side of the hypothesis with the left-hand side of the hypothesis in the conclusion of the goal; the hypothesis is cleared; if the left-hand side of the hypothesis is a variable, it is substituted everywhere in the context and the variable is removed. :ref:`Example <intropattern_rarrow_ex>` -* :n:`<-` - similar to :n:`->`, but replaces the left-hand side of the hypothesis +* :n:`<-` — similar to :n:`->`, but replaces the left-hand side of the hypothesis with the right-hand side of the hypothesis. -* :n:`[= {*, @intropattern} ]` - If the product is over an equality type, +* :n:`[= {*, @intropattern} ]` — If the product is over an equality type, applies either :tacn:`injection` or :tacn:`discriminate`. If :tacn:`injection` is applicable, the intropattern is used on the hypotheses generated by :tacn:`injection`. If the @@ -241,16 +241,16 @@ These patterns can be used when the hypothesis is an equality: **Other patterns** -* :n:`*` - introduces one or more quantified variables from the result +* :n:`*` — introduces one or more quantified variables from the result until there are no more quantified variables. :ref:`Example <intropattern_star_ex>` -* :n:`**` - introduces one or more quantified variables or hypotheses from the result until there are +* :n:`**` — introduces one or more quantified variables or hypotheses from the result until there are no more quantified variables or implications (:g:`->`). :g:`intros **` is equivalent to :g:`intros`. :ref:`Example <intropattern_2stars_ex>` -* :n:`@simple_intropattern_closed {* % @term}` - first applies each of the terms +* :n:`@simple_intropattern_closed {* % @term}` — first applies each of the terms with the :tacn:`apply ... in` tactic on the hypothesis to be introduced, then it uses :n:`@simple_intropattern_closed`. :ref:`Example <intropattern_injection_ex>` @@ -1409,7 +1409,7 @@ Controlling the proof flow While the different variants of :tacn:`assert` expect that no existential variables are generated by the tactic, :tacn:`eassert` removes this constraint. - This allows not to specify the asserted statement completeley before starting + This lets you avoid specifying the asserted statement completely before starting to prove it. .. tacv:: pose proof @term {? as @simple_intropattern} @@ -1555,8 +1555,8 @@ name of the variable (here :g:`n`) is chosen based on :g:`T`. :name: instantiate The instantiate tactic refines (see :tacn:`refine`) an existential variable - :n:`@ident` with the term :n:`@term`. It is equivalent to only [ident]: - :n:`refine @term` (preferred alternative). + :n:`@ident` with the term :n:`@term`. It is equivalent to + :n:`only [ident]: refine @term` (preferred alternative). .. note:: To be able to refer to an existential variable by name, the user must have given the name explicitly (see :ref:`Existential-Variables`). @@ -2008,7 +2008,7 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) .. coqtop:: reset all - Lemma le_minus : forall n:nat, n < 1 -> n = 0. + Lemma lt_1_r : forall n:nat, n < 1 -> n = 0. intros n H ; induction H. Here we did not get any information on the indexes to help fulfill @@ -2020,7 +2020,7 @@ analysis on inductive or co-inductive objects (see :ref:`inductive-definitions`) .. coqtop:: reset all Require Import Coq.Program.Equality. - Lemma le_minus : forall n:nat, n < 1 -> n = 0. + Lemma lt_1_r : forall n:nat, n < 1 -> n = 0. intros n H ; dependent induction H. The subgoal is cleaned up as the tactic tries to automatically @@ -2691,7 +2691,7 @@ simply :g:`t=u` dropping the implicit type of :g:`t` and :g:`u`. This tactic applies to any goal. The type of :token:`term` must have the form - ``forall (x``:sub:`1` ``:A``:sub:`1` ``) ... (x``:sub:`n` ``:A``:sub:`n` ``). eq term``:sub:`1` ``term``:sub:`2` ``.`` + ``forall (x``:sub:`1` ``:A``:sub:`1` ``) ... (x``:sub:`n` ``:A``:sub:`n` ``), eq term``:sub:`1` ``term``:sub:`2` ``.`` where :g:`eq` is the Leibniz equality or a registered setoid equality. @@ -3005,7 +3005,7 @@ the conversion in hypotheses :n:`{+ @ident}`. 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 + :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 @@ -3049,18 +3049,18 @@ the conversion in hypotheses :n:`{+ @ident}`. This is a synonym for ``lazy beta delta iota zeta``. -.. tacv:: compute {+ @qualid} - cbv {+ @qualid} +.. tacv:: compute [ {+ @qualid} ] + cbv [ {+ @qualid} ] These are synonyms of :n:`cbv beta delta {+ @qualid} iota zeta`. -.. tacv:: compute -{+ @qualid} - cbv -{+ @qualid} +.. tacv:: compute - [ {+ @qualid} ] + cbv - [ {+ @qualid} ] These are synonyms of :n:`cbv beta delta -{+ @qualid} iota zeta`. -.. tacv:: lazy {+ @qualid} - lazy -{+ @qualid} +.. tacv:: lazy [ {+ @qualid} ] + lazy - [ {+ @qualid} ] These are respectively synonyms of :n:`lazy beta delta {+ @qualid} iota zeta` and :n:`lazy beta delta -{+ @qualid} iota zeta`. @@ -3071,7 +3071,7 @@ the conversion in hypotheses :n:`{+ @ident}`. 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 - ``cbv`` tactic, but it cannot be fine-tuned. It is specially interesting for + :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. @@ -3080,14 +3080,14 @@ the conversion in hypotheses :n:`{+ @ident}`. 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 ``vm_compute``. Note however that the + 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. .. flag:: NativeCompute Profiling On Linux, if you have the ``perf`` profiler installed, this option makes - it possible to profile ``native_compute`` evaluations. + it possible to profile :tacn:`native_compute` evaluations. .. opt:: NativeCompute Profile Filename @string :name: NativeCompute Profile Filename @@ -3097,7 +3097,7 @@ the conversion in hypotheses :n:`{+ @ident}`. 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 - ``native_compute`` in a script. From the Linux command line, run ``perf report`` + :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. @@ -3153,14 +3153,15 @@ the conversion in hypotheses :n:`{+ @ident}`. use the name of the constant the (co)fixpoint comes from instead of the (co)fixpoint definition in recursive calls. - The ``cbn`` tactic is claimed to be a more principled, faster and more - predictable replacement for ``simpl``. + The :tacn:`cbn` tactic is claimed to be a more principled, faster and more + predictable replacement for :tacn:`simpl`. - The ``cbn`` tactic accepts the same flags as ``cbv`` and ``lazy``. The - behavior of both ``simpl`` and ``cbn`` can be tuned using the - Arguments vernacular command as follows: + 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 Arguments vernacular command as follows: - + A constant can be marked to be never unfolded by ``cbn`` or ``simpl``: + + A constant can be marked to be never unfolded by :tacn:`cbn` or + :tacn:`simpl`: .. example:: @@ -3169,7 +3170,7 @@ the conversion in hypotheses :n:`{+ @ident}`. Arguments minus n m : simpl never. After that command an expression like :g:`(minus (S x) y)` is left - untouched by the tactics ``cbn`` and ``simpl``. + untouched by the tactics :tacn:`cbn` and :tacn:`simpl`. + A constant can be marked to be unfolded only if applied to enough arguments. The number of arguments required can be specified using the @@ -3184,7 +3185,7 @@ the conversion in hypotheses :n:`{+ @ident}`. Notation "f \o g" := (fcomp f g) (at level 50). After that command the expression :g:`(f \o g)` is left untouched by - ``simpl`` while :g:`((f \o g) t)` is reduced to :g:`(f (g t))`. + :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. always unfolded. @@ -3206,7 +3207,7 @@ the conversion in hypotheses :n:`{+ @ident}`. Arguments minus !n !m. After that command, the expression :g:`(minus (S x) y)` is left untouched - by ``simpl``, while :g:`(minus (S x) (S y))` is reduced to :g:`(minus x y)`. + by :tacn:`simpl`, while :g:`(minus (S x) (S y))` is reduced to :g:`(minus x y)`. + A special heuristic to determine if a constant has to be unfolded can be activated with the following command: @@ -3222,25 +3223,25 @@ the conversion in hypotheses :n:`{+ @ident}`. :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 ``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 ``simpl`` on + 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 :g:`(plus n O) = n` changes nothing. Notice that only transparent constants whose name can be reused in the - recursive calls are possibly unfolded by ``simpl``. For instance a + 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 ``simpl`` and ``cbn``. - The tactic ``cbn`` reduces whenever it will be able to reuse it or not: + 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`. -.. tacv:: cbn {+ @qualid} - cbn -{+ @qualid} +.. tacv:: cbn [ {+ @qualid} ] + cbn - [ {+ @qualid} ] - These are respectively synonyms of :n:`cbn beta delta {+ @qualid} iota zeta` - and :n:`cbn beta delta -{+ @qualid} iota zeta` (see :tacn:`cbn`). + These are respectively synonyms of :n:`cbn beta delta [ {+ @qualid} ] iota zeta` + and :n:`cbn beta delta - [ {+ @qualid} ] iota zeta` (see :tacn:`cbn`). .. tacv:: simpl @pattern @@ -3249,7 +3250,7 @@ the conversion in hypotheses :n:`{+ @ident}`. .. tacv:: simpl @pattern at {+ @num} - This applies ``simpl`` only to the :n:`{+ @num}` occurrences of the subterms + This applies :tacn:`simpl` only to the :n:`{+ @num}` occurrences of the subterms matching :n:`@pattern` in the current goal. .. exn:: Too few occurrences. @@ -3265,7 +3266,7 @@ the conversion in hypotheses :n:`{+ @ident}`. .. tacv:: simpl @qualid at {+ @num} simpl @string at {+ @num} - This applies ``simpl`` only to the :n:`{+ @num}` applicative subterms whose + This applies :tacn:`simpl` only to the :n:`{+ @num}` applicative subterms whose head occurrence is :n:`@qualid` (or :n:`@string`). .. flag:: Debug RAKAM @@ -3960,6 +3961,9 @@ At Coq startup, only the core database is nonempty and can be used. :fset: internal database for the implementation of the ``FSets`` library. +:ordered_type: lemmas about ordered types (as defined in the legacy ``OrderedType`` module), + mainly used in the ``FSets`` and ``FMaps`` libraries. + You are advised not to put your own hints in the core database, but use one or several databases specific to your development. @@ -4001,8 +4005,8 @@ use one or several databases specific to your development. This vernacular command adds the terms :n:`{+ @term}` (their types must be equalities) in the rewriting bases :n:`{+ @ident}` with the default orientation - (left to right). Notice that the rewriting bases are distinct from the ``auto`` - hint bases and thatauto does not take them into account. + (left to right). Notice that the rewriting bases are distinct from the :tacn:`auto` + hint bases and that :tacn:`auto` does not take them into account. This command is synchronous with the section mechanism (see :ref:`section-mechanism`): when closing a section, all aliases created by ``Hint Rewrite`` in that @@ -4549,7 +4553,7 @@ Inversion .. tacv:: functional inversion @num - This does the same thing as :n:`intros until @num` folowed by + This does the same thing as :n:`intros until @num` followed by :n:`functional inversion @ident` where :token:`ident` is the identifier for the last introduced hypothesis. @@ -4565,8 +4569,8 @@ Inversion Classical tactics ----------------- -In order to ease the proving process, when the Classical module is -loaded. A few more tactics are available. Make sure to load the module +In order to ease the proving process, when the ``Classical`` module is +loaded, a few more tactics are available. Make sure to load the module using the ``Require Import`` command. .. tacn:: classical_left @@ -4623,7 +4627,7 @@ Automating The tactic :tacn:`omega`, due to Pierre Crégut, is an automatic decision procedure for Presburger arithmetic. It solves quantifier-free - formulas built with `~`, `\/`, `/\`, `->` on top of equalities, + formulas built with `~`, `\\/`, `/\\`, `->` on top of equalities, inequalities and disequalities on both the type :g:`nat` of natural numbers and :g:`Z` of binary integers. This tactic must be loaded by the command ``Require Import Omega``. See the additional documentation about omega diff --git a/doc/sphinx/proof-engine/vernacular-commands.rst b/doc/sphinx/proof-engine/vernacular-commands.rst index 2885d6dc33..843459b723 100644 --- a/doc/sphinx/proof-engine/vernacular-commands.rst +++ b/doc/sphinx/proof-engine/vernacular-commands.rst @@ -1012,8 +1012,9 @@ Controlling display .. flag:: Printing Dependent Evars Line - This option controls the printing of the “(dependent evars: …)” line when - ``-emacs`` is passed. + This option controls the printing of the “(dependent evars: …)” information + after each tactic. The information is used by the Prooftree tool in Proof + General. (https://askra.de/software/prooftree) .. _vernac-controlling-the-reduction-strategies: diff --git a/doc/sphinx/refman-preamble.rst b/doc/sphinx/refman-preamble.rst index c662028773..de95eda989 100644 --- a/doc/sphinx/refman-preamble.rst +++ b/doc/sphinx/refman-preamble.rst @@ -70,7 +70,11 @@ .. |p_i| replace:: `p`\ :math:`_{i}` .. |p_n| replace:: `p`\ :math:`_{n}` .. |Program| replace:: :strong:`Program` +.. |Prop| replace:: :math:`\Prop` +.. |SProp| replace:: :math:`\SProp` +.. |Set| replace:: :math:`\Set` .. |SSR| replace:: :smallcaps:`SSReflect` +.. |Type| replace:: :math:`\Type` .. |t_1| replace:: `t`\ :math:`_{1}` .. |t_i| replace:: `t`\ :math:`_{i}` .. |t_m| replace:: `t`\ :math:`_{m}` diff --git a/doc/sphinx/user-extensions/syntax-extensions.rst b/doc/sphinx/user-extensions/syntax-extensions.rst index fd315c097d..a28ce600ca 100644 --- a/doc/sphinx/user-extensions/syntax-extensions.rst +++ b/doc/sphinx/user-extensions/syntax-extensions.rst @@ -267,31 +267,30 @@ The second, more powerful control on printing is by using the format A *format* is an extension of the string denoting the notation with the possible following elements delimited by single quotes: -- extra spaces are translated into simple spaces +- tokens of the form ``'/ '`` are translated into breaking points. If + there is a line break, indents the number of spaces appearing after the + “``/``” (no indentation in the example) -- tokens of the form ``'/ '`` are translated into breaking point, in - case a line break occurs, an indentation of the number of spaces after - the “ ``/``” is applied (2 spaces in the given example) - -- token of the form ``'//'`` force writing on a new line +- tokens of the form ``'//'`` force writing on a new line - well-bracketed pairs of tokens of the form ``'[ '`` and ``']'`` are - translated into printing boxes; in case a line break occurs, an extra - indentation of the number of spaces given after the “ ``[``” is applied - (4 spaces in the example) + translated into printing boxes; if there is a line break, an extra + indentation of the number of spaces after the “``[``” is applied - well-bracketed pairs of tokens of the form ``'[hv '`` and ``']'`` are translated into horizontal-or-else-vertical printing boxes; if the content of the box does not fit on a single line, then every breaking - point forces a newline and an extra indentation of the number of - spaces given after the “ ``[``” is applied at the beginning of each - newline (3 spaces in the example) + point forces a new line and an extra indentation of the number of + spaces after the “``[hv``” is applied at the beginning of each new line - well-bracketed pairs of tokens of the form ``'[v '`` and ``']'`` are translated into vertical printing boxes; every breaking point forces a - newline, even if the line is large enough to display the whole content - of the box, and an extra indentation of the number of spaces given - after the “``[``” is applied at the beginning of each newline + new line, even if the line is large enough to display the whole content + of the box, and an extra indentation of the number of spaces + after the “``[v``” is applied at the beginning of each new line (3 spaces + in the example) + +- extra spaces in other tokens are preserved in the output Notations disappear when a section is closed. No typing of the denoted expression is performed at definition time. Type checking is done only @@ -592,7 +591,7 @@ placeholder being the nesting point. In the innermost occurrence of the nested iterating pattern, the second placeholder is finally filled with the terminating expression. -In the example above, the iterator :math:`φ([~]_E , [~]_I)` is :math:`cons [~]_E [~]_I` +In the example above, the iterator :math:`φ([~]_E , [~]_I)` is :math:`cons [~]_E\, [~]_I` and the terminating expression is ``nil``. Here are other examples: .. coqtop:: in @@ -751,12 +750,12 @@ level is otherwise given explicitly by using the syntax Levels are cumulative: a notation at level ``n`` of which the left end is a term shall use rules at level less than ``n`` to parse this -sub-term. More precisely, it shall use rules at level strictly less +subterm. More precisely, it shall use rules at level strictly less than ``n`` if the rule is declared with ``right associativity`` and rules at level less or equal than ``n`` if the rule is declared with ``left associativity``. Similarly, a notation at level ``n`` of which the right end is a term shall use by default rules at level strictly -less than ``n`` to parse this sub-term if the rule is declared left +less than ``n`` to parse this subterm if the rule is declared left associative and rules at level less or equal than ``n`` if the rule is declared right associative. This is what happens for instance in the rule diff --git a/doc/stdlib/hidden-files b/doc/stdlib/hidden-files index bc4d8b95ab..bb6df87970 100644 --- a/doc/stdlib/hidden-files +++ b/doc/stdlib/hidden-files @@ -44,6 +44,7 @@ plugins/micromega/ZCoeff.v plugins/micromega/ZMicromega.v plugins/micromega/ZifyInst.v plugins/micromega/ZifyBool.v +plugins/micromega/ZifyComparison.v plugins/micromega/ZifyClasses.v plugins/micromega/Zify.v plugins/nsatz/Nsatz.v diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index df7cda9aad..f0ada745e7 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -628,5 +628,6 @@ through the <tt>Require Import</tt> command.</p> theories/Compat/Coq88.v theories/Compat/Coq89.v theories/Compat/Coq810.v + theories/Compat/Coq811.v </dd> </dl> diff --git a/engine/evarutil.ml b/engine/evarutil.ml index c946125d3f..5444d88e47 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -661,26 +661,26 @@ let clear_hyps2_in_evi env sigma hyps t concl ids = (* spiwack: a few functions to gather evars on which goals depend. *) let queue_set q is_dependent set = Evar.Set.iter (fun a -> Queue.push (is_dependent,a) q) set -let queue_term evm q is_dependent c = - queue_set q is_dependent (evars_of_term evm c) +let queue_term q is_dependent c = + queue_set q is_dependent (evar_nodes_of_term c) let process_dependent_evar q acc evm is_dependent e = let evi = Evd.find evm e in (* Queues evars appearing in the types of the goal (conclusion, then hypotheses), they are all dependent. *) - queue_term evm q true evi.evar_concl; + queue_term q true evi.evar_concl; List.iter begin fun decl -> let open NamedDecl in - queue_term evm q true (NamedDecl.get_type decl); + queue_term q true (NamedDecl.get_type decl); match decl with | LocalAssum _ -> () - | LocalDef (_,b,_) -> queue_term evm q true b + | LocalDef (_,b,_) -> queue_term q true b end (EConstr.named_context_of_val evi.evar_hyps); match evi.evar_body with | Evar_empty -> if is_dependent then Evar.Map.add e None acc else acc | Evar_defined b -> - let subevars = evars_of_term evm b in + let subevars = evar_nodes_of_term b in (* evars appearing in the definition of an evar [e] are marked as dependent when [e] is dependent itself: if [e] is a non-dependent goal, then, unless they are reach from another diff --git a/engine/evd.ml b/engine/evd.ml index 6a721a1a8a..f051334f69 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -864,7 +864,7 @@ let universe_subst evd = UState.subst evd.universes let merge_context_set ?loc ?(sideff=false) rigid evd ctx' = - {evd with universes = UState.merge ?loc ~sideff ~extend:true rigid evd.universes ctx'} + {evd with universes = UState.merge ?loc ~sideff rigid evd.universes ctx'} let merge_universe_subst evd subst = {evd with universes = UState.merge_subst evd.universes subst } @@ -1403,7 +1403,16 @@ end let evars_of_term evd c = let rec evrec acc c = - match MiniEConstr.kind evd c with + let c = MiniEConstr.whd_evar evd c in + match kind c with + | Evar (n, l) -> Evar.Set.add n (Array.fold_left evrec acc l) + | _ -> Constr.fold evrec acc c + in + evrec Evar.Set.empty c + +let evar_nodes_of_term c = + let rec evrec acc c = + match kind c with | Evar (n, l) -> Evar.Set.add n (Array.fold_left evrec acc l) | _ -> Constr.fold evrec acc c in diff --git a/engine/evd.mli b/engine/evd.mli index 132f7bc745..5ab53947f7 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -509,6 +509,10 @@ val loc_of_conv_pb : evar_map -> evar_constraint -> Loc.t option val evars_of_term : evar_map -> econstr -> Evar.Set.t (** including evars in instances of evars *) +val evar_nodes_of_term : econstr -> Evar.Set.t + (** same as evars_of_term but also including defined evars. + For use in printing dependent evars *) + val evars_of_named_context : evar_map -> (econstr, etypes) Context.Named.pt -> Evar.Set.t val evars_of_filtered_evar_info : evar_map -> evar_info -> Evar.Set.t diff --git a/engine/proofview.ml b/engine/proofview.ml index 1f076470c1..d6f5aab1d1 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -1247,7 +1247,7 @@ module V82 = struct let top_evars initial { solution=sigma; } = let evars_of_initial (c,_) = - Evar.Set.elements (Evd.evars_of_term sigma c) + Evar.Set.elements (Evd.evar_nodes_of_term c) in CList.flatten (CList.map evars_of_initial initial) diff --git a/engine/uState.ml b/engine/uState.ml index d93ccafcf0..ba17cdde93 100644 --- a/engine/uState.ml +++ b/engine/uState.ml @@ -463,14 +463,6 @@ let restrict ctx vars = let uctx' = restrict_universe_context ~lbound:ctx.uctx_universes_lbound ctx.uctx_local vars in { ctx with uctx_local = uctx' } -let demote_seff_univs universes uctx = - let open Entries in - match universes with - | Polymorphic_entry _ -> uctx - | Monomorphic_entry (univs, _) -> - let seff = LSet.union uctx.uctx_seff_univs univs in - { uctx with uctx_seff_univs = seff } - type rigid = | UnivRigid | UnivFlexible of bool (** Is substitution by an algebraic ok? *) @@ -485,10 +477,9 @@ let univ_flexible_alg = UnivFlexible true context we merge comes from a side effect that is already inlined or defined separately. In the later case, there is no extension, see [emit_side_effects] for example. *) -let merge ?loc ~sideff ~extend rigid uctx ctx' = +let merge ?loc ~sideff rigid uctx ctx' = let levels = ContextSet.levels ctx' in let uctx = - if not extend then uctx else match rigid with | UnivRigid -> uctx | UnivFlexible b -> @@ -497,25 +488,23 @@ let merge ?loc ~sideff ~extend rigid uctx ctx' = else LMap.add u None accu in let uvars' = LSet.fold fold levels uctx.uctx_univ_variables in - if b then - { uctx with uctx_univ_variables = uvars'; - uctx_univ_algebraic = LSet.union uctx.uctx_univ_algebraic levels } - else { uctx with uctx_univ_variables = uvars' } + if b then + { uctx with uctx_univ_variables = uvars'; + uctx_univ_algebraic = LSet.union uctx.uctx_univ_algebraic levels } + else { uctx with uctx_univ_variables = uvars' } in - let uctx_local = - if not extend then uctx.uctx_local - else ContextSet.append ctx' uctx.uctx_local in + let uctx_local = ContextSet.append ctx' uctx.uctx_local in let declare g = LSet.fold (fun u g -> - try UGraph.add_universe ~lbound:uctx.uctx_universes_lbound ~strict:false u g - with UGraph.AlreadyDeclared when sideff -> g) - levels g + try UGraph.add_universe ~lbound:uctx.uctx_universes_lbound ~strict:false u g + with UGraph.AlreadyDeclared when sideff -> g) + levels g in let uctx_names = let fold u accu = let modify _ info = match info.uloc with - | None -> { info with uloc = loc } - | Some _ -> info + | None -> { info with uloc = loc } + | Some _ -> info in try LMap.modify u modify accu with Not_found -> LMap.add u { uname = None; uloc = loc } accu @@ -531,9 +520,36 @@ let merge ?loc ~sideff ~extend rigid uctx ctx' = let merge_subst uctx s = { uctx with uctx_univ_variables = LMap.subst_union uctx.uctx_univ_variables s } +let demote_seff_univs univs uctx = + let seff = LSet.union uctx.uctx_seff_univs univs in + { uctx with uctx_seff_univs = seff } + +let merge_seff uctx ctx' = + let levels = ContextSet.levels ctx' in + let declare g = + LSet.fold (fun u g -> + try UGraph.add_universe ~lbound:uctx.uctx_universes_lbound ~strict:false u g + with UGraph.AlreadyDeclared -> g) + levels g + in + let initial = declare uctx.uctx_initial_universes in + let univs = declare uctx.uctx_universes in + let uctx_universes = UGraph.merge_constraints (ContextSet.constraints ctx') univs in + { uctx with uctx_universes; + uctx_initial_universes = initial } + let emit_side_effects eff u = - let uctxs = Safe_typing.universes_of_private eff in - List.fold_left (merge ~sideff:true ~extend:false univ_rigid) u uctxs + let uctx = Safe_typing.universes_of_private eff in + let u = demote_seff_univs (fst uctx) u in + merge_seff u uctx + +let update_sigma_env uctx env = + let univs = UGraph.make_sprop_cumulative (Environ.universes env) in + let eunivs = + { uctx with uctx_initial_universes = univs; + uctx_universes = univs } + in + merge_seff eunivs eunivs.uctx_local let new_univ_variable ?loc rigid name ({ uctx_local = ctx; uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as uctx) = @@ -730,14 +746,6 @@ let minimize uctx = let universe_of_name uctx s = UNameMap.find s (fst uctx.uctx_names) -let update_sigma_env uctx env = - let univs = UGraph.make_sprop_cumulative (Environ.universes env) in - let eunivs = - { uctx with uctx_initial_universes = univs; - uctx_universes = univs } - in - merge ~sideff:true ~extend:false univ_rigid eunivs eunivs.uctx_local - let pr_weak prl {uctx_weak_constraints=weak} = let open Pp in prlist_with_sep fnl (fun (u,v) -> prl u ++ str " ~ " ++ prl v) (UPairSet.elements weak) diff --git a/engine/uState.mli b/engine/uState.mli index 52e48c4eeb..23ef84c55d 100644 --- a/engine/uState.mli +++ b/engine/uState.mli @@ -100,8 +100,6 @@ val restrict_universe_context : lbound:Univ.Level.t -> ContextSet.t -> LSet.t -> universes are preserved. *) val restrict : t -> Univ.LSet.t -> t -val demote_seff_univs : Entries.universes_entry -> t -> t - type rigid = | UnivRigid | UnivFlexible of bool (** Is substitution by an algebraic ok? *) @@ -110,10 +108,15 @@ val univ_rigid : rigid val univ_flexible : rigid val univ_flexible_alg : rigid -val merge : ?loc:Loc.t -> sideff:bool -> extend:bool -> rigid -> t -> Univ.ContextSet.t -> t +val merge : ?loc:Loc.t -> sideff:bool -> rigid -> t -> Univ.ContextSet.t -> t val merge_subst : t -> UnivSubst.universe_opt_subst -> t val emit_side_effects : Safe_typing.private_constants -> t -> t +val demote_seff_univs : Univ.LSet.t -> t -> t +(** Mark the universes as not local any more, because they have been + globally declared by some side effect. You should be using + emit_side_effects instead. *) + val new_univ_variable : ?loc:Loc.t -> rigid -> Id.t option -> t -> t * Univ.Level.t val add_global_univ : t -> Univ.Level.t -> t diff --git a/ide/coq2.ico b/ide/coq2.ico Binary files differindex bc1732fd99..bc1732fd99 100755..100644 --- a/ide/coq2.ico +++ b/ide/coq2.ico diff --git a/ide/wg_ScriptView.ml b/ide/wg_ScriptView.ml index 279815d671..181418d3d8 100644 --- a/ide/wg_ScriptView.ml +++ b/ide/wg_ScriptView.ml @@ -408,10 +408,8 @@ object (self) | _ -> () method apply_unicode_binding () = - (* Auxiliary method to reach the beginning of line or the - nearest space before the iterator. *) let rec get_line_start iter = - if iter#starts_line || Glib.Unichar.isspace iter#char then iter + if iter#starts_line then iter else get_line_start iter#backward_char in (* Main action *) diff --git a/interp/notation.ml b/interp/notation.ml index ea2173860d..70d3e4175e 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -1836,7 +1836,7 @@ let locate_notation prglob ntn scope = str "Notation" ++ fnl () ++ prlist_with_sep fnl (fun (ntn,l) -> let scope = find_default ntn scopes in - prlist + prlist_with_sep fnl (fun (sc,r,(_,df)) -> hov 0 ( pr_notation_info prglob df r ++ diff --git a/kernel/cooking.ml b/kernel/cooking.ml index 0951b07d49..fae06f7163 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -161,7 +161,7 @@ type 'opaque result = { cook_universes : universes; cook_relevance : Sorts.relevance; cook_inline : inline; - cook_context : Constr.named_context option; + cook_context : Id.Set.t option; } let expmod_constr_subst cache modlist subst c = @@ -239,14 +239,10 @@ let cook_constant { from = cb; info } = | Undef _ as x -> x | Def cs -> Def (Mod_subst.from_val (map (Mod_subst.force_constr cs))) | OpaqueDef o -> - OpaqueDef (Opaqueproof.discharge_direct_opaque info o) + OpaqueDef (Opaqueproof.discharge_opaque info o) | Primitive _ -> CErrors.anomaly (Pp.str "Primitives cannot be cooked") in - let const_hyps = - Context.Named.fold_outside (fun decl hyps -> - List.filter (fun decl' -> not (Id.equal (NamedDecl.get_id decl) (NamedDecl.get_id decl'))) - hyps) - hyps0 ~init:cb.const_hyps in + let const_hyps = Id.Set.diff (Context.Named.to_vars cb.const_hyps) (Context.Named.to_vars hyps0) in let typ = abstract_constant_type (expmod cb.const_type) hyps in { cook_body = body; diff --git a/kernel/cooking.mli b/kernel/cooking.mli index 671cdf51fe..83a8b9edfc 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -23,7 +23,7 @@ type 'opaque result = { cook_universes : universes; cook_relevance : Sorts.relevance; cook_inline : inline; - cook_context : Constr.named_context option; + cook_context : Names.Id.Set.t option; } val cook_constant : recipe -> Opaqueproof.opaque result diff --git a/kernel/entries.ml b/kernel/entries.ml index 47e2f72b0e..046ea86872 100644 --- a/kernel/entries.ml +++ b/kernel/entries.ml @@ -61,7 +61,7 @@ type mutual_inductive_entry = { type definition_entry = { const_entry_body : constr; (* List of section variables *) - const_entry_secctx : Constr.named_context option; + const_entry_secctx : Id.Set.t option; (* State id on which the completion of type checking is reported *) const_entry_feedback : Stateid.t option; const_entry_type : types option; @@ -70,7 +70,7 @@ type definition_entry = { type section_def_entry = { secdef_body : constr; - secdef_secctx : Constr.named_context option; + secdef_secctx : Id.Set.t option; secdef_feedback : Stateid.t option; secdef_type : types option; } @@ -78,7 +78,7 @@ type section_def_entry = { type 'a opaque_entry = { opaque_entry_body : 'a; (* List of section variables *) - opaque_entry_secctx : Constr.named_context; + opaque_entry_secctx : Id.Set.t; (* State id on which the completion of type checking is reported *) opaque_entry_feedback : Stateid.t option; opaque_entry_type : types; @@ -88,7 +88,7 @@ type 'a opaque_entry = { type inline = int option (* inlining level, None for no inlining *) type parameter_entry = - Constr.named_context option * types in_universes_entry * inline + Id.Set.t option * types in_universes_entry * inline type primitive_entry = { prim_entry_type : types option; @@ -99,14 +99,10 @@ type primitive_entry = { type 'a proof_output = constr Univ.in_universe_context_set * 'a type 'a const_entry_body = 'a proof_output Future.computation -(** Dummy wrapper type discriminable from unit *) -type 'a seff_wrap = { seff_wrap : 'a } - -type _ constant_entry = - | DefinitionEntry : definition_entry -> unit constant_entry - | OpaqueEntry : 'a const_entry_body opaque_entry -> 'a seff_wrap constant_entry - | ParameterEntry : parameter_entry -> unit constant_entry - | PrimitiveEntry : primitive_entry -> unit constant_entry +type constant_entry = + | DefinitionEntry : definition_entry -> constant_entry + | ParameterEntry : parameter_entry -> constant_entry + | PrimitiveEntry : primitive_entry -> constant_entry (** {6 Modules } *) diff --git a/kernel/environ.ml b/kernel/environ.ml index 4a2aeea22d..98d66cafa1 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -50,12 +50,19 @@ type constant_key = Opaqueproof.opaque constant_body * (link_info ref * key) type mind_key = mutual_inductive_body * link_info ref -type globals = { - env_constants : constant_key Cmap_env.t; - env_inductives : mind_key Mindmap_env.t; - env_modules : module_body MPmap.t; - env_modtypes : module_type_body MPmap.t; -} +module Globals = struct + + type view = + { constants : constant_key Cmap_env.t + ; inductives : mind_key Mindmap_env.t + ; modules : module_body MPmap.t + ; modtypes : module_type_body MPmap.t + } + + type t = view + + let view x = x +end type stratification = { env_universes : UGraph.t; @@ -88,7 +95,7 @@ type rel_context_val = { } type env = { - env_globals : globals; + env_globals : Globals.t; env_named_context : named_context_val; (* section variables *) env_rel_context : rel_context_val; env_nb_rel : int; @@ -110,11 +117,12 @@ let empty_rel_context_val = { } let empty_env = { - env_globals = { - env_constants = Cmap_env.empty; - env_inductives = Mindmap_env.empty; - env_modules = MPmap.empty; - env_modtypes = MPmap.empty}; + env_globals = + { Globals.constants = Cmap_env.empty + ; inductives = Mindmap_env.empty + ; modules = MPmap.empty + ; modtypes = MPmap.empty + }; env_named_context = empty_named_context_val; env_rel_context = empty_rel_context_val; env_nb_rel = 0; @@ -215,29 +223,29 @@ let lookup_named_ctxt id ctxt = fst (Id.Map.find id ctxt.env_named_map) let fold_constants f env acc = - Cmap_env.fold (fun c (body,_) acc -> f c body acc) env.env_globals.env_constants acc + Cmap_env.fold (fun c (body,_) acc -> f c body acc) env.env_globals.Globals.constants acc let fold_inductives f env acc = - Mindmap_env.fold (fun c (body,_) acc -> f c body acc) env.env_globals.env_inductives acc + Mindmap_env.fold (fun c (body,_) acc -> f c body acc) env.env_globals.Globals.inductives acc (* Global constants *) let lookup_constant_key kn env = - Cmap_env.find kn env.env_globals.env_constants + Cmap_env.find kn env.env_globals.Globals.constants let lookup_constant kn env = - fst (Cmap_env.find kn env.env_globals.env_constants) + fst (Cmap_env.find kn env.env_globals.Globals.constants) (* Mutual Inductives *) let lookup_mind kn env = - fst (Mindmap_env.find kn env.env_globals.env_inductives) + fst (Mindmap_env.find kn env.env_globals.Globals.inductives) let mind_context env mind = let mib = lookup_mind mind env in Declareops.inductive_polymorphic_context mib let lookup_mind_key kn env = - Mindmap_env.find kn env.env_globals.env_inductives + Mindmap_env.find kn env.env_globals.Globals.inductives let oracle env = env.env_typing_flags.conv_oracle let set_oracle env o = @@ -468,10 +476,10 @@ let no_link_info = NotLinked let add_constant_key kn cb linkinfo env = let new_constants = - Cmap_env.add kn (cb,(ref linkinfo, ref None)) env.env_globals.env_constants in + Cmap_env.add kn (cb,(ref linkinfo, ref None)) env.env_globals.Globals.constants in let new_globals = { env.env_globals with - env_constants = new_constants } in + Globals.constants = new_constants } in { env with env_globals = new_globals } let add_constant kn cb env = @@ -598,10 +606,10 @@ let template_polymorphic_pind (ind,u) env = else template_polymorphic_ind ind env let add_mind_key kn (_mind, _ as mind_key) env = - let new_inds = Mindmap_env.add kn mind_key env.env_globals.env_inductives in + let new_inds = Mindmap_env.add kn mind_key env.env_globals.Globals.inductives in let new_globals = { env.env_globals with - env_inductives = new_inds; } in + Globals.inductives = new_inds; } in { env with env_globals = new_globals } let add_mind kn mib env = @@ -688,22 +696,22 @@ let keep_hyps env needed = let add_modtype mtb env = let mp = mtb.mod_mp in - let new_modtypes = MPmap.add mp mtb env.env_globals.env_modtypes in - let new_globals = { env.env_globals with env_modtypes = new_modtypes } in + let new_modtypes = MPmap.add mp mtb env.env_globals.Globals.modtypes in + let new_globals = { env.env_globals with Globals.modtypes = new_modtypes } in { env with env_globals = new_globals } let shallow_add_module mb env = let mp = mb.mod_mp in - let new_mods = MPmap.add mp mb env.env_globals.env_modules in - let new_globals = { env.env_globals with env_modules = new_mods } in + let new_mods = MPmap.add mp mb env.env_globals.Globals.modules in + let new_globals = { env.env_globals with Globals.modules = new_mods } in { env with env_globals = new_globals } let lookup_module mp env = - MPmap.find mp env.env_globals.env_modules + MPmap.find mp env.env_globals.Globals.modules -let lookup_modtype mp env = - MPmap.find mp env.env_globals.env_modtypes +let lookup_modtype mp env = + MPmap.find mp env.env_globals.Globals.modtypes (*s Judgments. *) diff --git a/kernel/environ.mli b/kernel/environ.mli index f7de98dcfb..5af2a7288b 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -46,8 +46,18 @@ type constant_key = Opaqueproof.opaque constant_body * (link_info ref * key) type mind_key = mutual_inductive_body * link_info ref -type globals -(** globals = constants + projections + inductive types + modules + module-types *) +module Globals : sig + type t + + type view = + { constants : constant_key Cmap_env.t + ; inductives : mind_key Mindmap_env.t + ; modules : module_body MPmap.t + ; modtypes : module_type_body MPmap.t + } + + val view : t -> view +end type stratification = { env_universes : UGraph.t; @@ -67,7 +77,7 @@ type rel_context_val = private { } type env = private { - env_globals : globals; + env_globals : Globals.t; env_named_context : named_context_val; (* section variables *) env_rel_context : rel_context_val; env_nb_rel : int; diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml index f0ffd2e073..f0b706e4f5 100644 --- a/kernel/opaqueproof.ml +++ b/kernel/opaqueproof.ml @@ -24,7 +24,7 @@ type 'a delayed_universes = | PrivateMonomorphic of 'a | PrivatePolymorphic of int * Univ.ContextSet.t -type opaque_proofterm = cooking_info list * (Constr.t * unit delayed_universes) option +type opaque_proofterm = (Constr.t * unit delayed_universes) option type indirect_accessor = { access_proof : DirPath.t -> int -> opaque_proofterm; @@ -38,10 +38,10 @@ let drop_mono = function type proofterm = (constr * Univ.ContextSet.t delayed_universes) Future.computation type opaque = - | Indirect of substitution list * DirPath.t * int (* subst, lib, index *) - | Direct of cooking_info list * proofterm +| Indirect of substitution list * cooking_info list * DirPath.t * int (* subst, discharge, lib, index *) + type opaquetab = { - opaque_val : (cooking_info list * proofterm) Int.Map.t; + opaque_val : proofterm Int.Map.t; (** Actual proof terms *) opaque_len : int; (** Size of the above map *) @@ -56,44 +56,33 @@ let empty_opaquetab = { let not_here () = CErrors.user_err Pp.(str "Cannot access opaque delayed proof") -let create cu = Direct ([],cu) - -let turn_indirect dp o tab = match o with - | Indirect (_,_,i) -> - if not (Int.Map.mem i tab.opaque_val) - then CErrors.anomaly (Pp.str "Indirect in a different table.") - else CErrors.anomaly (Pp.str "Already an indirect opaque.") - | Direct (d, cu) -> - (* Invariant: direct opaques only exist inside sections, we turn them - indirect as soon as we are at toplevel. At this moment, we perform - hashconsing of their contents, potentially as a future. *) - let hcons (c, u) = - let c = Constr.hcons c in - let u = match u with - | PrivateMonomorphic u -> PrivateMonomorphic (Univ.hcons_universe_context_set u) - | PrivatePolymorphic (n, u) -> PrivatePolymorphic (n, Univ.hcons_universe_context_set u) - in - (c, u) - in - let cu = Future.chain cu hcons in - let id = tab.opaque_len in - let opaque_val = Int.Map.add id (d,cu) tab.opaque_val in - let opaque_dir = - if DirPath.equal dp tab.opaque_dir then tab.opaque_dir - else if DirPath.equal tab.opaque_dir DirPath.initial then dp - else CErrors.anomaly - (Pp.str "Using the same opaque table for multiple dirpaths.") in - let ntab = { opaque_val; opaque_dir; opaque_len = id + 1 } in - Indirect ([],dp,id), ntab +let create dp cu tab = + let hcons (c, u) = + let c = Constr.hcons c in + let u = match u with + | PrivateMonomorphic u -> PrivateMonomorphic (Univ.hcons_universe_context_set u) + | PrivatePolymorphic (n, u) -> PrivatePolymorphic (n, Univ.hcons_universe_context_set u) + in + (c, u) + in + let cu = Future.chain cu hcons in + let id = tab.opaque_len in + let opaque_val = Int.Map.add id cu tab.opaque_val in + let opaque_dir = + if DirPath.equal dp tab.opaque_dir then tab.opaque_dir + else if DirPath.equal tab.opaque_dir DirPath.initial then dp + else CErrors.anomaly + (Pp.str "Using the same opaque table for multiple dirpaths.") in + let ntab = { opaque_val; opaque_dir; opaque_len = id + 1 } in + Indirect ([], [], dp, id), ntab let subst_opaque sub = function - | Indirect (s,dp,i) -> Indirect (sub::s,dp,i) - | Direct _ -> CErrors.anomaly (Pp.str "Substituting a Direct opaque.") +| Indirect (s, ci, dp, i) -> Indirect (sub :: s, ci, dp, i) -let discharge_direct_opaque ci = function - | Indirect _ -> CErrors.anomaly (Pp.str "Not a direct opaque.") - | Direct (d, cu) -> - Direct (ci :: d, cu) +let discharge_opaque info = function +| Indirect (s, ci, dp, i) -> + assert (CList.is_empty s); + Indirect ([], info :: ci, dp, i) let join except cu = match except with | None -> ignore (Future.join cu) @@ -102,25 +91,21 @@ let join except cu = match except with else ignore (Future.join cu) let join_opaque ?except { opaque_val = prfs; opaque_dir = odp; _ } = function - | Direct (_,cu) -> join except cu - | Indirect (_,dp,i) -> - if DirPath.equal dp odp then - let (_, fp) = Int.Map.find i prfs in - join except fp +| Indirect (_,_,dp,i) -> + if DirPath.equal dp odp then + let fp = Int.Map.find i prfs in + join except fp let force_proof access { opaque_val = prfs; opaque_dir = odp; _ } = function - | Direct (d, cu) -> - let (c, u) = Future.force cu in - access.access_discharge d (c, drop_mono u) - | Indirect (l,dp,i) -> + | Indirect (l,d,dp,i) -> let c, u = if DirPath.equal dp odp then - let (d, cu) = Int.Map.find i prfs in + let cu = Int.Map.find i prfs in let (c, u) = Future.force cu in access.access_discharge d (c, drop_mono u) else - let (d, cu) = access.access_proof dp i in + let cu = access.access_proof dp i in match cu with | None -> not_here () | Some (c, u) -> access.access_discharge d (c, u) @@ -133,21 +118,19 @@ let get_mono (_, u) = match u with | PrivatePolymorphic _ -> Univ.ContextSet.empty let force_constraints _access { opaque_val = prfs; opaque_dir = odp; _ } = function - | Direct (_,cu) -> - get_mono (Future.force cu) - | Indirect (_,dp,i) -> +| Indirect (_,_,dp,i) -> if DirPath.equal dp odp then - let ( _, cu) = Int.Map.find i prfs in + let cu = Int.Map.find i prfs in get_mono (Future.force cu) else Univ.ContextSet.empty module FMap = Future.UUIDMap let dump ?(except = Future.UUIDSet.empty) { opaque_val = otab; opaque_len = n; _ } = - let opaque_table = Array.make n ([], None) in + let opaque_table = Array.make n None in let f2t_map = ref FMap.empty in - let iter n (d, cu) = + let iter n cu = let uid = Future.uuid cu in let () = f2t_map := FMap.add (Future.uuid cu) n !f2t_map in let c = @@ -160,7 +143,7 @@ let dump ?(except = Future.UUIDSet.empty) { opaque_val = otab; opaque_len = n; _ CErrors.anomaly Pp.(str"Proof object "++int n++str" is not checked nor to be checked") in - opaque_table.(n) <- (d, c) + opaque_table.(n) <- c in let () = Int.Map.iter iter otab in opaque_table, !f2t_map diff --git a/kernel/opaqueproof.mli b/kernel/opaqueproof.mli index 758a9f5107..1870241dcd 100644 --- a/kernel/opaqueproof.mli +++ b/kernel/opaqueproof.mli @@ -16,10 +16,7 @@ open Mod_subst Opaque proof terms are special since: - they can be lazily computed and substituted - they are stored in an optionally loaded segment of .vo files - An [opaque] proof terms holds the real data until fully discharged. - In this case it is called [direct]. - When it is [turn_indirect] the data is relocated to an opaque table - and the [opaque] is turned into an index. *) + An [opaque] proof terms holds an index into an opaque table. *) type 'a delayed_universes = | PrivateMonomorphic of 'a @@ -33,12 +30,7 @@ type opaque val empty_opaquetab : opaquetab (** From a [proofterm] to some [opaque]. *) -val create : proofterm -> opaque - -(** Turn a direct [opaque] into an indirect one. It is your responsibility to - hashcons the inner term beforehand. The integer is an hint of the maximum id - used so far *) -val turn_indirect : DirPath.t -> opaque -> opaquetab -> opaque * opaquetab +val create : DirPath.t -> proofterm -> opaquetab -> opaque * opaquetab type work_list = (Univ.Instance.t * Id.t array) Cmap.t * (Univ.Instance.t * Id.t array) Mindmap.t @@ -47,14 +39,14 @@ type cooking_info = { modlist : work_list; abstract : Constr.named_context * Univ.Instance.t * Univ.AUContext.t } -type opaque_proofterm = cooking_info list * (Constr.t * unit delayed_universes) option +type opaque_proofterm = (Constr.t * unit delayed_universes) option type indirect_accessor = { access_proof : DirPath.t -> int -> opaque_proofterm; access_discharge : cooking_info list -> (Constr.t * unit delayed_universes) -> (Constr.t * unit delayed_universes); } -(** When stored indirectly, opaque terms are indexed by their library +(** Opaque terms are indexed by their library dirpath and an integer index. The two functions above activate this indirect storage, by telling how to retrieve terms. *) @@ -66,7 +58,7 @@ val force_constraints : indirect_accessor -> opaquetab -> opaque -> Univ.Context val subst_opaque : substitution -> opaque -> opaque -val discharge_direct_opaque : +val discharge_opaque : cooking_info -> opaque -> opaque val join_opaque : ?except:Future.UUIDSet.t -> opaquetab -> opaque -> unit diff --git a/kernel/retypeops.ml b/kernel/retypeops.ml index a51b762f95..f398e6a5da 100644 --- a/kernel/retypeops.ml +++ b/kernel/retypeops.ml @@ -71,6 +71,7 @@ let rec relevance_of_fterm env extra lft f = | FLambda (len, tys, bdy, e) -> let extra = List.rev_append (List.map (fun (x,_) -> binder_relevance x) tys) extra in let lft = Esubst.el_liftn len lft in + let e = Esubst.subs_liftn len e in relevance_of_term_extra env extra lft e bdy | FLetIn (x, _, _, bdy, e) -> relevance_of_term_extra env (x.binder_relevance :: extra) diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index db16bd1e79..00559206ee 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -173,6 +173,8 @@ let is_initial senv = | [], NONE -> ModPath.equal senv.modpath ModPath.initial | _ -> false +let sections_are_opened senv = not (Section.is_empty senv.sections) + let delta_of_senv senv = senv.modresolver,senv.paramresolver let constant_of_delta_kn_senv senv kn = @@ -297,13 +299,6 @@ let lift_constant c = in { c with const_body = body } -let map_constant f c = - let body = match c.const_body with - | OpaqueDef o -> OpaqueDef (f o) - | Def _ | Undef _ | Primitive _ as body -> body - in - { c with const_body = body } - let push_private_constants env eff = let eff = side_effects_of_private_constants eff in let add_if_undefined env eff = @@ -318,10 +313,10 @@ let concat_private = SideEffects.concat let universes_of_private eff = let fold acc eff = match eff.seff_body.const_universes with - | Monomorphic ctx -> ctx :: acc + | Monomorphic ctx -> Univ.ContextSet.union ctx acc | Polymorphic _ -> acc in - List.fold_left fold [] (side_effects_of_private_constants eff) + List.fold_left fold Univ.ContextSet.empty (side_effects_of_private_constants eff) let env_of_safe_env senv = senv.env let env_of_senv = env_of_safe_env @@ -334,8 +329,6 @@ type constraints_addition = let push_context_set poly cst senv = if Univ.ContextSet.is_empty cst then senv - else if Section.is_polymorphic senv.sections then - CErrors.user_err (Pp.str "Cannot add global universe constraints inside a polymorphic section.") else let sections = if Section.is_empty senv.sections then senv.sections @@ -579,31 +572,16 @@ let add_field ?(is_include=false) ((l,sfb) as field) gn senv = let update_resolver f senv = { senv with modresolver = f senv.modresolver } -(** Insertion of constants and parameters in environment *) -type 'a effect_entry = -| EffectEntry : private_constants Entries.seff_wrap effect_entry -| PureEntry : unit effect_entry - type global_declaration = - | ConstantEntry : 'a effect_entry * 'a Entries.constant_entry -> global_declaration +| ConstantEntry : Entries.constant_entry -> global_declaration +| OpaqueEntry : private_constants Entries.const_entry_body Entries.opaque_entry -> global_declaration type exported_private_constant = Constant.t -let add_constant_aux ~in_section senv (kn, cb) = +let add_constant_aux senv (kn, cb) = let l = Constant.label kn in (* This is the only place where we hashcons the contents of a constant body *) - let cb = if in_section then cb else Declareops.hcons_const_body cb in - let cb, otab = match cb.const_body with - | OpaqueDef lc when not in_section -> - (* In coqc, opaque constants outside sections will be stored - indirectly in a specific table *) - let od, otab = - Opaqueproof.turn_indirect - (library_dp_of_senv senv) lc (Environ.opaque_tables senv.env) in - { cb with const_body = OpaqueDef od }, otab - | _ -> cb, (Environ.opaque_tables senv.env) - in - let senv = { senv with env = Environ.set_opaque_tables senv.env otab } in + let cb = if sections_are_opened senv then cb else Declareops.hcons_const_body cb in let senv' = add_field (l,SFBconst cb) (C kn) senv in let senv'' = match cb.const_body with | Undef (Some lev) -> @@ -715,7 +693,7 @@ let check_signatures curmb sl = type side_effect_declaration = | DefinitionEff : Entries.definition_entry -> side_effect_declaration -| OpaqueEff : unit Entries.const_entry_body Entries.opaque_entry -> side_effect_declaration +| OpaqueEff : Constr.constr Entries.opaque_entry -> side_effect_declaration let constant_entry_of_side_effect eff = let cb = eff.seff_body in @@ -734,8 +712,8 @@ let constant_entry_of_side_effect eff = | _ -> assert false in if Declareops.is_opaque cb then OpaqueEff { - opaque_entry_body = Future.from_val ((p, Univ.ContextSet.empty), ()); - opaque_entry_secctx = cb.const_hyps; + opaque_entry_body = p; + opaque_entry_secctx = Context.Named.to_vars cb.const_hyps; opaque_entry_feedback = None; opaque_entry_type = cb.const_type; opaque_entry_universes = univs; @@ -743,7 +721,7 @@ let constant_entry_of_side_effect eff = else DefinitionEff { const_entry_body = p; - const_entry_secctx = Some cb.const_hyps; + const_entry_secctx = Some (Context.Named.to_vars cb.const_hyps); const_entry_feedback = None; const_entry_type = Some cb.const_type; const_entry_universes = univs; @@ -752,6 +730,25 @@ let constant_entry_of_side_effect eff = let export_eff eff = (eff.seff_constant, eff.seff_body) +let is_empty_private = function +| Opaqueproof.PrivateMonomorphic ctx -> Univ.ContextSet.is_empty ctx +| Opaqueproof.PrivatePolymorphic (_, ctx) -> Univ.ContextSet.is_empty ctx + +let empty_private univs = match univs with +| Monomorphic _ -> Opaqueproof.PrivateMonomorphic Univ.ContextSet.empty +| Polymorphic auctx -> Opaqueproof.PrivatePolymorphic (Univ.AUContext.size auctx, Univ.ContextSet.empty) + +(* Special function to call when the body of an opaque definition is provided. + It performs the type-checking of the body immediately. *) +let translate_direct_opaque env kn ce = + let cb, ctx = Term_typing.translate_opaque env kn ce in + let body = ce.Entries.opaque_entry_body, Univ.ContextSet.empty in + let handle _env c () = (c, Univ.ContextSet.empty, 0) in + let (c, u) = Term_typing.check_delayed handle ctx (body, ()) in + (* No constraints can be generated, we set it empty everywhere *) + let () = assert (is_empty_private u) in + { cb with const_body = OpaqueDef c } + let export_side_effects mb env (b_ctx, eff) = let not_exists e = try ignore(Environ.lookup_constant e.seff_constant env); false @@ -776,26 +773,14 @@ let export_side_effects mb env (b_ctx, eff) = if Int.equal sl 0 then let env, cb = let kn = eff.seff_constant in - let ce = constant_entry_of_side_effect eff in - let open Entries in - let open Term_typing in - let cb = match ce with - | DefinitionEff ce -> - Term_typing.translate_constant Pure env kn (DefinitionEntry ce) - | OpaqueEff ce -> - let handle _env c () = (c, Univ.ContextSet.empty, 0) in - Term_typing.translate_constant (SideEffects handle) env kn (OpaqueEntry ce) - in - let map cu = - let (c, u) = Future.force cu in - let () = match u with - | Opaqueproof.PrivateMonomorphic ctx - | Opaqueproof.PrivatePolymorphic (_, ctx) -> - assert (Univ.ContextSet.is_empty ctx) - in - c + let ce = constant_entry_of_side_effect eff in + let open Entries in + let cb = match ce with + | DefinitionEff ce -> + Term_typing.translate_constant env kn (DefinitionEntry ce) + | OpaqueEff ce -> + translate_direct_opaque env kn ce in - let cb = map_constant map cb in let eff = { eff with seff_body = cb } in (push_seff env eff, export_eff eff) in @@ -807,88 +792,103 @@ let export_side_effects mb env (b_ctx, eff) = in translate_seff trusted seff [] env -let export_private_constants ~in_section ce senv = +let push_opaque_proof pf senv = + let o, otab = Opaqueproof.create (library_dp_of_senv senv) pf (Environ.opaque_tables senv.env) in + let senv = { senv with env = Environ.set_opaque_tables senv.env otab } in + senv, o + +let export_private_constants ce senv = let exported, ce = export_side_effects senv.revstruct senv.env ce in - let map univs p = - let local = match univs with - | Monomorphic _ -> Opaqueproof.PrivateMonomorphic Univ.ContextSet.empty - | Polymorphic auctx -> Opaqueproof.PrivatePolymorphic (Univ.AUContext.size auctx, Univ.ContextSet.empty) - in - Opaqueproof.create (Future.from_val (p, local)) + let map senv (kn, c) = match c.const_body with + | OpaqueDef p -> + let local = empty_private c.const_universes in + let senv, o = push_opaque_proof (Future.from_val (p, local)) senv in + senv, (kn, { c with const_body = OpaqueDef o }) + | Def _ | Undef _ | Primitive _ as body -> + senv, (kn, { c with const_body = body }) in - let map (kn, cb) = (kn, map_constant (fun c -> map cb.const_universes c) cb) in - let bodies = List.map map exported in + let senv, bodies = List.fold_left_map map senv exported in let exported = List.map (fun (kn, _) -> kn) exported in (* No delayed constants to declare *) - let senv = List.fold_left (add_constant_aux ~in_section) senv bodies in + let senv = List.fold_left add_constant_aux senv bodies in (ce, exported), senv -let add_constant (type a) ~(side_effect : a effect_entry) ~in_section l decl senv : (Constant.t * a) * safe_environment = +let add_constant l decl senv = let kn = Constant.make2 senv.modpath l in - let cb = + let cb = match decl with - | ConstantEntry (EffectEntry, ce) -> + | OpaqueEntry ce -> let handle env body eff = let body, uctx, signatures = inline_side_effects env body eff in let trusted = check_signatures senv.revstruct signatures in body, uctx, trusted in - Term_typing.translate_constant (Term_typing.SideEffects handle) senv.env kn ce - | ConstantEntry (PureEntry, ce) -> - Term_typing.translate_constant Term_typing.Pure senv.env kn ce + let cb, ctx = Term_typing.translate_opaque senv.env kn ce in + let map pf = Term_typing.check_delayed handle ctx pf in + let pf = Future.chain ce.Entries.opaque_entry_body map in + { cb with const_body = OpaqueDef pf } + | ConstantEntry ce -> + Term_typing.translate_constant senv.env kn ce in let senv = - let delayed_cst = match cb.const_body with - | OpaqueDef fc when not (Declareops.constant_is_polymorphic cb) -> - let map (_, u) = match u with - | Opaqueproof.PrivateMonomorphic ctx -> ctx - | Opaqueproof.PrivatePolymorphic _ -> assert false + let senv, cb, delayed_cst = match cb.const_body with + | OpaqueDef fc -> + let senv, o = push_opaque_proof fc senv in + let delayed_cst = + if not (Declareops.constant_is_polymorphic cb) then + let map (_, u) = match u with + | Opaqueproof.PrivateMonomorphic ctx -> ctx + | Opaqueproof.PrivatePolymorphic _ -> assert false + in + let fc = Future.chain fc map in + match Future.peek_val fc with + | None -> [Later fc] + | Some c -> [Now c] + else [] in - let fc = Future.chain fc map in - begin match Future.peek_val fc with - | None -> [Later fc] - | Some c -> [Now c] - end - | Undef _ | Def _ | Primitive _ | OpaqueDef _ -> [] + senv, { cb with const_body = OpaqueDef o }, delayed_cst + | Undef _ | Def _ | Primitive _ as body -> + senv, { cb with const_body = body }, [] in - let cb = map_constant (fun c -> Opaqueproof.create c) cb in - let senv = add_constant_aux ~in_section senv (kn, cb) in + let senv = add_constant_aux senv (kn, cb) in add_constraints_list delayed_cst senv in let senv = match decl with - | ConstantEntry (_,(Entries.PrimitiveEntry { Entries.prim_entry_content = CPrimitives.OT_type t; _ })) -> - if in_section then CErrors.anomaly (Pp.str "Primitive type not allowed in sections"); + | ConstantEntry (Entries.PrimitiveEntry { Entries.prim_entry_content = CPrimitives.OT_type t; _ }) -> + if sections_are_opened senv then CErrors.anomaly (Pp.str "Primitive type not allowed in sections"); add_retroknowledge (Retroknowledge.Register_type(t,kn)) senv | _ -> senv in - let eff : a = match side_effect with - | PureEntry -> () - | EffectEntry -> - let body, univs = match cb.const_body with - | (Primitive _ | Undef _) -> assert false - | Def c -> (Def c, cb.const_universes) - | OpaqueDef o -> - let (b, delayed) = Future.force o in - match cb.const_universes, delayed with - | Monomorphic ctx', Opaqueproof.PrivateMonomorphic ctx -> - OpaqueDef b, Monomorphic (Univ.ContextSet.union ctx ctx') - | Polymorphic auctx, Opaqueproof.PrivatePolymorphic (_, ctx) -> - (* Upper layers enforce that there are no internal constraints *) - let () = assert (Univ.ContextSet.is_empty ctx) in - OpaqueDef b, Polymorphic auctx - | (Monomorphic _ | Polymorphic _), (Opaqueproof.PrivateMonomorphic _ | Opaqueproof.PrivatePolymorphic _) -> - assert false + kn, senv + +let add_private_constant l decl senv : (Constant.t * private_constants) * safe_environment = + let kn = Constant.make2 senv.modpath l in + let cb = + match decl with + | OpaqueEff ce -> + translate_direct_opaque senv.env kn ce + | DefinitionEff ce -> + Term_typing.translate_constant senv.env kn (Entries.DefinitionEntry ce) in - let cb = { cb with const_body = body; const_universes = univs } in + let senv, dcb = match cb.const_body with + | Def _ as const_body -> senv, { cb with const_body } + | OpaqueDef c -> + let local = empty_private cb.const_universes in + let senv, o = push_opaque_proof (Future.from_val (c, local)) senv in + senv, { cb with const_body = OpaqueDef o } + | Undef _ | Primitive _ -> assert false + in + let senv = add_constant_aux senv (kn, dcb) in + let eff = let from_env = CEphemeron.create senv.revstruct in let eff = { from_env = from_env; seff_constant = kn; seff_body = cb; } in - { Entries.seff_wrap = SideEffects.add eff empty_private_constants } + SideEffects.add eff empty_private_constants in (kn, eff), senv @@ -947,13 +947,13 @@ let add_module l me inl senv = (** {6 Interactive sections *) -let open_section ~poly senv = +let open_section senv = let custom = { rev_env = senv.env; rev_univ = senv.univ; rev_objlabels = senv.objlabels; } in - let sections = Section.open_section ~poly ~custom senv.sections in + let sections = Section.open_section ~custom senv.sections in { senv with sections } let close_section senv = @@ -962,7 +962,6 @@ let close_section senv = let env0 = senv.env in (* First phase: revert the declarations added in the section *) let sections, entries, cstrs, revert = Section.close_section sections0 in - let () = assert (not (Section.is_polymorphic sections0) || Univ.ContextSet.is_empty cstrs) in let rec pop_revstruct accu entries revstruct = match entries, revstruct with | [], revstruct -> accu, revstruct | _ :: _, [] -> @@ -988,6 +987,9 @@ let close_section senv = that are going to be replayed. Those that are not forced are not readded by {!add_constant_aux}. *) let { rev_env = env; rev_univ = univ; rev_objlabels = objlabels } = revert in + (* Do not revert the opaque table, the discharged opaque constants are + referring to it. *) + let env = Environ.set_opaque_tables env (Environ.opaque_tables senv.env) in let senv = { senv with env; revstruct; sections; univ; objlabels; } in (* Second phase: replay the discharged section contents *) let senv = add_constraints (Now cstrs) senv in @@ -999,12 +1001,11 @@ let close_section senv = in let fold senv = function | `Definition (kn, cb) -> - let in_section = not (Section.is_empty senv.sections) in let info = cooking_info (Section.segment_of_constant env0 kn sections0) in let r = { Cooking.from = cb; info } in let cb = Term_typing.translate_recipe senv.env kn r in (* Delayed constants are already in the global environment *) - add_constant_aux ~in_section senv (kn, cb) + add_constant_aux senv (kn, cb) | `Inductive (ind, mib) -> let info = cooking_info (Section.segment_of_inductive env0 ind sections0) in let mie = Cooking.cook_inductive info mib in diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index d3ca642a89..b2f6668577 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -59,7 +59,7 @@ val inline_private_constants : val push_private_constants : Environ.env -> private_constants -> Environ.env (** Push the constants in the environment if not already there. *) -val universes_of_private : private_constants -> Univ.ContextSet.t list +val universes_of_private : private_constants -> Univ.ContextSet.t val is_curmod_library : safe_environment -> bool @@ -73,23 +73,27 @@ val is_joined_environment : safe_environment -> bool (** Insertion of global axioms or definitions *) -type 'a effect_entry = -| EffectEntry : private_constants Entries.seff_wrap effect_entry -| PureEntry : unit effect_entry - type global_declaration = - | ConstantEntry : 'a effect_entry * 'a Entries.constant_entry -> global_declaration +| ConstantEntry : Entries.constant_entry -> global_declaration +| OpaqueEntry : private_constants Entries.const_entry_body Entries.opaque_entry -> global_declaration + +type side_effect_declaration = +| DefinitionEff : Entries.definition_entry -> side_effect_declaration +| OpaqueEff : Constr.constr Entries.opaque_entry -> side_effect_declaration type exported_private_constant = Constant.t -val export_private_constants : in_section:bool -> +val export_private_constants : private_constants Entries.proof_output -> (Constr.constr Univ.in_universe_context_set * exported_private_constant list) safe_transformer -(** returns the main constant plus a certificate of its validity *) +(** returns the main constant *) val add_constant : - side_effect:'a effect_entry -> in_section:bool -> Label.t -> global_declaration -> - (Constant.t * 'a) safe_transformer + Label.t -> global_declaration -> Constant.t safe_transformer + +(** Similar to add_constant but also returns a certificate *) +val add_private_constant : + Label.t -> side_effect_declaration -> (Constant.t * private_constants) safe_transformer (** Adding an inductive type *) @@ -134,10 +138,12 @@ val check_engagement : Environ.env -> Declarations.set_predicativity -> unit (** {6 Interactive section functions } *) -val open_section : poly:bool -> safe_transformer0 +val open_section : safe_transformer0 val close_section : safe_transformer0 +val sections_are_opened : safe_environment -> bool + (** Insertion of local declarations (Local or Variables) *) val push_named_assum : (Id.t * Constr.types) -> safe_transformer0 diff --git a/kernel/section.ml b/kernel/section.ml index 188249e77e..a1242f0faf 100644 --- a/kernel/section.ml +++ b/kernel/section.ml @@ -14,49 +14,40 @@ open Univ module NamedDecl = Context.Named.Declaration -type _ section_kind = -| SecMono : [ `mono ] section_kind -| SecPoly : [ `poly ] section_kind - -type (_, 'a) section_universes = -| SecMonoUniv : 'a -> ([ `mono ], 'a) section_universes -| SecPolyUniv : Name.t array * UContext.t -> ([ `poly ], 'a) section_universes - type section_entry = | SecDefinition of Constant.t | SecInductive of MutInd.t type 'a entry_map = 'a Cmap.t * 'a Mindmap.t -type ('a, 'b) section = { +type 'a section = { sec_context : int; (** Length of the named context suffix that has been introduced locally *) - sec_universes : ('a, ContextSet.t) section_universes; + sec_mono_universes : ContextSet.t; + sec_poly_universes : Name.t array * UContext.t; (** Universes local to the section *) + has_poly_univs : bool; + (** Are there polymorphic universes or constraints, including in previous sections. *) sec_entries : section_entry list; (** Definitions introduced in the section *) - sec_data : ('a, unit) section_universes entry_map; + sec_data : (Instance.t * AUContext.t) entry_map; (** Additional data synchronized with the section *) - sec_custom : 'b; + sec_custom : 'a; } (** Sections can be nested with the proviso that no monomorphic section can be opened inside a polymorphic one. The reverse is allowed. *) -type 'a t = { - sec_poly : ([ `poly ], 'a) section list; - sec_mono : ([ `mono ], 'a) section list; -} +type 'a t = 'a section list -let empty = { - sec_poly = []; - sec_mono = []; -} +let empty = [] + +let is_empty = List.is_empty -let is_empty s = - List.is_empty s.sec_poly && List.is_empty s.sec_mono +let depth = List.length -let is_polymorphic s = - not (List.is_empty s.sec_poly) +let has_poly_univs = function + | [] -> false + | sec :: _ -> sec.has_poly_univs let find_emap e (cmap, imap) = match e with | SecDefinition con -> Cmap.find con cmap @@ -66,104 +57,80 @@ let add_emap e v (cmap, imap) = match e with | SecDefinition con -> (Cmap.add con v cmap, imap) | SecInductive ind -> (cmap, Mindmap.add ind v imap) -type 'b on_sec = { on_sec : 'a. 'a section_kind -> ('a, 'b) section -> ('a, 'b) section } +let on_last_section f sections = match sections with +| [] -> CErrors.user_err (Pp.str "No opened section") +| sec :: rem -> f sec :: rem -let on_last_section f { sec_poly; sec_mono } = match sec_poly, sec_mono with -| [], [] -> CErrors.user_err (Pp.str "No opened section") -| sec :: rem, _ -> - let sec_poly = f.on_sec SecPoly sec :: rem in - { sec_mono; sec_poly } -| [], sec :: rem -> - let sec_mono = f.on_sec SecMono sec :: rem in - { sec_mono; sec_poly } - -type ('r, 'b) with_sec = { with_sec : 'a. ('a section_kind * ('a, 'b) section) option -> 'r } - -let with_last_section f { sec_poly; sec_mono } = match sec_poly, sec_mono with -| [], [] -> f.with_sec None -| sec :: _, _ -> f.with_sec (Some (SecPoly, sec)) -| [], sec :: _ -> f.with_sec (Some (SecMono, sec)) +let with_last_section f sections = match sections with +| [] -> f None +| sec :: _ -> f (Some sec) let push_local s = - let on_sec _ sec = { sec with sec_context = sec.sec_context + 1 } in - on_last_section { on_sec } s + let on_sec sec = { sec with sec_context = sec.sec_context + 1 } in + on_last_section on_sec s let push_context (nas, ctx) s = - let on_sec (type a) (kind : a section_kind) (sec : (a, _) section) : (a, _) section = match kind with - | SecMono -> - CErrors.anomaly (Pp.str "Adding polymorphic constraints to monomorphic section") - | SecPoly -> - let SecPolyUniv (snas, sctx) = sec.sec_universes in - let sec_universes = SecPolyUniv (Array.append snas nas, UContext.union sctx ctx) in - { sec with sec_universes } + let on_sec sec = + if UContext.is_empty ctx then sec + else + let (snas, sctx) = sec.sec_poly_universes in + let sec_poly_universes = (Array.append snas nas, UContext.union sctx ctx) in + { sec with sec_poly_universes; has_poly_univs = true } + in + on_last_section on_sec s + +let is_polymorphic_univ u s = + let check sec = + let (_, uctx) = sec.sec_poly_universes in + Array.exists (fun u' -> Level.equal u u') (Instance.to_array (UContext.instance uctx)) in - on_last_section { on_sec } s + List.exists check s let push_constraints uctx s = - let on_sec (type a) (kind : a section_kind) (sec : (a, _) section) : (a, _) section = match kind with - | SecMono -> - let SecMonoUniv uctx' = sec.sec_universes in - let sec_universes = SecMonoUniv (ContextSet.union uctx uctx') in - { sec with sec_universes } - | SecPoly -> - CErrors.anomaly (Pp.str "Adding monomorphic constraints to polymorphic section") + let on_sec sec = + if sec.has_poly_univs && Constraint.exists (fun (l,_,r) -> is_polymorphic_univ l s || is_polymorphic_univ r s) (snd uctx) + then CErrors.user_err Pp.(str "Cannot add monomorphic constraints which refer to section polymorphic universes."); + let uctx' = sec.sec_mono_universes in + let sec_mono_universes = (ContextSet.union uctx uctx') in + { sec with sec_mono_universes } in - on_last_section { on_sec } s - -let open_section ~poly ~custom sections = - if poly then - let sec = { - sec_context = 0; - sec_universes = SecPolyUniv ([||], Univ.UContext.empty); - sec_entries = []; - sec_data = (Cmap.empty, Mindmap.empty); - sec_custom = custom; - } in - { sections with sec_poly = sec :: sections.sec_poly } - else if List.is_empty sections.sec_poly then - let sec = { - sec_context = 0; - sec_universes = SecMonoUniv Univ.ContextSet.empty; - sec_entries = []; - sec_data = (Cmap.empty, Mindmap.empty); - sec_custom = custom; - } in - { sections with sec_mono = sec :: sections.sec_mono } - else - CErrors.user_err (Pp.str "Cannot open a monomorphic section inside a polymorphic one") + on_last_section on_sec s + +let open_section ~custom sections = + let sec = { + sec_context = 0; + sec_mono_universes = ContextSet.empty; + sec_poly_universes = ([||], UContext.empty); + has_poly_univs = has_poly_univs sections; + sec_entries = []; + sec_data = (Cmap.empty, Mindmap.empty); + sec_custom = custom; + } in + sec :: sections let close_section sections = - match sections.sec_poly, sections.sec_mono with - | sec :: psecs, _ -> - let sections = { sections with sec_poly = psecs } in - sections, sec.sec_entries, Univ.ContextSet.empty, sec.sec_custom - | [], sec :: msecs -> - let sections = { sections with sec_mono = msecs } in - let SecMonoUniv cstrs = sec.sec_universes in - sections, sec.sec_entries, cstrs, sec.sec_custom - | [], [] -> + match sections with + | sec :: sections -> + sections, sec.sec_entries, sec.sec_mono_universes, sec.sec_custom + | [] -> CErrors.user_err (Pp.str "No opened section.") -let same_poly (type a) ~poly (knd : a section_kind) = match knd with -| SecPoly -> poly -| SecMono -> not poly - -let drop_global (type a) : (a, _) section_universes -> (a, unit) section_universes = function -| SecMonoUniv _ -> SecMonoUniv () -| SecPolyUniv _ as u -> u +let make_decl_univs (nas,uctx) = abstract_universes nas uctx let push_global ~poly e s = if is_empty s then s + else if has_poly_univs s && not poly + then CErrors.user_err + Pp.(str "Cannot add a universe monomorphic declaration when \ + section polymorphic universes are present.") else - let on_sec knd sec = - if same_poly ~poly knd then { sec with + let on_sec sec = + { sec with sec_entries = e :: sec.sec_entries; - sec_data = add_emap e (drop_global sec.sec_universes) sec.sec_data; - } else - CErrors.user_err (Pp.str "Cannot mix universe polymorphic and \ - monomorphic declarations in sections.") + sec_data = add_emap e (make_decl_univs sec.sec_poly_universes) sec.sec_data; + } in - on_last_section { on_sec } s + on_last_section on_sec s let push_constant ~poly con s = push_global ~poly (SecDefinition con) s @@ -171,8 +138,8 @@ let push_inductive ~poly ind s = push_global ~poly (SecInductive ind) s type abstr_info = { abstr_ctx : Constr.named_context; - abstr_subst : Univ.Instance.t; - abstr_uctx : Univ.AUContext.t; + abstr_subst : Instance.t; + abstr_uctx : AUContext.t; } let empty_segment = { @@ -181,51 +148,40 @@ let empty_segment = { abstr_uctx = AUContext.empty; } -let extract_hyps sec vars hyps = - (* FIXME: this code is fishy. It is supposed to check that declared section - variables are an ordered subset of the ambient ones, but it doesn't check - e.g. uniqueness of naming nor convertibility of the section data. *) - let rec aux ids hyps = match ids, hyps with - | id :: ids, decl :: hyps when Names.Id.equal id (NamedDecl.get_id decl) -> - decl :: aux ids hyps - | _ :: ids, hyps -> - aux ids hyps - | [], _ -> [] - in - let ids = List.map NamedDecl.get_id @@ List.firstn sec.sec_context vars in - aux ids hyps +let extract_hyps sec vars used = + (* Keep the section-local segment of variables *) + let vars = List.firstn sec.sec_context vars in + (* Only keep the part that is used by the declaration *) + List.filter (fun d -> Id.Set.mem (NamedDecl.get_id d) used) vars let section_segment_of_entry vars e hyps sections = (* [vars] are the named hypotheses, [hyps] the subset that is declared by the global *) - let with_sec (type a) (s : (a section_kind * (a, _) section) option) = match s with + let with_sec s = match s with | None -> CErrors.user_err (Pp.str "No opened section.") - | Some (knd, sec) -> + | Some sec -> let hyps = extract_hyps sec vars hyps in - let inst, auctx = match knd, find_emap e sec.sec_data with - | SecMono, SecMonoUniv () -> - Instance.empty, AUContext.empty - | SecPoly, SecPolyUniv (nas, ctx) -> - Univ.abstract_universes nas ctx - in + let inst, auctx = find_emap e sec.sec_data in { abstr_ctx = hyps; abstr_subst = inst; abstr_uctx = auctx; } in - with_last_section { with_sec } sections + with_last_section with_sec sections let segment_of_constant env con s = let body = Environ.lookup_constant con env in let vars = Environ.named_context env in - section_segment_of_entry vars (SecDefinition con) body.Declarations.const_hyps s + let used = Context.Named.to_vars body.Declarations.const_hyps in + section_segment_of_entry vars (SecDefinition con) used s let segment_of_inductive env mind s = let mib = Environ.lookup_mind mind env in let vars = Environ.named_context env in - section_segment_of_entry vars (SecInductive mind) mib.Declarations.mind_hyps s + let used = Context.Named.to_vars mib.Declarations.mind_hyps in + section_segment_of_entry vars (SecInductive mind) used s let instance_from_variable_context = List.rev %> List.filter NamedDecl.is_local_assum %> List.map NamedDecl.get_id %> Array.of_list @@ -237,18 +193,18 @@ let extract_worklist info = let replacement_context env s = let with_sec sec = match sec with | None -> CErrors.user_err (Pp.str "No opened section.") - | Some (_, sec) -> + | Some sec -> let cmap, imap = sec.sec_data in let cmap = Cmap.mapi (fun con _ -> extract_worklist @@ segment_of_constant env con s) cmap in let imap = Mindmap.mapi (fun ind _ -> extract_worklist @@ segment_of_inductive env ind s) imap in (cmap, imap) in - with_last_section { with_sec } s + with_last_section with_sec s let is_in_section env gr s = let with_sec sec = match sec with | None -> false - | Some (_, sec) -> + | Some sec -> let open GlobRef in match gr with | VarRef id -> @@ -259,11 +215,4 @@ let is_in_section env gr s = | IndRef (ind, _) | ConstructRef ((ind, _), _) -> Mindmap.mem ind (snd sec.sec_data) in - with_last_section { with_sec } s - -let is_polymorphic_univ u s = - let check sec = - let SecPolyUniv (_, uctx) = sec.sec_universes in - Array.mem u (Instance.to_array (UContext.instance uctx)) - in - List.exists check s.sec_poly + with_last_section with_sec s diff --git a/kernel/section.mli b/kernel/section.mli index c1026a2980..ec863b3b90 100644 --- a/kernel/section.mli +++ b/kernel/section.mli @@ -21,8 +21,8 @@ val empty : 'a t val is_empty : 'a t -> bool (** Checks whether there is no opened section *) -val is_polymorphic : 'a t -> bool -(** Checks whether last opened section is polymorphic *) +val depth : 'a t -> int +(** Number of nested sections (0 if no sections are open) *) (** {6 Manipulating sections} *) @@ -30,7 +30,7 @@ type section_entry = | SecDefinition of Constant.t | SecInductive of MutInd.t -val open_section : poly:bool -> custom:'a -> 'a t -> 'a t +val open_section : custom:'a -> 'a t -> 'a t (** Open a new section with the provided universe polymorphic status. Sections can be nested, with the proviso that polymorphic sections cannot appear inside a monomorphic one. A custom data can be attached to this section, @@ -86,5 +86,3 @@ val replacement_context : Environ.env -> 'a t -> Opaqueproof.work_list (** Section segments of all declarations from this section. *) val is_in_section : Environ.env -> GlobRef.t -> 'a t -> bool - -val is_polymorphic_univ : Level.t -> 'a t -> bool diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index b65e62ba30..f85b3db413 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -29,10 +29,6 @@ module NamedDecl = Context.Named.Declaration type 'a effect_handler = env -> Constr.t -> 'a -> (Constr.t * Univ.ContextSet.t * int) -type _ trust = -| Pure : unit trust -| SideEffects : 'a effect_handler -> 'a Entries.seff_wrap trust - let skip_trusted_seff sl b e = let rec aux sl b e acc = let open Context.Rel.Declaration in @@ -64,7 +60,11 @@ let feedback_completion_typecheck = Option.iter (fun state_id -> Feedback.feedback ~id:state_id Feedback.Complete) -let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = +type typing_context = +| MonoTyCtx of Environ.env * unsafe_type_judgment * Univ.ContextSet.t * Id.Set.t * Stateid.t option +| PolyTyCtx of Environ.env * unsafe_type_judgment * Univ.universe_level_subst * Univ.AUContext.t * Id.Set.t * Stateid.t option + +let infer_declaration env (dcl : constant_entry) = match dcl with | ParameterEntry (ctx,(t,uctx),nl) -> let env = match uctx with @@ -112,79 +112,9 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = cook_relevance = Sorts.Relevant; } - (** Definition [c] is opaque (Qed), non polymorphic and with a specified type, - so we delay the typing and hash consing of its body. *) - - | OpaqueEntry ({ opaque_entry_type = typ; - opaque_entry_universes = Monomorphic_entry univs; _ } as c) -> - let env = push_context_set ~strict:true univs env in - let { opaque_entry_body = body; opaque_entry_feedback = feedback_id; _ } = c in - let tyj = Typeops.infer_type env typ in - let proofterm = - Future.chain body begin fun ((body,uctx),side_eff) -> - (* don't redeclare universes which are declared for the type *) - let uctx = Univ.ContextSet.diff uctx univs in - let SideEffects handle = trust in - let (body, uctx', valid_signatures) = handle env body side_eff in - let uctx = Univ.ContextSet.union uctx uctx' in - let env = push_context_set uctx env in - let body,env,ectx = skip_trusted_seff valid_signatures body env in - let j = Typeops.infer env body in - let j = unzip ectx j in - let _ = Typeops.judge_of_cast env j DEFAULTcast tyj in - let c = j.uj_val in - feedback_completion_typecheck feedback_id; - c, Opaqueproof.PrivateMonomorphic uctx - end in - let def = OpaqueDef proofterm in - { - Cooking.cook_body = def; - cook_type = tyj.utj_val; - cook_universes = Monomorphic univs; - cook_relevance = Sorts.relevance_of_sort tyj.utj_type; - cook_inline = false; - cook_context = Some c.opaque_entry_secctx; - } - - (** Similar case for polymorphic entries. *) - - | OpaqueEntry ({ opaque_entry_type = typ; - opaque_entry_universes = Polymorphic_entry (nas, uctx); _ } as c) -> - let { opaque_entry_body = body; opaque_entry_feedback = feedback_id; _ } = c in - let env = push_context ~strict:false uctx env in - let tj = Typeops.infer_type env typ in - let sbst, auctx = Univ.abstract_universes nas uctx in - let usubst = Univ.make_instance_subst sbst in - let proofterm = Future.chain body begin fun ((body, ctx), side_eff) -> - let SideEffects handle = trust in - let body, ctx', _ = handle env body side_eff in - let ctx = Univ.ContextSet.union ctx ctx' in - (** [ctx] must contain local universes, such that it has no impact - on the rest of the graph (up to transitivity). *) - let env = push_subgraph ctx env in - let private_univs = on_snd (Univ.subst_univs_level_constraints usubst) ctx in - let j = Typeops.infer env body in - let _ = Typeops.judge_of_cast env j DEFAULTcast tj in - let def = Vars.subst_univs_level_constr usubst j.uj_val in - let () = feedback_completion_typecheck feedback_id in - def, Opaqueproof.PrivatePolymorphic (Univ.AUContext.size auctx, private_univs) - end in - let def = OpaqueDef proofterm in - let typ = Vars.subst_univs_level_constr usubst tj.utj_val in - { - Cooking.cook_body = def; - cook_type = typ; - cook_universes = Polymorphic auctx; - cook_relevance = Sorts.relevance_of_sort tj.utj_type; - cook_inline = false; - cook_context = Some c.opaque_entry_secctx; - } - - (** Other definitions have to be processed immediately. *) | DefinitionEntry c -> let { const_entry_type = typ; _ } = c in let { const_entry_body = body; const_entry_feedback = feedback_id; _ } = c in - let Pure = trust in let env, usubst, univs = match c.const_entry_universes with | Monomorphic_entry ctx -> let env = push_context_set ~strict:true ctx env in @@ -218,32 +148,66 @@ let infer_declaration (type a) ~(trust : a trust) env (dcl : a constant_entry) = cook_context = c.const_entry_secctx; } +(** Definition is opaque (Qed), so we delay the typing of its body. *) +let infer_opaque env = function + | ({ opaque_entry_type = typ; + opaque_entry_universes = Monomorphic_entry univs; _ } as c) -> + let env = push_context_set ~strict:true univs env in + let { opaque_entry_feedback = feedback_id; _ } = c in + let tyj = Typeops.infer_type env typ in + let context = MonoTyCtx (env, tyj, univs, c.opaque_entry_secctx, feedback_id) in + let def = OpaqueDef () in + { + Cooking.cook_body = def; + cook_type = tyj.utj_val; + cook_universes = Monomorphic univs; + cook_relevance = Sorts.relevance_of_sort tyj.utj_type; + cook_inline = false; + cook_context = Some c.opaque_entry_secctx; + }, context + + | ({ opaque_entry_type = typ; + opaque_entry_universes = Polymorphic_entry (nas, uctx); _ } as c) -> + let { opaque_entry_feedback = feedback_id; _ } = c in + let env = push_context ~strict:false uctx env in + let tj = Typeops.infer_type env typ in + let sbst, auctx = Univ.abstract_universes nas uctx in + let usubst = Univ.make_instance_subst sbst in + let context = PolyTyCtx (env, tj, usubst, auctx, c.opaque_entry_secctx, feedback_id) in + let def = OpaqueDef () in + let typ = Vars.subst_univs_level_constr usubst tj.utj_val in + { + Cooking.cook_body = def; + cook_type = typ; + cook_universes = Polymorphic auctx; + cook_relevance = Sorts.relevance_of_sort tj.utj_type; + cook_inline = false; + cook_context = Some c.opaque_entry_secctx; + }, context + +let check_section_variables env declared_set typ body = + let ids_typ = global_vars_set env typ in + let ids_def = global_vars_set env body in + let inferred_set = Environ.really_needed env (Id.Set.union ids_typ ids_def) in + if not (Id.Set.subset inferred_set declared_set) then + let l = Id.Set.elements (Id.Set.diff inferred_set declared_set) in + let n = List.length l in + let declared_vars = Pp.pr_sequence Id.print (Id.Set.elements declared_set) in + let inferred_vars = Pp.pr_sequence Id.print (Id.Set.elements inferred_set) in + let missing_vars = Pp.pr_sequence Id.print (List.rev l) in + user_err Pp.(prlist str + ["The following section "; (String.plural n "variable"); " "; + (String.conjugate_verb_to_be n); " used but not declared:"] ++ fnl () ++ + missing_vars ++ str "." ++ fnl () ++ fnl () ++ + str "You can either update your proof to not depend on " ++ missing_vars ++ + str ", or you can update your Proof line from" ++ fnl () ++ + str "Proof using " ++ declared_vars ++ fnl () ++ + str "to" ++ fnl () ++ + str "Proof using " ++ inferred_vars) + let build_constant_declaration env result = let open Cooking in let typ = result.cook_type in - let check declared inferred = - let mk_set l = List.fold_right Id.Set.add (List.map NamedDecl.get_id l) Id.Set.empty in - let inferred_set, declared_set = mk_set inferred, mk_set declared in - if not (Id.Set.subset inferred_set declared_set) then - let l = Id.Set.elements (Id.Set.diff inferred_set declared_set) in - let n = List.length l in - let declared_vars = Pp.pr_sequence Id.print (Id.Set.elements declared_set) in - let inferred_vars = Pp.pr_sequence Id.print (Id.Set.elements inferred_set) in - let missing_vars = Pp.pr_sequence Id.print (List.rev l) in - user_err Pp.(prlist str - ["The following section "; (String.plural n "variable"); " "; - (String.conjugate_verb_to_be n); " used but not declared:"] ++ fnl () ++ - missing_vars ++ str "." ++ fnl () ++ fnl () ++ - str "You can either update your proof to not depend on " ++ missing_vars ++ - str ", or you can update your Proof line from" ++ fnl () ++ - str "Proof using " ++ declared_vars ++ fnl () ++ - str "to" ++ fnl () ++ - str "Proof using " ++ inferred_vars) in - let sort l = - List.filter (fun decl -> - let id = NamedDecl.get_id decl in - List.exists (NamedDecl.get_id %> Names.Id.equal id) l) - (named_context env) in (* We try to postpone the computation of used section variables *) let hyps, def = let context_ids = List.map NamedDecl.get_id (named_context env) in @@ -252,7 +216,7 @@ let build_constant_declaration env result = | None -> if List.is_empty context_ids then (* Empty section context: no need to check *) - [], def + Id.Set.empty, def else (* No declared section vars, and non-empty section context: we must look at the body NOW, if any *) @@ -264,29 +228,21 @@ let build_constant_declaration env result = (* Opaque definitions always come with their section variables *) assert false in - keep_hyps env (Id.Set.union ids_typ ids_def), def + 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 *) - sort declared, + declared, match def with - | Undef _ | Primitive _ as x -> x (* nothing to check *) + | Undef _ | Primitive _ | OpaqueDef _ as x -> x (* nothing to check *) | Def cs as x -> - let ids_typ = global_vars_set env typ in - let ids_def = global_vars_set env (Mod_subst.force_constr cs) in - let inferred = keep_hyps env (Id.Set.union ids_typ ids_def) in - check declared inferred; - x - | OpaqueDef lc -> (* In this case we can postpone the check *) - let iter k cu = Future.chain cu (fun (c, _ as p) -> k c; p) in - let kont c = - let ids_typ = global_vars_set env typ in - let ids_def = global_vars_set env c in - let inferred = keep_hyps env (Id.Set.union ids_typ ids_def) in - check declared inferred - in - OpaqueDef (iter kont lc) + 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 let tps = let res = Cbytegen.compile_constant_body ~fail_on_error:false env univs def in Option.map Cemitcodes.from_val res @@ -300,11 +256,46 @@ let build_constant_declaration env result = const_inline_code = result.cook_inline; const_typing_flags = Environ.typing_flags env } +let check_delayed (type a) (handle : a effect_handler) tyenv (body : a proof_output) = match tyenv with +| MonoTyCtx (env, tyj, univs, declared, feedback_id) -> + let ((body, uctx), side_eff) = body in + (* don't redeclare universes which are declared for the type *) + let uctx = Univ.ContextSet.diff uctx univs in + let (body, uctx', valid_signatures) = handle env body side_eff in + let uctx = Univ.ContextSet.union uctx uctx' in + let env = push_context_set uctx env in + let body,env,ectx = skip_trusted_seff valid_signatures body env in + let j = Typeops.infer env body in + let j = unzip ectx j in + let _ = Typeops.judge_of_cast env j DEFAULTcast tyj in + let c = j.uj_val in + let () = check_section_variables env declared tyj.utj_val body in + feedback_completion_typecheck feedback_id; + c, Opaqueproof.PrivateMonomorphic uctx +| PolyTyCtx (env, tj, usubst, auctx, declared, feedback_id) -> + let ((body, ctx), side_eff) = body in + let body, ctx', _ = handle env body side_eff in + let ctx = Univ.ContextSet.union ctx ctx' in + (** [ctx] must contain local universes, such that it has no impact + on the rest of the graph (up to transitivity). *) + let env = push_subgraph ctx env in + let private_univs = on_snd (Univ.subst_univs_level_constraints usubst) ctx in + let j = Typeops.infer env body in + let _ = Typeops.judge_of_cast env j DEFAULTcast tj in + let () = check_section_variables env declared tj.utj_val body in + let def = Vars.subst_univs_level_constr usubst j.uj_val in + let () = feedback_completion_typecheck feedback_id in + def, Opaqueproof.PrivatePolymorphic (Univ.AUContext.size auctx, private_univs) + (*s Global and local constant declaration. *) -let translate_constant mb env _kn ce = +let translate_constant env _kn ce = build_constant_declaration env - (infer_declaration ~trust:mb env ce) + (infer_declaration env ce) + +let translate_opaque env _kn ce = + let def, ctx = infer_opaque env ce in + build_constant_declaration env def, ctx let translate_local_assum env t = let j = Typeops.infer env t in @@ -317,7 +308,10 @@ let translate_recipe env _kn r = let univs = result.cook_universes in let res = Cbytegen.compile_constant_body ~fail_on_error:false env univs result.cook_body in let tps = Option.map Cemitcodes.from_val res in - { const_hyps = Option.get result.cook_context; + let hyps = Option.get result.cook_context in + (* Trust the set of section hypotheses generated by Cooking *) + let hyps = List.filter (fun d -> Id.Set.mem (NamedDecl.get_id d) hyps) (Environ.named_context env) in + { const_hyps = hyps; const_body = result.cook_body; const_type = result.cook_type; const_body_code = tps; @@ -336,7 +330,7 @@ let translate_local_def env _id centry = const_entry_universes = Monomorphic_entry Univ.ContextSet.empty; const_entry_inline_code = false; } in - let decl = infer_declaration ~trust:Pure env (DefinitionEntry centry) in + let decl = infer_declaration env (DefinitionEntry centry) in let typ = decl.cook_type in let () = match decl.cook_universes with | Monomorphic ctx -> assert (Univ.ContextSet.is_empty ctx) diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index ef01ece185..c9f6d66e36 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -22,9 +22,7 @@ open Entries type 'a effect_handler = env -> Constr.t -> 'a -> (Constr.t * Univ.ContextSet.t * int) -type _ trust = -| Pure : unit trust -| SideEffects : 'a effect_handler -> 'a Entries.seff_wrap trust +type typing_context val translate_local_def : env -> Id.t -> section_def_entry -> constr * Sorts.relevance * types @@ -32,15 +30,21 @@ val translate_local_def : env -> Id.t -> section_def_entry -> val translate_local_assum : env -> types -> types * Sorts.relevance val translate_constant : - 'a trust -> env -> Constant.t -> 'a constant_entry -> - Opaqueproof.proofterm constant_body + env -> Constant.t -> constant_entry -> + 'a constant_body + +val translate_opaque : + env -> Constant.t -> 'a opaque_entry -> + unit constant_body * typing_context val translate_recipe : env -> Constant.t -> Cooking.recipe -> Opaqueproof.opaque constant_body +val check_delayed : 'a effect_handler -> typing_context -> 'a proof_output -> (Constr.t * Univ.ContextSet.t Opaqueproof.delayed_universes) + (** Internal functions, mentioned here for debug purpose only *) -val infer_declaration : trust:'a trust -> env -> - 'a constant_entry -> Opaqueproof.proofterm Cooking.result +val infer_declaration : env -> + constant_entry -> typing_context Cooking.result val build_constant_declaration : env -> Opaqueproof.proofterm Cooking.result -> Opaqueproof.proofterm constant_body diff --git a/lib/flags.ml b/lib/flags.ml index f09dc48f5d..7676665fe9 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -60,7 +60,7 @@ let we_are_parsing = ref false (* Current means no particular compatibility consideration. For correct comparisons, this constructor should remain the last one. *) -type compat_version = V8_8 | V8_9 | Current +type compat_version = V8_8 | V8_9 | V8_10 | Current let compat_version = ref Current @@ -71,6 +71,9 @@ let version_compare v1 v2 = match v1, v2 with | V8_9, V8_9 -> 0 | V8_9, _ -> -1 | _, V8_9 -> 1 + | V8_10, V8_10 -> 0 + | V8_10, _ -> -1 + | _, V8_10 -> 1 | Current, Current -> 0 let version_strictly_greater v = version_compare !compat_version v > 0 @@ -79,6 +82,7 @@ let version_less_or_equal v = not (version_strictly_greater v) let pr_version = function | V8_8 -> "8.8" | V8_9 -> "8.9" + | V8_10 -> "8.10" | Current -> "current" (* Translate *) diff --git a/lib/flags.mli b/lib/flags.mli index 185a5f8425..3f72cc4b91 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -48,7 +48,7 @@ val we_are_parsing : bool ref (* Set Printing All flag. For some reason it is a global flag *) val raw_print : bool ref -type compat_version = V8_8 | V8_9 | Current +type compat_version = V8_8 | V8_9 | V8_10 | Current val compat_version : compat_version ref val version_compare : compat_version -> compat_version -> int val version_strictly_greater : compat_version -> bool diff --git a/library/global.ml b/library/global.ml index 315a147d2c..98d3e9cb1f 100644 --- a/library/global.ml +++ b/library/global.ml @@ -102,15 +102,17 @@ let typing_flags () = Environ.typing_flags (env ()) let make_sprop_cumulative () = globalize0 Safe_typing.make_sprop_cumulative let set_allow_sprop b = globalize0 (Safe_typing.set_allow_sprop b) let sprop_allowed () = Environ.sprop_allowed (env()) -let export_private_constants ~in_section cd = globalize (Safe_typing.export_private_constants ~in_section cd) -let add_constant ~side_effect ~in_section id d = globalize (Safe_typing.add_constant ~side_effect ~in_section (i2l id) d) +let export_private_constants cd = globalize (Safe_typing.export_private_constants cd) +let add_constant id d = globalize (Safe_typing.add_constant (i2l id) d) +let add_private_constant id d = globalize (Safe_typing.add_private_constant (i2l id) d) let add_mind id mie = globalize (Safe_typing.add_mind (i2l id) mie) let add_modtype id me inl = globalize (Safe_typing.add_modtype (i2l id) me inl) let add_module id me inl = globalize (Safe_typing.add_module (i2l id) me inl) let add_include me ismod inl = globalize (Safe_typing.add_include me ismod inl) -let open_section ~poly = globalize0 (Safe_typing.open_section ~poly) +let open_section () = globalize0 Safe_typing.open_section let close_section fs = globalize0_with_summary fs Safe_typing.close_section +let sections_are_opened () = Safe_typing.sections_are_opened (safe_env()) let start_module id = globalize (Safe_typing.start_module (i2l id)) let start_modtype id = globalize (Safe_typing.start_modtype (i2l id)) diff --git a/library/global.mli b/library/global.mli index 26ccb90271..f8b1f35f4d 100644 --- a/library/global.mli +++ b/library/global.mli @@ -46,12 +46,14 @@ val push_named_assum : (Id.t * Constr.types) -> unit val push_named_def : (Id.t * Entries.section_def_entry) -> unit val push_section_context : (Name.t array * Univ.UContext.t) -> unit -val export_private_constants : in_section:bool -> +val export_private_constants : Safe_typing.private_constants Entries.proof_output -> Constr.constr Univ.in_universe_context_set * Safe_typing.exported_private_constant list val add_constant : - side_effect:'a Safe_typing.effect_entry -> in_section:bool -> Id.t -> Safe_typing.global_declaration -> Constant.t * 'a + Id.t -> Safe_typing.global_declaration -> Constant.t +val add_private_constant : + Id.t -> Safe_typing.side_effect_declaration -> Constant.t * Safe_typing.private_constants val add_mind : Id.t -> Entries.mutual_inductive_entry -> MutInd.t @@ -73,13 +75,15 @@ val add_include : (** Sections *) -val open_section : poly:bool -> unit +val open_section : unit -> unit (** [poly] is true when the section should be universe polymorphic *) val close_section : Summary.frozen -> unit (** Close the section and reset the global state to the one at the time when the section what opened. *) +val sections_are_opened : unit -> bool + (** Interactive modules and module types *) val start_module : Id.t -> ModPath.t diff --git a/library/lib.ml b/library/lib.ml index 1c6f82e8a6..80b50b26d0 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -107,7 +107,6 @@ let segment_of_objects prefix = let initial_prefix = Nametab.{ obj_dir = default_library; obj_mp = ModPath.initial; - obj_sec = DirPath.empty; } type lib_state = { @@ -132,10 +131,10 @@ let library_dp () = let cwd () = !lib_state.path_prefix.Nametab.obj_dir let current_mp () = !lib_state.path_prefix.Nametab.obj_mp -let current_sections () = !lib_state.path_prefix.Nametab.obj_sec +let current_sections () = Safe_typing.sections_of_safe_env (Global.safe_env()) -let sections_depth () = List.length (Names.DirPath.repr (current_sections ())) -let sections_are_opened () = not (Names.DirPath.is_empty (current_sections ())) +let sections_depth () = Section.depth (current_sections()) +let sections_are_opened = Global.sections_are_opened let cwd_except_section () = Libnames.pop_dirpath_n (sections_depth ()) (cwd ()) @@ -169,7 +168,6 @@ let pop_path_prefix () = let op = !lib_state.path_prefix in lib_state := { !lib_state with path_prefix = Nametab.{ op with obj_dir = pop_dirpath op.obj_dir; - obj_sec = pop_dirpath op.obj_sec; } } let find_entry_p p = @@ -282,7 +280,7 @@ let current_mod_id () = let start_mod is_type export id mp fs = let dir = add_dirpath_suffix (!lib_state.path_prefix.Nametab.obj_dir) id in - let prefix = Nametab.{ obj_dir = dir; obj_mp = mp; obj_sec = Names.DirPath.empty } in + let prefix = Nametab.{ obj_dir = dir; obj_mp = mp; } in let exists = if is_type then Nametab.exists_cci (make_path id) else Nametab.exists_dir dir @@ -330,9 +328,9 @@ let contents_after sp = let (after,_,_) = split_lib sp in after let start_compilation s mp = if !lib_state.comp_name != None then user_err Pp.(str "compilation unit is already started"); - if not (Names.DirPath.is_empty (!lib_state.path_prefix.Nametab.obj_sec)) then + if Global.sections_are_opened () then (* XXX not sure if we need this check *) user_err Pp.(str "some sections are already opened"); - let prefix = Nametab.{ obj_dir = s; obj_mp = mp; obj_sec = DirPath.empty } in + let prefix = Nametab.{ obj_dir = s; obj_mp = mp } in add_anonymous_entry (CompilingLibrary prefix); lib_state := { !lib_state with comp_name = Some s; path_prefix = prefix } @@ -425,9 +423,6 @@ let extract_worklist info = let sections () = Safe_typing.sections_of_safe_env @@ Global.safe_env () -let is_polymorphic_univ u = - Section.is_polymorphic_univ u (sections ()) - let replacement_context () = Section.replacement_context (Global.env ()) (sections ()) @@ -464,11 +459,11 @@ let section_instance = let open GlobRef in function (*************) (* Sections. *) -let open_section ~poly id = - let () = Global.open_section ~poly in +let open_section id = + let () = Global.open_section () in let opp = !lib_state.path_prefix in let obj_dir = add_dirpath_suffix opp.Nametab.obj_dir id in - let prefix = Nametab.{ obj_dir; obj_mp = opp.obj_mp; obj_sec = add_dirpath_suffix opp.obj_sec id } in + let prefix = Nametab.{ obj_dir; obj_mp = opp.obj_mp; } in if Nametab.exists_dir obj_dir then user_err ~hdr:"open_section" (Id.print id ++ str " already exists."); let fs = Summary.freeze_summaries ~marshallable:false in diff --git a/library/lib.mli b/library/lib.mli index 5ce601f2d3..cef50a5f3b 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -95,6 +95,7 @@ val make_kn : Id.t -> KerName.t (** Are we inside an opened section *) val sections_are_opened : unit -> bool +[@@ocaml.deprecated "Use Global.sections_are_opened"] val sections_depth : unit -> int (** Are we inside an opened module type *) @@ -147,7 +148,7 @@ val library_part : GlobRef.t -> DirPath.t (** {6 Sections } *) -val open_section : poly:bool -> Id.t -> unit +val open_section : Id.t -> unit val close_section : unit -> unit (** {6 We can get and set the state of the operations (used in [States]). } *) @@ -183,8 +184,6 @@ val is_in_section : GlobRef.t -> bool val replacement_context : unit -> Opaqueproof.work_list -val is_polymorphic_univ : Univ.Level.t -> bool - (** {6 Discharge: decrease the section level if in the current section } *) (* XXX Why can't we use the kernel functions ? *) diff --git a/library/nametab.ml b/library/nametab.ml index aed7d08ac1..8626ee1c59 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -18,12 +18,10 @@ open Globnames type object_prefix = { obj_dir : DirPath.t; obj_mp : ModPath.t; - obj_sec : DirPath.t; } let eq_op op1 op2 = DirPath.equal op1.obj_dir op2.obj_dir && - DirPath.equal op1.obj_sec op2.obj_sec && ModPath.equal op1.obj_mp op2.obj_mp (* to this type are mapped DirPath.t's in the nametab *) diff --git a/library/nametab.mli b/library/nametab.mli index 6ee22fc283..55458fe2c6 100644 --- a/library/nametab.mli +++ b/library/nametab.mli @@ -74,7 +74,6 @@ open Globnames type object_prefix = { obj_dir : DirPath.t; obj_mp : ModPath.t; - obj_sec : DirPath.t; } val eq_op : object_prefix -> object_prefix -> bool diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index e0d63a723e..0a41bba8ce 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -597,7 +597,7 @@ let unfreeze (grams, lex) = (** No need to provide an init function : the grammar state is statically available, and already empty initially, while the lexer state should not be reset, since it contains - keywords declared in g_*.ml4 *) + keywords declared in g_*.mlg *) let parser_summary_tag = Summary.declare_summary_tag "GRAMMAR_LEXER" diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 10f78a5a72..ca5adf8ab3 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -108,7 +108,7 @@ end - "f" constr(x) (developer gives an EXTEND rule) | - | macro-generation in tacextend.ml4/vernacextend.ml4/argextend.ml4 + | macro-generation in tacextend.mlg/vernacextend.mlg/argextend.mlg V [GramTerminal "f"; GramNonTerminal (ConstrArgType, Aentry ("constr","constr"), Some "x")] diff --git a/plugins/cc/README b/plugins/cc/README index c616b5daab..7df7b971e8 100644 --- a/plugins/cc/README +++ b/plugins/cc/README @@ -9,7 +9,7 @@ Files : - ccalgo.ml : congruence closure algorithm - ccproof.ml : proof generation code -- cctac.ml4 : the tactic itself +- cctac.mlg : the tactic itself - CCSolve.v : a small Ltac tactic based on congruence Known Bugs : the congruence tactic can fail due to type dependencies. diff --git a/plugins/cc/ccproof.ml b/plugins/cc/ccproof.ml index ef012e5092..f47a14cdc7 100644 --- a/plugins/cc/ccproof.ml +++ b/plugins/cc/ccproof.ml @@ -9,7 +9,7 @@ (************************************************************************) (* This file uses the (non-compressed) union-find structure to generate *) -(* proof-trees that will be transformed into proof-terms in cctac.ml4 *) +(* proof-trees that will be transformed into proof-terms in cctac.mlg *) open CErrors open Constr diff --git a/plugins/extraction/json.ml b/plugins/extraction/json.ml index fba6b7c780..912a20f389 100644 --- a/plugins/extraction/json.ml +++ b/plugins/extraction/json.ml @@ -16,7 +16,10 @@ let json_bool b = if b then str "true" else str "false" let json_global typ ref = - json_str (Common.pp_global typ ref) + if is_custom ref then + json_str (find_custom ref) + else + json_str (Common.pp_global typ ref) let json_id id = json_str (Id.to_string id) diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index 96a3d00dc2..be9259861a 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -380,7 +380,7 @@ let check_inside_module () = warn_extraction_inside_module () let check_inside_section () = - if Lib.sections_are_opened () then + if Global.sections_are_opened () then err (str "You can't do that within a section." ++ fnl () ++ str "Close it and try again.") diff --git a/plugins/funind/gen_principle.ml b/plugins/funind/gen_principle.ml index 6011af74e5..0452665585 100644 --- a/plugins/funind/gen_principle.ml +++ b/plugins/funind/gen_principle.ml @@ -234,23 +234,6 @@ let change_property_sort evd toSort princ princName = ) (List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) princ_info.Tactics.params) -(* XXX: To be cleaned up soon in favor of common save path. *) -let save name const ?hook uctx scope kind = - let open Declare in - let open DeclareDef in - let fix_exn = Future.fix_exn_of const.Declare.proof_entry_body in - let r = match scope with - | Discharge -> - let c = SectionLocalDef const in - let () = declare_variable ~name ~kind c in - GlobRef.VarRef name - | Global local -> - let kn = declare_constant ~name ~kind ~local (DefinitionEntry const) in - GlobRef.ConstRef kn - in - DeclareDef.Hook.(call ?hook ~fix_exn { S.uctx; obls = []; scope; dref = r }); - definition_message name - let generate_functional_principle (evd: Evd.evar_map ref) interactive_proof old_princ_type sorts new_princ_name funs i proof_tac @@ -307,7 +290,14 @@ let generate_functional_principle (evd: Evd.evar_map ref) Don't forget to close the goal if an error is raised !!!! *) let uctx = Evd.evar_universe_context sigma in - save new_princ_name entry ~hook uctx (DeclareDef.Global Declare.ImportDefaultBehavior) Decls.(IsProof Theorem) + let hook_data = hook, uctx, [] in + let _ : Names.GlobRef.t = DeclareDef.declare_definition + ~name:new_princ_name ~hook_data + ~scope:(DeclareDef.Global Declare.ImportDefaultBehavior) + ~kind:Decls.(IsProof Theorem) + UnivNames.empty_binders + entry [] in + () with e when CErrors.noncritical e -> raise (Defining_principle e) diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 80fc64fe65..b55d8537d6 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -10,8 +10,6 @@ let mk_correct_id id = Nameops.add_suffix (mk_rel_id id) "_correct" let mk_complete_id id = Nameops.add_suffix (mk_rel_id id) "_complete" let mk_equation_id id = Nameops.add_suffix id "_equation" -let msgnl m = () - let fresh_id avoid s = Namegen.next_ident_away_in_goal (Id.of_string s) (Id.Set.of_list avoid) let fresh_name avoid s = Name (fresh_id avoid s) diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index cd5202a6c7..550f727951 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -9,9 +9,6 @@ val mk_correct_id : Id.t -> Id.t val mk_complete_id : Id.t -> Id.t val mk_equation_id : Id.t -> Id.t - -val msgnl : Pp.t -> unit - val fresh_id : Id.t list -> string -> Id.t val fresh_name : Id.t list -> string -> Name.t val get_name : Id.t list -> ?default:string -> Name.t -> Name.t diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 4c5eab1a9b..29356df81d 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -1539,13 +1539,7 @@ let recursive_definition ~interactive_proof ~is_mes function_name rec_impls type generate_induction_principle f_ref tcc_lemma_constr functional_ref eq_ref rec_arg_num (EConstr.of_constr rec_arg_type) - (nb_prod evd (EConstr.of_constr res)) relation; - Flags.if_verbose - msgnl (h 1 (Ppconstr.pr_id function_name ++ - spc () ++ str"is defined" )++ fnl () ++ - h 1 (Ppconstr.pr_id equation_id ++ - spc () ++ str"is defined" ) - ) + (nb_prod evd (EConstr.of_constr res)) relation in (* XXX STATE Why do we need this... why is the toplevel protection not enough *) funind_purify (fun () -> diff --git a/plugins/ltac/g_tactic.mlg b/plugins/ltac/g_tactic.mlg index 9b52b710c1..1b00a93834 100644 --- a/plugins/ltac/g_tactic.mlg +++ b/plugins/ltac/g_tactic.mlg @@ -182,10 +182,6 @@ let mkCLambdaN_simple bl c = match bl with let loc_of_ne_list l = Loc.merge_opt (List.hd l).CAst.loc (List.last l).CAst.loc -let map_int_or_var f = function - | ArgArg x -> ArgArg (f x) - | ArgVar _ as y -> y - let all_concl_occs_clause = { onhyps=Some[]; concl_occs=AllOccurrences } let merge_occurrences loc cl = function @@ -269,7 +265,7 @@ GRAMMAR EXTEND Gram [ [ nl = LIST1 nat_or_var -> { OnlyOccurrences nl } | "-"; n = nat_or_var; nl = LIST0 int_or_var -> (* have used int_or_var instead of nat_or_var for compatibility *) - { AllOccurrencesBut (List.map (map_int_or_var abs) (n::nl)) } ] ] + { AllOccurrencesBut (List.map (Locusops.or_var_map abs) (n::nl)) } ] ] ; occs: [ [ "at"; occs = occs_nums -> { occs } | -> { AllOccurrences } ] ] diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml index b6e7dd64b0..bf5d49f678 100644 --- a/plugins/ltac/tacsubst.ml +++ b/plugins/ltac/tacsubst.ml @@ -76,25 +76,21 @@ let subst_and_short_name f (c,n) = (* assert (n=None); *)(* since tacdef are strictly globalized *) (f c,None) -let subst_or_var f = let open Locus in function - | ArgVar _ as x -> x - | ArgArg x -> ArgArg (f x) - let subst_located f = Loc.map f let subst_reference subst = - subst_or_var (subst_located (subst_kn subst)) + Locusops.or_var_map (subst_located (subst_kn subst)) (*CSC: subst_global_reference is used "only" for RefArgType, that propagates to the syntactic non-terminals "global", used in commands such as Print. It is also used for non-evaluable references. *) let subst_global_reference subst = - subst_or_var (subst_located (subst_global_reference subst)) + Locusops.or_var_map (subst_located (subst_global_reference subst)) let subst_evaluable subst = let subst_eval_ref = subst_evaluable_reference subst in - subst_or_var (subst_and_short_name subst_eval_ref) + Locusops.or_var_map (subst_and_short_name subst_eval_ref) let subst_constr_with_occurrences subst (l,c) = (l,subst_glob_constr subst c) diff --git a/plugins/micromega/Fourier_util.v b/plugins/micromega/Fourier_util.v index b62153dee4..95fa5b88df 100644 --- a/plugins/micromega/Fourier_util.v +++ b/plugins/micromega/Fourier_util.v @@ -1,7 +1,7 @@ Require Export Rbase. Require Import Lra. -Open Scope R_scope. +Local Open Scope R_scope. Lemma Rlt_mult_inv_pos : forall x y:R, 0 < x -> 0 < y -> 0 < x * / y. intros x y H H0; try assumption. diff --git a/plugins/micromega/Lia.v b/plugins/micromega/Lia.v index 7e04fe0220..3351c7ef8a 100644 --- a/plugins/micromega/Lia.v +++ b/plugins/micromega/Lia.v @@ -44,9 +44,9 @@ Ltac zchecker_ext := (@eq_refl bool true <: @eq bool (ZTautoCheckerExt __ff __wit) true) (@find Z Z0 __varmap)). -Ltac lia := zify; xlia zchecker_ext. +Ltac lia := PreOmega.zify; xlia zchecker_ext. -Ltac nia := zify; xnlia zchecker. +Ltac nia := PreOmega.zify; xnlia zchecker. (* Local Variables: *) diff --git a/plugins/micromega/RMicromega.v b/plugins/micromega/RMicromega.v index d8282a1127..3651b54ed8 100644 --- a/plugins/micromega/RMicromega.v +++ b/plugins/micromega/RMicromega.v @@ -41,7 +41,7 @@ Proof. exact Rplus_opp_r. Qed. -Open Scope R_scope. +Local Open Scope R_scope. Lemma Rsor : SOR R0 R1 Rplus Rmult Rminus Ropp (@eq R) Rle Rlt. Proof. diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v index 47c77ea927..c160e11467 100644 --- a/plugins/micromega/ZMicromega.v +++ b/plugins/micromega/ZMicromega.v @@ -22,8 +22,9 @@ Require FSetPositive FSetEqProperties. Require Import ZCoeff. Require Import Refl. Require Import ZArith. +Require PreOmega. (*Declare ML Module "micromega_plugin".*) -Open Scope Z_scope. +Local Open Scope Z_scope. Ltac flatten_bool := repeat match goal with @@ -100,11 +101,16 @@ Require Import EnvRing. Lemma Zsor : SOR 0 1 Z.add Z.mul Z.sub Z.opp (@eq Z) Z.le Z.lt. Proof. - constructor ; intros ; subst ; try (intuition (auto with zarith)). + constructor ; intros ; subst; try reflexivity. apply Zsth. apply Zth. + auto using Z.le_antisymm. + eauto using Z.le_trans. + apply Z.le_neq. destruct (Z.lt_trichotomy n m) ; intuition. + apply Z.add_le_mono_l; assumption. apply Z.mul_pos_pos ; auto. + discriminate. Qed. Lemma ZSORaddon : @@ -195,7 +201,8 @@ Proof. (fun x : N => x) (pow_N 1 Z.mul) env Flhs). generalize ((eval_pexpr Z.add Z.mul Z.sub Z.opp (fun x : Z => x) (fun x : N => x) (pow_N 1 Z.mul) env Frhs)). - destruct Fop ; simpl; intros ; intuition (auto with zarith). + destruct Fop ; simpl; intros; + intuition auto using Z.le_ge, Z.ge_le, Z.lt_gt, Z.gt_lt. Qed. @@ -489,7 +496,7 @@ Definition ZweakTautoChecker (w: list ZWitness) (f : BFormula (Formula Z)) : boo (* To get a complete checker, the proof format has to be enriched *) Require Import Zdiv. -Open Scope Z_scope. +Local Open Scope Z_scope. Definition ceiling (a b:Z) : Z := let (q,r) := Z.div_eucl a b in @@ -531,7 +538,10 @@ Proof. apply Z.mul_le_mono_pos_l in H; auto with zarith. - assert (0 < Z.pos r) by easy. rewrite Z.add_1_r, Z.le_succ_l. - apply Z.mul_lt_mono_pos_l with a; auto with zarith. + apply Z.mul_lt_mono_pos_l with a. + auto using Z.gt_lt. + eapply Z.lt_le_trans. 2: eassumption. + now apply Z.lt_add_pos_r. - now elim H1. Qed. @@ -627,20 +637,15 @@ Qed. Lemma Zgcd_pol_ge : forall p, fst (Zgcd_pol p) >= 0. Proof. - induction p. - simpl. auto with zarith. - simpl. auto. + induction p. 1-2: easy. simpl. case_eq (Zgcd_pol p1). case_eq (Zgcd_pol p3). intros. simpl. unfold ZgcdM. - generalize (Z.gcd_nonneg z1 z2). - generalize (Zmax_spec (Z.gcd z1 z2) 1). - generalize (Z.gcd_nonneg (Z.max (Z.gcd z1 z2) 1) z). - generalize (Zmax_spec (Z.gcd (Z.max (Z.gcd z1 z2) 1) z) 1). - auto with zarith. + apply Z.le_ge; transitivity 1. easy. + apply Z.le_max_r. Qed. Lemma Zdivide_pol_Zdivide : forall p x y, Zdivide_pol x p -> (y | x) -> Zdivide_pol y p. @@ -698,7 +703,7 @@ Proof. induction p. simpl. intros. inversion H. - constructor. replace (c - 0) with c in H1 ; auto with zarith. + constructor. rewrite Z.sub_0_r in *. assumption. intros. constructor. simpl in H. inversion H ; subst; clear H. @@ -735,7 +740,7 @@ Proof. destruct HH2. rewrite H2. apply Zdivide_pol_sub ; auto. - auto with zarith. + apply Z.lt_le_trans with 1. reflexivity. now apply Z.ge_le. destruct HH2. rewrite H2. apply Zdivide_pol_one. unfold ZgcdM in HH1. unfold ZgcdM. @@ -1050,7 +1055,7 @@ Fixpoint bdepth (pf : ZArithProof) : nat := | DoneProof => O | RatProof _ p => S (bdepth p) | CutProof _ p => S (bdepth p) - | EnumProof _ _ l => S (List.fold_right (fun pf x => Max.max (bdepth pf) x) O l) + | EnumProof _ _ l => S (List.fold_right (fun pf x => Nat.max (bdepth pf) x) O l) end. Require Import Wf_nat. @@ -1069,19 +1074,19 @@ Proof. unfold ltof. simpl. generalize ( (fold_right - (fun (pf : ZArithProof) (x : nat) => Max.max (bdepth pf) x) 0%nat l)). + (fun (pf : ZArithProof) (x : nat) => Nat.max (bdepth pf) x) 0%nat l)). intros. generalize (bdepth y) ; intros. - generalize (Max.max_l n0 n) (Max.max_r n0 n). - auto with zarith. + rewrite Nat.lt_succ_r. apply Nat.le_max_l. generalize (IHl a0 b y H). unfold ltof. simpl. - generalize ( (fold_right (fun (pf : ZArithProof) (x : nat) => Max.max (bdepth pf) x) 0%nat + generalize ( (fold_right (fun (pf : ZArithProof) (x : nat) => Nat.max (bdepth pf) x) 0%nat l)). intros. - generalize (Max.max_l (bdepth a) n) (Max.max_r (bdepth a) n). - auto with zarith. + eapply lt_le_trans. eassumption. + rewrite <- Nat.succ_le_mono. + apply Nat.le_max_r. Qed. @@ -1113,10 +1118,14 @@ Proof. intros. inv H2. change (RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x)) with eval_pol in *. - apply Zgcd_pol_correct_lt with (env:=env) in H1. - generalize (narrow_interval_lower_bound g (- c0) (eval_pol env (Zdiv_pol (PsubC Z.sub e c0) g)) H0). - auto with zarith. - auto with zarith. + apply Zgcd_pol_correct_lt with (env:=env) in H1. 2: auto using Z.gt_lt. + apply Z.le_add_le_sub_l, Z.ge_le; rewrite Z.add_0_r. + apply (narrow_interval_lower_bound g (- c0) (eval_pol env (Zdiv_pol (PsubC Z.sub e c0) g)) H0). + apply Z.le_ge. + rewrite <- Z.sub_0_l. + apply Z.le_sub_le_add_r. + rewrite <- H1. + assumption. (* g <= 0 *) intros. inv H2. auto with zarith. Qed. @@ -1143,7 +1152,7 @@ Proof. case_eq (Z.gtb g 0). intros. rewrite <- Zgt_is_gt_bool in H. - rewrite Zgcd_pol_correct_lt with (1:= H1) in H2; auto with zarith. + rewrite Zgcd_pol_correct_lt with (1:= H1) in H2. 2: auto using Z.gt_lt. unfold nformula_of_cutting_plane. change (eval_pol env (padd e' (Pc z)) = 0). inv H3. @@ -1159,7 +1168,7 @@ Proof. apply Zeq_bool_eq in H0. subst. simpl. rewrite Z.add_0_r, Z.mul_eq_0 in H2. - intuition auto with zarith. + intuition subst; easy. rewrite negb_false_iff in H0. apply Zeq_bool_eq in H0. assert (HH := Zgcd_is_gcd g c). @@ -1168,14 +1177,15 @@ Proof. apply Zdivide_opp_r in H4. rewrite Zdivide_ceiling ; auto. apply Z.sub_move_0_r. - apply Z.div_unique_exact ; auto with zarith. + apply Z.div_unique_exact. now intros ->. + now rewrite Z.add_move_0_r in H2. intros. unfold nformula_of_cutting_plane. inv H3. change (eval_pol env (padd e' (Pc 0)) = 0). rewrite eval_pol_add. simpl. - auto with zarith. + now rewrite Z.add_0_r. (* NonEqual *) intros. inv H0. @@ -1184,7 +1194,7 @@ Proof. unfold nformula_of_cutting_plane. unfold eval_op1 in *. rewrite (RingMicromega.eval_pol_add Zsor ZSORaddon). - simpl. auto with zarith. + simpl. now rewrite Z.add_0_r. (* Strict *) destruct p as [[e' z] op]. case_eq (makeCuttingPlane (PsubC Z.sub e 1)). @@ -1193,7 +1203,7 @@ Proof. apply makeCuttingPlane_ns_sound with (env:=env) (2:= H). simpl in *. rewrite (RingMicromega.PsubC_ok Zsor ZSORaddon). - auto with zarith. + now apply Z.lt_le_pred. (* NonStrict *) destruct p as [[e' z] op]. case_eq (makeCuttingPlane e). @@ -1220,13 +1230,14 @@ Proof. rewrite negb_true_iff in H. apply Zeq_bool_neq in H. change (eval_pol env p = 0) in H2. - rewrite Zgcd_pol_correct_lt with (1:= H0) in H2; auto with zarith. + rewrite Zgcd_pol_correct_lt with (1:= H0) in H2. 2: auto using Z.gt_lt. set (x:=eval_pol env (Zdiv_pol (PsubC Z.sub p c) g)) in *; clearbody x. contradict H5. - apply Zis_gcd_gcd; auto with zarith. + apply Zis_gcd_gcd. apply Z.lt_le_incl, Z.gt_lt; assumption. constructor; auto with zarith. exists (-x). - rewrite Z.mul_opp_l, Z.mul_comm; auto with zarith. + rewrite Z.mul_opp_l, Z.mul_comm. + now apply Z.add_move_0_l. (**) destruct (makeCuttingPlane p); discriminate. discriminate. @@ -1321,11 +1332,13 @@ Proof. change (RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x)) with eval_pol in HCutR. unfold eval_op1 in HCutR. destruct op1 ; simpl in Hop1 ; try discriminate; - rewrite eval_pol_add in HCutR; simpl in HCutR; auto with zarith. + rewrite eval_pol_add in HCutR; simpl in HCutR. + rewrite Z.add_move_0_l in HCutR; rewrite HCutR, Z.opp_involutive; reflexivity. + now apply Z.le_sub_le_add_r in HCutR. (**) apply is_pol_Z0_eval_pol with (env := env) in HZ0. - rewrite eval_pol_add in HZ0. - replace (eval_pol env p1) with (- eval_pol env p2) by omega. + rewrite eval_pol_add, Z.add_move_r, Z.sub_0_l in HZ0. + rewrite HZ0. apply eval_Psatz_sound with (env:=env) in Hf1 ; auto. apply cutting_plane_sound with (1:= Hf1) in HCutL. unfold nformula_of_cutting_plane in HCutL. @@ -1334,7 +1347,10 @@ Proof. change (RingMicromega.eval_pol Z.add Z.mul (fun x : Z => x)) with eval_pol in HCutL. unfold eval_op1 in HCutL. rewrite eval_pol_add in HCutL. simpl in HCutL. - destruct op2 ; simpl in Hop2 ; try discriminate ; omega. + destruct op2 ; simpl in Hop2 ; try discriminate. + rewrite Z.add_move_r, Z.sub_0_l in HCutL. + now rewrite HCutL, Z.opp_involutive. + now rewrite <- Z.le_sub_le_add_l in HCutL. revert Hfix. match goal with | |- context[?F pf (-z1) z2 = true] => set (FF := F) @@ -1348,26 +1364,24 @@ Proof. generalize (-z1). clear z1. intro z1. revert z1 z2. induction pf;simpl ;intros. - generalize (Zgt_cases z1 z2). - destruct (Z.gtb z1 z2). - intros. - apply False_ind ; omega. - discriminate. + revert Hfix. + now case (Z.gtb_spec); [ | easy ]; intros LT; elim (Zlt_not_le _ _ LT); transitivity x. flatten_bool. - assert (HH:(x = z1 \/ z1 +1 <=x)%Z) by omega. - destruct HH. - subst. - exists a ; auto. - assert (z1 + 1 <= x <= z2)%Z by omega. - elim IHpf with (2:=H2) (3:= H4). - destruct H4. + destruct (Z_le_lt_eq_dec _ _ (proj1 H0)) as [ LT | -> ]. + 2: exists a; auto. + rewrite <- Z.le_succ_l in LT. + assert (LE: (Z.succ z1 <= x <= z2)%Z) by intuition. + elim IHpf with (2:=H2) (3:= LE). intros. exists x0 ; split;tauto. intros until 1. apply H ; auto. unfold ltof in *. simpl in *. - zify. omega. + PreOmega.zify. + intuition subst. assumption. + eapply Z.lt_le_trans. eassumption. + apply Z.add_le_mono_r. assumption. (*/asser *) destruct (HH _ H1) as [pr [Hin Hcheker]]. assert (make_impl (eval_nformula env) ((PsubC Z.sub p1 (eval_pol env p1),Equal) :: l) False). diff --git a/plugins/micromega/Zify.v b/plugins/micromega/Zify.v index 57d812b0fd..785a53fafa 100644 --- a/plugins/micromega/Zify.v +++ b/plugins/micromega/Zify.v @@ -87,4 +87,4 @@ Ltac applySpec S := (** [zify_post_hook] is there to be redefined. *) Ltac zify_post_hook := idtac. -Ltac zify := zify_tac ; (iter_specs applySpec) ; zify_post_hook. +Ltac zify := zify_op ; (iter_specs applySpec) ; zify_post_hook. diff --git a/plugins/micromega/ZifyBool.v b/plugins/micromega/ZifyBool.v index ec37c2003f..b94b74097b 100644 --- a/plugins/micromega/ZifyBool.v +++ b/plugins/micromega/ZifyBool.v @@ -8,8 +8,8 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) Require Import Bool ZArith. -Require Import ZifyClasses. -Open Scope Z_scope. +Require Import Zify ZifyClasses. +Local Open Scope Z_scope. (* Instances of [ZifyClasses] for dealing with boolean operators. Various encodings of boolean are possible. One objective is to have an encoding that is terse but also lia friendly. @@ -42,6 +42,16 @@ Instance Op_orb : BinOp orb := TBOpInj := ltac:(destruct n,m; reflexivity)}. Add BinOp Op_orb. +Instance Op_implb : BinOp implb := + { TBOp := fun x y => Z.max (1 - x) y; + TBOpInj := ltac:(destruct n,m; reflexivity) }. +Add BinOp Op_implb. + +Instance Op_xorb : BinOp xorb := + { TBOp := fun x y => Z.max (x - y) (y - x); + TBOpInj := ltac:(destruct n,m; reflexivity) }. +Add BinOp Op_xorb. + Instance Op_negb : UnOp negb := { TUOp := fun x => 1 - x ; TUOpInj := ltac:(destruct x; reflexivity)}. Add UnOp Op_negb. @@ -52,10 +62,11 @@ Add BinRel Op_eq_bool. Instance Op_true : CstOp true := { TCst := 1 ; TCstInj := eq_refl }. +Add CstOp Op_true. Instance Op_false : CstOp false := { TCst := 0 ; TCstInj := eq_refl }. - +Add CstOp Op_false. (** Comparisons are encoded using the predicates [isZero] and [isLeZero].*) @@ -222,19 +233,23 @@ Add BinOp Op_nat_ltb. (** Injected boolean operators *) -Lemma Z_eqb_ZSpec_ok : forall x, x <> isZero x. +Lemma Z_eqb_ZSpec_ok : forall x, 0 <= isZero x <= 1 /\ + (x = 0 <-> isZero x = 1). Proof. intros. unfold isZero. destruct (x =? 0) eqn:EQ. - apply Z.eqb_eq in EQ. - simpl. congruence. + simpl. intuition try congruence; + compute ; congruence. - apply Z.eqb_neq in EQ. - simpl. auto. + simpl. intuition try congruence; + compute ; congruence. Qed. + Instance Z_eqb_ZSpec : UnOpSpec isZero := - {| UPred := fun n r => n <> r ; USpec := Z_eqb_ZSpec_ok |}. + {| UPred := fun n r => 0 <= r <= 1 /\ (n = 0 <-> isZero n = 1) ; USpec := Z_eqb_ZSpec_ok |}. Add Spec Z_eqb_ZSpec. Lemma leZeroSpec_ok : forall x, x <= 0 /\ isLeZero x = 1 \/ x > 0 /\ isLeZero x = 0. diff --git a/plugins/micromega/ZifyComparison.v b/plugins/micromega/ZifyComparison.v new file mode 100644 index 0000000000..8a8b40ded8 --- /dev/null +++ b/plugins/micromega/ZifyComparison.v @@ -0,0 +1,81 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \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 Bool ZArith. +Require Import ZifyClasses. +Local Open Scope Z_scope. + +(** [Z_of_comparison] is the injection function for comparison *) +Definition Z_of_comparison (c : comparison) : Z := + match c with + | Lt => -1 + | Eq => 0 + | Gt => 1 + end. + +Lemma Z_of_comparison_bound : forall x, -1 <= Z_of_comparison x <= 1. +Proof. + destruct x ; simpl; compute; intuition congruence. +Qed. + +Instance Inj_comparison_Z : InjTyp comparison Z := + { inj := Z_of_comparison ; pred :=(fun x => -1 <= x <= 1) ; cstr := Z_of_comparison_bound}. +Add InjTyp Inj_comparison_Z. + +Definition ZcompareZ (x y : Z) := + Z_of_comparison (Z.compare x y). + +Program Instance BinOp_Zcompare : BinOp Z.compare := + { TBOp := ZcompareZ }. +Add BinOp BinOp_Zcompare. + +Instance Op_eq_comparison : BinRel (@eq comparison) := + {TR := @eq Z ; TRInj := ltac:(destruct n,m; simpl ; intuition congruence) }. +Add BinRel Op_eq_comparison. + +Instance Op_Eq : CstOp Eq := + { TCst := 0 ; TCstInj := eq_refl }. +Add CstOp Op_Eq. + +Instance Op_Lt : CstOp Lt := + { TCst := -1 ; TCstInj := eq_refl }. +Add CstOp Op_Lt. + +Instance Op_Gt : CstOp Gt := + { TCst := 1 ; TCstInj := eq_refl }. +Add CstOp Op_Gt. + + +Lemma Zcompare_spec : forall x y, + (x = y -> ZcompareZ x y = 0) + /\ + (x > y -> ZcompareZ x y = 1) + /\ + (x < y -> ZcompareZ x y = -1). +Proof. + unfold ZcompareZ. + intros. + destruct (x ?= y) eqn:C; simpl. + - rewrite Z.compare_eq_iff in C. + intuition. + - rewrite Z.compare_lt_iff in C. + intuition. + - rewrite Z.compare_gt_iff in C. + intuition. +Qed. + +Instance ZcompareSpec : BinOpSpec ZcompareZ := + {| BPred := fun x y r => (x = y -> r = 0) + /\ + (x > y -> r = 1) + /\ + (x < y -> r = -1) + ; BSpec := Zcompare_spec|}. +Add Spec ZcompareSpec. diff --git a/plugins/micromega/ZifyInst.v b/plugins/micromega/ZifyInst.v index 1217e8a5f7..afd7101667 100644 --- a/plugins/micromega/ZifyInst.v +++ b/plugins/micromega/ZifyInst.v @@ -15,7 +15,7 @@ Require Import Arith Max Min BinInt BinNat Znat Nnat. Require Import ZifyClasses. Declare ML Module "zify_plugin". -Open Scope Z_scope. +Local Open Scope Z_scope. (** Propositional logic *) Instance PropAnd : PropOp and. @@ -119,6 +119,7 @@ Add UnOp Op_S. Instance Op_O : CstOp O := {| TCst := Z0 ; TCstInj := eq_refl (Z.of_nat 0) |}. +Add CstOp Op_O. Instance Op_Z_abs_nat : UnOp Z.abs_nat := { TUOp := Z.abs ; TUOpInj := Zabs2Nat.id_abs }. @@ -409,13 +410,34 @@ Add UnOp Op_Z_to_nat. (** Specification of derived operators over Z *) +Lemma z_max_spec : forall n m, + n <= Z.max n m /\ m <= Z.max n m /\ (Z.max n m = n \/ Z.max n m = m). +Proof. + intros. + generalize (Z.le_max_l n m). + generalize (Z.le_max_r n m). + generalize (Z.max_spec_le n m). + intuition idtac. +Qed. + Instance ZmaxSpec : BinOpSpec Z.max := {| BPred := fun n m r => n < m /\ r = m \/ m <= n /\ r = n ; BSpec := Z.max_spec|}. Add Spec ZmaxSpec. -Instance ZminSpec : BinOpSpec Z.min := - {| BPred := fun n m r : Z => n < m /\ r = n \/ m <= n /\ r = m ; - BSpec := Z.min_spec|}. +Lemma z_min_spec : forall n m, + Z.min n m <= n /\ Z.min n m <= m /\ (Z.min n m = n \/ Z.min n m = m). +Proof. + intros. + generalize (Z.le_min_l n m). + generalize (Z.le_min_r n m). + generalize (Z.min_spec_le n m). + intuition idtac. +Qed. + + +Program Instance ZminSpec : BinOpSpec Z.min := + {| BPred := fun n m r => n < m /\ r = n \/ m <= n /\ r = m ; + BSpec := Z.min_spec |}. Add Spec ZminSpec. Instance ZsgnSpec : UnOpSpec Z.sgn := diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 90c9f86b07..1772a3c333 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -782,7 +782,7 @@ struct (** [eq_constr gl x y] returns an updated [gl] if x and y can be unified *) let eq_constr gl x y = let evd = gl.sigma in - match EConstr.eq_constr_universes gl.env evd x y with + match EConstr.eq_constr_universes_proj gl.env evd x y with | Some csts -> let csts = UnivProblem.to_constraints ~force_weak:false (Evd.universes evd) csts in begin @@ -806,15 +806,16 @@ struct ({vars=vars';gl=gl'}, CamlToCoq.positive n) let get_rank env v = - let evd = env.gl.sigma in + let gl = env.gl in let rec _get_rank env n = match env with | [] -> raise (Invalid_argument "get_rank") | e::l -> - if EConstr.eq_constr evd e v - then n - else _get_rank l (n+1) in + match eq_constr gl e v with + | Some _ -> n + | None -> _get_rank l (n+1) + in _get_rank env.vars 1 let elements env = env.vars diff --git a/plugins/micromega/g_zify.mlg b/plugins/micromega/g_zify.mlg index 424a7d7c54..66f263c0b1 100644 --- a/plugins/micromega/g_zify.mlg +++ b/plugins/micromega/g_zify.mlg @@ -26,7 +26,7 @@ VERNAC COMMAND EXTEND DECLAREINJECTION CLASSIFIED AS SIDEFF | ["Add" "CstOp" constr(t) ] -> { Zify.CstOp.register t } | ["Add" "BinRel" constr(t) ] -> { Zify.BinRel.register t } | ["Add" "PropOp" constr(t) ] -> { Zify.PropOp.register t } -| ["Add" "PropUOp" constr(t) ] -> { Zify.PropOp.register t } +| ["Add" "PropUOp" constr(t) ] -> { Zify.PropUnOp.register t } | ["Add" "Spec" constr(t) ] -> { Zify.Spec.register t } | ["Add" "BinOpSpec" constr(t) ] -> { Zify.Spec.register t } | ["Add" "UnOpSpec" constr(t) ] -> { Zify.Spec.register t } @@ -38,7 +38,7 @@ TACTIC EXTEND ITER END TACTIC EXTEND TRANS -| [ "zify_tac" ] -> { Zify.zify_tac } +| [ "zify_op" ] -> { Zify.zify_tac } | [ "saturate" ] -> { Zify.saturate } END diff --git a/plugins/micromega/mutils.ml b/plugins/micromega/mutils.ml index 39905f8c52..cca66c0719 100644 --- a/plugins/micromega/mutils.ml +++ b/plugins/micromega/mutils.ml @@ -106,12 +106,15 @@ let extract_best red lt l = | Some(c,e), rst -> extractb c e [] rst -let rec find_some pred l = +let rec find_option pred l = match l with - | [] -> None + | [] -> raise Not_found | e::l -> match pred e with - | Some r -> Some r - | None -> find_some pred l + | Some r -> r + | None -> find_option pred l + +let find_some pred l = + try Some (find_option pred l) with Not_found -> None let extract_all pred l = diff --git a/plugins/micromega/zify.ml b/plugins/micromega/zify.ml index be6037ccdb..0a57677220 100644 --- a/plugins/micromega/zify.ml +++ b/plugins/micromega/zify.ml @@ -24,27 +24,13 @@ let unsafe_to_constr = EConstr.Unsafe.to_constr let pr_constr env evd e = Printer.pr_econstr_env env evd e -(** [get_arrow_typ evd t] returns [t1;.tn] such that t = t1 -> .. -> tn.ci_npar - (only syntactic matching) - *) -let rec get_arrow_typ evd t = - match EConstr.kind evd t with - | Prod (a, p1, p2) (*when a.Context.binder_name = Names.Anonymous*) -> - p1 :: get_arrow_typ evd p2 - | _ -> [t] - -(** [get_binary_arrow t] return t' such that t = t' -> t' -> t' *) -let get_binary_arrow evd t = - let l = get_arrow_typ evd t in +let rec find_option pred l = match l with - | [] -> assert false - | [t1; t2; t3] -> Some (t1, t2, t3) - | _ -> None + | [] -> raise Not_found + | e::l -> match pred e with + | Some r -> r + | None -> find_option pred l -(** [get_unary_arrow t] return t' such that t = t' -> t' *) -let get_unary_arrow evd t = - let l = get_arrow_typ evd t in - match l with [] -> assert false | [t1; t2] -> Some (t1, t2) | _ -> None (** [HConstr] is a map indexed by EConstr.t. It should only be used using closed terms. @@ -57,6 +43,8 @@ module HConstr = struct Constr.compare (unsafe_to_constr c) (unsafe_to_constr c') end) + type 'a t = 'a list M.t + let lfind h m = try M.find h m with Not_found -> [] let add h e m = @@ -72,27 +60,23 @@ module HConstr = struct let fold f m acc = M.fold (fun k l acc -> List.fold_left (fun acc e -> f k e acc) acc l) m acc - let iter = M.iter - end + (** [get_projections_from_constant (evd,c) ] returns an array of constr [| a1,.. an|] such that [c] is defined as Definition c := mk a1 .. an with mk a constructor. ai is therefore either a type parameter or a projection. *) -let get_projections_from_constant (evd, i) = - match Constr.kind (unsafe_to_constr i) with - | Constr.Const (c, u) -> - (match Environ.constant_opt_value_in (Global.env ()) (c,u) with - | None -> failwith "Add Injection requires a constant (with a body)" - | Some c -> ( - match EConstr.kind evd (EConstr.of_constr c) with - | App (c, a) -> Some a - | _ -> None )) - | _ -> None +let get_projections_from_constant (evd, i) = + match EConstr.kind evd (Reductionops.clos_whd_flags CClosure.all (Global.env ()) evd i) with + | App (c, a) -> Some a + | _ -> + raise (CErrors.user_err Pp.(str "The hnf of term " ++ pr_constr (Global.env ()) evd i + ++ str " should be an application i.e. (c a1 ... an)")) + (** An instance of type, say T, is registered into a hashtable, say TableT. *) type 'a decl = @@ -101,34 +85,111 @@ type 'a decl = deriv: 'a (* Projections of insterest *) } -(* Different type of declarations *) -type decl_kind = - | PropOp - | InjTyp - | BinRel - | BinOp - | UnOp - | CstOp - | Saturate -let string_of_decl = function - | PropOp -> "PropOp" - | InjTyp -> "InjTyp" - | BinRel -> "BinRel" - | BinOp -> "BinOp" - | UnOp -> "UnOp" - | CstOp -> "CstOp" - | Saturate -> "Saturate" +module EInjT = struct + type t = + { isid: bool + ; (* S = T -> inj = fun x -> x*) + source: EConstr.t + ; (* S *) + target: EConstr.t + ; (* T *) + (* projections *) + inj: EConstr.t + ; (* S -> T *) + pred: EConstr.t + ; (* T -> Prop *) + cstr: EConstr.t option + (* forall x, pred (inj x) *) } +end +module EBinOpT = struct + type t = + { (* Op : source1 -> source2 -> source3 *) + source1: EConstr.t + ; source2: EConstr.t + ; source3: EConstr.t + ; target: EConstr.t + ; inj1: EConstr.t + ; (* InjTyp source1 target *) + inj2: EConstr.t + ; (* InjTyp source2 target *) + inj3: EConstr.t + ; (* InjTyp source3 target *) + tbop: EConstr.t + (* TBOpInj *) } +end +module ECstOpT = struct + type t = {source: EConstr.t; target: EConstr.t; inj: EConstr.t} +end +module EUnOpT = struct + type t = + { source1: EConstr.t + ; source2: EConstr.t + ; target: EConstr.t + ; inj1_t: EConstr.t + ; inj2_t: EConstr.t + ; unop: EConstr.t } +end + +module EBinRelT = struct + type t = + {source: EConstr.t; target: EConstr.t; inj: EConstr.t; brel: EConstr.t} +end + +module EPropBinOpT = struct + type t = EConstr.t +end + +module EPropUnOpT = struct + type t = EConstr.t +end + + +module ESatT = struct + type t = {parg1: EConstr.t; parg2: EConstr.t; satOK: EConstr.t} +end + +(* Different type of declarations *) +type decl_kind = + | PropOp of EPropBinOpT.t decl + | PropUnOp of EPropUnOpT.t decl + | InjTyp of EInjT.t decl + | BinRel of EBinRelT.t decl + | BinOp of EBinOpT.t decl + | UnOp of EUnOpT.t decl + | CstOp of ECstOpT.t decl + | Saturate of ESatT.t decl + + +let get_decl = function + | PropOp d -> d.decl + | PropUnOp d -> d.decl + | InjTyp d -> d.decl + | BinRel d -> d.decl + | BinOp d -> d.decl + | UnOp d -> d.decl + | CstOp d -> d.decl + | Saturate d -> d.decl + +type term_kind = + | Application of EConstr.constr + | OtherTerm of EConstr.constr module type Elt = sig type elt - val name : decl_kind - (** [name] of the table *) + val name : string + (** name *) + + val table : (term_kind * decl_kind) HConstr.t ref + + val cast : elt decl -> decl_kind + + val dest : decl_kind -> (elt decl) option val get_key : int (** [get_key] is the type-index used as key for the instance *) @@ -138,128 +199,36 @@ module type Elt = sig built from the type-instance i and the arguments (type indexes and projections) of the type-class constructor. *) - val reduce_term : Evd.evar_map -> EConstr.t -> EConstr.t - (** [reduce_term evd t] normalises [t] in a table dependent way. *) - -end - -module type S = sig - val register : Constrexpr.constr_expr -> unit + (* val arity : int*) - val print : unit -> unit end -let not_registered = Summary.ref ~name:"zify_to_register" [] - -module MakeTable (E : Elt) = struct - (** Given a term [c] and its arguments ai, - we construct a HConstr.t table that is - indexed by ai for i = E.get_key. - The elements of the table are built using E.mk_elt c [|a0,..,an|] - *) - - let make_elt (evd, i) = - match get_projections_from_constant (evd, i) with - | None -> - let env = Global.env () in - let t = string_of_ppcmds (pr_constr env evd i) in - failwith ("Cannot register term " ^ t) - | Some a -> E.mk_elt evd i a - let table = Summary.ref ~name:("zify_" ^ string_of_decl E.name) HConstr.empty +let table = Summary.ref ~name:("zify_table") HConstr.empty - let register_constr env evd c = - let c = EConstr.of_constr c in - let t = get_type_of env evd c in - match EConstr.kind evd t with - | App (intyp, args) -> - let styp = E.reduce_term evd args.(E.get_key) in - let elt = {decl= c; deriv= make_elt (evd, c)} in - table := HConstr.add styp elt !table - | _ -> failwith "Can only register terms of type [F X1 .. Xn]" +let saturate = Summary.ref ~name:("zify_saturate") HConstr.empty - let get evd c = - let c' = E.reduce_term evd c in - HConstr.find c' !table +let table_cache = ref HConstr.empty +let saturate_cache = ref HConstr.empty - let get_all evd c = - let c' = E.reduce_term evd c in - HConstr.find_all c' !table - let fold_declared_const f evd acc = - HConstr.fold - (fun _ e acc -> f (fst (EConstr.destConst evd e.decl)) acc) - !table acc +(** Each type-class gives rise to a different table. + They only differ on how projections are extracted. *) +module EInj = struct + open EInjT - exception FoundNorm of EConstr.t + type elt = EInjT.t - let can_unify evd k t = - try - let _ = Unification.w_unify (Global.env ()) evd Reduction.CONV k t in - true ; - with _ -> false + let name = "EInj" - let unify_with_key evd t = - try - HConstr.iter - (fun k _ -> - if can_unify evd k t - then raise (FoundNorm k) - else ()) !table ; t - with FoundNorm k -> k + let table = table + let cast x = InjTyp x - let pp_keys () = - let env = Global.env () in - let evd = Evd.from_env env in - HConstr.fold - (fun k _ acc -> Pp.(pr_constr env evd k ++ str " " ++ acc)) - !table (Pp.str "") + let dest = function + | InjTyp x -> Some x + | _ -> None - let register_obj : Constr.constr -> Libobject.obj = - let cache_constr (_, c) = - not_registered := (E.name,c)::!not_registered - in - let subst_constr (subst, c) = Mod_subst.subst_mps subst c in - Libobject.declare_object - @@ Libobject.superglobal_object_nodischarge - ("register-zify-" ^ string_of_decl E.name) - ~cache:cache_constr ~subst:(Some subst_constr) - - (** [register c] is called from the VERNACULAR ADD [name] constr(t). - The term [c] is interpreted and - registered as a [superglobal_object_nodischarge]. - TODO: pre-compute [get_type_of] - [cache_constr] is using another environment. - *) - let register c = - let env = Global.env () in - let evd = Evd.from_env env in - let evd, c = Constrintern.interp_open_constr env evd c in - let _ = Lib.add_anonymous_leaf (register_obj (EConstr.to_constr evd c)) in - () - - let print () = Feedback.msg_notice (pp_keys ()) -end - -(** Each type-class gives rise to a different table. - They only differ on how projections are extracted. *) -module InjElt = struct - type elt = - { isid: bool - ; (* S = T -> inj = fun x -> x*) - source: EConstr.t - ; (* S *) - target: EConstr.t - ; (* T *) - (* projections *) - inj: EConstr.t - ; (* S -> T *) - pred: EConstr.t - ; (* T -> Prop *) - cstr: EConstr.t option - (* forall x, pred (inj x) *) } - - let name = InjTyp let mk_elt evd i (a : EConstr.t array) = let isid = EConstr.eq_constr evd a.(0) a.(1) in @@ -272,40 +241,15 @@ module InjElt = struct let get_key = 0 - let reduce_term evd t = t - end -module InjTable = MakeTable (InjElt) - - -let coq_eq = lazy ( EConstr.of_constr - (UnivGen.constr_of_monomorphic_global - (Coqlib.lib_ref ("core.eq.type")))) - -let reduce_type evd ty = - try ignore (InjTable.get evd ty) ; ty - with Not_found -> - (* Maybe it unifies *) - InjTable.unify_with_key evd ty - module EBinOp = struct - type elt = - { (* Op : source1 -> source2 -> source3 *) - source1: EConstr.t - ; source2: EConstr.t - ; source3: EConstr.t - ; target: EConstr.t - ; inj1: EConstr.t - ; (* InjTyp source1 target *) - inj2: EConstr.t - ; (* InjTyp source2 target *) - inj3: EConstr.t - ; (* InjTyp source3 target *) - tbop: EConstr.t - (* TBOpInj *) } + type elt = EBinOpT.t + open EBinOpT + + let name = "BinOp" - let name = BinOp + let table = table let mk_elt evd i a = { source1= a.(0) @@ -319,34 +263,50 @@ module EBinOp = struct let get_key = 4 - let reduce_term evd t = t + + let cast x = BinOp x + + let dest = function + | BinOp x -> Some x + | _ -> None end module ECstOp = struct - type elt = {source: EConstr.t; target: EConstr.t; inj: EConstr.t} + type elt = ECstOpT.t + open ECstOpT + + let name = "CstOp" + + let table = table + + let cast x = CstOp x + + let dest = function + | CstOp x -> Some x + | _ -> None - let name = CstOp let mk_elt evd i a = {source= a.(0); target= a.(1); inj= a.(3)} let get_key = 2 - let reduce_term evd t = t - end - module EUnOp = struct - type elt = - { source1: EConstr.t - ; source2: EConstr.t - ; target: EConstr.t - ; inj1_t: EConstr.t - ; inj2_t: EConstr.t - ; unop: EConstr.t } + type elt = EUnOpT.t + open EUnOpT + + let name = "UnOp" + + let table = table + + let cast x = UnOp x + + let dest = function + | UnOp x -> Some x + | _ -> None - let name = UnOp let mk_elt evd i a = { source1= a.(0) @@ -358,72 +318,202 @@ module EUnOp = struct let get_key = 3 - let reduce_term evd t = t - end -open EUnOp - module EBinRel = struct - type elt = - {source: EConstr.t; target: EConstr.t; inj: EConstr.t; brel: EConstr.t} + type elt = EBinRelT.t + open EBinRelT + + let name = "BinRel" + + let table = table + + let cast x = BinRel x - let name = BinRel + let dest = function + | BinRel x -> Some x + | _ -> None let mk_elt evd i a = {source= a.(0); target= a.(1); inj= a.(3); brel= a.(4)} let get_key = 2 +end + +module EPropOp = struct + type elt = EConstr.t + + let name = "PropBinOp" - (** [reduce_term evd t] if t = @eq ty normalises ty to a declared type e.g Z if it exists. *) - let reduce_term evd t = - match EConstr.kind evd t with - | App(c,a) -> if EConstr.eq_constr evd (Lazy.force coq_eq) c - then - match a with - | [| ty |] -> EConstr.mkApp(c,[| reduce_type evd ty|]) - | _ -> t - else t - | _ -> t + let table = table + + let cast x = PropOp x + + let dest = function + | PropOp x -> Some x + | _ -> None + + let mk_elt evd i a = i + + let get_key = 0 end -module EPropOp = struct +module EPropUnOp = struct type elt = EConstr.t - let name = PropOp + let name = "PropUnOp" + + let table = table + + let cast x = PropUnOp x + + let dest = function + | PropUnOp x -> Some x + | _ -> None let mk_elt evd i a = i let get_key = 0 - let reduce_term evd t = t +end + + + +let constr_of_term_kind = function + | Application c -> c + | OtherTerm c -> c + + +let fold_declared_const f evd acc = + HConstr.fold + (fun _ (_,e) acc -> f (fst (EConstr.destConst evd (get_decl e))) acc) + (!table_cache) acc + + + +module type S = sig + val register : Constrexpr.constr_expr -> unit + + val print : unit -> unit end -module ESat = struct - type elt = {parg1: EConstr.t; parg2: EConstr.t; satOK: EConstr.t} - let name = Saturate +module MakeTable (E : Elt) = struct + (** Given a term [c] and its arguments ai, + we construct a HConstr.t table that is + indexed by ai for i = E.get_key. + The elements of the table are built using E.mk_elt c [|a0,..,an|] + *) - let mk_elt evd i a = {parg1= a.(2); parg2= a.(3); satOK= a.(5)} + let make_elt (evd, i) = + match get_projections_from_constant (evd, i) with + | None -> + let env = Global.env () in + let t = string_of_ppcmds (pr_constr env evd i) in + failwith ("Cannot register term " ^ t) + | Some a -> E.mk_elt evd i a + + let register_hint evd t elt = + match EConstr.kind evd t with + | App(c,_) -> + E.table := HConstr.add c (Application t, E.cast elt) !E.table + | _ -> E.table := HConstr.add t (OtherTerm t, E.cast elt) !E.table - let get_key = 1 - let reduce_term evd t = t + + + let register_constr env evd c = + let c = EConstr.of_constr c in + let t = get_type_of env evd c in + match EConstr.kind evd t with + | App (intyp, args) -> + let styp = args.(E.get_key) in + let elt = {decl= c; deriv= (make_elt (evd, c))} in + register_hint evd styp elt + | _ -> + let env = Global.env () in + raise (CErrors.user_err Pp. + (str ": Cannot register term "++pr_constr env evd c++ + str ". It has type "++pr_constr env evd t++str " which should be of the form [F X1 .. Xn]")) + + let register_obj : Constr.constr -> Libobject.obj = + let cache_constr (_, c) = + let env = Global.env () in + let evd = Evd.from_env env in + register_constr env evd c + in + let subst_constr (subst, c) = Mod_subst.subst_mps subst c in + Libobject.declare_object + @@ Libobject.superglobal_object_nodischarge + ("register-zify-" ^ E.name) + ~cache:cache_constr ~subst:(Some subst_constr) + + (** [register c] is called from the VERNACULAR ADD [name] constr(t). + The term [c] is interpreted and + registered as a [superglobal_object_nodischarge]. + TODO: pre-compute [get_type_of] - [cache_constr] is using another environment. + *) + let register = fun c -> + let env = Global.env () in + let evd = Evd.from_env env in + let evd, c = Constrintern.interp_open_constr env evd c in + let _ = Lib.add_anonymous_leaf (register_obj (EConstr.to_constr evd c)) in + () + + + let pp_keys () = + let env = Global.env () in + let evd = Evd.from_env env in + HConstr.fold + (fun _ (k,d) acc -> + match E.dest d with + | None -> acc + | Some _ -> + Pp.(pr_constr env evd (constr_of_term_kind k) ++ str " " ++ acc)) + (!E.table) (Pp.str "") + + + let print () = Feedback.msg_info (pp_keys ()) end +module InjTable = MakeTable (EInj) + + +module ESat = struct + type elt = ESatT.t + open ESatT + + let name = "Saturate" + + let table = saturate + + let cast x = Saturate x + + let dest = function + | Saturate x -> Some x + | _ -> None + + let mk_elt evd i a = {parg1= a.(2); parg2= a.(3); satOK= a.(5)} + + let get_key = 1 + +end module BinOp = MakeTable (EBinOp) module UnOp = MakeTable (EUnOp) module CstOp = MakeTable (ECstOp) module BinRel = MakeTable (EBinRel) module PropOp = MakeTable (EPropOp) +module PropUnOp = MakeTable (EPropUnOp) module Saturate = MakeTable (ESat) - +let init_cache () = + table_cache := !table; + saturate_cache := !saturate (** The module [Spec] is used to register @@ -467,37 +557,11 @@ module Spec = struct end -let register_decl = function - | PropOp -> PropOp.register_constr - | InjTyp -> InjTable.register_constr - | BinRel -> BinRel.register_constr - | BinOp -> BinOp.register_constr - | UnOp -> UnOp.register_constr - | CstOp -> CstOp.register_constr - | Saturate -> Saturate.register_constr - - -let process_decl (d,c) = - let env = Global.env () in - let evd = Evd.from_env env in - register_decl d env evd c - -let process_all_decl () = - List.iter process_decl !not_registered ; - not_registered := [] - - let unfold_decl evd = let f cst acc = cst :: acc in - let acc = InjTable.fold_declared_const f evd [] in - let acc = BinOp.fold_declared_const f evd acc in - let acc = UnOp.fold_declared_const f evd acc in - let acc = CstOp.fold_declared_const f evd acc in - let acc = BinRel.fold_declared_const f evd acc in - let acc = PropOp.fold_declared_const f evd acc in - acc + fold_declared_const f evd [] -open InjElt +open EInjT (** Get constr of lemma and projections in ZifyClasses. *) @@ -545,7 +609,7 @@ let iff = lazy (zify "iff") let to_unfold = lazy - (List.map locate_const + (List.rev_map locate_const [ "source_prop" ; "target_prop" ; "uop_iff" @@ -567,6 +631,7 @@ let to_unfold = ; "mkapp0" ; "mkprop_op" ]) + (** Module [CstrTable] records terms [x] injected into [inj x] together with the corresponding type constraint. The terms are stored by side-effect during the traversal @@ -585,7 +650,7 @@ module CstrTable = struct let table : EConstr.t HConstr.t = HConstr.create 10 - let register evd t (i : EConstr.t) = HConstr.replace table t i + let register evd t (i : EConstr.t) = HConstr.add table t i let get () = let l = HConstr.fold (fun k i acc -> (k, i) :: acc) table [] in @@ -601,7 +666,7 @@ module CstrTable = struct let has_hyp = let hyps_table = HConstr.create 20 in List.iter - (fun (_, (t : EConstr.types)) -> HConstr.replace hyps_table t ()) + (fun (_, (t : EConstr.types)) -> HConstr.add hyps_table t ()) (Tacmach.New.pf_hyps_types gl) ; fun c -> HConstr.mem hyps_table c in @@ -641,9 +706,9 @@ let mkvar red evd inj v = ; EConstr.mkApp (force eq_refl, [|inj.target; iv|]) |] ) type texpr = - | Var of InjElt.elt * EConstr.t + | Var of EInj.elt * EConstr.t (** Var is a term that cannot be injected further *) - | Constant of InjElt.elt * EConstr.t + | Constant of EInj.elt * EConstr.t (** Constant is a term that is solely built from constructors *) | Injterm of EConstr.t (** Injected is an injected term represented by a term of type [injterm] *) @@ -667,7 +732,7 @@ let mkapp2_id evd i (* InjTyp S3 T *) let default () = let e1' = inj_term_of_texpr evd e1 in let e2' = inj_term_of_texpr evd e2 in - EBinOp.( + EBinOpT.( Injterm (EConstr.mkApp ( force mkapp2 @@ -694,7 +759,7 @@ let mkapp2_id evd i (* InjTyp S3 T *) | _, _ -> default () let mkapp_id evd i inj (unop, u) f e1 = - if EConstr.eq_constr evd u.unop f then + EUnOpT.(if EConstr.eq_constr evd u.unop f then (* Injection does nothing *) match e1 with | Constant (_, e) | Var (_, e) -> Var (inj, EConstr.mkApp (f, [|e|])) @@ -716,61 +781,109 @@ let mkapp_id evd i inj (unop, u) f e1 = (EConstr.mkApp ( force mkapp , [|u.source1; u.source2; u.target; f; u.inj1_t; u.inj2_t; unop; e1|] - )) + ))) type typed_constr = {constr: EConstr.t; typ: EConstr.t} -type op = - | Unop of - { unop: EConstr.t - ; (* unop : typ unop_arg -> unop_typ *) - unop_typ: EConstr.t - ; unop_arg: typed_constr } - | Binop of - { binop: EConstr.t - ; (* binop : typ binop_arg1 -> typ binop_arg2 -> binop_typ *) - binop_typ: EConstr.t - ; binop_arg1: typed_constr - ; binop_arg2: typed_constr } - - -let rec trans_expr env evd e = + + +let get_injection env evd t = + match snd (HConstr.find t !table_cache) with + | InjTyp i -> i + | _ -> raise Not_found + + + (* [arrow] is the term (fun (x:Prop) (y : Prop) => x -> y) *) + let arrow = + let name x = + Context.make_annot (Name.mk_name (Names.Id.of_string x)) Sorts.Relevant in + EConstr.mkLambda + ( name "x" + , EConstr.mkProp + , EConstr.mkLambda + ( name "y" + , EConstr.mkProp + , EConstr.mkProd + ( Context.make_annot Names.Anonymous Sorts.Relevant + , EConstr.mkRel 2 + , EConstr.mkRel 2 ) ) ) + + + let is_prop env sigma term = + let sort = Retyping.get_sort_of env sigma term in + Sorts.is_prop sort + + (** [get_application env evd e] expresses [e] as an application (c a) + where c is the head symbol and [a] is the array of arguments. + The function also transforms (x -> y) as (arrow x y) *) + let get_operator env evd e = + let is_arrow a p1 p2 = + is_prop env evd p1 && is_prop (EConstr.push_rel (Context.Rel.Declaration.LocalAssum(a,p1)) env) evd p2 + && (a.Context.binder_name = Names.Anonymous || EConstr.Vars.noccurn evd 1 p2) in + match EConstr.kind evd e with + | Prod (a, p1, p2) when is_arrow a p1 p2 -> + (arrow,[|p1 ;p2|]) + | App(c,a) -> (c,a) + | _ -> (e,[||]) + + + let is_convertible env evd k t = + Reductionops.check_conv env evd k t + + (** [match_operator env evd hd arg (t,d)] + - hd is head operator of t + - If t = OtherTerm _, then t = hd + - If t = Application _, then + we extract the relevant number of arguments from arg + and check for convertibility *) + let match_operator env evd hd args (t, d) = + let decomp t i = + let n = Array.length args in + let t' = EConstr.mkApp(hd,Array.sub args 0 (n-i)) in + if is_convertible env evd t' t + then Some (d,t) + else None in + + match t with + | OtherTerm t -> Some(d,t) + | Application t -> + match d with + | CstOp _ -> decomp t 0 + | UnOp _ -> decomp t 1 + | BinOp _ -> decomp t 2 + | BinRel _ -> decomp t 2 + | PropOp _ -> decomp t 2 + | PropUnOp _ -> decomp t 1 + | _ -> None + + + let rec trans_expr env evd e = (* Get the injection *) - let {decl= i; deriv= inj} = InjTable.get evd e.typ in + let {decl= i; deriv= inj} = get_injection env evd e.typ in let e = e.constr in if EConstr.isConstruct evd e then Constant (inj, e) (* Evaluate later *) else + let (c,a) = get_operator env evd e in try - (* The term [e] might be a registered constant *) - let {decl= c} = CstOp.get evd e in - Injterm - (EConstr.mkApp (force mkapp0, [|inj.source; inj.target; e; i; c|])) - with Not_found -> ( - (* Let decompose the term *) - match EConstr.kind evd e with - | App (t, a) -> ( - try - match Array.length a with - | 1 -> - let {decl= unop; deriv= u} = UnOp.get evd t in - let a' = trans_expr env evd {constr= a.(0); typ= u.source1} in - if is_constant a' && EConstr.isConstruct evd t then - Constant (inj, e) - else mkapp_id evd i inj (unop, u) t a' - | 2 -> - let {decl= bop; deriv= b} = BinOp.get evd t in - let a0 = - trans_expr env evd {constr= a.(0); typ= b.EBinOp.source1} - in - let a1 = - trans_expr env evd {constr= a.(1); typ= b.EBinOp.source2} - in - if is_constant a0 && is_constant a1 && EConstr.isConstruct evd t - then Constant (inj, e) - else mkapp2_id evd i inj t bop b a0 a1 - | _ -> Var (inj, e) - with Not_found -> Var (inj, e) ) - | _ -> Var (inj, e) ) + let (k,t) = find_option (match_operator env evd c a) (HConstr.find_all c !table_cache) in + let n = Array.length a in + match k with + | CstOp {decl = c'} -> + Injterm (EConstr.mkApp (force mkapp0, [|inj.source; inj.target; e; i; c'|])) + | UnOp {decl = unop ; deriv = u} -> + let a' = trans_expr env evd {constr= a.(n-1); typ= u.EUnOpT.source1} in + if is_constant a' && EConstr.isConstruct evd t then + Constant (inj, e) + else mkapp_id evd i inj (unop, u) t a' + | BinOp {decl = binop ; deriv = b} -> + let a0 = trans_expr env evd {constr= a.(n-2); typ= b.EBinOpT.source1} in + let a1 = trans_expr env evd {constr= a.(n-1); typ= b.EBinOpT.source2} in + if is_constant a0 && is_constant a1 && EConstr.isConstruct evd t + then Constant (inj, e) + else mkapp2_id evd i inj t binop b a0 a1 + | d -> + Var (inj,e) + with Not_found -> Var (inj,e) let trans_expr env evd e = try trans_expr env evd e with Not_found -> @@ -779,68 +892,6 @@ let trans_expr env evd e = ( Pp.str "Missing injection for type " ++ Printer.pr_leconstr_env env evd e.typ )) -let is_prop env sigma term = - let sort = Retyping.get_sort_of env sigma term in - Sorts.is_prop sort - -let get_rel env evd e = - let is_arrow a p1 p2 = - is_prop env evd p1 && is_prop (EConstr.push_rel (Context.Rel.Declaration.LocalAssum(a,p1)) env) evd p2 - && (a.Context.binder_name = Names.Anonymous || EConstr.Vars.noccurn evd 1 p2) - in - match EConstr.kind evd e with - | Prod (a, p1, p2) when is_arrow a p1 p2 -> - (* X -> Y becomes (fun x y => x -> y) x y *) - let name x = - Context.make_annot (Name.mk_name (Names.Id.of_string x)) Sorts.Relevant - in - let arrow = - EConstr.mkLambda - ( name "x" - , EConstr.mkProp - , EConstr.mkLambda - ( name "y" - , EConstr.mkProp - , EConstr.mkProd - ( Context.make_annot Names.Anonymous Sorts.Relevant - , EConstr.mkRel 2 - , EConstr.mkRel 2 ) ) ) - in - Binop - { binop= arrow - ; binop_typ= EConstr.mkProp - ; binop_arg1= {constr= p1; typ= EConstr.mkProp} - ; binop_arg2= {constr= p2; typ= EConstr.mkProp} } - | App (c, a) -> - let len = Array.length a in - if len >= 2 then - let c, a1, a2 = - if len = 2 then (c, a.(0), a.(1)) - else if len > 2 then - ( EConstr.mkApp (c, Array.sub a 0 (len - 2)) - , a.(len - 2) - , a.(len - 1) ) - else raise Not_found - in - let typ = get_type_of env evd c in - match get_binary_arrow evd typ with - | None -> raise Not_found - | Some (t1, t2, t3) -> - Binop - { binop= c - ; binop_typ= t3 - ; binop_arg1= {constr= a1; typ= t1} - ; binop_arg2= {constr= a2; typ= t2} } - else if len = 1 then - let typ = get_type_of env evd c in - match get_unary_arrow evd typ with - | None -> raise Not_found - | Some (t1, t2) -> - Unop {unop= c; unop_typ= t2; unop_arg= {constr= a.(0); typ= t1}} - else raise Not_found - | _ -> raise Not_found - -let get_rel env evd e = try Some (get_rel env evd e) with Not_found -> None type tprop = | TProp of EConstr.t (** Transformed proposition *) @@ -852,47 +903,42 @@ let mk_iprop e = let inj_prop_of_tprop = function TProp p -> p | IProp e -> mk_iprop e let rec trans_prop env evd e = - match get_rel env evd e with - | None -> IProp e - | Some (Binop {binop= r; binop_typ= t1; binop_arg1= a1; binop_arg2= a2}) -> - assert (EConstr.eq_constr evd EConstr.mkProp t1) ; - if EConstr.eq_constr evd a1.typ a2.typ then - (* Arguments have the same type *) - if - EConstr.eq_constr evd EConstr.mkProp t1 - && EConstr.eq_constr evd EConstr.mkProp a1.typ - then - (* Prop -> Prop -> Prop *) - try - let {decl= rop} = PropOp.get evd r in - let t1 = trans_prop env evd a1.constr in - let t2 = trans_prop env evd a2.constr in - match (t1, t2) with + let (c,a) = get_operator env evd e in + try + let (k,t) = find_option (match_operator env evd c a) (HConstr.find_all c !table_cache) in + let n = Array.length a in + match k with + | PropOp {decl= rop} -> + begin + try + let t1 = trans_prop env evd a.(n-2) in + let t2 = trans_prop env evd a.(n-1) in + match (t1, t2) with | IProp _, IProp _ -> IProp e | _, _ -> - let t1 = inj_prop_of_tprop t1 in + let t1 = inj_prop_of_tprop t1 in let t2 = inj_prop_of_tprop t2 in - TProp (EConstr.mkApp (force mkprop_op, [|r; rop; t1; t2|])) - with Not_found -> IProp e - else - (* A -> A -> Prop *) - try - let {decl= br; deriv= rop} = BinRel.get evd r in - let a1 = trans_expr env evd {a1 with typ = rop.EBinRel.source} in - let a2 = trans_expr env evd {a2 with typ = rop.EBinRel.source} in - if EConstr.eq_constr evd r rop.EBinRel.brel then + TProp (EConstr.mkApp (force mkprop_op, [|t; rop; t1; t2|])) + with Not_found -> IProp e + end + | BinRel {decl = br ; deriv = rop} -> + begin + try + let a1 = trans_expr env evd {constr = a.(n-2) ; typ = rop.EBinRelT.source} in + let a2 = trans_expr env evd {constr = a.(n-1) ; typ = rop.EBinRelT.source} in + if EConstr.eq_constr evd t rop.EBinRelT.brel then match (constr_of_texpr a1, constr_of_texpr a2) with - | Some e1, Some e2 -> IProp (EConstr.mkApp (r, [|e1; e2|])) + | Some e1, Some e2 -> IProp (EConstr.mkApp (t, [|e1; e2|])) | _, _ -> let a1 = inj_term_of_texpr evd a1 in let a2 = inj_term_of_texpr evd a2 in TProp (EConstr.mkApp ( force mkrel - , [| rop.EBinRel.source - ; rop.EBinRel.target - ; r - ; rop.EBinRel.inj + , [| rop.EBinRelT.source + ; rop.EBinRelT.target + ; t + ; rop.EBinRelT.inj ; br ; a1 ; a2 |] )) @@ -902,37 +948,35 @@ let rec trans_prop env evd e = TProp (EConstr.mkApp ( force mkrel - , [| rop.EBinRel.source - ; rop.EBinRel.target - ; r - ; rop.EBinRel.inj + , [| rop.EBinRelT.source + ; rop.EBinRelT.target + ; t + ; rop.EBinRelT.inj ; br ; a1 ; a2 |] )) with Not_found -> IProp e - else IProp e - | Some (Unop {unop; unop_typ; unop_arg}) -> - if - EConstr.eq_constr evd EConstr.mkProp unop_typ - && EConstr.eq_constr evd EConstr.mkProp unop_arg.typ - then - try - let {decl= rop} = PropOp.get evd unop in - let t1 = trans_prop env evd unop_arg.constr in - match t1 with - | IProp _ -> IProp e - | _ -> - let t1 = inj_prop_of_tprop t1 in - TProp (EConstr.mkApp (force mkuprop_op, [|unop; rop; t1|])) - with Not_found -> IProp e - else IProp e + end + | PropUnOp {decl = rop} -> + begin + try + let t1 = trans_prop env evd a.(n-1) in + match t1 with + | IProp _ -> IProp e + | _ -> + let t1 = inj_prop_of_tprop t1 in + TProp (EConstr.mkApp (force mkuprop_op, [|t; rop; t1|])) + with Not_found -> IProp e + end + | _ -> IProp e + with Not_found -> IProp e let unfold n env evd c = let cbv l = CClosure.RedFlags.( Tacred.cbv_norm_flags (mkflags - (fBETA :: fMATCH :: fFIX :: fCOFIX :: fZETA :: List.map fCONST l))) + (fBETA :: fMATCH :: fFIX :: fCOFIX :: fZETA :: List.rev_map fCONST l))) in let unfold_decl = unfold_decl evd in (* Unfold the let binding *) @@ -943,7 +987,7 @@ let unfold n env evd c = Tacred.unfoldn [(Locus.AllOccurrences, Names.EvalVarRef n)] env evd c in (* Reduce the term *) - let c = cbv (force to_unfold @ unfold_decl) env evd c in + let c = cbv (List.rev_append (force to_unfold) unfold_decl) env evd c in c let trans_check_prop env evd t = @@ -1029,7 +1073,7 @@ let zify_tac = Proofview.Goal.enter (fun gl -> Coqlib.check_required_library ["Coq"; "micromega"; "ZifyClasses"] ; Coqlib.check_required_library ["Coq"; "micromega"; "ZifyInst"] ; - process_all_decl (); + init_cache (); let evd = Tacmach.New.project gl in let env = Tacmach.New.pf_env gl in let concl = trans_check_prop env evd (Tacmach.New.pf_concl gl) in @@ -1038,12 +1082,12 @@ let zify_tac = tclTHENOpt concl trans_concl (Tacticals.New.tclTHEN (Tacticals.New.tclTHENLIST - (List.map (fun (h, p, t) -> trans_hyp h p t) hyps)) + (List.rev_map (fun (h, p, t) -> trans_hyp h p t) hyps)) (CstrTable.gen_cstr l)) ) let iter_specs tac = Tacticals.New.tclTHENLIST - (List.fold_right (fun d acc -> tac d :: acc) (Spec.get ()) []) + (List.fold_left (fun acc d -> tac d :: acc) [] (Spec.get ())) let iter_specs (tac: Ltac_plugin.Tacinterp.Value.t) = @@ -1063,11 +1107,11 @@ let sat_constr c d = if Array.length args = 2 then ( let h1 = Tacred.cbv_beta env evd - (EConstr.mkApp (d.ESat.parg1, [|args.(0)|])) + (EConstr.mkApp (d.ESatT.parg1, [|args.(0)|])) in let h2 = Tacred.cbv_beta env evd - (EConstr.mkApp (d.ESat.parg2, [|args.(1)|])) + (EConstr.mkApp (d.ESatT.parg2, [|args.(1)|])) in match (find_hyp evd h1 hyps, find_hyp evd h2 hyps) with | Some h1, Some h2 -> @@ -1078,7 +1122,7 @@ let sat_constr c d = in let trm = EConstr.mkApp - ( d.ESat.satOK + ( d.ESatT.satOK , [|args.(0); args.(1); EConstr.mkVar h1; EConstr.mkVar h2|] ) in @@ -1087,20 +1131,28 @@ let sat_constr c d = else Tacticals.New.tclIDTAC | _ -> Tacticals.New.tclIDTAC ) + +let get_all_sat env evd c = + List.fold_left (fun acc e -> + match e with + | (_,Saturate s) -> s::acc + | _ -> acc) [] (HConstr.find_all c !saturate_cache ) + let saturate = Proofview.Goal.enter (fun gl -> + init_cache (); let table = CstrTable.HConstr.create 20 in let concl = Tacmach.New.pf_concl gl in let hyps = Tacmach.New.pf_hyps_types gl in let evd = Tacmach.New.project gl in - process_all_decl (); + let env = Tacmach.New.pf_env gl in let rec sat t = match EConstr.kind evd t with | App (c, args) -> sat c ; Array.iter sat args ; if Array.length args = 2 then - let ds = Saturate.get_all evd c in + let ds = get_all_sat env evd c in if ds = [] then () else ( List.iter (fun x -> CstrTable.HConstr.add table t x.deriv) ds ) diff --git a/plugins/micromega/zify.mli b/plugins/micromega/zify.mli index f7844f53bc..54e8f07ddc 100644 --- a/plugins/micromega/zify.mli +++ b/plugins/micromega/zify.mli @@ -17,6 +17,7 @@ module BinOp : S module CstOp : S module BinRel : S module PropOp : S +module PropUnOp : S module Spec : S module Saturate : S diff --git a/plugins/setoid_ring/InitialRing.v b/plugins/setoid_ring/InitialRing.v index a98a963207..dc096554c8 100644 --- a/plugins/setoid_ring/InitialRing.v +++ b/plugins/setoid_ring/InitialRing.v @@ -828,31 +828,31 @@ Ltac ring_elements set ext rspec pspec sspec dspec rk := end in ring_elements set ext rspec pspec sspec dspec rk ltac:(fun arth ext_r morph p_spec s_spec d_spec => - match type of morph with + lazymatch type of morph with | @ring_morph ?R ?r0 ?rI ?radd ?rmul ?rsub ?ropp ?req ?C ?c0 ?c1 ?cadd ?cmul ?csub ?copp ?ceq_b ?phi => let gen_lemma2_0 := constr:(gen_lemma2 R r0 rI radd rmul rsub ropp req set ext_r arth C c0 c1 cadd cmul csub copp ceq_b phi morph) in - match p_spec with + lazymatch p_spec with | @mkhypo (power_theory _ _ _ ?Cp_phi ?rpow) ?pp_spec => let gen_lemma2_1 := constr:(gen_lemma2_0 _ Cp_phi rpow pp_spec) in - match d_spec with + lazymatch d_spec with | @mkhypo (div_theory _ _ _ _ ?cdiv) ?dd_spec => let gen_lemma2_2 := constr:(gen_lemma2_1 cdiv dd_spec) in - match s_spec with + lazymatch s_spec with | @mkhypo (sign_theory _ _ ?get_sign) ?ss_spec => let lemma2 := constr:(gen_lemma2_2 get_sign ss_spec) in let lemma1 := constr:(ring_correct set ext_r arth morph pp_spec dd_spec) in fun f => f arth ext_r morph lemma1 lemma2 - | _ => fail 4 "ring: bad sign specification" + | _ => fail "ring: bad sign specification" end - | _ => fail 3 "ring: bad coefficient division specification" + | _ => fail "ring: bad coefficient division specification" end - | _ => fail 2 "ring: bad power specification" + | _ => fail "ring: bad power specification" end - | _ => fail 1 "ring internal error: ring_lemmas, please report" + | _ => fail "ring internal error: ring_lemmas, please report" end). (* Tactic for constant *) diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 76c393450b..e3e787df2c 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -139,8 +139,8 @@ let _ = add_tacdef false ((Loc.ghost,Id.of_string"ring_closed_term" let ic c = let env = Global.env() in let sigma = Evd.from_env env in - let sigma, c = Constrintern.interp_open_constr env sigma c in - (sigma, c) + let c, uctx = Constrintern.interp_constr env sigma c in + (Evd.from_ctx uctx, c) let ic_unsafe c = (*FIXME remove *) let env = Global.env() in diff --git a/plugins/ssr/ssrfun.v b/plugins/ssr/ssrfun.v index 0ce3752a51..b8affba541 100644 --- a/plugins/ssr/ssrfun.v +++ b/plugins/ssr/ssrfun.v @@ -56,6 +56,10 @@ Require Import ssreflect. Structure inference, as in the implementation of the mxdirect predicate in matrix.v. + - The empty type: + void == a notation for the Empty_set type of the standard library. + of_void T == the canonical injection void -> T. + - Sigma types: tag w == the i of w : {i : I & T i}. tagged w == the T i component of w : {i : I & T i}. @@ -166,7 +170,7 @@ Require Import ssreflect. right_loop inv op <-> op, inv obey the inverse loop right axiom: (x op y) op (inv y) = x for all x, y. rev_right_loop inv op <-> op, inv obey the inverse loop reverse right - axiom: (x op y) op (inv y) = x for all x, y. + axiom: (x op (inv y)) op y = x for all x, y. Note that familiar "cancellation" identities like x + y - y = x or x - y + y = x are respectively instances of right_loop and rev_right_loop The corresponding lemmas will use the K and NK/VK suffixes, respectively. @@ -483,6 +487,12 @@ Arguments idfun {T} x /. Definition phant_id T1 T2 v1 v2 := phantom T1 v1 -> phantom T2 v2. +(** The empty type. **) + +Notation void := Empty_set. + +Definition of_void T (x : void) : T := match x with end. + (** Strong sigma types. **) Section Tag. @@ -642,6 +652,9 @@ End Injections. Lemma Some_inj {T : nonPropType} : injective (@Some T). Proof. by move=> x y []. Qed. +Lemma of_voidK T : pcancel (of_void T) [fun _ => None]. +Proof. by case. Qed. + (** cancellation lemmas for dependent type casts. **) Lemma esymK T x y : cancel (@esym T x y) (@esym T y x). Proof. by case: y /. Qed. diff --git a/pretyping/globEnv.ml b/pretyping/globEnv.ml index d49a39b547..aebe47a7a7 100644 --- a/pretyping/globEnv.ml +++ b/pretyping/globEnv.ml @@ -166,7 +166,7 @@ let interp_ltac_variable ?loc typing_fun env sigma id : Evd.evar_map * unsafe_ju here, as the call to the main pretyping function is caught inside the try but I want to avoid refactoring this function too much for now. *) - typing_fun {env with lvar} term + typing_fun {env with lvar; static_env = env.renamed_env} term with Not_found -> (* Check if [id] is a ltac variable not bound to a term *) (* and build a nice error message *) diff --git a/pretyping/locusops.ml b/pretyping/locusops.ml index 02c8f6a2a8..9c6cf090a2 100644 --- a/pretyping/locusops.ml +++ b/pretyping/locusops.ml @@ -10,6 +10,12 @@ open Locus +(** Utilities on or_var *) + +let or_var_map f = function + | ArgArg x -> ArgArg (f x) + | ArgVar _ as y -> y + (** Utilities on occurrences *) let occurrences_map f = function diff --git a/pretyping/locusops.mli b/pretyping/locusops.mli index 195dbec935..47d2ffe797 100644 --- a/pretyping/locusops.mli +++ b/pretyping/locusops.mli @@ -11,6 +11,10 @@ open Names open Locus +(** Utilities on or_var *) + +val or_var_map : ('a -> 'b) -> 'a or_var -> 'b or_var + (** Utilities on occurrences *) val occurrences_map : diff --git a/printing/printer.ml b/printing/printer.ml index 328082fbc2..10a31ac256 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -635,27 +635,34 @@ let () = optwrite = (fun v -> should_print_dependent_evars := v) } let print_dependent_evars gl sigma seeds = - let constraints = print_evar_constraints gl sigma in - let evars () = - if !should_print_dependent_evars then - let evars = Evarutil.gather_dependent_evars sigma seeds in - let evars = - Evar.Map.fold begin fun e i s -> - let e' = pr_internal_existential_key e in - match i with - | None -> s ++ str" " ++ e' ++ str " open," - | Some i -> - s ++ str " " ++ e' ++ str " using " ++ - Evar.Set.fold begin fun d s -> - pr_internal_existential_key d ++ str " " ++ s - end i (str ",") - end evars (str "") + if !should_print_dependent_evars then + let mt_pp = mt () in + let evars = Evarutil.gather_dependent_evars sigma seeds in + let evars_pp = Evar.Map.fold (fun e i s -> + let e' = pr_internal_existential_key e in + let sep = if s = mt_pp then "" else ", " in + s ++ str sep ++ e' ++ + (match i with + | None -> str ":" ++ (Termops.pr_existential_key sigma e) + | Some i -> + let using = Evar.Set.fold (fun d s -> + s ++ str " " ++ (pr_internal_existential_key d)) + i mt_pp in + str " using" ++ using)) + evars mt_pp + in + let evars_current_pp = match gl with + | None -> mt_pp + | Some gl -> + let evars_current = Evarutil.gather_dependent_evars sigma [ gl ] in + Evar.Map.fold (fun e _ s -> + s ++ str " " ++ (pr_internal_existential_key e)) + evars_current mt_pp in cut () ++ cut () ++ - str "(dependent evars:" ++ evars ++ str ")" - else mt () - in - constraints ++ evars () + str "(dependent evars: " ++ evars_pp ++ + str "; in current goal:" ++ evars_current_pp ++ str ")" + else mt () module GoalMap = Evar.Map @@ -732,6 +739,10 @@ let pr_subgoals ?(pr_first=true) ?(diffs=false) ?os_map else pr_rec 1 (g::l) in + let pr_evar_info gl sigma seeds = + let first_goal = if pr_first then gl else None in + print_evar_constraints gl sigma ++ print_dependent_evars first_goal sigma seeds + in (* Side effect! This has to be made more robust *) let () = match close_cmd with @@ -742,23 +753,21 @@ let pr_subgoals ?(pr_first=true) ?(diffs=false) ?os_map (* Main function *) match goals with | [] -> - begin - let exl = Evd.undefined_map sigma in - if Evar.Map.is_empty exl then - (str"No more subgoals." ++ print_dependent_evars None sigma seeds) - else - let pei = pr_evars_int sigma ~shelf ~given_up:[] 1 exl in - v 0 ((str "No more subgoals," - ++ str " but there are non-instantiated existential variables:" - ++ cut () ++ (hov 0 pei) - ++ print_dependent_evars None sigma seeds - ++ cut () ++ str "You can use Grab Existential Variables.")) - end + let exl = Evd.undefined_map sigma in + if Evar.Map.is_empty exl then + v 0 (str "No more subgoals." ++ pr_evar_info None sigma seeds) + else + let pei = pr_evars_int sigma ~shelf ~given_up:[] 1 exl in + v 0 ((str "No more subgoals," + ++ str " but there are non-instantiated existential variables:" + ++ cut () ++ (hov 0 pei) + ++ pr_evar_info None sigma seeds + ++ cut () ++ str "You can use Grab Existential Variables.")) | g1::rest -> let goals = print_multiple_goals g1 rest in let ngoals = List.length rest+1 in v 0 ( - int ngoals ++ focused_if_needed ++ str(String.plural ngoals "subgoal") + int ngoals ++ focused_if_needed ++ str(String.plural ngoals "subgoal") ++ print_extra ++ str (if (should_gname()) then ", subgoal 1" else "") ++ (if should_tag() then pr_goal_tag g1 else str"") @@ -766,7 +775,7 @@ let pr_subgoals ?(pr_first=true) ?(diffs=false) ?os_map ++ (if unfocused=[] then str "" else (cut() ++ cut() ++ str "*** Unfocused goals:" ++ cut() ++ pr_rec (List.length rest + 2) unfocused)) - ++ print_dependent_evars (Some g1) sigma seeds + ++ pr_evar_info (Some g1) sigma seeds ) let pr_open_subgoals_diff ?(quiet=false) ?(diffs=false) ?oproof proof = diff --git a/printing/printer.mli b/printing/printer.mli index d62d3789d3..87b09ff755 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -186,6 +186,7 @@ val pr_ne_evar_set : Pp.t -> Pp.t -> evar_map -> Evar.Set.t -> Pp.t val print_and_diff : Proof.t option -> Proof.t option -> unit +val print_dependent_evars : Evar.t option -> evar_map -> Evar.t list -> Pp.t (** Declarations for the "Print Assumption" command *) type axiom = diff --git a/printing/printmod.ml b/printing/printmod.ml index 03921bca30..4cc6bc2052 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -213,7 +213,7 @@ let print_kn locals kn = let nametab_register_dir obj_mp = let id = mk_fake_top () in let obj_dir = DirPath.make [id] in - Nametab.(push_dir (Until 1) obj_dir (GlobDirRef.DirModule { obj_dir; obj_mp; obj_sec = DirPath.empty })) + Nametab.(push_dir (Until 1) obj_dir (GlobDirRef.DirModule { obj_dir; obj_mp; })) (** Nota: the [global_reference] we register in the nametab below might differ from internal ones, since we cannot recreate here diff --git a/stm/stm.ml b/stm/stm.ml index 1042061021..5c6df26cbb 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1056,7 +1056,7 @@ end (* }}} *) (* Wrapper for the proof-closing special path for Qed *) let stm_qed_delay_proof ?route ~proof ~info ~id ~st ~loc ~control pending : Vernacstate.t = set_id_for_feedback ?route dummy_doc id; - Vernacentries.interp_qed_delayed_proof ~proof ~info ~st ~control (CAst.make ?loc pending) + Vernacinterp.interp_qed_delayed_proof ~proof ~info ~st ~control (CAst.make ?loc pending) (* Wrapper for Vernacentries.interp to set the feedback id *) (* It is currently called 19 times, this number should be certainly @@ -1083,7 +1083,7 @@ let stm_vernac_interp ?route id st { verbose; expr } : Vernacstate.t = (stm_pperr_endline Pp.(fun () -> str "ignoring " ++ Ppvernac.pr_vernac expr); st) else begin stm_pperr_endline Pp.(fun () -> str "interpreting " ++ Ppvernac.pr_vernac expr); - Vernacentries.interp ?verbosely:(Some verbose) ~st expr + Vernacinterp.interp ?verbosely:(Some verbose) ~st expr end (****************************** CRUFT *****************************************) @@ -1743,9 +1743,9 @@ end = struct (* {{{ *) assert (Univ.ContextSet.is_empty uctx) in let pr = Constr.hcons pr in - let (ci, dummy) = p.(bucket) in + let dummy = p.(bucket) in let () = assert (Option.is_empty dummy) in - p.(bucket) <- ci, Some (pr, priv); + p.(bucket) <- Some (pr, priv); Univ.ContextSet.union cst uc, false let check_task name l i = @@ -1970,7 +1970,7 @@ end = struct (* {{{ *) let stm_fail ~st fail f = if fail then - Vernacentries.with_fail ~st f + Vernacinterp.with_fail ~st f else f () @@ -2891,7 +2891,7 @@ let process_transaction ~doc ?(newtip=Stateid.fresh ()) |> Exninfo.iraise else - let proof_mode = Some (Vernacentries.get_default_proof_mode ()) in + let proof_mode = Some (Vernacinterp.get_default_proof_mode ()) in let id = VCS.new_node ~id:newtip proof_mode () in let bname = VCS.mk_branch_name x in VCS.checkout VCS.Branch.master; diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 8d600c2859..24976d8c1f 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -51,7 +51,7 @@ let stm_allow_nested_proofs_option_name = ["Nested";"Proofs";"Allowed"] let options_affecting_stm_scheduling = [ Attributes.universe_polymorphism_option_name; stm_allow_nested_proofs_option_name; - Vernacentries.proof_mode_opt_name; + Vernacinterp.proof_mode_opt_name; Attributes.program_mode_option_name; Proof_using.proof_using_opt_name; ] diff --git a/tactics/abstract.ml b/tactics/abstract.ml index edeb27ab88..03ab0a1c13 100644 --- a/tactics/abstract.ml +++ b/tactics/abstract.ml @@ -149,9 +149,12 @@ let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = let (_, info) = CErrors.push src in iraise (e, info) in + let body, effs = Future.force const.Declare.proof_entry_body in + (* We drop the side-effects from the entry, they already exist in the ambient environment *) + let const = { const with Declare.proof_entry_body = Future.from_val (body, ()) } in let const, args = shrink_entry sign const in let args = List.map EConstr.of_constr args in - let cd = Declare.DefinitionEntry { const with Declare.proof_entry_opaque = opaque } in + let cd = { const with Declare.proof_entry_opaque = opaque } in let kind = if opaque then Decls.(IsProof Lemma) else Decls.(IsDefinition Definition) in let cst () = (* do not compute the implicit arguments, it may be costly *) @@ -172,8 +175,7 @@ let cache_term_by_tactic_then ~opaque ~name_op ?(goal_type=None) tac tacK = in let lem = mkConstU (cst, inst) in let evd = Evd.set_universe_context evd ectx in - let effs = Evd.concat_side_effects eff - (snd (Future.force const.Declare.proof_entry_body)) in + let effs = Evd.concat_side_effects eff effs in let solve = Proofview.tclEFFECTS effs <*> tacK lem args diff --git a/tactics/declare.ml b/tactics/declare.ml index e418240d3a..7d32f1a7e8 100644 --- a/tactics/declare.ml +++ b/tactics/declare.ml @@ -52,11 +52,7 @@ let name_instance inst = let declare_universe_context ~poly ctx = if poly then - (* FIXME: some upper layers declare universes several times, we hack around - by checking whether the universes already exist. *) - let (univs, cstr) = ctx in - let univs = Univ.LSet.filter (fun u -> not (Lib.is_polymorphic_univ u)) univs in - let uctx = Univ.ContextSet.to_context (univs, cstr) in + let uctx = Univ.ContextSet.to_context ctx in let nas = name_instance (Univ.UContext.instance uctx) in Global.push_section_context (nas, uctx) else @@ -72,7 +68,7 @@ type constant_obj = { type 'a proof_entry = { proof_entry_body : 'a Entries.const_entry_body; (* List of section variables *) - proof_entry_secctx : Constr.named_context option; + proof_entry_secctx : Id.Set.t option; (* State id on which the completion of type checking is reported *) proof_entry_feedback : Stateid.t option; proof_entry_type : Constr.types option; @@ -208,7 +204,11 @@ let cast_proof_entry e = const_entry_inline_code = e.proof_entry_inline_code; } -let cast_opaque_proof_entry e = +type ('a, 'b) effect_entry = +| EffectEntry : (private_constants, private_constants Entries.const_entry_body) effect_entry +| PureEntry : (unit, Constr.constr) effect_entry + +let cast_opaque_proof_entry (type a b) (entry : (a, b) effect_entry) (e : a proof_entry) : b opaque_entry = let typ = match e.proof_entry_type with | None -> assert false | Some typ -> typ @@ -222,21 +222,40 @@ let cast_opaque_proof_entry e = Id.Set.empty, Id.Set.empty else let ids_typ = global_vars_set env typ in - let (pf, _), eff = Future.force e.proof_entry_body in - let env = Safe_typing.push_private_constants env eff in + let pf, env = match entry with + | PureEntry -> + let (pf, _), () = Future.force e.proof_entry_body in + pf, env + | EffectEntry -> + let (pf, _), eff = Future.force e.proof_entry_body in + let env = Safe_typing.push_private_constants env eff in + pf, env + in let vars = global_vars_set env pf in ids_typ, vars in let () = if Aux_file.recording () then record_aux env hyp_typ hyp_def in - keep_hyps env (Id.Set.union hyp_typ hyp_def) + Environ.really_needed env (Id.Set.union hyp_typ hyp_def) | Some hyps -> hyps in + let (body, univs : b * _) = match entry with + | PureEntry -> + let (body, uctx), () = Future.force e.proof_entry_body in + let univs = match e.proof_entry_universes with + | Monomorphic_entry uctx' -> Monomorphic_entry (Univ.ContextSet.union uctx uctx') + | Polymorphic_entry _ -> + assert (Univ.ContextSet.is_empty uctx); + e.proof_entry_universes + in + body, univs + | EffectEntry -> e.proof_entry_body, e.proof_entry_universes + in { - opaque_entry_body = e.proof_entry_body; + opaque_entry_body = body; opaque_entry_secctx = secctx; opaque_entry_feedback = e.proof_entry_feedback; opaque_entry_type = typ; - opaque_entry_universes = e.proof_entry_universes; + opaque_entry_universes = univs; } let get_roles export eff = @@ -251,58 +270,65 @@ let is_unsafe_typing_flags () = let flags = Environ.typing_flags (Global.env()) in not (flags.check_universes && flags.check_guarded && flags.check_positive) -let define_constant ~side_effect ~name cd = +let define_constant ~name cd = (* Logically define the constant and its subproofs, no libobject tampering *) - let in_section = Lib.sections_are_opened () in let export, decl, unsafe = match cd with | DefinitionEntry de -> (* We deal with side effects *) if not de.proof_entry_opaque then (* This globally defines the side-effects in the environment. *) let body, eff = Future.force de.proof_entry_body in - let body, export = Global.export_private_constants ~in_section (body, eff.Evd.seff_private) in + let body, export = Global.export_private_constants (body, eff.Evd.seff_private) in let export = get_roles export eff in let de = { de with proof_entry_body = Future.from_val (body, ()) } in let cd = Entries.DefinitionEntry (cast_proof_entry de) in - export, ConstantEntry (PureEntry, cd), false + export, ConstantEntry cd, false else let map (body, eff) = body, eff.Evd.seff_private in let body = Future.chain de.proof_entry_body map in let de = { de with proof_entry_body = body } in - let de = cast_opaque_proof_entry de in - [], ConstantEntry (EffectEntry, Entries.OpaqueEntry de), false + let de = cast_opaque_proof_entry EffectEntry de in + [], OpaqueEntry de, false | ParameterEntry e -> - [], ConstantEntry (PureEntry, Entries.ParameterEntry e), not (Lib.is_modtype_strict()) + [], ConstantEntry (Entries.ParameterEntry e), not (Lib.is_modtype_strict()) | PrimitiveEntry e -> - [], ConstantEntry (PureEntry, Entries.PrimitiveEntry e), false + [], ConstantEntry (Entries.PrimitiveEntry e), false in - let kn, eff = Global.add_constant ~side_effect ~in_section name decl in + let kn = Global.add_constant name decl in if unsafe || is_unsafe_typing_flags() then feedback_axiom(); - kn, eff, export + kn, export let declare_constant ?(local = ImportDefaultBehavior) ~name ~kind cd = let () = check_exists name in - let kn, (), export = define_constant ~side_effect:PureEntry ~name cd in + let kn, export = define_constant ~name cd in (* Register the libobjects attached to the constants and its subproofs *) let () = List.iter register_side_effect export in let () = register_constant kn kind local in kn -let declare_private_constant ?role ?(local = ImportDefaultBehavior) ~name ~kind cd = - let kn, eff, export = define_constant ~side_effect:EffectEntry ~name cd in - let () = assert (CList.is_empty export) in +let declare_private_constant ?role ?(local = ImportDefaultBehavior) ~name ~kind de = + let kn, eff = + let de = + if not de.proof_entry_opaque then + DefinitionEff (cast_proof_entry de) + else + let de = cast_opaque_proof_entry PureEntry de in + OpaqueEff de + in + Global.add_private_constant name de + in let () = register_constant kn kind local in let seff_roles = match role with | None -> Cmap.empty | Some r -> Cmap.singleton kn r in - let eff = { Evd.seff_private = eff.Entries.seff_wrap; Evd.seff_roles; } in + let eff = { Evd.seff_private = eff; Evd.seff_roles; } in kn, eff (** Declaration of section variables and local definitions *) type variable_declaration = | SectionLocalDef of Evd.side_effects proof_entry - | SectionLocalAssum of { typ:Constr.types; univs:Univ.ContextSet.t; poly:bool; impl:Glob_term.binding_kind } + | SectionLocalAssum of { typ:Constr.types; impl:Glob_term.binding_kind; } (* This object is only for things which iterate over objects to find variables (only Prettyp.print_context AFAICT) *) @@ -315,16 +341,15 @@ let declare_variable ~name ~kind d = if Decls.variable_exists name then raise (AlreadyDeclared (None, name)); - let impl,opaque,poly = match d with (* Fails if not well-typed *) - | SectionLocalAssum {typ;univs;poly;impl} -> - let () = declare_universe_context ~poly univs in + let impl,opaque = match d with (* Fails if not well-typed *) + | SectionLocalAssum {typ;impl} -> let () = Global.push_named_assum (name,typ) in - impl, true, poly + impl, true | SectionLocalDef (de) -> (* The body should already have been forced upstream because it is a section-local definition, but it's not enforced by typing *) let (body, eff) = Future.force de.proof_entry_body in - let ((body, uctx), export) = Global.export_private_constants ~in_section:true (body, eff.Evd.seff_private) in + let ((body, uctx), export) = Global.export_private_constants (body, eff.Evd.seff_private) in let eff = get_roles export eff in let () = List.iter register_side_effect eff in let poly, univs = match de.proof_entry_universes with @@ -342,12 +367,11 @@ let declare_variable ~name ~kind d = secdef_type = de.proof_entry_type; } in let () = Global.push_named_def (name, se) in - Glob_term.Explicit, de.proof_entry_opaque, - poly + Glob_term.Explicit, de.proof_entry_opaque in Nametab.push (Nametab.Until 1) (Libnames.make_path DirPath.empty name) (GlobRef.VarRef name); Decls.(add_variable_data name {opaque;kind}); - add_anonymous_leaf (inVariable ()); + ignore(add_leaf name (inVariable ()) : Libobject.object_name); Impargs.declare_var_implicits ~impl name; Notation.declare_ref_arguments_scope Evd.empty (GlobRef.VarRef name) @@ -591,7 +615,7 @@ let declare_univ_binders gr pl = Lib.add_anonymous_leaf (input_univ_names (QualifiedUniv l, univs)) let do_universe ~poly l = - let in_section = Lib.sections_are_opened () in + let in_section = Global.sections_are_opened () in let () = if poly && not in_section then CErrors.user_err ~hdr:"Constraint" @@ -608,28 +632,12 @@ let do_universe ~poly l = let do_constraint ~poly l = let open Univ in let u_of_id x = - let level = Pretyping.interp_known_glob_level (Evd.from_env (Global.env ())) x in - Lib.is_polymorphic_univ level, level - in - let in_section = Lib.sections_are_opened () in - let () = - if poly && not in_section then - CErrors.user_err ~hdr:"Constraint" - (str"Cannot declare polymorphic constraints outside sections") - in - let check_poly p p' = - if poly then () - else if p || p' then - CErrors.user_err ~hdr:"Constraint" - (str "Cannot declare a global constraint on " ++ - str "a polymorphic universe, use " - ++ str "Polymorphic Constraint instead") + Pretyping.interp_known_glob_level (Evd.from_env (Global.env ())) x in let constraints = List.fold_left (fun acc (l, d, r) -> - let p, lu = u_of_id l and p', ru = u_of_id r in - check_poly p p'; - Constraint.add (lu, d, ru) acc) - Constraint.empty l + let lu = u_of_id l and ru = u_of_id r in + Constraint.add (lu, d, ru) acc) + Constraint.empty l in let uctx = ContextSet.add_constraints constraints ContextSet.empty in declare_universe_context ~poly uctx diff --git a/tactics/declare.mli b/tactics/declare.mli index 4cb876cecb..a6c1374a77 100644 --- a/tactics/declare.mli +++ b/tactics/declare.mli @@ -23,7 +23,7 @@ open Entries type 'a proof_entry = { proof_entry_body : 'a Entries.const_entry_body; (* List of section variables *) - proof_entry_secctx : Constr.named_context option; + proof_entry_secctx : Id.Set.t option; (* State id on which the completion of type checking is reported *) proof_entry_feedback : Stateid.t option; proof_entry_type : Constr.types option; @@ -36,7 +36,7 @@ type 'a proof_entry = { type variable_declaration = | SectionLocalDef of Evd.side_effects proof_entry - | SectionLocalAssum of { typ:types; univs:Univ.ContextSet.t; poly:bool; impl:Glob_term.binding_kind } + | SectionLocalAssum of { typ:types; impl:Glob_term.binding_kind; } type 'a constant_entry = | DefinitionEntry of 'a proof_entry @@ -78,7 +78,7 @@ val declare_private_constant -> ?local:import_status -> name:Id.t -> kind:Decls.logical_kind - -> Evd.side_effects constant_entry + -> unit proof_entry -> Constant.t * Evd.side_effects (** Since transparent constants' side effects are globally declared, we diff --git a/tactics/ind_tables.ml b/tactics/ind_tables.ml index 54393dce00..3f824a94bf 100644 --- a/tactics/ind_tables.ml +++ b/tactics/ind_tables.ml @@ -124,8 +124,17 @@ let define internal role id c poly univs = let ctx = UState.minimize univs in let c = UnivSubst.nf_evars_and_universes_opt_subst (fun _ -> None) (UState.subst ctx) c in let univs = UState.univ_entry ~poly ctx in - let entry = Declare.definition_entry ~univs c in - let kn, eff = Declare.declare_private_constant ~role ~kind:Decls.(IsDefinition Scheme) ~name:id (Declare.DefinitionEntry entry) in + let entry = { + Declare.proof_entry_body = + Future.from_val ((c,Univ.ContextSet.empty), ()); + proof_entry_secctx = None; + proof_entry_type = None; + proof_entry_universes = univs; + proof_entry_opaque = false; + proof_entry_inline_code = false; + proof_entry_feedback = None; + } in + let kn, eff = Declare.declare_private_constant ~role ~kind:Decls.(IsDefinition Scheme) ~name:id entry in let () = match internal with | InternalTacticRequest -> () | _-> Declare.definition_message id diff --git a/tactics/pfedit.ml b/tactics/pfedit.ml index 5be7b4fa28..413c6540a3 100644 --- a/tactics/pfedit.ml +++ b/tactics/pfedit.ml @@ -124,8 +124,7 @@ let build_constant_by_tactic ~name ctx sign ~poly typ tac = let { entries; universes } = close_proof ~opaque:Transparent ~keep_body_ucst_separate:false (fun x -> x) pf in match entries with | [entry] -> - let univs = UState.demote_seff_univs entry.Declare.proof_entry_universes universes in - entry, status, univs + entry, status, universes | _ -> CErrors.anomaly Pp.(str "[build_constant_by_tactic] close_proof returned more than one proof term") with reraise -> @@ -141,7 +140,7 @@ let build_by_tactic ?(side_eff=true) env sigma ~poly typ tac = if side_eff then Safe_typing.inline_private_constants env (body, eff.Evd.seff_private) else body in - let univs = UState.merge ~sideff:side_eff ~extend:true Evd.univ_rigid univs ctx in + let univs = UState.merge ~sideff:side_eff Evd.univ_rigid univs ctx in cb, status, univs let refine_by_tactic ~name ~poly env sigma ty tac = diff --git a/tactics/proof_global.ml b/tactics/proof_global.ml index a2929e45cd..b723922642 100644 --- a/tactics/proof_global.ml +++ b/tactics/proof_global.ml @@ -36,7 +36,7 @@ type opacity_flag = Opaque | Transparent type t = { endline_tactic : Genarg.glob_generic_argument option - ; section_vars : Constr.named_context option + ; section_vars : Id.Set.t option ; proof : Proof.t ; udecl: UState.universe_decl (** Initial universe declarations *) @@ -128,7 +128,7 @@ let set_used_variables ps l = if not (Option.is_empty ps.section_vars) then CErrors.user_err Pp.(str "Used section variables can be declared only once"); (* EJGA: This is always empty thus we should modify the type *) - (ctx, []), { ps with section_vars = Some ctx} + (ctx, []), { ps with section_vars = Some (Context.Named.to_vars ctx) } let get_open_goals ps = let Proof.{ goals; stack; shelf } = Proof.data ps.proof in diff --git a/tactics/proof_global.mli b/tactics/proof_global.mli index d15e23c2cc..b9d1b37a11 100644 --- a/tactics/proof_global.mli +++ b/tactics/proof_global.mli @@ -17,7 +17,7 @@ type t (* Should be moved into a proper view *) val get_proof : t -> Proof.t val get_proof_name : t -> Names.Id.t -val get_used_variables : t -> Constr.named_context option +val get_used_variables : t -> Names.Id.Set.t option (** Get the universe declaration associated to the current proof. *) val get_universe_decl : t -> UState.universe_decl diff --git a/test-suite/Makefile b/test-suite/Makefile index c0bdb29fab..c60f39231e 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -32,18 +32,21 @@ include ../Makefile.common # Variables ####################################################################### -# Default value when called from a freshly compiled Coq, but can be -# easily overridden - +ifneq ($(wildcard ../_build),) +BIN:=$(shell cd ..; pwd)/_build/install/default/bin/ +COQLIB:=$(shell cd ..; pwd)/_build/install/default/lib/coq +else BIN := $(shell cd ..; pwd)/bin/ -COQFLAGS?= COQLIB?= ifeq ($(COQLIB),) COQLIB := $(shell ocaml ocaml_pwd.ml ..) endif +endif # exists ../_build export COQLIB +COQFLAGS?= + coqc := $(BIN)coqc -q -R prerequisite TestSuite $(COQFLAGS) coqchk := $(BIN)coqchk -R prerequisite TestSuite coqdoc := $(BIN)coqdoc diff --git a/test-suite/bugs/closed/bug_10669.v b/test-suite/bugs/closed/bug_10669.v new file mode 100644 index 0000000000..433e300acb --- /dev/null +++ b/test-suite/bugs/closed/bug_10669.v @@ -0,0 +1,12 @@ + +Context (A0:Type) (B0:A0). +Definition foo0 := B0. + +Set Universe Polymorphism. +Context (A1:Type) (B1:A1). +Definition foo1 := B1. + +Section S. + Context (A2:Type) (B2:A2). + Definition foo2 := B2. +End S. diff --git a/test-suite/bugs/closed/bug_10888.v b/test-suite/bugs/closed/bug_10888.v new file mode 100644 index 0000000000..3c2e8011d7 --- /dev/null +++ b/test-suite/bugs/closed/bug_10888.v @@ -0,0 +1,11 @@ + +Module Type T. +Context {A:Type}. +End T. + +Module M(X:T). + Import X. + Check X.A. + Check A. + Definition B := A. +End M. diff --git a/test-suite/bugs/closed/bug_10894.v b/test-suite/bugs/closed/bug_10894.v new file mode 100644 index 0000000000..b8c9367951 --- /dev/null +++ b/test-suite/bugs/closed/bug_10894.v @@ -0,0 +1,12 @@ +(* Check that uconstrs are interpreted in the ltac-substituted environment *) +(* Was a regression introduced in 4dab4fc (#7288) *) + +Tactic Notation "bind" hyp(x) "in" uconstr(f) "as" ident(h) := + set (h := fun x => f). + +Fact test : nat -> nat. +Proof. + intros n. + bind n in (n*n) as f. + assert (f 0 = 0) by reflexivity. +Abort. diff --git a/test-suite/bugs/closed/bug_10904.v b/test-suite/bugs/closed/bug_10904.v new file mode 100644 index 0000000000..32b25ff726 --- /dev/null +++ b/test-suite/bugs/closed/bug_10904.v @@ -0,0 +1,8 @@ +Definition a := fun (P:SProp) (p:P) => p. + +Lemma foo : (let k := a in let k' := a in fun (x:nat) y => x) = (let k := a in fun x y => y). +Proof. + Fail reflexivity. + match goal with |- ?l = _ => exact_no_check (eq_refl l) end. +Fail Qed. +Abort. diff --git a/test-suite/bugs/closed/bug_6323.v b/test-suite/bugs/closed/bug_6323.v index fdc33befc6..24feb7155c 100644 --- a/test-suite/bugs/closed/bug_6323.v +++ b/test-suite/bugs/closed/bug_6323.v @@ -6,4 +6,5 @@ Goal True. simple refine (let id' : { x : X' | True } -> X' := _ in _); [ abstract refine (@proj1_sig _ _) | ] ]. -Abort. + exact I. +Defined. diff --git a/test-suite/bugs/closed/bug_9512.v b/test-suite/bugs/closed/bug_9512.v new file mode 100644 index 0000000000..25285622a9 --- /dev/null +++ b/test-suite/bugs/closed/bug_9512.v @@ -0,0 +1,35 @@ +Require Import Coq.ZArith.BinInt Coq.omega.Omega Coq.micromega.Lia. + +Set Primitive Projections. +Record params := { width : Z }. +Definition p : params := Build_params 64. + +Set Printing All. + +Goal width p = 0%Z -> width p = 0%Z. + intros. + + assert_succeeds (enough True; [omega|]). + assert_succeeds (enough True; [lia|]). + +(* H : @eq Z (width p) Z0 *) +(* ============================ *) +(* @eq Z (width p) Z0 *) + + change tt with tt in H. + +(* H : @eq Z (width p) Z0 *) +(* ============================ *) +(* @eq Z (width p) Z0 *) + + assert_succeeds (enough True; [lia|]). + (* Tactic failure: <tactic closure> fails. *) + (* assert_succeeds (enough True; [omega|]). *) + (* Tactic failure: <tactic closure> fails. *) + + (* omega. *) + (* Error: Omega can't solve this system *) + + lia. + (* Tactic failure: Cannot find witness. *) +Qed. diff --git a/test-suite/bugs/closed/bug_9851.v b/test-suite/bugs/closed/bug_9851.v new file mode 100644 index 0000000000..1f57ce8471 --- /dev/null +++ b/test-suite/bugs/closed/bug_9851.v @@ -0,0 +1,18 @@ +Require Import Ring_base. +Record word : Type := Build_word + { rep : Type; + zero : rep; one: rep; + add : rep -> rep -> rep; + sub : rep -> rep -> rep; + opp : rep -> rep; + mul : rep -> rep -> rep; + }. +Axiom rth + : forall (word : word ), + @ring_theory (@rep word) + (@zero word) + (@one word) (@add word) + (@mul word) (@sub word) + (@opp word) (@eq (@rep word)). + +Fail Add Ring wring: (@rth _). diff --git a/test-suite/bugs/opened/bug_1596.v b/test-suite/bugs/opened/bug_1596.v index 820022d995..27cb731151 100644 --- a/test-suite/bugs/opened/bug_1596.v +++ b/test-suite/bugs/opened/bug_1596.v @@ -69,9 +69,8 @@ Definition t := (X.t * Y.t)%type. elim (X.lt_not_eq H2 H3). elim H0;clear H0;intros. right. - split. - eauto. - eauto. + split; + eauto with ordered_type. Qed. Lemma lt_not_eq : forall (x y:t),(lt x y)->~(eq x y). @@ -97,7 +96,7 @@ Definition t := (X.t * Y.t)%type. apply EQ. split;trivial. apply GT. - right;auto. + right;auto with ordered_type. apply GT. left;trivial. Defined. diff --git a/test-suite/ltac2/ltac2env.v b/test-suite/ltac2/ltac2env.v new file mode 100644 index 0000000000..743e62932d --- /dev/null +++ b/test-suite/ltac2/ltac2env.v @@ -0,0 +1,15 @@ +Require Import Ltac2.Ltac2. + +Ltac2 get_opt o := match o with None => Control.throw Not_found | Some x => x end. + +Goal True. +Proof. +(* Fails at runtime because not fully applied *) +Fail ltac1:(ltac2:(x |- ())). +(* Type mismatch: Ltac1.t vs. constr *) +Fail ltac1:(ltac2:(x |- pose $x)). +(* Check that runtime cast is OK *) +ltac1:(let t := ltac2:(x |- let c := (get_opt (Ltac1.to_constr x)) in pose $c) in t nat). +(* Type mismatch *) +Fail ltac1:(let t := ltac2:(x |- let c := (get_opt (Ltac1.to_constr x)) in pose $c) in t ident:(foo)). +Abort. diff --git a/test-suite/misc/votour.sh b/test-suite/misc/votour.sh new file mode 100755 index 0000000000..ac26aed49b --- /dev/null +++ b/test-suite/misc/votour.sh @@ -0,0 +1,3 @@ +command -v "${BIN}votour" || { echo "Missing votour"; exit 1; } + +"${BIN}votour" prerequisite/ssr_mini_mathcomp.vo < /dev/null diff --git a/test-suite/output-coqtop/DependentEvars.out b/test-suite/output-coqtop/DependentEvars.out new file mode 100644 index 0000000000..9ca3fa3357 --- /dev/null +++ b/test-suite/output-coqtop/DependentEvars.out @@ -0,0 +1,91 @@ + +Coq < +Coq < Coq < 1 subgoal + + ============================ + forall P Q R : Prop, (Q -> R) -> (P -> Q) -> (P -> Q) -> P -> R + +(dependent evars: ; in current goal:) + +strange_imp_trans < +strange_imp_trans < No more subgoals. + +(dependent evars: ; in current goal:) + +strange_imp_trans < +Coq < Coq < 1 subgoal + + ============================ + forall P Q : Prop, (P -> Q) /\ P -> Q + +(dependent evars: ; in current goal:) + +modpon < +modpon < No more subgoals. + +(dependent evars: ; in current goal:) + +modpon < +Coq < Coq < +Coq < P1 is declared +P2 is declared +P3 is declared +P4 is declared + +Coq < p12 is declared + +Coq < p123 is declared + +Coq < p34 is declared + +Coq < Coq < 1 subgoal + + P1, P2, P3, P4 : Prop + p12 : P1 -> P2 + p123 : (P1 -> P2) -> P3 + p34 : P3 -> P4 + ============================ + P4 + +(dependent evars: ; in current goal:) + +p14 < +p14 < 4 focused subgoals +(shelved: 2) + + P1, P2, P3, P4 : Prop + p12 : P1 -> P2 + p123 : (P1 -> P2) -> P3 + p34 : P3 -> P4 + ============================ + ?Q -> P4 + +subgoal 2 is: + ?P -> ?Q +subgoal 3 is: + ?P -> ?Q +subgoal 4 is: + ?P + +(dependent evars: ?X4:?P, ?X5:?Q; in current goal: ?X5) + +p14 < 3 focused subgoals +(shelved: 2) + + P1, P2, P3, P4 : Prop + p12 : P1 -> P2 + p123 : (P1 -> P2) -> P3 + p34 : P3 -> P4 + ============================ + ?P -> (?Goal2 -> P4) /\ ?Goal2 + +subgoal 2 is: + ?P -> (?Goal2 -> P4) /\ ?Goal2 +subgoal 3 is: + ?P + +(dependent evars: ?X4:?P, ?X5 using ?X10 ?X11, ?X10 using ?X11, ?X11:?Goal2; in current goal: ?X4 ?X5 ?X10 ?X11) + +p14 < +Coq < +Coq < diff --git a/test-suite/output-coqtop/DependentEvars.v b/test-suite/output-coqtop/DependentEvars.v new file mode 100644 index 0000000000..5a59054073 --- /dev/null +++ b/test-suite/output-coqtop/DependentEvars.v @@ -0,0 +1,24 @@ +Set Printing Dependent Evars Line. +Lemma strange_imp_trans : + forall P Q R : Prop, (Q -> R) -> (P -> Q) -> (P -> Q) -> P -> R. +Proof. + auto. +Qed. + +Lemma modpon : forall P Q : Prop, (P -> Q) /\ P -> Q. +Proof. + tauto. +Qed. + +Section eex. + Variables P1 P2 P3 P4 : Prop. + Hypothesis p12 : P1 -> P2. + Hypothesis p123 : (P1 -> P2) -> P3. + Hypothesis p34 : P3 -> P4. + + Lemma p14 : P4. + Proof. + eapply strange_imp_trans. + apply modpon. + Abort. +End eex. diff --git a/test-suite/output-coqtop/DependentEvars2.out b/test-suite/output-coqtop/DependentEvars2.out new file mode 100644 index 0000000000..29ebba7c86 --- /dev/null +++ b/test-suite/output-coqtop/DependentEvars2.out @@ -0,0 +1,120 @@ + +Coq < +Coq < Coq < 1 subgoal + + ============================ + forall P Q R : Prop, (Q -> R) -> (P -> Q) -> (P -> Q) -> P -> R + +(dependent evars: ; in current goal:) + +strange_imp_trans < +strange_imp_trans < No more subgoals. + +(dependent evars: ; in current goal:) + +strange_imp_trans < +Coq < Coq < 1 subgoal + + ============================ + forall P Q : Prop, (P -> Q) /\ P -> Q + +(dependent evars: ; in current goal:) + +modpon < +modpon < No more subgoals. + +(dependent evars: ; in current goal:) + +modpon < +Coq < Coq < +Coq < P1 is declared +P2 is declared +P3 is declared +P4 is declared + +Coq < p12 is declared + +Coq < p123 is declared + +Coq < p34 is declared + +Coq < Coq < 1 subgoal + + P1, P2, P3, P4 : Prop + p12 : P1 -> P2 + p123 : (P1 -> P2) -> P3 + p34 : P3 -> P4 + ============================ + P4 + +(dependent evars: ; in current goal:) + +p14 < +p14 < Second proof: + +p14 < 4 focused subgoals +(shelved: 2) + + P1, P2, P3, P4 : Prop + p12 : P1 -> P2 + p123 : (P1 -> P2) -> P3 + p34 : P3 -> P4 + ============================ + ?Q -> P4 + +subgoal 2 is: + ?P -> ?Q +subgoal 3 is: + ?P -> ?Q +subgoal 4 is: + ?P + +(dependent evars: ?X4:?P, ?X5:?Q; in current goal: ?X5) + +p14 < 1 focused subgoal +(shelved: 2) + + P1, P2, P3, P4 : Prop + p12 : P1 -> P2 + p123 : (P1 -> P2) -> P3 + p34 : P3 -> P4 + ============================ + ?Q -> P4 + +(dependent evars: ?X4:?P, ?X5:?Q; in current goal: ?X5) + +p14 < This subproof is complete, but there are some unfocused goals. +Try unfocusing with "}". + +3 subgoals +(shelved: 2) + +subgoal 1 is: + ?P -> (?Goal2 -> P4) /\ ?Goal2 +subgoal 2 is: + ?P -> (?Goal2 -> P4) /\ ?Goal2 +subgoal 3 is: + ?P + +(dependent evars: ?X4:?P, ?X5 using ?X10 ?X11, ?X10 using ?X11, ?X11:?Goal2; in current goal:) + +p14 < 3 focused subgoals +(shelved: 2) + + P1, P2, P3, P4 : Prop + p12 : P1 -> P2 + p123 : (P1 -> P2) -> P3 + p34 : P3 -> P4 + ============================ + ?P -> (?Goal2 -> P4) /\ ?Goal2 + +subgoal 2 is: + ?P -> (?Goal2 -> P4) /\ ?Goal2 +subgoal 3 is: + ?P + +(dependent evars: ?X4:?P, ?X5 using ?X10 ?X11, ?X10 using ?X11, ?X11:?Goal2; in current goal: ?X4 ?X5 ?X10 ?X11) + +p14 < +Coq < +Coq < diff --git a/test-suite/output-coqtop/DependentEvars2.v b/test-suite/output-coqtop/DependentEvars2.v new file mode 100644 index 0000000000..d0f3a4012e --- /dev/null +++ b/test-suite/output-coqtop/DependentEvars2.v @@ -0,0 +1,27 @@ +Set Printing Dependent Evars Line. +Lemma strange_imp_trans : + forall P Q R : Prop, (Q -> R) -> (P -> Q) -> (P -> Q) -> P -> R. +Proof. + auto. +Qed. + +Lemma modpon : forall P Q : Prop, (P -> Q) /\ P -> Q. +Proof. + tauto. +Qed. + +Section eex. + Variables P1 P2 P3 P4 : Prop. + Hypothesis p12 : P1 -> P2. + Hypothesis p123 : (P1 -> P2) -> P3. + Hypothesis p34 : P3 -> P4. + + Lemma p14 : P4. + Proof. + idtac "Second proof:". + eapply strange_imp_trans. + { + apply modpon. + } + Abort. +End eex. diff --git a/test-suite/output/UnivBinders.out b/test-suite/output/UnivBinders.out index a89fd64999..d48d8b900f 100644 --- a/test-suite/output/UnivBinders.out +++ b/test-suite/output/UnivBinders.out @@ -38,10 +38,10 @@ Argument scopes are [type_scope _] bar@{u} = nat : Wrap@{u} Set (* u |= Set < u *) -foo@{u UnivBinders.17 v} = -Type@{UnivBinders.17} -> Type@{v} -> Type@{u} - : Type@{max(u+1,UnivBinders.17+1,v+1)} -(* u UnivBinders.17 v |= *) +foo@{u UnivBinders.18 v} = +Type@{UnivBinders.18} -> Type@{v} -> Type@{u} + : Type@{max(u+1,UnivBinders.18+1,v+1)} +(* u UnivBinders.18 v |= *) Type@{i} -> Type@{j} : Type@{max(i+1,j+1)} (* {j i} |= *) @@ -68,19 +68,19 @@ mono The command has indeed failed with message: Universe u already exists. bobmorane = -let tt := Type@{UnivBinders.33} in -let ff := Type@{UnivBinders.35} in tt -> ff - : Type@{max(UnivBinders.32,UnivBinders.34)} +let tt := Type@{UnivBinders.34} in +let ff := Type@{UnivBinders.36} in tt -> ff + : Type@{max(UnivBinders.33,UnivBinders.35)} The command has indeed failed with message: Universe u already bound. foo@{E M N} = Type@{M} -> Type@{N} -> Type@{E} : Type@{max(E+1,M+1,N+1)} (* E M N |= *) -foo@{u UnivBinders.17 v} = -Type@{UnivBinders.17} -> Type@{v} -> Type@{u} - : Type@{max(u+1,UnivBinders.17+1,v+1)} -(* u UnivBinders.17 v |= *) +foo@{u UnivBinders.18 v} = +Type@{UnivBinders.18} -> Type@{v} -> Type@{u} + : Type@{max(u+1,UnivBinders.18+1,v+1)} +(* u UnivBinders.18 v |= *) Inductive Empty@{E} : Type@{E} := (* E |= *) Record PWrap (A : Type@{E}) : Type@{E} := pwrap { punwrap : A } @@ -143,26 +143,26 @@ Applied.infunct@{u v} = inmod@{u} -> Type@{v} : Type@{max(u+1,v+1)} (* u v |= *) -axfoo@{i UnivBinders.57 UnivBinders.58} : -Type@{UnivBinders.57} -> Type@{i} -(* i UnivBinders.57 UnivBinders.58 |= *) +axfoo@{i UnivBinders.59 UnivBinders.60} : +Type@{UnivBinders.59} -> Type@{i} +(* i UnivBinders.59 UnivBinders.60 |= *) axfoo is universe polymorphic Argument scope is [type_scope] Expands to: Constant UnivBinders.axfoo -axbar@{i UnivBinders.57 UnivBinders.58} : -Type@{UnivBinders.58} -> Type@{i} -(* i UnivBinders.57 UnivBinders.58 |= *) +axbar@{i UnivBinders.59 UnivBinders.60} : +Type@{UnivBinders.60} -> Type@{i} +(* i UnivBinders.59 UnivBinders.60 |= *) axbar is universe polymorphic Argument scope is [type_scope] Expands to: Constant UnivBinders.axbar -axfoo' : Type@{axbar'.u0} -> Type@{axbar'.i} +axfoo' : Type@{axfoo'.u0} -> Type@{axfoo'.i} axfoo' is not universe polymorphic Argument scope is [type_scope] Expands to: Constant UnivBinders.axfoo' -axbar' : Type@{axbar'.u0} -> Type@{axbar'.i} +axbar' : Type@{axfoo'.u0} -> Type@{axfoo'.i} axbar' is not universe polymorphic Argument scope is [type_scope] diff --git a/test-suite/output/locate.out b/test-suite/output/locate.out new file mode 100644 index 0000000000..473db2d312 --- /dev/null +++ b/test-suite/output/locate.out @@ -0,0 +1,3 @@ +Notation +"b1 && b2" := if b1 then b2 else false (default interpretation) +"x && y" := andb x y : bool_scope diff --git a/test-suite/output/locate.v b/test-suite/output/locate.v new file mode 100644 index 0000000000..af8b0ee193 --- /dev/null +++ b/test-suite/output/locate.v @@ -0,0 +1,3 @@ +Set Printing Width 400. +Notation "b1 && b2" := (if b1 then b2 else false). +Locate "&&". diff --git a/test-suite/success/CompatCurrentFlag.v b/test-suite/success/CompatCurrentFlag.v index 81469d79c3..fd6101bf89 100644 --- a/test-suite/success/CompatCurrentFlag.v +++ b/test-suite/success/CompatCurrentFlag.v @@ -1,3 +1,3 @@ -(* -*- coq-prog-args: ("-compat" "8.10") -*- *) +(* -*- coq-prog-args: ("-compat" "8.11") -*- *) (** Check that the current compatibility flag actually requires the relevant modules. *) -Import Coq.Compat.Coq810. +Import Coq.Compat.Coq811. diff --git a/test-suite/success/CompatOldFlag.v b/test-suite/success/CompatOldFlag.v index afeb57f9f2..f774cef44f 100644 --- a/test-suite/success/CompatOldFlag.v +++ b/test-suite/success/CompatOldFlag.v @@ -1,5 +1,5 @@ -(* -*- coq-prog-args: ("-compat" "8.8") -*- *) +(* -*- coq-prog-args: ("-compat" "8.9") -*- *) (** Check that the current-minus-two compatibility flag actually requires the relevant modules. *) +Import Coq.Compat.Coq811. Import Coq.Compat.Coq810. Import Coq.Compat.Coq89. -Import Coq.Compat.Coq88. diff --git a/test-suite/success/CompatOldOldFlag.v b/test-suite/success/CompatOldOldFlag.v new file mode 100644 index 0000000000..20eef955b4 --- /dev/null +++ b/test-suite/success/CompatOldOldFlag.v @@ -0,0 +1,6 @@ +(* -*- coq-prog-args: ("-compat" "8.8") -*- *) +(** Check that the current-minus-three compatibility flag actually requires the relevant modules. *) +Import Coq.Compat.Coq811. +Import Coq.Compat.Coq810. +Import Coq.Compat.Coq89. +Import Coq.Compat.Coq88. diff --git a/test-suite/success/CompatPreviousFlag.v b/test-suite/success/CompatPreviousFlag.v index c8f75915c8..1c5ccc1a92 100644 --- a/test-suite/success/CompatPreviousFlag.v +++ b/test-suite/success/CompatPreviousFlag.v @@ -1,4 +1,4 @@ -(* -*- coq-prog-args: ("-compat" "8.9") -*- *) +(* -*- coq-prog-args: ("-compat" "8.10") -*- *) (** Check that the current-minus-one compatibility flag actually requires the relevant modules. *) +Import Coq.Compat.Coq811. Import Coq.Compat.Coq810. -Import Coq.Compat.Coq89. diff --git a/test-suite/success/section_poly.v b/test-suite/success/section_poly.v new file mode 100644 index 0000000000..1e2201f2de --- /dev/null +++ b/test-suite/success/section_poly.v @@ -0,0 +1,74 @@ + + +Section Foo. + + Variable X : Type. + + Polymorphic Section Bar. + + Variable A : Type. + + Definition id (a:A) := a. + +End Bar. +Check id@{_}. +End Foo. +Check id@{_}. + +Polymorphic Section Foo. +Variable A : Type. +Section Bar. + Variable B : Type. + + Inductive prod := Prod : A -> B -> prod. +End Bar. +Check prod@{_}. +End Foo. +Check prod@{_ _}. + +Section Foo. + + Universe K. + Inductive bla := Bla : Type@{K} -> bla. + + Polymorphic Definition bli@{j} := Type@{j} -> bla. + + Definition bloo := bli@{_}. + + Polymorphic Universe i. + + Fail Definition x := Type. + Fail Inductive x : Type := . + Polymorphic Definition x := Type. + Polymorphic Inductive y : x := . + + Variable A : Type. (* adds a mono univ for the Type, which is unrelated to the others *) + + Fail Variable B : (y : Type@{i}). + (* not allowed: mono constraint (about a fresh univ for y) regarding + poly univ i *) + + Polymorphic Variable B : Type. (* new polymorphic stuff always OK *) + + Variable C : Type@{i}. (* no new univs so no problems *) + + Polymorphic Definition thing := bloo -> y -> A -> B. + +End Foo. +Check bli@{_}. +Check bloo@{}. + +Check thing@{_ _ _}. + +Section Foo. + + Polymorphic Universes i k. + Universe j. + Fail Constraint i < j. + Fail Constraint i < k. + + (* referring to mono univs in poly constraints is OK. *) + Polymorphic Constraint i < j. Polymorphic Constraint j < k. + + Polymorphic Definition foo := Type@{j}. +End Foo. diff --git a/test-suite/tools/update-compat/run.sh b/test-suite/tools/update-compat/run.sh index 7ff5571ffb..61273c4f37 100755 --- a/test-suite/tools/update-compat/run.sh +++ b/test-suite/tools/update-compat/run.sh @@ -6,4 +6,4 @@ SCRIPT_DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" >/dev/null && pwd )" # we assume that the script lives in test-suite/tools/update-compat/, # and that update-compat.py lives in dev/tools/ cd "${SCRIPT_DIR}/../../.." -dev/tools/update-compat.py --assert-unchanged --release || exit $? +dev/tools/update-compat.py --assert-unchanged --master || exit $? diff --git a/theories/Compat/Coq810.v b/theories/Compat/Coq810.v index d24af2186f..c611d356ce 100644 --- a/theories/Compat/Coq810.v +++ b/theories/Compat/Coq810.v @@ -9,3 +9,5 @@ (************************************************************************) (** Compatibility file for making Coq act similar to Coq v8.10 *) + +Require Export Coq.Compat.Coq811. diff --git a/theories/Compat/Coq811.v b/theories/Compat/Coq811.v new file mode 100644 index 0000000000..4a9a041d4e --- /dev/null +++ b/theories/Compat/Coq811.v @@ -0,0 +1,11 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \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) *) +(************************************************************************) + +(** Compatibility file for making Coq act similar to Coq v8.11 *) diff --git a/theories/FSets/FMapAVL.v b/theories/FSets/FMapAVL.v index 8627ff7353..ea4062d9fe 100644 --- a/theories/FSets/FMapAVL.v +++ b/theories/FSets/FMapAVL.v @@ -593,14 +593,14 @@ Qed. Lemma MapsTo_1 : forall m x y e, X.eq x y -> MapsTo x e m -> MapsTo y e m. Proof. - induction m; simpl; intuition_in; eauto. + induction m; simpl; intuition_in; eauto with ordered_type. Qed. Hint Immediate MapsTo_1 : core. Lemma In_1 : forall m x y, X.eq x y -> In x m -> In y m. Proof. - intros m x y; induction m; simpl; intuition_in; eauto. + intros m x y; induction m; simpl; intuition_in; eauto with ordered_type. Qed. Lemma In_node_iff : @@ -671,7 +671,7 @@ Qed. Lemma lt_tree_trans : forall x y, X.lt x y -> forall m, lt_tree x m -> lt_tree y m. Proof. - eauto. + eauto with ordered_type. Qed. Lemma gt_tree_not_in : @@ -683,7 +683,7 @@ Qed. Lemma gt_tree_trans : forall x y, X.lt y x -> forall m, gt_tree x m -> gt_tree y m. Proof. - eauto. + eauto with ordered_type. Qed. Hint Resolve lt_tree_not_in lt_tree_trans gt_tree_not_in gt_tree_trans : core. @@ -707,7 +707,7 @@ Qed. Lemma is_empty_1 : forall m, Empty m -> is_empty m = true. Proof. destruct m as [|r x e l h]; simpl; auto. - intro H; elim (H x e); auto. + intro H; elim (H x e); auto with ordered_type. Qed. Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. @@ -732,7 +732,7 @@ Lemma find_1 : forall m x e, bst m -> MapsTo x e m -> find x m = Some e. Proof. intros m x; functional induction (find x m); auto; intros; clearf; inv bst; intuition_in; simpl; auto; - try solve [order | absurd (X.lt x y); eauto | absurd (X.lt y x); eauto]. + try solve [order | absurd (X.lt x y); eauto with ordered_type | absurd (X.lt y x); eauto with ordered_type]. Qed. Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. @@ -832,8 +832,8 @@ Lemma bal_bst : forall l x e r, bst l -> bst r -> Proof. intros l x e r; functional induction (bal l x e r); intros; clearf; inv bst; repeat apply create_bst; auto; unfold create; try constructor; - (apply lt_tree_node || apply gt_tree_node); auto; - (eapply lt_tree_trans || eapply gt_tree_trans); eauto. + (apply lt_tree_node || apply gt_tree_node); auto with ordered_type; + (eapply lt_tree_trans || eapply gt_tree_trans); eauto with ordered_type. Qed. Hint Resolve bal_bst : core. @@ -865,7 +865,7 @@ Lemma add_in : forall m x y e, Proof. intros m x y e; functional induction (add x e m); auto; intros; try (rewrite bal_in, IHt); intuition_in. - apply In_1 with x; auto. + apply In_1 with x; auto with ordered_type. Qed. Lemma add_bst : forall m x e, bst m -> bst (add x e m). @@ -874,14 +874,14 @@ Proof. inv bst; try apply bal_bst; auto; intro z; rewrite add_in; intuition. apply MX.eq_lt with x; auto. - apply MX.lt_eq with x; auto. + apply MX.lt_eq with x; auto with ordered_type. Qed. Hint Resolve add_bst : core. Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m). Proof. intros m x y e; functional induction (add x e m); - intros; inv bst; try rewrite bal_mapsto; unfold create; eauto. + intros; inv bst; try rewrite bal_mapsto; unfold create; eauto with ordered_type. Qed. Lemma add_2 : forall m x y e e', ~X.eq x y -> @@ -912,7 +912,7 @@ Proof. intros; rewrite find_mapsto_equiv; auto. split; eauto using add_2, add_3. destruct X.compare; try (apply H0; order). - auto using find_1, add_1. + auto using find_1, add_1 with ordered_type. Qed. (** * Extraction of minimum binding *) @@ -971,7 +971,7 @@ Proof. generalize (remove_min_in ll lx ld lr _x m#1). rewrite e0; simpl; intros. rewrite (bal_in l' x d r y) in H. - assert (In m#1 (Node ll lx ld lr _x)) by (rewrite H4; auto); clear H4. + assert (In m#1 (Node ll lx ld lr _x)) by (rewrite H4; auto with ordered_type); clear H4. assert (X.lt m#1 x) by order. decompose [or] H; order. Qed. @@ -1050,7 +1050,7 @@ Proof. (* EQ *) inv bst; clear e0. rewrite merge_in; intuition; [ order | order | intuition_in ]. - elim H4; eauto. + elim H4; eauto with ordered_type. (* GT *) inv bst; clear e0. rewrite bal_in; auto. @@ -1069,7 +1069,7 @@ Proof. destruct H; eauto. (* EQ *) inv bst. - apply merge_bst; eauto. + apply merge_bst; eauto with ordered_type. (* GT *) inv bst. apply bal_bst; auto. @@ -1124,8 +1124,8 @@ Lemma join_bst : forall l x d r, bst l -> bst r -> Proof. join_tac; auto; try (simpl; auto; fail); inv bst; apply bal_bst; auto; clear Hrl Hlr; intro; intros; rewrite join_in in *. - intuition; [ apply MX.lt_eq with x | ]; eauto. - intuition; [ apply MX.eq_lt with x | ]; eauto. + intuition; [ apply MX.lt_eq with x | ]; eauto with ordered_type. + intuition; [ apply MX.eq_lt with x | ]; eauto with ordered_type. Qed. Hint Resolve join_bst : core. @@ -1135,8 +1135,8 @@ Lemma join_find : forall l x d r y, Proof. join_tac; auto; inv bst; simpl (join (Leaf elt)); - try (assert (X.lt lx x) by auto); - try (assert (X.lt x rx) by auto); + try (assert (X.lt lx x) by auto with ordered_type); + try (assert (X.lt x rx) by auto with ordered_type); rewrite ?add_find, ?bal_find; auto. simpl; destruct X.compare; auto. @@ -1260,7 +1260,7 @@ Proof. change (bst (m2',xd)#1). rewrite <-e1; eauto. intros y Hy. apply H1; auto. - rewrite remove_min_in, e1; simpl; auto. + rewrite remove_min_in, e1; simpl; auto with ordered_type. change (gt_tree (m2',xd)#2#1 (m2',xd)#1). rewrite <-e1; eauto. Qed. Hint Resolve concat_bst : core. @@ -1283,9 +1283,9 @@ Proof. simpl; destruct X.compare as [Hlt| |Hlt]; simpl; auto. destruct (find y m2'); auto. symmetry; rewrite not_find_iff; auto; intro. - apply (MX.lt_not_gt Hlt); apply H1; auto; rewrite H3; auto. + apply (MX.lt_not_gt Hlt); apply H1; auto; rewrite H3; auto with ordered_type. - intros z Hz; apply H1; auto; rewrite H3; auto. + intros z Hz; apply H1; auto; rewrite H3; auto with ordered_type. Qed. @@ -1338,12 +1338,12 @@ Proof. apply InA_InfA with (eqA:=eqke); auto with *. intros (y',e') H6. destruct (elements_aux_mapsto r acc y' e'); intuition. red; simpl; eauto. - red; simpl; eauto. - intros. + red; simpl; eauto with ordered_type. + intros x e0 y0 H H6. inversion_clear H. destruct H7; simpl in *. order. - destruct (elements_aux_mapsto r acc x e0); intuition eauto. + destruct (elements_aux_mapsto r acc x e0); intuition eauto with ordered_type. Qed. Lemma elements_sort : forall s : t elt, bst s -> sort ltk (elements s). @@ -1363,7 +1363,8 @@ Lemma elements_aux_cardinal : Proof. simple induction m; simpl; intuition. rewrite <- H; simpl. - rewrite <- H0; omega. + rewrite <- H0, Nat.add_succ_r, (Nat.add_comm (cardinal t)), Nat.add_assoc. + reflexivity. Qed. Lemma elements_cardinal : forall (m:t elt), cardinal m = length (elements m). @@ -1567,7 +1568,7 @@ Lemma mapi_1 : forall (m: tree elt)(x:key)(e:elt), MapsTo x e m -> exists y, X.eq y x /\ MapsTo x (f y e) (mapi f m). Proof. induction m; simpl; inversion_clear 1; auto. -exists k; auto. +exists k; auto with ordered_type. destruct (IHm1 _ _ H0). exists x0; intuition. destruct (IHm2 _ _ H0). @@ -2072,7 +2073,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: X.eq x1 x2 -> D.eq d1 d2 -> Cmp c l1 l2 -> Cmp c ((x1,d1)::l1) ((x2,d2)::l2). Proof. - destruct c; simpl; intros; P.MX.elim_comp; auto. + destruct c; simpl; intros; P.MX.elim_comp; auto with ordered_type. Qed. Hint Resolve cons_Cmp : core. diff --git a/theories/FSets/FMapFacts.v b/theories/FSets/FMapFacts.v index 1a531542cc..758f9d41b0 100644 --- a/theories/FSets/FMapFacts.v +++ b/theories/FSets/FMapFacts.v @@ -1822,7 +1822,7 @@ Module OrdProperties (M:S). destruct (gtb (x,e) (a,e')); destruct (gtb (x,e) (b,e'')); auto. unfold O.ltk in *; simpl in *; intros. symmetry; rewrite H2. - apply ME.eq_lt with a; auto. + apply ME.eq_lt with a; auto with ordered_type. rewrite <- H1; auto. unfold O.ltk in *; simpl in *; intros. rewrite H1. @@ -1869,7 +1869,7 @@ Module OrdProperties (M:S). rewrite <- elements_mapsto_iff in H1. assert (~E.eq x t0). contradict H. - exists e0; apply MapsTo_1 with t0; auto. + exists e0; apply MapsTo_1 with t0; auto with ordered_type. ME.order. apply (@filter_sort _ eqke); auto with *; clean_eauto. intros. @@ -1888,9 +1888,9 @@ Module OrdProperties (M:S). find_mapsto_iff, (H0 t0), <- find_mapsto_iff, add_mapsto_iff by (auto with *). unfold O.eqke, O.ltk; simpl. - destruct (E.compare t0 x); intuition; try fold (~E.eq x t0); auto. + destruct (E.compare t0 x); intuition; try fold (~E.eq x t0); auto with ordered_type. - elim H; exists e0; apply MapsTo_1 with t0; auto. - - fold (~E.lt t0 x); auto. + - fold (~E.lt t0 x); auto with ordered_type. Qed. Lemma elements_Add_Above : forall m m' x e, @@ -1905,7 +1905,7 @@ Module OrdProperties (M:S). destruct x0; destruct y. rewrite <- elements_mapsto_iff in H1. unfold O.eqke, O.ltk in *; simpl in *; destruct H3. - apply ME.lt_eq with x; auto. + apply ME.lt_eq with x; auto with ordered_type. apply H; firstorder. inversion H3. red; intros a; destruct a. @@ -1991,7 +1991,7 @@ Module OrdProperties (M:S). injection H as [= -> ->]. inversion_clear H1. red in H; simpl in *; intuition. - elim H0; eauto. + elim H0; eauto with ordered_type. inversion H. change (max_elt_aux (p::l) = Some (x,e)) in H. generalize (IHl x e H); clear IHl; intros IHl. @@ -2007,9 +2007,9 @@ Module OrdProperties (M:S). inversion_clear H2. inversion_clear H5. red in H2; simpl in H2; ME.order. - eapply IHl; eauto. + eapply IHl; eauto with ordered_type. econstructor; eauto. - red; eauto. + red; eauto with ordered_type. inversion H2; auto. Qed. @@ -2022,7 +2022,7 @@ Module OrdProperties (M:S). induction (elements m). simpl; try discriminate. destruct a; destruct l; simpl in *. - injection H; intros; subst; constructor; red; auto. + injection H; intros; subst; constructor; red; auto with ordered_type. constructor 2; auto. Qed. @@ -2069,7 +2069,7 @@ Module OrdProperties (M:S). destruct (elements m). simpl; try discriminate. destruct p; simpl in *. - injection H; intros; subst; constructor; red; auto. + injection H; intros; subst; constructor; red; auto with ordered_type. Qed. Lemma min_elt_Empty : @@ -2106,7 +2106,7 @@ Module OrdProperties (M:S). apply IHn. assert (S n = S (cardinal (remove k m))). rewrite Heqn. - eapply cardinal_2; eauto with map. + eapply cardinal_2; eauto with map ordered_type. inversion H1; auto. eapply max_elt_Above; eauto. @@ -2133,7 +2133,7 @@ Module OrdProperties (M:S). apply IHn. assert (S n = S (cardinal (remove k m))). rewrite Heqn. - eapply cardinal_2; eauto with map. + eapply cardinal_2; eauto with map ordered_type. inversion H1; auto. eapply min_elt_Below; eauto. diff --git a/theories/FSets/FMapFullAVL.v b/theories/FSets/FMapFullAVL.v index 8ca9401a06..fa553d9fce 100644 --- a/theories/FSets/FMapFullAVL.v +++ b/theories/FSets/FMapFullAVL.v @@ -68,7 +68,7 @@ Hint Constructors avl : core. Lemma height_non_negative : forall (s : t elt), avl s -> height s >= 0. Proof. - induction s; simpl; intros; auto with zarith. + induction s; simpl; intros. now apply Z.le_ge. inv avl; intuition; omega_max. Qed. @@ -712,7 +712,7 @@ Module IntMake_ord (I:Int)(X: OrderedType)(D : OrderedType) <: X.eq x1 x2 -> D.eq d1 d2 -> Cmp c l1 l2 -> Cmp c ((x1,d1)::l1) ((x2,d2)::l2). Proof. - destruct c; simpl; intros; MX.elim_comp; auto. + destruct c; simpl; intros; MX.elim_comp; auto with ordered_type. Qed. Hint Resolve cons_Cmp : core. diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v index b21d809059..cad528644a 100644 --- a/theories/FSets/FMapList.v +++ b/theories/FSets/FMapList.v @@ -68,7 +68,7 @@ Proof. intros m. case m;auto. intros (k,e) l inlist. - absurd (InA eqke (k, e) ((k, e) :: l));auto. + absurd (InA eqke (k, e) ((k, e) :: l)); auto with ordered_type. Qed. Lemma is_empty_2 : forall m, is_empty m = true -> Empty m. @@ -106,14 +106,14 @@ Proof. elim (sort_inv sorted);auto. elim (In_inv belong1);auto. intro abs. - absurd (X.eq x k');auto. + absurd (X.eq x k'); auto with ordered_type. Qed. Lemma mem_2 : forall m (Hm:Sort m) x, mem x m = true -> In x m. Proof. intros m Hm x; generalize Hm; clear Hm; unfold PX.In,PX.MapsTo. functional induction (mem x m); intros sorted hyp;try ((inversion hyp);fail). - exists _x; auto. + exists _x; auto with ordered_type. induction IHb; auto. exists x0; auto. inversion_clear sorted; auto. @@ -135,7 +135,7 @@ Function find (k:key) (s: t elt) {struct s} : option elt := Lemma find_2 : forall m x e, find x m = Some e -> MapsTo x e m. Proof. intros m x. unfold PX.MapsTo. - functional induction (find x m);simpl;intros e' eqfind; inversion eqfind; auto. + functional induction (find x m);simpl;intros e' eqfind; inversion eqfind; auto with ordered_type. Qed. Lemma find_1 : forall m (Hm:Sort m) x e, MapsTo x e m -> find x m = Some e. @@ -174,7 +174,7 @@ Lemma add_1 : forall m x y e, X.eq x y -> MapsTo y e (add x e m). Proof. intros m x y e; generalize y; clear y. unfold PX.MapsTo. - functional induction (add x e m);simpl;auto. + functional induction (add x e m);simpl;auto with ordered_type. Qed. Lemma add_2 : forall m x y e e', @@ -195,12 +195,12 @@ Qed. Lemma add_3 : forall m x y e e', ~ X.eq x y -> MapsTo y e (add x e' m) -> MapsTo y e m. -Proof. +Proof with auto with ordered_type. intros m x y e e'. generalize y e; clear y e; unfold PX.MapsTo. functional induction (add x e' m);simpl; intros. - apply (In_inv_3 H0); compute; auto. - apply (In_inv_3 H0); compute; auto. - constructor 2; apply (In_inv_3 H0); compute; auto. + apply (In_inv_3 H0)... + apply (In_inv_3 H0)... + constructor 2; apply (In_inv_3 H0)... inversion_clear H0; auto. Qed. @@ -254,7 +254,7 @@ Proof. clear e0;inversion_clear Hm. apply Sort_Inf_NotIn with x0; auto. - apply Inf_eq with (k',x0);auto; compute; apply X.eq_trans with x; auto. + apply Inf_eq with (k',x0);auto; compute; apply X.eq_trans with x; auto with ordered_type. clear e0;inversion_clear Hm. assert (notin:~ In y (remove x l)) by auto. @@ -374,13 +374,13 @@ Definition Equivb cmp m m' := Lemma equal_1 : forall m (Hm:Sort m) m' (Hm': Sort m') cmp, Equivb cmp m m' -> equal cmp m m' = true. -Proof. +Proof with auto with ordered_type. intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'. functional induction (equal cmp m m'); simpl; subst;auto; unfold Equivb; intuition; subst. match goal with H: X.compare _ _ = _ |- _ => clear H end. assert (cmp_e_e':cmp e e' = true). - apply H1 with x; auto. + apply H1 with x... rewrite cmp_e_e'; simpl. apply IHb; auto. inversion_clear Hm; auto. @@ -388,7 +388,7 @@ Proof. unfold Equivb; intuition. destruct (H0 k). assert (In k ((x,e) ::l)). - destruct H as (e'', hyp); exists e''; auto. + destruct H as (e'', hyp); exists e''... destruct (In_inv (H2 H4)); auto. inversion_clear Hm. elim (Sort_Inf_NotIn H6 H7). @@ -396,20 +396,20 @@ Proof. apply MapsTo_eq with k; auto; order. destruct (H0 k). assert (In k ((x',e') ::l')). - destruct H as (e'', hyp); exists e''; auto. + destruct H as (e'', hyp); exists e''... destruct (In_inv (H3 H4)); auto. inversion_clear Hm'. elim (Sort_Inf_NotIn H6 H7). destruct H as (e'', hyp); exists e''; auto. apply MapsTo_eq with k; auto; order. - apply H1 with k; destruct (X.eq_dec x k); auto. + apply H1 with k; destruct (X.eq_dec x k)... destruct (X.compare x x') as [Hlt|Heq|Hlt]; try contradiction; clear y. destruct (H0 x). assert (In x ((x',e')::l')). apply H; auto. - exists e; auto. + exists e... destruct (In_inv H3). order. inversion_clear Hm'. @@ -420,7 +420,7 @@ Proof. destruct (H0 x'). assert (In x' ((x,e)::l)). apply H2; auto. - exists e'; auto. + exists e'... destruct (In_inv H3). order. inversion_clear Hm. @@ -434,13 +434,13 @@ Proof. clear H1;destruct p as (k,e). destruct (H0 k). destruct H1. - exists e; auto. + exists e... inversion H1. destruct p as (x,e). destruct (H0 x). destruct H. - exists e; auto. + exists e... inversion H. destruct p;destruct p0;contradiction. @@ -449,7 +449,7 @@ Qed. Lemma equal_2 : forall m (Hm:Sort m) m' (Hm:Sort m') cmp, equal cmp m m' = true -> Equivb cmp m m'. -Proof. +Proof with auto with ordered_type. intros m Hm m' Hm' cmp; generalize Hm Hm'; clear Hm Hm'. functional induction (equal cmp m m'); simpl; subst;auto; unfold Equivb; intuition; try discriminate; subst; @@ -464,16 +464,16 @@ Proof. exists e'; constructor; split; trivial; apply X.eq_trans with x; auto. destruct (H k). destruct (H9 H8) as (e'',hyp). - exists e''; auto. + exists e''... inversion_clear Hm;inversion_clear Hm'. destruct (andb_prop _ _ H); clear H. destruct (IHb H1 H3 H6). destruct (In_inv H0). - exists e; constructor; split; trivial; apply X.eq_trans with x'; auto. + exists e; constructor; split; trivial; apply X.eq_trans with x'... destruct (H k). destruct (H10 H8) as (e'',hyp). - exists e''; auto. + exists e''... inversion_clear Hm;inversion_clear Hm'. destruct (andb_prop _ _ H); clear H. @@ -615,7 +615,8 @@ Proof. inversion_clear 1. exists x'. destruct H0; simpl in *. - split; auto. + split. + auto with ordered_type. constructor 1. unfold eqke in *; simpl in *; intuition congruence. destruct IHm as (y, hyp); auto. @@ -946,7 +947,7 @@ Proof. destruct (IHm0 H0) as (_,H4); apply H4; auto. case_eq (find x m0); intros; auto. assert (eqk (elt:=oee') (k,(oo,oo')) (x,(oo,oo'))). - red; auto. + red; auto with ordered_type. destruct (Sort_Inf_NotIn H0 (Inf_eq (eqk_sym H5) H1)). exists p; apply find_2; auto. (* k < x *) @@ -1315,7 +1316,7 @@ Proof. apply (IHm1 H0 (Build_slist H5)); intuition. Qed. -Ltac cmp_solve := unfold eq, lt; simpl; try Raw.MX.elim_comp; auto. +Ltac cmp_solve := unfold eq, lt; simpl; try Raw.MX.elim_comp; auto with ordered_type. Definition compare : forall m1 m2, Compare lt eq m1 m2. Proof. diff --git a/theories/FSets/FMapPositive.v b/theories/FSets/FMapPositive.v index e5133f66b2..342a51b39b 100644 --- a/theories/FSets/FMapPositive.v +++ b/theories/FSets/FMapPositive.v @@ -476,8 +476,8 @@ Module PositiveMap <: S with Module E:=PositiveOrderedTypeBits. unfold elements. intros m; set (p:=1); clearbody p; revert m p. induction m; simpl; auto; intros. - rewrite (IHm1 (append p 2)), (IHm2 (append p 3)); auto. - destruct o; rewrite app_length; simpl; omega. + rewrite (IHm1 (append p 2)), (IHm2 (append p 3)). + destruct o; rewrite app_length; simpl; auto. Qed. End CompcertSpec. diff --git a/theories/FSets/FSetBridge.v b/theories/FSets/FSetBridge.v index 6e08c38a49..f0b31e6986 100644 --- a/theories/FSets/FSetBridge.v +++ b/theories/FSets/FSetBridge.v @@ -63,11 +63,11 @@ Module DepOfNodep (Import M: S) <: Sdep with Module E := M.E. {s' : t | forall y : elt, In y s' <-> ~ E.eq x y /\ In y s}. Proof. intros; exists (remove x s); intuition. - absurd (In x (remove x s)); auto with set. - apply In_1 with y; auto. + absurd (In x (remove x s)); auto with set ordered_type. + apply In_1 with y; auto with ordered_type. elim (E.eq_dec x y); intros; auto. - absurd (In x (remove x s)); auto with set. - apply In_1 with y; auto. + absurd (In x (remove x s)); auto with set ordered_type. + apply In_1 with y; auto with ordered_type. eauto with set. Qed. @@ -470,7 +470,7 @@ Module NodepOfDep (M: Sdep) <: S with Module E := M.E. Hint Resolve elements_3 : core. Lemma elements_3w : forall s : t, NoDupA E.eq (elements s). - Proof. auto. Qed. + Proof. auto with ordered_type. Qed. Definition min_elt (s : t) : option elt := match min_elt s with diff --git a/theories/FSets/FSetEqProperties.v b/theories/FSets/FSetEqProperties.v index da504259f5..1983c6caa1 100644 --- a/theories/FSets/FSetEqProperties.v +++ b/theories/FSets/FSetEqProperties.v @@ -17,7 +17,7 @@ [mem x s=true] instead of [In x s], [equal s s'=true] instead of [Equal s s'], etc. *) -Require Import FSetProperties Zerob Sumbool Omega DecidableTypeEx. +Require Import FSetProperties Zerob Sumbool DecidableTypeEx. Module WEqProperties_fun (Import E:DecidableType)(M:WSfun E). Module Import MP := WProperties_fun E M. @@ -847,11 +847,16 @@ Proof. unfold sum. intros f g Hf Hg. assert (fc : compat_opL (fun x:elt =>plus (f x))). red; auto with fset. -assert (ft : transposeL (fun x:elt =>plus (f x))). red; intros; omega. +assert (ft : transposeL (fun x:elt =>plus (f x))). red; intros x y z. + rewrite !PeanoNat.Nat.add_assoc, (PeanoNat.Nat.add_comm (f x) (f y)); reflexivity. assert (gc : compat_opL (fun x:elt => plus (g x))). red; auto with fset. -assert (gt : transposeL (fun x:elt =>plus (g x))). red; intros; omega. +assert (gt : transposeL (fun x:elt =>plus (g x))). red; intros x y z. + rewrite !PeanoNat.Nat.add_assoc, (PeanoNat.Nat.add_comm (g x) (g y)); reflexivity. assert (fgc : compat_opL (fun x:elt =>plus ((f x)+(g x)))). repeat red; auto. -assert (fgt : transposeL (fun x:elt=>plus ((f x)+(g x)))). red; intros; omega. +assert (fgt : transposeL (fun x:elt=>plus ((f x)+(g x)))). red; intros x y z. + set (u := (f x + g x)); set (v := (f y + g y)). + rewrite !PeanoNat.Nat.add_assoc, (PeanoNat.Nat.add_comm u). + reflexivity. assert (st : Equivalence (@Logic.eq nat)) by (split; congruence). intros s;pattern s; apply set_rec. intros. @@ -859,7 +864,10 @@ rewrite <- (fold_equal _ _ st _ fc ft 0 _ _ H). rewrite <- (fold_equal _ _ st _ gc gt 0 _ _ H). rewrite <- (fold_equal _ _ st _ fgc fgt 0 _ _ H); auto. intros; do 3 (rewrite (fold_add _ _ st);auto). -rewrite H0;simpl;omega. +rewrite H0;simpl. +rewrite <- !(PeanoNat.Nat.add_assoc (f x)); f_equal. +rewrite !PeanoNat.Nat.add_assoc. f_equal. +apply PeanoNat.Nat.add_comm. do 3 rewrite fold_empty;auto. Qed. @@ -872,7 +880,11 @@ assert (cc : compat_opL (fun x => plus (if f x then 1 else 0))). repeat red; intros. rewrite (Hf _ _ H); auto. assert (ct : transposeL (fun x => plus (if f x then 1 else 0))). - red; intros; omega. + red; intros. + set (a := if f x then _ else _). + rewrite PeanoNat.Nat.add_comm. + rewrite <- !PeanoNat.Nat.add_assoc. f_equal. + apply PeanoNat.Nat.add_comm. intros s;pattern s; apply set_rec. intros. change elt with E.t. @@ -921,9 +933,11 @@ Lemma sum_compat : forall f g, Proper (E.eq==>Logic.eq) f -> Proper (E.eq==>Logic.eq) g -> forall s, (forall x, In x s -> f x=g x) -> sum f s=sum g s. intros. -unfold sum; apply (fold_compat _ (@Logic.eq nat)); auto with *. +unfold sum; apply (fold_compat _ (@Logic.eq nat)); auto with fset. intros x x' Hx y y' Hy. rewrite Hx, Hy; auto. +intros x y z; rewrite !PeanoNat.Nat.add_assoc; f_equal; apply PeanoNat.Nat.add_comm. intros x x' Hx y y' Hy. rewrite Hx, Hy; auto. +intros x y z; rewrite !PeanoNat.Nat.add_assoc; f_equal; apply PeanoNat.Nat.add_comm. Qed. End Sum. diff --git a/theories/FSets/FSetProperties.v b/theories/FSets/FSetProperties.v index c6b2e0a09d..e500debc73 100644 --- a/theories/FSets/FSetProperties.v +++ b/theories/FSets/FSetProperties.v @@ -939,7 +939,7 @@ Module OrdProperties (M:S). generalize (gtb_1 x a)(gtb_1 x b); destruct (gtb x a); destruct (gtb x b); auto. intros. symmetry; rewrite H1. - apply ME.eq_lt with a; auto. + apply ME.eq_lt with a; auto with ordered_type. rewrite <- H0; auto. intros. rewrite H0. @@ -1013,7 +1013,7 @@ Module OrdProperties (M:S). intros. inversion_clear H2. rewrite <- elements_iff in H1. - apply ME.lt_eq with x; auto. + apply ME.lt_eq with x; auto with ordered_type. inversion H3. red; intros a. rewrite InA_app_iff, InA_cons, InA_nil by auto with *. @@ -1052,7 +1052,7 @@ Module OrdProperties (M:S). apply X0 with (remove e s) e; auto with set. apply IHn. assert (S n = S (cardinal (remove e s))). - rewrite Heqn; apply cardinal_2 with e; auto with set. + rewrite Heqn; apply cardinal_2 with e; auto with set ordered_type. inversion H0; auto. red; intros. rewrite remove_iff in H0; destruct H0. @@ -1073,7 +1073,7 @@ Module OrdProperties (M:S). apply X0 with (remove e s) e; auto with set. apply IHn. assert (S n = S (cardinal (remove e s))). - rewrite Heqn; apply cardinal_2 with e; auto with set. + rewrite Heqn; apply cardinal_2 with e; auto with set ordered_type. inversion H0; auto. red; intros. rewrite remove_iff in H0; destruct H0. diff --git a/theories/Logic/ClassicalFacts.v b/theories/Logic/ClassicalFacts.v index 2a9e15ab37..8538b54c08 100644 --- a/theories/Logic/ClassicalFacts.v +++ b/theories/Logic/ClassicalFacts.v @@ -29,7 +29,7 @@ Table of contents: 3. Weak classical axioms -3.1. Weak excluded middle +3.1. Weak excluded middle and classical de Morgan law 3.2. Gödel-Dummett axiom and right distributivity of implication over disjunction @@ -514,7 +514,7 @@ End Weak_proof_irrelevance_CCI. (** * Weak classical axioms *) (** We show the following increasing in the strength of axioms: - - weak excluded-middle + - weak excluded-middle and classical De Morgan's law - right distributivity of implication over disjunction and Gödel-Dummett axiom - independence of general premises and drinker's paradox - excluded-middle @@ -523,11 +523,15 @@ End Weak_proof_irrelevance_CCI. (** ** Weak excluded-middle *) (** The weak classical logic based on [~~A \/ ~A] is referred to with - name KC in [[ChagrovZakharyaschev97]] + name KC in [[ChagrovZakharyaschev97]]. See [[SorbiTerwijn11]] for + a short survey. [[ChagrovZakharyaschev97]] Alexander Chagrov and Michael Zakharyaschev, "Modal Logic", Clarendon Press, 1997. -*) + + [[SorbiTerwijn11]] Andrea Sorbi and Sebastiaan A. Terwijn, + "Generalizations of the weak law of the excluded-middle", Notre + Dame J. Formal Logic, vol 56(2), pp 321-331, 2015. *) Definition weak_excluded_middle := forall A:Prop, ~~A \/ ~A. @@ -539,16 +543,21 @@ Definition weak_excluded_middle := Definition weak_generalized_excluded_middle := forall A B:Prop, ((A -> B) -> B) \/ (A -> B). +(** Classical De Morgan's law *) + +Definition classical_de_morgan_law := + forall A B:Prop, ~(A /\ B) -> ~A \/ ~B. + (** ** Gödel-Dummett axiom *) (** [(A->B) \/ (B->A)] is studied in [[Dummett59]] and is based on [[Gödel33]]. [[Dummett59]] Michael A. E. Dummett. "A Propositional Calculus - with a Denumerable Matrix", In the Journal of Symbolic Logic, Vol - 24 No. 2(1959), pp 97-103. + with a Denumerable Matrix", In the Journal of Symbolic Logic, vol + 24(2), pp 97-103, 1959. [[Gödel33]] Kurt Gödel. "Zum intuitionistischen Aussagenkalkül", - Ergeb. Math. Koll. 4 (1933), pp. 34-38. + Ergeb. Math. Koll. 4, pp. 34-38, 1933. *) Definition GodelDummett := forall A B:Prop, (A -> B) \/ (B -> A). @@ -590,6 +599,16 @@ Proof. right; intro HA; apply (HAnotA HA HA). Qed. +(** The weak excluded middle is equivalent to the classical De Morgan's law *) + +Lemma weak_excluded_middle_iff_classical_de_morgan_law : + weak_excluded_middle <-> classical_de_morgan_law. +Proof. + split; [intro WEM|intro CDML]; intros A *. + - destruct (WEM A); tauto. + - destruct (CDML A (~A)); tauto. +Qed. + (** ** Independence of general premises and drinker's paradox *) (** Independence of general premises is the unconstrained, non diff --git a/theories/QArith/QArith_base.v b/theories/QArith/QArith_base.v index b60feb9256..54d35cded2 100644 --- a/theories/QArith/QArith_base.v +++ b/theories/QArith/QArith_base.v @@ -79,7 +79,7 @@ Notation "x <= y <= z" := (x<=y/\y<=z) : Q_scope. Lemma inject_Z_injective (a b: Z): inject_Z a == inject_Z b <-> a = b. Proof. - unfold Qeq. simpl. omega. + unfold Qeq; simpl; rewrite !Z.mul_1_r; reflexivity. Qed. (** Another approach : using Qcompare for defining order relations. *) @@ -599,9 +599,7 @@ Proof. Qed. Lemma Qle_antisym x y : x<=y -> y<=x -> x==y. -Proof. - unfold Qle, Qeq; auto with zarith. -Qed. +Proof. apply Z.le_antisymm. Qed. Lemma Qle_trans : forall x y z, x<=y -> y<=z -> x<=z. Proof. @@ -618,14 +616,10 @@ Qed. Hint Resolve Qle_trans : qarith. Lemma Qlt_irrefl x : ~x<x. -Proof. - unfold Qlt. auto with zarith. -Qed. +Proof. apply Z.lt_irrefl. Qed. Lemma Qlt_not_eq x y : x<y -> ~ x==y. -Proof. - unfold Qlt, Qeq; auto with zarith. -Qed. +Proof. apply Z.lt_neq. Qed. Lemma Zle_Qle (x y: Z): (x <= y)%Z = (inject_Z x <= inject_Z y). Proof. @@ -647,9 +641,7 @@ Proof. Qed. Lemma Qlt_le_weak x y : x<y -> x<=y. -Proof. - unfold Qle, Qlt; auto with zarith. -Qed. +Proof. apply Z.lt_le_incl. Qed. Lemma Qle_lt_trans : forall x y z, x<=y -> y<z -> x<z. Proof. @@ -684,25 +676,17 @@ Qed. (** [x<y] iff [~(y<=x)] *) -Lemma Qnot_lt_le : forall x y, ~ x<y -> y<=x. -Proof. - unfold Qle, Qlt; auto with zarith. -Qed. +Lemma Qnot_lt_le x y : ~ x < y -> y <= x. +Proof. apply Z.nlt_ge. Qed. -Lemma Qnot_le_lt : forall x y, ~ x<=y -> y<x. -Proof. - unfold Qle, Qlt; auto with zarith. -Qed. +Lemma Qnot_le_lt x y : ~ x <= y -> y < x. +Proof. apply Z.nle_gt. Qed. -Lemma Qlt_not_le : forall x y, x<y -> ~ y<=x. -Proof. - unfold Qle, Qlt; auto with zarith. -Qed. +Lemma Qlt_not_le x y : x < y -> ~ y <= x. +Proof. apply Z.lt_nge. Qed. -Lemma Qle_not_lt : forall x y, x<=y -> ~ y<x. -Proof. - unfold Qle, Qlt; auto with zarith. -Qed. +Lemma Qle_not_lt x y : x <= y -> ~ y < x. +Proof. apply Z.le_ngt. Qed. Lemma Qle_lt_or_eq : forall x y, x<=y -> x<y \/ x==y. Proof. @@ -746,21 +730,24 @@ Defined. Lemma Qopp_le_compat : forall p q, p<=q -> -q <= -p. Proof. intros (a1,a2) (b1,b2); unfold Qle, Qlt; simpl. - rewrite !Z.mul_opp_l. omega. + now rewrite !Z.mul_opp_l, <- Z.opp_le_mono. Qed. + Hint Resolve Qopp_le_compat : qarith. Lemma Qle_minus_iff : forall p q, p <= q <-> 0 <= q+-p. Proof. intros (x1,x2) (y1,y2); unfold Qle; simpl. - rewrite Z.mul_opp_l. omega. + rewrite Z.mul_1_r, Z.mul_opp_l, <- Z.le_sub_le_add_r, Z.opp_involutive. + reflexivity. Qed. Lemma Qlt_minus_iff : forall p q, p < q <-> 0 < q+-p. Proof. intros (x1,x2) (y1,y2); unfold Qlt; simpl. - rewrite Z.mul_opp_l. omega. + rewrite Z.mul_1_r, Z.mul_opp_l, <- Z.lt_sub_lt_add_r, Z.opp_involutive. + reflexivity. Qed. Lemma Qplus_le_compat : @@ -831,9 +818,11 @@ Lemma Qmult_le_compat_r : forall x y z, x <= y -> 0 <= z -> x*z <= y*z. Proof. intros (a1,a2) (b1,b2) (c1,c2); unfold Qle, Qlt; simpl. Open Scope Z_scope. + rewrite Z.mul_1_r. intros; simpl_mult. rewrite Z.mul_shuffle1, (Z.mul_shuffle1 b1). - apply Z.mul_le_mono_nonneg_r; auto with zarith. + apply Z.mul_le_mono_nonneg_r; auto. + now apply Z.mul_nonneg_nonneg. Close Scope Z_scope. Qed. @@ -843,9 +832,10 @@ Proof. Open Scope Z_scope. simpl_mult. rewrite Z.mul_shuffle1, (Z.mul_shuffle1 b1). + rewrite Z.mul_1_r. intros LT LE. apply Z.mul_le_mono_pos_r in LE; trivial. - apply Z.mul_pos_pos; [omega|easy]. + apply Z.mul_pos_pos; easy. Close Scope Z_scope. Qed. @@ -866,10 +856,11 @@ Lemma Qmult_lt_compat_r : forall x y z, 0 < z -> x < y -> x*z < y*z. Proof. intros (a1,a2) (b1,b2) (c1,c2); unfold Qle, Qlt; simpl. Open Scope Z_scope. + rewrite Z.mul_1_r. intros; simpl_mult. rewrite Z.mul_shuffle1, (Z.mul_shuffle1 b1). apply Z.mul_lt_mono_pos_r; auto with zarith. - apply Z.mul_pos_pos; [omega|reflexivity]. + apply Z.mul_pos_pos; easy. Close Scope Z_scope. Qed. @@ -880,8 +871,9 @@ Proof. unfold Qle, Qlt; simpl. simpl_mult. rewrite Z.mul_shuffle1, (Z.mul_shuffle1 b1). + rewrite Z.mul_1_r. intro LT. rewrite <- Z.mul_lt_mono_pos_r. reflexivity. - apply Z.mul_pos_pos; [omega|reflexivity]. + now apply Z.mul_pos_pos. Close Scope Z_scope. Qed. @@ -896,6 +888,7 @@ Proof. intros a b Ha Hb. unfold Qle in *. simpl in *. +rewrite Z.mul_1_r in *. auto with *. Qed. diff --git a/theories/QArith/Qreduction.v b/theories/QArith/Qreduction.v index 78cd549ce6..e314f64028 100644 --- a/theories/QArith/Qreduction.v +++ b/theories/QArith/Qreduction.v @@ -35,7 +35,7 @@ Proof. rewrite <- Hg in LE; clear Hg. assert (0 <> g) by (intro; subst; discriminate). rewrite Z2Pos.id. ring. - rewrite <- (Z.mul_pos_cancel_l g); [now rewrite <- Hd | omega]. + now rewrite <- (Z.mul_pos_cancel_l g); [ rewrite <- Hd | apply Z.le_neq ]. Close Scope Z_scope. Qed. @@ -60,8 +60,8 @@ Proof. - congruence. - (*rel_prime*) constructor. - * exists aa; auto with zarith. - * exists bb; auto with zarith. + * exists aa; auto using Z.mul_1_r. + * exists bb; auto using Z.mul_1_r. * intros x Ha Hb. destruct Hg1 as (Hg11,Hg12,Hg13). destruct (Hg13 (g*x)) as (x',Hx). @@ -73,8 +73,8 @@ Proof. apply Z.mul_reg_l with g; auto. rewrite Hx at 1; ring. - (* rel_prime *) constructor. - * exists cc; auto with zarith. - * exists dd; auto with zarith. + * exists cc; auto using Z.mul_1_r. + * exists dd; auto using Z.mul_1_r. * intros x Hc Hd. inversion Hg'1 as (Hg'11,Hg'12,Hg'13). destruct (Hg'13 (g'*x)) as (x',Hx). @@ -85,9 +85,9 @@ Proof. exists x'. apply Z.mul_reg_l with g'; auto. rewrite Hx at 1; ring. - apply Z.lt_gt. - rewrite <- (Z.mul_pos_cancel_l g); [now rewrite <- Hg4 | omega]. + rewrite <- (Z.mul_pos_cancel_l g); [ now rewrite <- Hg4 | apply Z.le_neq; intuition ]. - apply Z.lt_gt. - rewrite <- (Z.mul_pos_cancel_l g'); [now rewrite <- Hg'4 | omega]. + rewrite <- (Z.mul_pos_cancel_l g'); [now rewrite <- Hg'4 | apply Z.le_neq; intuition ]. - apply Z.mul_reg_l with (g*g'). * rewrite Z.mul_eq_0. now destruct 1. * rewrite Z.mul_shuffle1, <- Hg3, <- Hg'4. diff --git a/theories/QArith/Qround.v b/theories/QArith/Qround.v index af5c471d5d..8d68038582 100644 --- a/theories/QArith/Qround.v +++ b/theories/QArith/Qround.v @@ -13,7 +13,8 @@ Require Import QArith. Lemma Qopp_lt_compat: forall p q : Q, p < q -> - q < - p. Proof. intros (a1,a2) (b1,b2); unfold Qle, Qlt; simpl. -rewrite !Z.mul_opp_l; omega. +rewrite !Z.mul_opp_l. +apply Z.opp_lt_mono. Qed. Hint Resolve Qopp_lt_compat : qarith. @@ -38,7 +39,7 @@ intros z. unfold Qceiling. simpl. rewrite Zdiv_1_r. -auto with *. +apply Z.opp_involutive. Qed. Lemma Qfloor_le : forall x, Qfloor x <= x. @@ -119,7 +120,7 @@ Lemma Qceiling_resp_le : forall x y, x <= y -> (Qceiling x <= Qceiling y)%Z. Proof. intros x y Hxy. unfold Qceiling. -cut (Qfloor (-y) <= Qfloor (-x))%Z; auto with *. +rewrite <- Z.opp_le_mono; auto with qarith. Qed. Hint Resolve Qceiling_resp_le : qarith. diff --git a/theories/Reals/Rtrigo1.v b/theories/Reals/Rtrigo1.v index a760a0af6a..0df1442f46 100644 --- a/theories/Reals/Rtrigo1.v +++ b/theories/Reals/Rtrigo1.v @@ -18,6 +18,7 @@ Require Export Cos_rel. Require Export Cos_plus. Require Import ZArith_base. Require Import Zcomplements. +Import Omega. Require Import Lra. Require Import Ranalysis1. Require Import Rsqrt_def. diff --git a/theories/Structures/OrderedType.v b/theories/Structures/OrderedType.v index 566dd31a9e..a411c5e54e 100644 --- a/theories/Structures/OrderedType.v +++ b/theories/Structures/OrderedType.v @@ -26,6 +26,8 @@ Arguments LT [X lt eq x y] _. Arguments EQ [X lt eq x y] _. Arguments GT [X lt eq x y] _. +Create HintDb ordered_type. + Module Type MiniOrderedType. Parameter Inline t : Type. @@ -42,8 +44,8 @@ Module Type MiniOrderedType. Parameter compare : forall x y : t, Compare lt eq x y. - Hint Immediate eq_sym : core. - Hint Resolve eq_refl eq_trans lt_not_eq lt_trans : core. + Hint Immediate eq_sym : ordered_type. + Hint Resolve eq_refl eq_trans lt_not_eq lt_trans : ordered_type. End MiniOrderedType. @@ -60,9 +62,9 @@ Module MOT_to_OT (Import O : MiniOrderedType) <: OrderedType. Include O. Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}. - Proof. - intros; elim (compare x y); intro H; [ right | left | right ]; auto. - assert (~ eq y x); auto. + Proof with auto with ordered_type. + intros; elim (compare x y); intro H; [ right | left | right ]... + assert (~ eq y x)... Defined. End MOT_to_OT. @@ -79,31 +81,30 @@ Module OrderedTypeFacts (Import O: OrderedType). Lemma lt_antirefl : forall x, ~ lt x x. Proof. - intros; intro; absurd (eq x x); auto. + intros; intro; absurd (eq x x); auto with ordered_type. Qed. Instance lt_strorder : StrictOrder lt. Proof. split; [ exact lt_antirefl | exact lt_trans]. Qed. Lemma lt_eq : forall x y z, lt x y -> eq y z -> lt x z. - Proof. + Proof with auto with ordered_type. intros; destruct (compare x z) as [Hlt|Heq|Hlt]; auto. - elim (lt_not_eq H); apply eq_trans with z; auto. - elim (lt_not_eq (lt_trans Hlt H)); 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. + Proof with auto with ordered_type. intros; destruct (compare x z) as [Hlt|Heq|Hlt]; auto. - elim (lt_not_eq H0); apply eq_trans with x; auto. - elim (lt_not_eq (lt_trans H0 Hlt)); auto. + elim (lt_not_eq H0); apply eq_trans with x... + elim (lt_not_eq (lt_trans H0 Hlt))... Qed. Instance lt_compat : Proper (eq==>eq==>iff) lt. - Proof. apply proper_sym_impl_iff_2; auto with *. intros x x' Hx y y' Hy H. - apply eq_lt with x; auto. + apply eq_lt with x; auto with ordered_type. apply lt_eq with y; auto. Qed. @@ -143,9 +144,9 @@ Module OrderedTypeFacts (Import O: OrderedType). Lemma eq_not_gt x y : eq x y -> ~ lt y x. Proof. order. Qed. Lemma lt_not_gt x y : lt x y -> ~ lt y x. Proof. order. Qed. - Hint Resolve gt_not_eq eq_not_lt : core. - Hint Immediate eq_lt lt_eq le_eq eq_le neq_eq eq_neq : core. - Hint Resolve eq_not_gt lt_antirefl lt_not_gt : core. + Hint Resolve gt_not_eq eq_not_lt : ordered_type. + Hint Immediate eq_lt lt_eq le_eq eq_le neq_eq eq_neq : ordered_type. + Hint Resolve eq_not_gt lt_antirefl lt_not_gt : ordered_type. Lemma elim_compare_eq : forall x y : t, @@ -197,7 +198,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. + intros; 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. @@ -247,8 +248,8 @@ Proof. exact (SortA_NoDupA eq_equiv lt_strorder lt_compat). Qed. End ForNotations. -Hint Resolve ListIn_In Sort_NoDup Inf_lt : core. -Hint Immediate In_eq Inf_lt : core. +Hint Resolve ListIn_In Sort_NoDup Inf_lt : ordered_type. +Hint Immediate In_eq Inf_lt : ordered_type. End OrderedTypeFacts. @@ -266,8 +267,8 @@ Module KeyOrderedType(O:OrderedType). eq (fst p) (fst p') /\ (snd p) = (snd p'). Definition ltk (p p':key*elt) := lt (fst p) (fst p'). - Hint Unfold eqk eqke ltk : core. - Hint Extern 2 (eqke ?a ?b) => split : core. + Hint Unfold eqk eqke ltk : ordered_type. + Hint Extern 2 (eqke ?a ?b) => split : ordered_type. (* eqke is stricter than eqk *) @@ -283,35 +284,35 @@ Module KeyOrderedType(O:OrderedType). Lemma ltk_right_l : forall x k e e', ltk (k,e) x -> ltk (k,e') x. Proof. auto. Qed. - Hint Immediate ltk_right_r ltk_right_l : core. + Hint Immediate ltk_right_r ltk_right_l : ordered_type. (* eqk, eqke are equalities, ltk is a strict order *) Lemma eqk_refl : forall e, eqk e e. - Proof. auto. Qed. + Proof. auto with ordered_type. Qed. Lemma eqke_refl : forall e, eqke e e. - Proof. auto. Qed. + Proof. auto with ordered_type. Qed. Lemma eqk_sym : forall e e', eqk e e' -> eqk e' e. - Proof. auto. Qed. + Proof. auto with ordered_type. Qed. Lemma eqke_sym : forall e e', eqke e e' -> eqke e' e. Proof. unfold eqke; intuition. Qed. Lemma eqk_trans : forall e e' e'', eqk e e' -> eqk e' e'' -> eqk e e''. - Proof. eauto. Qed. + Proof. eauto with ordered_type. Qed. Lemma eqke_trans : forall e e' e'', eqke e e' -> eqke e' e'' -> eqke e e''. Proof. - unfold eqke; intuition; [ eauto | congruence ]. + unfold eqke; intuition; [ eauto with ordered_type | congruence ]. Qed. Lemma ltk_trans : forall e e' e'', ltk e e' -> ltk e' e'' -> ltk e e''. - Proof. eauto. Qed. + Proof. eauto with ordered_type. Qed. Lemma ltk_not_eqk : forall e e', ltk e e' -> ~ eqk e e'. - Proof. unfold eqk, ltk; auto. Qed. + Proof. unfold eqk, ltk; auto with ordered_type. Qed. Lemma ltk_not_eqke : forall e e', ltk e e' -> ~eqke e e'. Proof. @@ -319,18 +320,18 @@ Module KeyOrderedType(O:OrderedType). exact (lt_not_eq H H1). Qed. - Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : core. - Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke : core. - Hint Immediate eqk_sym eqke_sym : core. + Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : ordered_type. + Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke : ordered_type. + Hint Immediate eqk_sym eqke_sym : ordered_type. Global Instance eqk_equiv : Equivalence eqk. - Proof. constructor; eauto. Qed. + Proof. constructor; eauto with ordered_type. Qed. Global Instance eqke_equiv : Equivalence eqke. - Proof. split; eauto. Qed. + Proof. split; eauto with ordered_type. Qed. Global Instance ltk_strorder : StrictOrder ltk. - Proof. constructor; eauto. intros x; apply (irreflexivity (x:=fst x)). Qed. + Proof. constructor; eauto with ordered_type. intros x; apply (irreflexivity (x:=fst x)). Qed. Global Instance ltk_compat : Proper (eqk==>eqk==>iff) ltk. Proof. @@ -348,45 +349,45 @@ Module KeyOrderedType(O:OrderedType). Lemma eqk_not_ltk : forall x x', eqk x x' -> ~ltk x x'. Proof. - unfold eqk, ltk; simpl; auto. + unfold eqk, ltk; simpl; auto with ordered_type. Qed. Lemma ltk_eqk : forall e e' e'', ltk e e' -> eqk e' e'' -> ltk e e''. - Proof. eauto. Qed. + Proof. eauto with ordered_type. Qed. Lemma eqk_ltk : forall e e' e'', eqk e e' -> ltk e' e'' -> ltk e e''. Proof. intros (k,e) (k',e') (k'',e''). - unfold ltk, eqk; simpl; eauto. + unfold ltk, eqk; simpl; eauto with ordered_type. Qed. - Hint Resolve eqk_not_ltk : core. - Hint Immediate ltk_eqk eqk_ltk : core. + Hint Resolve eqk_not_ltk : ordered_type. + Hint Immediate ltk_eqk eqk_ltk : ordered_type. Lemma InA_eqke_eqk : forall x m, InA eqke x m -> InA eqk x m. Proof. unfold eqke; induction 1; intuition. Qed. - Hint Resolve InA_eqke_eqk : core. + Hint Resolve InA_eqke_eqk : ordered_type. Definition MapsTo (k:key)(e:elt):= InA eqke (k,e). Definition In k m := exists e:elt, MapsTo k e m. Notation Sort := (sort ltk). Notation Inf := (lelistA ltk). - Hint Unfold MapsTo In : core. + Hint Unfold MapsTo In : ordered_type. (* An alternative formulation for [In k l] is [exists e, InA eqk (k,e) l] *) Lemma In_alt : forall k l, In k l <-> exists e, InA eqk (k,e) l. - Proof. + Proof with auto with ordered_type. firstorder. - exists x; auto. + exists x... induction H. - destruct y. - exists e; auto. + destruct y. + exists e... destruct IHInA as [e H0]. - exists e; auto. + exists e... Qed. Lemma MapsTo_eq : forall l x y e, eq x y -> MapsTo x e l -> MapsTo y e l. @@ -405,8 +406,8 @@ Module KeyOrderedType(O:OrderedType). Lemma Inf_lt : forall l x x', ltk x x' -> Inf x' l -> Inf x l. Proof. exact (InfA_ltA ltk_strorder). Qed. - Hint Immediate Inf_eq : core. - Hint Resolve Inf_lt : core. + Hint Immediate Inf_eq : ordered_type. + Hint Resolve Inf_lt : ordered_type. Lemma Sort_Inf_In : forall l p q, Sort l -> Inf q l -> InA eqk p l -> ltk q p. @@ -420,8 +421,8 @@ Module KeyOrderedType(O:OrderedType). intros; red; intros. destruct H1 as [e' H2]. elim (@ltk_not_eqk (k,e) (k,e')). - eapply Sort_Inf_In; eauto. - red; simpl; auto. + eapply Sort_Inf_In; eauto with ordered_type. + red; simpl; auto with ordered_type. Qed. Lemma Sort_NoDupA: forall l, Sort l -> NoDupA eqk l. @@ -437,7 +438,7 @@ 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. + inversion_clear 2; auto with ordered_type. left; apply Sort_In_cons_1 with l; auto. Qed. @@ -451,7 +452,7 @@ Module KeyOrderedType(O:OrderedType). 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_clear H0; eauto with ordered_type. destruct H1; simpl in *; intuition. Qed. @@ -469,19 +470,19 @@ Module KeyOrderedType(O:OrderedType). End Elt. - Hint Unfold eqk eqke ltk : core. - Hint Extern 2 (eqke ?a ?b) => split : core. - Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : core. - Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke : core. - Hint Immediate eqk_sym eqke_sym : core. - Hint Resolve eqk_not_ltk : core. - Hint Immediate ltk_eqk eqk_ltk : core. - Hint Resolve InA_eqke_eqk : core. - Hint Unfold MapsTo In : core. - Hint Immediate Inf_eq : core. - Hint Resolve Inf_lt : core. - Hint Resolve Sort_Inf_NotIn : core. - Hint Resolve In_inv_2 In_inv_3 : core. + Hint Unfold eqk eqke ltk : ordered_type. + Hint Extern 2 (eqke ?a ?b) => split : ordered_type. + Hint Resolve eqk_trans eqke_trans eqk_refl eqke_refl : ordered_type. + Hint Resolve ltk_trans ltk_not_eqk ltk_not_eqke : ordered_type. + Hint Immediate eqk_sym eqke_sym : ordered_type. + Hint Resolve eqk_not_ltk : ordered_type. + Hint Immediate ltk_eqk eqk_ltk : ordered_type. + Hint Resolve InA_eqke_eqk : ordered_type. + Hint Unfold MapsTo In : ordered_type. + Hint Immediate Inf_eq : ordered_type. + Hint Resolve Inf_lt : ordered_type. + Hint Resolve Sort_Inf_NotIn : ordered_type. + Hint Resolve In_inv_2 In_inv_3 : ordered_type. End KeyOrderedType. diff --git a/theories/Structures/OrderedTypeEx.v b/theories/Structures/OrderedTypeEx.v index 9b99fa5de4..cc216b21f8 100644 --- a/theories/Structures/OrderedTypeEx.v +++ b/theories/Structures/OrderedTypeEx.v @@ -12,7 +12,6 @@ Require Import OrderedType. Require Import ZArith. Require Import PeanoNat. Require Import Ascii String. -Require Import Omega. Require Import NArith Ndec. Require Import Compare_dec. @@ -55,7 +54,7 @@ Module Nat_as_OT <: UsualOrderedType. Proof. unfold lt; intros; apply lt_trans with y; auto. Qed. Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. - Proof. unfold lt, eq; intros; omega. Qed. + Proof. unfold lt, eq; intros ? ? LT ->; revert LT; apply Nat.lt_irrefl. Qed. Definition compare x y : Compare lt eq x y. Proof. @@ -85,10 +84,10 @@ Module Z_as_OT <: UsualOrderedType. Definition lt (x y:Z) := (x<y). Lemma lt_trans : forall x y z, x<y -> y<z -> x<z. - Proof. intros; omega. Qed. + Proof. exact Z.lt_trans. Qed. Lemma lt_not_eq : forall x y, x<y -> ~ x=y. - Proof. intros; omega. Qed. + Proof. intros x y LT ->; revert LT; apply Z.lt_irrefl. Qed. Definition compare x y : Compare lt eq x y. Proof. @@ -178,7 +177,7 @@ Module PairOrderedType(O1 O2:OrderedType) <: OrderedType. Lemma eq_refl : forall x : t, eq x x. Proof. - intros (x1,x2); red; simpl; auto. + intros (x1,x2); red; simpl; auto with ordered_type. Qed. Lemma eq_sym : forall x y : t, eq x y -> eq y x. @@ -188,16 +187,16 @@ Module PairOrderedType(O1 O2:OrderedType) <: OrderedType. Lemma eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z. Proof. - intros (x1,x2) (y1,y2) (z1,z2); unfold eq; simpl; intuition eauto. + intros (x1,x2) (y1,y2) (z1,z2); unfold eq; simpl; intuition eauto with ordered_type. Qed. Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. Proof. intros (x1,x2) (y1,y2) (z1,z2); unfold eq, lt; simpl; intuition. - left; eauto. + left; eauto with ordered_type. left; eapply MO1.lt_eq; eauto. left; eapply MO1.eq_lt; eauto. - right; split; eauto. + right; split; eauto with ordered_type. Qed. Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. @@ -214,7 +213,7 @@ Module PairOrderedType(O1 O2:OrderedType) <: OrderedType. destruct (O2.compare x2 y2). apply LT; unfold lt; auto. apply EQ; unfold eq; auto. - apply GT; unfold lt; auto. + apply GT; unfold lt; auto with ordered_type. apply GT; unfold lt; auto. Defined. diff --git a/theories/ZArith/ZArith.v b/theories/ZArith/ZArith.v index b0744caa7b..38f9336f1b 100644 --- a/theories/ZArith/ZArith.v +++ b/theories/ZArith/ZArith.v @@ -18,6 +18,7 @@ Require Export Zpow_def. (** Extra modules using [Omega] or [Ring]. *) +Require Export Omega. Require Export Zcomplements. Require Export Zpower. Require Export Zdiv. diff --git a/theories/ZArith/Zcomplements.v b/theories/ZArith/Zcomplements.v index 73c8ec11c6..0be6f8c8de 100644 --- a/theories/ZArith/Zcomplements.v +++ b/theories/ZArith/Zcomplements.v @@ -10,7 +10,6 @@ Require Import ZArithRing. Require Import ZArith_base. -Require Export Omega. Require Import Wf_nat. Local Open Scope Z_scope. @@ -40,10 +39,19 @@ Proof. reflexivity. Qed. Lemma floor_ok : forall p:positive, floor p <= Zpos p < 2 * floor p. Proof. - unfold floor. induction p; simpl. - - rewrite !Pos2Z.inj_xI, (Pos2Z.inj_xO (xO _)), Pos2Z.inj_xO. omega. - - rewrite (Pos2Z.inj_xO (xO _)), (Pos2Z.inj_xO p), Pos2Z.inj_xO. omega. - - omega. + unfold floor. induction p as [p [IH1p IH2p]|p [IH1p IH2]|]; simpl. + - rewrite !Pos2Z.inj_xI, (Pos2Z.inj_xO (xO _)), Pos2Z.inj_xO. + split. + + apply Z.le_trans with (2 * Z.pos p); auto with zarith. + rewrite <- (Z.add_0_r (2 * Z.pos p)) at 1; auto with zarith. + + apply Z.lt_le_trans with (2 * (Z.pos p + 1)). + * rewrite Z.mul_add_distr_l, Z.mul_1_r. + apply Zplus_lt_compat_l; red; auto with zarith. + * apply Z.mul_le_mono_nonneg_l; auto with zarith. + rewrite Z.add_1_r; apply Zlt_le_succ; auto. + - rewrite (Pos2Z.inj_xO (xO _)), (Pos2Z.inj_xO p), Pos2Z.inj_xO. + split; auto with zarith. + - split; auto with zarith; red; auto. Qed. (**********************************************************************) @@ -64,9 +72,10 @@ Proof. - rewrite Z.abs_eq; auto; intros. destruct (H (Z.abs m)); auto with zarith. destruct (Zabs_dec m) as [-> | ->]; trivial. - - rewrite Z.abs_neq, Z.opp_involutive; auto with zarith; intros. - destruct (H (Z.abs m)); auto with zarith. - destruct (Zabs_dec m) as [-> | ->]; trivial. + - rewrite Z.abs_neq, Z.opp_involutive; intros. + + destruct (H (Z.abs m)); auto with zarith. + destruct (Zabs_dec m) as [-> | ->]; trivial. + + apply Z.opp_le_mono; rewrite Z.opp_involutive; auto. Qed. Theorem Z_lt_abs_induction : @@ -84,9 +93,10 @@ Proof. - rewrite Z.abs_eq; auto; intros. elim (H (Z.abs m)); intros; auto with zarith. elim (Zabs_dec m); intro eq; rewrite eq; trivial. - - rewrite Z.abs_neq, Z.opp_involutive; auto with zarith; intros. - destruct (H (Z.abs m)); auto with zarith. - destruct (Zabs_dec m) as [-> | ->]; trivial. + - rewrite Z.abs_neq, Z.opp_involutive; intros. + + destruct (H (Z.abs m)); auto with zarith. + destruct (Zabs_dec m) as [-> | ->]; trivial. + + apply Z.opp_le_mono; rewrite Z.opp_involutive; auto. Qed. (** To do case analysis over the sign of [z] *) @@ -129,7 +139,7 @@ Section Zlength_properties. clear l. induction l. auto with zarith. intros. simpl length; simpl Zlength_aux. - rewrite IHl, Nat2Z.inj_succ; auto with zarith. + rewrite IHl, Nat2Z.inj_succ, Z.add_succ_comm; auto. unfold Zlength. now rewrite H. Qed. diff --git a/theories/ZArith/Zdiv.v b/theories/ZArith/Zdiv.v index 78df9941c9..2aaab3e50e 100644 --- a/theories/ZArith/Zdiv.v +++ b/theories/ZArith/Zdiv.v @@ -14,7 +14,7 @@ (** Initial Contribution by Claude Marché and Xavier Urbain *) Require Export ZArith_base. -Require Import Zbool Omega ZArithRing Zcomplements Setoid Morphisms. +Require Import Zbool ZArithRing Zcomplements Setoid Morphisms. Local Open Scope Z_scope. (** The definition of the division is now in [BinIntDef], the initial @@ -67,7 +67,12 @@ Definition Remainder_alt r b := Z.abs r < Z.abs b /\ Z.sgn r <> - Z.sgn b. Lemma Remainder_equiv : forall r b, Remainder r b <-> Remainder_alt r b. Proof. - intros; unfold Remainder, Remainder_alt; omega with *. + unfold Remainder, Remainder_alt. + intros [ | r | r ] [ | b | b ]; intuition try easy. + - now apply Z.opp_lt_mono. + - right; split. + + now apply Z.opp_lt_mono. + + apply Pos2Z.neg_is_nonpos. Qed. Hint Unfold Remainder : core. @@ -104,7 +109,7 @@ Proof (Z.mod_neg_bound a b). Lemma Z_div_mod_eq a b : b > 0 -> a = b*(a/b) + (a mod b). Proof. - intros Hb; apply Z.div_mod; auto with zarith. + intros Hb; apply Z.div_mod; now intros ->. Qed. Lemma Zmod_eq_full a b : b<>0 -> a mod b = a - (a/b)*b. @@ -224,18 +229,25 @@ Proof Z.div_mul. (* Division of positive numbers is positive. *) Lemma Z_div_pos: forall a b, b > 0 -> 0 <= a -> 0 <= a/b. -Proof. intros. apply Z.div_pos; auto with zarith. Qed. +Proof. intros. apply Z.div_pos; auto using Z.gt_lt. Qed. Lemma Z_div_ge0: forall a b, b > 0 -> a >= 0 -> a/b >=0. Proof. - intros; generalize (Z_div_pos a b H); auto with zarith. + intros; apply Z.le_ge, Z_div_pos; auto using Z.ge_le. Qed. (** As soon as the divisor is greater or equal than 2, the division is strictly decreasing. *) Lemma Z_div_lt : forall a b:Z, b >= 2 -> a > 0 -> a/b < a. -Proof. intros. apply Z.div_lt; auto with zarith. Qed. +Proof. + intros a b b_ge_2 a_gt_0. + apply Z.div_lt. + - apply Z.gt_lt; exact a_gt_0. + - apply (Z.lt_le_trans _ 2). + + reflexivity. + + apply Z.ge_le; exact b_ge_2. +Qed. (** A division of a small number by a bigger one yields zero. *) @@ -250,17 +262,17 @@ Proof Z.mod_small. (** [Z.ge] is compatible with a positive division. *) Lemma Z_div_ge : forall a b c:Z, c > 0 -> a >= b -> a/c >= b/c. -Proof. intros. apply Z.le_ge. apply Z.div_le_mono; auto with zarith. Qed. +Proof. intros. apply Z.le_ge. apply Z.div_le_mono; auto using Z.gt_lt, Z.ge_le. Qed. (** Same, with [Z.le]. *) Lemma Z_div_le : forall a b c:Z, c > 0 -> a <= b -> a/c <= b/c. -Proof. intros. apply Z.div_le_mono; auto with zarith. Qed. +Proof. intros. apply Z.div_le_mono; auto using Z.gt_lt. Qed. (** With our choice of division, rounding of (a/b) is always done toward bottom: *) Lemma Z_mult_div_ge : forall a b:Z, b > 0 -> b*(a/b) <= a. -Proof. intros. apply Z.mul_div_le; auto with zarith. Qed. +Proof. intros. apply Z.mul_div_le; auto using Z.gt_lt. Qed. Lemma Z_mult_div_ge_neg : forall a b:Z, b < 0 -> b*(a/b) >= a. Proof. intros. apply Z.le_ge. apply Z.mul_div_ge; auto with zarith. Qed. @@ -296,14 +308,18 @@ Proof. intros a b q; rewrite Z.mul_comm; apply Z.div_le_lower_bound. Qed. Lemma Zdiv_le_compat_l: forall p q r, 0 <= p -> 0 < q < r -> p / r <= p / q. -Proof. intros; apply Z.div_le_compat_l; auto with zarith. Qed. +Proof. intros; apply Z.div_le_compat_l; intuition auto using Z.lt_le_incl. Qed. Theorem Zdiv_sgn: forall a b, 0 <= Z.sgn (a/b) * Z.sgn a * Z.sgn b. Proof. destruct a as [ |a|a]; destruct b as [ |b|b]; simpl; auto with zarith; generalize (Z.div_pos (Zpos a) (Zpos b)); unfold Z.div, Z.div_eucl; - destruct Z.pos_div_eucl as (q,r); destruct r; omega with *. + destruct Z.pos_div_eucl as (q,r); destruct r; + rewrite ?Z.mul_1_r, <-?Z.opp_eq_mul_m1, ?Z.sgn_opp, ?Z.opp_involutive; + match goal with [|- (_ -> _ -> ?P) -> _] => + intros HH; assert (HH1 : P); auto with zarith + end; apply Z.sgn_nonneg; auto with zarith. Qed. (** * Relations between usual operations and Z.modulo and Z.div *) @@ -346,14 +362,14 @@ Proof. intros. zero_or_not b. apply Z.div_opp_l_z; auto. Qed. Lemma Z_div_nz_opp_full : forall a b:Z, a mod b <> 0 -> (-a)/b = -(a/b)-1. -Proof. intros a b. zero_or_not b. intros; rewrite Z.div_opp_l_nz; auto. Qed. +Proof. intros a b. zero_or_not b. easy. intros; rewrite Z.div_opp_l_nz; auto. Qed. Lemma Z_div_zero_opp_r : forall a b:Z, a mod b = 0 -> a/(-b) = -(a/b). Proof. intros. zero_or_not b. apply Z.div_opp_r_z; auto. Qed. Lemma Z_div_nz_opp_r : forall a b:Z, a mod b <> 0 -> a/(-b) = -(a/b)-1. -Proof. intros a b. zero_or_not b. intros; rewrite Z.div_opp_r_nz; auto. Qed. +Proof. intros a b. zero_or_not b. easy. intros; rewrite Z.div_opp_r_nz; auto. Qed. (** Cancellations. *) @@ -372,14 +388,16 @@ Lemma Zmult_mod_distr_l: forall a b c, (c*a) mod (c*b) = c * (a mod b). Proof. intros. zero_or_not c. rewrite (Z.mul_comm c b); zero_or_not b. - rewrite (Z.mul_comm b c). apply Z.mul_mod_distr_l; auto. + + now rewrite Z.mul_0_r. + + rewrite (Z.mul_comm b c). apply Z.mul_mod_distr_l; auto. Qed. Lemma Zmult_mod_distr_r: forall a b c, (a*c) mod (b*c) = (a mod b) * c. Proof. intros. zero_or_not b. rewrite (Z.mul_comm b c); zero_or_not c. - rewrite (Z.mul_comm c b). apply Z.mul_mod_distr_r; auto. + + now rewrite Z.mul_0_r. + + rewrite (Z.mul_comm c b). apply Z.mul_mod_distr_r; auto. Qed. (** Operations modulo. *) @@ -456,7 +474,7 @@ Proof. unfold eqm; auto. Qed. Lemma eqm_trans : forall a b c, a == b -> b == c -> a == c. -Proof. unfold eqm; eauto with *. Qed. +Proof. now unfold eqm; intros a b c ->. Qed. Instance eqm_setoid : Equivalence eqm. Proof. @@ -501,7 +519,8 @@ End EqualityModulo. Lemma Zdiv_Zdiv : forall a b c, 0<=b -> 0<=c -> (a/b)/c = a/(b*c). Proof. intros. zero_or_not b. rewrite Z.mul_comm. zero_or_not c. - rewrite Z.mul_comm. apply Z.div_div; auto with zarith. + rewrite Z.mul_comm. apply Z.div_div; auto. + apply Z.le_neq; auto. Qed. (** Unfortunately, the previous result isn't always true on negative numbers. @@ -519,7 +538,10 @@ Qed. Theorem Zdiv_mult_le: forall a b c, 0<=a -> 0<=b -> 0<=c -> c*(a/b) <= (c*a)/b. Proof. - intros. zero_or_not b. apply Z.div_mul_le; auto with zarith. Qed. + intros. zero_or_not b. now rewrite Z.mul_0_r. + apply Z.div_mul_le; auto. + apply Z.le_neq; auto. +Qed. (** Z.modulo is related to divisibility (see more in Znumtheory) *) @@ -566,17 +588,17 @@ Qed. Lemma Z_div_same : forall a, a > 0 -> a/a = 1. Proof. - intros; apply Z_div_same_full; auto with zarith. + now intros; apply Z_div_same_full; intros ->. Qed. Lemma Z_div_plus : forall a b c:Z, c > 0 -> (a + b * c) / c = a / c + b. Proof. - intros; apply Z_div_plus_full; auto with zarith. + now intros; apply Z_div_plus_full; intros ->. Qed. Lemma Z_div_mult : forall a b:Z, b > 0 -> (a*b)/b = a. Proof. - intros; apply Z_div_mult_full; auto with zarith. + now intros; apply Z_div_mult_full; intros ->. Qed. Lemma Z_mod_plus : forall a b c:Z, c > 0 -> (a + b * c) mod c = a mod c. @@ -591,7 +613,7 @@ Qed. Lemma Z_div_exact_2 : forall a b:Z, b > 0 -> a mod b = 0 -> a = b*(a/b). Proof. - intros; apply Z_div_exact_full_2; auto with zarith. + now intros; apply Z_div_exact_full_2; auto; intros ->. Qed. Lemma Z_mod_zero_opp : forall a b:Z, b > 0 -> a mod b = 0 -> (-a) mod b = 0. @@ -673,14 +695,15 @@ Theorem Zdiv_eucl_extended : Proof. intros b Hb a. destruct (Z_le_gt_dec 0 b) as [Hb'|Hb']. - - assert (Hb'' : b > 0) by omega. + - assert (Hb'' : b > 0) by (apply Z.lt_gt, Z.le_neq; auto). rewrite Z.abs_eq; [ apply Zdiv_eucl_exist; assumption | assumption ]. - - assert (Hb'' : - b > 0) by omega. + - assert (Hb'' : - b > 0). + { now apply Z.lt_gt, Z.opp_lt_mono; rewrite Z.opp_involutive; apply Z.gt_lt. } destruct (Zdiv_eucl_exist Hb'' a) as ((q,r),[]). exists (- q, r). split. + rewrite <- Z.mul_opp_comm; assumption. - + rewrite Z.abs_neq; [ assumption | omega ]. + + rewrite Z.abs_neq; [ assumption | apply Z.lt_le_incl, Z.gt_lt; auto ]. Qed. Arguments Zdiv_eucl_extended : default implicits. diff --git a/theories/ZArith/Znumtheory.v b/theories/ZArith/Znumtheory.v index 5d1a13ff6c..01365135c5 100644 --- a/theories/ZArith/Znumtheory.v +++ b/theories/ZArith/Znumtheory.v @@ -117,17 +117,23 @@ Proof. right. now rewrite <- Z.mod_divide. Defined. +Lemma Z_lt_neq {x y: Z} : x < y -> y <> x. +Proof. auto using Z.lt_neq, Z.neq_sym. Qed. + Theorem Zdivide_Zdiv_eq a b : 0 < a -> (a | b) -> b = a * (b / a). Proof. intros Ha H. - rewrite (Z.div_mod b a) at 1; auto with zarith. - rewrite Zdivide_mod; auto with zarith. + rewrite (Z.div_mod b a) at 1. + + rewrite Zdivide_mod; auto with zarith. + + auto using Z_lt_neq. Qed. Theorem Zdivide_Zdiv_eq_2 a b c : 0 < a -> (a | b) -> (c * b) / a = c * (b / a). Proof. - intros. apply Z.divide_div_mul_exact; auto with zarith. + intros. apply Z.divide_div_mul_exact. + + now apply Z_lt_neq. + + auto with zarith. Qed. Theorem Zdivide_le: forall a b : Z, @@ -139,28 +145,30 @@ Qed. Theorem Zdivide_Zdiv_lt_pos a b : 1 < a -> 0 < b -> (a | b) -> 0 < b / a < b . Proof. - intros H1 H2 H3; split. - apply Z.mul_pos_cancel_l with a; auto with zarith. - rewrite <- Zdivide_Zdiv_eq; auto with zarith. - now apply Z.div_lt. + intros H1 H2 H3. + assert (0 < a) by (now transitivity 1). + split. + + apply Z.mul_pos_cancel_l with a; auto. + rewrite <- Zdivide_Zdiv_eq; auto. + + now apply Z.div_lt. Qed. Lemma Zmod_div_mod n m a: 0 < n -> 0 < m -> (n | m) -> a mod n = (a mod m) mod n. -Proof. +Proof with auto using Z_lt_neq. intros H1 H2 (p,Hp). - rewrite (Z.div_mod a m) at 1; auto with zarith. + rewrite (Z.div_mod a m) at 1... rewrite Hp at 1. - rewrite Z.mul_shuffle0, Z.add_comm, Z.mod_add; auto with zarith. + rewrite Z.mul_shuffle0, Z.add_comm, Z.mod_add... Qed. Lemma Zmod_divide_minus a b c: 0 < b -> a mod b = c -> (b | a - c). -Proof. - intros H H1. apply Z.mod_divide; auto with zarith. - rewrite Zminus_mod; auto with zarith. +Proof with auto using Z_lt_neq. + intros H H1. apply Z.mod_divide... + rewrite Zminus_mod. rewrite H1. rewrite <- (Z.mod_small c b) at 1. - rewrite Z.sub_diag, Z.mod_0_l; auto with zarith. + rewrite Z.sub_diag, Z.mod_0_l... subst. now apply Z.mod_pos_bound. Qed. @@ -169,10 +177,11 @@ Lemma Zdivide_mod_minus a b c: Proof. intros (H1, H2) H3. assert (0 < b) by Z.order. - replace a with ((a - c) + c); auto with zarith. - rewrite Z.add_mod; auto with zarith. - rewrite (Zdivide_mod (a-c) b); try rewrite Z.add_0_l; auto with zarith. - rewrite Z.mod_mod; try apply Zmod_small; auto with zarith. + assert (b <> 0) by now apply Z_lt_neq. + replace a with ((a - c) + c) by ring. + rewrite Z.add_mod; auto. + rewrite (Zdivide_mod (a-c) b); try rewrite Z.add_0_l; auto. + rewrite Z.mod_mod; try apply Zmod_small; auto. Qed. (** * Greatest common divisor (gcd). *) @@ -300,8 +309,9 @@ Section extended_euclid_algorithm. set (q := u3 / x) in *. assert (Hq : 0 <= u3 - q * x < x). replace (u3 - q * x) with (u3 mod x). - apply Z_mod_lt; omega. - assert (xpos : x > 0). omega. + apply Z_mod_lt. + apply Z.lt_gt, Z.le_neq; auto. + assert (xpos : x > 0) by (apply Z.lt_gt, Z.le_neq; auto). generalize (Z_div_mod_eq u3 x xpos). unfold q. intro eq; pattern u3 at 2; rewrite eq; ring. @@ -325,11 +335,13 @@ Section extended_euclid_algorithm. intros; apply euclid_rec with (u1 := 1) (u2 := 0) (u3 := a) (v1 := 0) (v2 := 1) (v3 := b); - auto with zarith; ring. + auto; ring. intros; apply euclid_rec with (u1 := 1) (u2 := 0) (u3 := a) (v1 := 0) (v2 := -1) (v3 := - b); - auto with zarith; try ring. + auto; try ring. + now apply Z.opp_nonneg_nonpos, Z.lt_le_incl, Z.gt_lt. + auto with zarith. Qed. End extended_euclid_algorithm. @@ -433,22 +445,24 @@ Lemma rel_prime_cross_prod : rel_prime a b -> rel_prime c d -> b > 0 -> d > 0 -> a * d = b * c -> a = c /\ b = d. Proof. - intros a b c d; intros. + intros a b c d; intros H H0 H1 H2 H3. elim (Z.divide_antisym b d). - split; auto with zarith. - rewrite H4 in H3. - rewrite Z.mul_comm in H3. - apply Z.mul_reg_l with d; auto with zarith. - intros; omega. - apply Gauss with a. - rewrite H3. - auto with zarith. - red; auto with zarith. - apply Gauss with c. - rewrite Z.mul_comm. - rewrite <- H3. - auto with zarith. - red; auto with zarith. + - split; auto with zarith. + rewrite H4 in H3. + rewrite Z.mul_comm in H3. + apply Z.mul_reg_l with d; auto. + contradict H2; rewrite H2; discriminate. + - intros H4; contradict H1; rewrite H4. + apply Zgt_asym, Z.lt_gt, Z.opp_lt_mono. + now rewrite Z.opp_involutive; apply Z.gt_lt. + - apply Gauss with a. + + rewrite H3; auto with zarith. + + now apply Zis_gcd_sym. + - apply Gauss with c. + + rewrite Z.mul_comm. + rewrite <- H3. + auto with zarith. + + now apply Zis_gcd_sym. Qed. (** After factorization by a gcd, the original numbers are relatively prime. *) @@ -457,32 +471,35 @@ Lemma Zis_gcd_rel_prime : forall a b g:Z, b > 0 -> g >= 0 -> Zis_gcd a b g -> rel_prime (a / g) (b / g). Proof. - intros a b g; intros. - assert (g <> 0). - intro. - elim H1; intros. - elim H4; intros. - rewrite H2 in H6; subst b; omega. + intros a b g; intros H H0 H1. + assert (H2 : g <> 0) by + (intro; + elim H1; intros; + elim H4; intros; + rewrite H2 in H6; subst b; + contradict H; rewrite Z.mul_0_r; discriminate). + assert (H3 : g > 0) by + (apply Z.lt_gt, Z.le_neq; split; try apply Z.ge_le; auto). unfold rel_prime. - destruct H1. - destruct H1 as (a',H1). - destruct H3 as (b',H3). + destruct H1 as [Ha Hb Hab]. + destruct Ha as [a' Ha']. + destruct Hb as [b' Hb']. replace (a/g) with a'; - [|rewrite H1; rewrite Z_div_mult; auto with zarith]. + [|rewrite Ha'; rewrite Z_div_mult; auto with zarith]. replace (b/g) with b'; - [|rewrite H3; rewrite Z_div_mult; auto with zarith]. + [|rewrite Hb'; rewrite Z_div_mult; auto with zarith]. constructor. - exists a'; auto with zarith. - exists b'; auto with zarith. - intros x (xa,H5) (xb,H6). - destruct (H4 (x*g)) as (x',Hx'). - exists xa; rewrite Z.mul_assoc; rewrite <- H5; auto. - exists xb; rewrite Z.mul_assoc; rewrite <- H6; auto. - replace g with (1*g) in Hx'; auto with zarith. - do 2 rewrite Z.mul_assoc in Hx'. - apply Z.mul_reg_r in Hx'; trivial. - rewrite Z.mul_1_r in Hx'. - exists x'; auto with zarith. + - exists a'; rewrite ?Z.mul_1_r; auto with zarith. + - exists b'; rewrite ?Z.mul_1_r; auto with zarith. + - intros x (xa,H5) (xb,H6). + destruct (Hab (x*g)) as (x',Hx'). + exists xa; rewrite Z.mul_assoc; rewrite <- H5; auto. + exists xb; rewrite Z.mul_assoc; rewrite <- H6; auto. + replace g with (1*g) in Hx'; auto with zarith. + do 2 rewrite Z.mul_assoc in Hx'. + apply Z.mul_reg_r in Hx'; trivial. + rewrite Z.mul_1_r in Hx'. + exists x'; auto with zarith. Qed. Theorem rel_prime_sym: forall a b, rel_prime a b -> rel_prime b a. @@ -504,18 +521,18 @@ Qed. Theorem rel_prime_1: forall n, rel_prime 1 n. Proof. intros n; red; apply Zis_gcd_intro; auto. - exists 1; auto with zarith. - exists n; auto with zarith. + exists 1; reflexivity. + exists n; rewrite Z.mul_1_r; reflexivity. Qed. Theorem not_rel_prime_0: forall n, 1 < n -> ~ rel_prime 0 n. Proof. intros n H H1; absurd (n = 1 \/ n = -1). - intros [H2 | H2]; subst; contradict H; auto with zarith. + intros [H2 | H2]; subst; contradict H; discriminate. case (Zis_gcd_unique 0 n n 1); auto. apply Zis_gcd_intro; auto. - exists 0; auto with zarith. - exists 1; auto with zarith. + exists 0; reflexivity. + exists 1; rewrite Z.mul_1_l; reflexivity. Qed. Theorem rel_prime_mod: forall p q, 0 < q -> @@ -528,15 +545,16 @@ Proof. apply bezout_rel_prime. apply Bezout_intro with q1 (r1 + q1 * (p / q)). rewrite <- H2. - pattern p at 3; rewrite (Z_div_mod_eq p q); try ring; auto with zarith. + pattern p at 3; rewrite (Z_div_mod_eq p q); try ring. + now apply Z.lt_gt. Qed. Theorem rel_prime_mod_rev: forall p q, 0 < q -> rel_prime (p mod q) q -> rel_prime p q. Proof. intros p q H H0. - rewrite (Z_div_mod_eq p q); auto with zarith; red. - apply Zis_gcd_sym; apply Zis_gcd_for_euclid2; auto with zarith. + rewrite (Z_div_mod_eq p q) by now apply Z.lt_gt. red. + apply Zis_gcd_sym; apply Zis_gcd_for_euclid2; auto. Qed. Theorem Zrel_prime_neq_mod_0: forall a b, 1 < b -> rel_prime a b -> a mod b <> 0. @@ -544,7 +562,8 @@ Proof. intros a b H H1 H2. case (not_rel_prime_0 _ H). rewrite <- H2. - apply rel_prime_mod; auto with zarith. + apply rel_prime_mod; auto. + now transitivity 1. Qed. (** * Primality *) @@ -563,25 +582,56 @@ Proof. assert (a = - p \/ - p < a < -1 \/ a = -1 \/ a = 0 \/ a = 1 \/ 1 < a < p \/ a = p). { assert (Z.abs a <= Z.abs p) as H2. - apply Zdivide_bounds; [ assumption | omega ]. + apply Zdivide_bounds; [ assumption | now intros -> ]. revert H2. pattern (Z.abs a); apply Zabs_ind; pattern (Z.abs p); apply Zabs_ind; - intros; omega. } + intros H2 H3 H4. + - destruct (Zle_lt_or_eq _ _ H4) as [H5 | H5]; try intuition. + destruct (Zle_lt_or_eq _ _ (Z.ge_le _ _ H3)) as [H6 | H6]; try intuition. + destruct (Zle_lt_or_eq _ _ (Zlt_le_succ _ _ H6)) as [H7 | H7]; intuition. + - contradict H2; apply Zlt_not_le; apply Z.lt_trans with (2 := H); red; auto. + - destruct (Zle_lt_or_eq _ _ H4) as [H5 | H5]. + + destruct (Zle_lt_or_eq _ _ H3) as [H6 | H6]; try intuition. + assert (H7 : a <= Z.pred 0) by (apply Z.lt_le_pred; auto). + destruct (Zle_lt_or_eq _ _ H7) as [H8 | H8]; intuition. + assert (- p < a < -1); try intuition. + now apply Z.opp_lt_mono; rewrite Z.opp_involutive. + + now left; rewrite <- H5, Z.opp_involutive. + - contradict H2. + apply Zlt_not_le; apply Z.lt_trans with (2 := H); red; auto. + } intuition idtac. (* -p < a < -1 *) - - absurd (rel_prime (- a) p); intuition. - inversion H2. - assert (- a | - a) by auto with zarith. - assert (- a | p) by auto with zarith. - apply H7, Z.divide_1_r in H8; intuition. + - absurd (rel_prime (- a) p). + + intros [H1p H2p H3p]. + assert (- a | - a) by auto with zarith. + assert (- a | p) by auto with zarith. + apply H3p, Z.divide_1_r in H5; auto with zarith. + destruct H5. + * contradict H4; rewrite <- (Z.opp_involutive a), H5 . + apply Z.lt_irrefl. + * contradict H4; rewrite <- (Z.opp_involutive a), H5 . + discriminate. + + apply H0; split. + * now apply Z.opp_le_mono; rewrite Z.opp_involutive; apply Z.lt_le_incl. + * now apply Z.opp_lt_mono; rewrite Z.opp_involutive. (* a = 0 *) - - inversion H1. subst a; omega. + - contradict H. + replace p with 0; try discriminate. + now apply sym_equal, Z.divide_0_l; rewrite <-H2. (* 1 < a < p *) - - absurd (rel_prime a p); intuition. - inversion H2. - assert (a | a) by auto with zarith. - assert (a | p) by auto with zarith. - apply H7, Z.divide_1_r in H8; intuition. + - absurd (rel_prime a p). + + intros [H1p H2p H3p]. + assert (a | a) by auto with zarith. + assert (a | p) by auto with zarith. + apply H3p, Z.divide_1_r in H5; auto with zarith. + destruct H5. + * contradict H3; rewrite <- (Z.opp_involutive a), H5 . + apply Z.lt_irrefl. + * contradict H3; rewrite <- (Z.opp_involutive a), H5 . + discriminate. + + apply H0; split; auto. + now apply Z.lt_le_incl. Qed. (** A prime number is relatively prime with any number it does not divide *) @@ -605,12 +655,17 @@ Proof. intros a p Hp [H1 H2]. apply rel_prime_sym; apply prime_rel_prime; auto. intros [q Hq]; subst a. - case (Z.le_gt_cases q 0); intros Hl. - absurd (q * p <= 0 * p); auto with zarith. - absurd (1 * p <= q * p); auto with zarith. + destruct Hp as [H3 H4]. + contradict H2; apply Zle_not_lt. + rewrite <- (Z.mul_1_l p) at 1. + apply Zmult_le_compat_r. + - apply (Zlt_le_succ 0). + apply Zmult_lt_0_reg_r with p. + + apply Z.le_succ_l, Z.lt_le_incl; auto. + + now apply Z.le_succ_l. + - apply Z.lt_le_incl, Z.le_succ_l, Z.lt_le_incl; auto. Qed. - (** If a prime [p] divides [ab] then it divides either [a] or [b] *) Lemma prime_mult : @@ -623,38 +678,44 @@ Qed. Lemma not_prime_0: ~ prime 0. Proof. - intros H1; case (prime_divisors _ H1 2); auto with zarith. + intros H1; case (prime_divisors _ H1 2); auto with zarith; intuition; discriminate. Qed. Lemma not_prime_1: ~ prime 1. Proof. - intros H1; absurd (1 < 1); auto with zarith. + intros H1; absurd (1 < 1). discriminate. inversion H1; auto. Qed. Lemma prime_2: prime 2. Proof. - apply prime_intro; auto with zarith. - intros n (H,H'); Z.le_elim H; auto with zarith. - - contradict H'; auto with zarith. - - subst n. constructor; auto with zarith. + apply prime_intro. + - red; auto. + - intros n (H,H'); Z.le_elim H; auto with zarith. + + contradict H'; auto with zarith. + now apply Zle_not_lt, (Zlt_le_succ 1). + + subst n. constructor; auto with zarith. Qed. Theorem prime_3: prime 3. Proof. apply prime_intro; auto with zarith. - intros n (H,H'); Z.le_elim H; auto with zarith. - - replace n with 2 by omega. - constructor; auto with zarith. - intros x (q,Hq) (q',Hq'). - exists (q' - q). ring_simplify. now rewrite <- Hq, <- Hq'. - - replace n with 1 by trivial. - constructor; auto with zarith. + - red; auto. + - intros n (H,H'); Z.le_elim H; auto with zarith. + + replace n with 2. + * constructor; auto with zarith. + intros x (q,Hq) (q',Hq'). + exists (q' - q). ring_simplify. now rewrite <- Hq, <- Hq'. + * apply Z.le_antisymm. + ++ now apply (Zlt_le_succ 1). + ++ now apply (Z.lt_le_pred _ 3). + + replace n with 1 by trivial. + constructor; auto with zarith. Qed. Theorem prime_ge_2 p : prime p -> 2 <= p. Proof. - intros (Hp,_); auto with zarith. + now intros (Hp,_); apply (Zlt_le_succ 1). Qed. Definition prime' p := 1<p /\ (forall n, 1<n<p -> ~ (n|p)). @@ -675,17 +736,24 @@ Proof. assert (Hx := Z.abs_nonneg x). set (y:=Z.abs x) in *; clearbody y; clear x; rename y into x. destruct (Z_0_1_more x Hx) as [->|[->|Hx']]. - + exfalso. apply Z.divide_0_l in Hxn. omega. + + exfalso. apply Z.divide_0_l in Hxn. + absurd (1 <= n). + * rewrite Hxn; red; auto. + * intuition. + now exists 1. + elim (H x); auto. split; trivial. - apply Z.le_lt_trans with n; auto with zarith. + apply Z.le_lt_trans with n; try intuition. apply Z.divide_pos_le; auto with zarith. + apply Z.lt_le_trans with (2 := H0); red; auto. - (* prime' -> prime *) constructor; trivial. intros n Hn Hnp. - case (Zis_gcd_unique n p n 1); auto with zarith. - constructor; auto with zarith. - apply H; auto with zarith. + case (Zis_gcd_unique n p n 1). + + constructor; auto with zarith. + + apply H; auto with zarith. + now intuition; apply Z.lt_le_incl. + + intros H1; intuition; subst n; discriminate. + + intros H1; intuition; subst n; discriminate. Qed. Theorem square_not_prime: forall a, ~ prime (a * a). @@ -698,7 +766,9 @@ Proof. assert (H' : 1 < a) by now apply (Z.square_lt_simpl_nonneg 1). apply (Ha' a). + split; trivial. - rewrite <- (Z.mul_1_l a) at 1. apply Z.mul_lt_mono_pos_r; omega. + rewrite <- (Z.mul_1_l a) at 1. + apply Z.mul_lt_mono_pos_r; auto. + apply Z.lt_trans with (2 := H'); red; auto. + exists a; auto. Qed. @@ -709,10 +779,11 @@ Proof. assert (Hp: 0 < p); try apply Z.lt_le_trans with 2; try apply prime_ge_2; auto with zarith. assert (Hq: 0 < q); try apply Z.lt_le_trans with 2; try apply prime_ge_2; auto with zarith. case prime_divisors with (2 := H2); auto. - intros H4; contradict Hp; subst; auto with zarith. - intros [H4| [H4 | H4]]; subst; auto. - contradict H; auto; apply not_prime_1. - contradict Hp; auto with zarith. + - intros H4; contradict Hp; subst; discriminate. + - intros [H4| [H4 | H4]]; subst; auto. + + contradict H; auto; apply not_prime_1. + + contradict Hp; apply Zle_not_lt, (Z.opp_le_mono _ 0). + now rewrite Z.opp_involutive; apply Z.lt_le_incl. Qed. (** we now prove that [Z.gcd] is indeed a gcd in @@ -748,6 +819,9 @@ Proof. apply Zgcd_is_gcd; auto. Z.le_elim H1. - generalize (Z.gcd_nonneg a b); auto with zarith. + intros H3 H4; contradict H3. + rewrite <- (Z.opp_involutive (Z.gcd a b)), <- H4. + now apply Zlt_not_le, Z.opp_lt_mono; rewrite Z.opp_involutive. - subst. now case (Z.gcd a b). Qed. @@ -801,7 +875,8 @@ Proof. case (Zis_gcd_unique a b (Z.gcd a b) 1); auto. apply Zgcd_is_gcd. intros H2; absurd (0 <= Z.gcd a b); auto with zarith. - generalize (Z.gcd_nonneg a b); auto with zarith. + - rewrite H2; red; auto. + - generalize (Z.gcd_nonneg a b); auto with zarith. Qed. Definition rel_prime_dec: forall a b, @@ -819,18 +894,25 @@ Definition prime_dec_aux: Proof. intros p m. case (Z_lt_dec 1 m); intros H1; - [ | left; intros; exfalso; omega ]. + [ | left; intros; exfalso; + contradict H1; apply Z.lt_trans with n; intuition]. pattern m; apply natlike_rec; auto with zarith. - left; intros; exfalso; omega. - intros x Hx IH; destruct IH as [F|E]. - destruct (rel_prime_dec x p) as [Y|N]. - left; intros n [HH1 HH2]. - rewrite Z.lt_succ_r in HH2. - Z.le_elim HH2; subst; auto with zarith. - - case (Z_lt_dec 1 x); intros HH1. - * right; exists x; split; auto with zarith. - * left; intros n [HHH1 HHH2]; contradict HHH1; auto with zarith. - - right; destruct E as (n,((H0,H2),H3)); exists n; auto with zarith. + - left; intros; exfalso. + absurd (1 < 0); try discriminate. + apply Z.lt_trans with n; intuition. + - intros x Hx IH; destruct IH as [F|E]. + + destruct (rel_prime_dec x p) as [Y|N]. + * left; intros n [HH1 HH2]. + rewrite Z.lt_succ_r in HH2. + Z.le_elim HH2; subst; auto with zarith. + * case (Z_lt_dec 1 x); intros HH1. + -- right; exists x; split; auto with zarith. + -- left; intros n [HHH1 HHH2]; contradict HHH1; auto with zarith. + apply Zle_not_lt; apply Z.le_trans with x. + ++ now apply Zlt_succ_le. + ++ now apply Znot_gt_le; contradict HH1; apply Z.gt_lt. + + right; destruct E as (n,((H0,H2),H3)); exists n; auto with zarith. + - apply Z.le_trans with (2 := Z.lt_le_incl _ _ H1); discriminate. Defined. Definition prime_dec: forall p, { prime p }+{ ~ prime p }. @@ -842,6 +924,7 @@ Proof. constructor; auto with zarith. * right; intros H3; inversion_clear H3 as [Hp1 Hp2]. case H2; intros n [Hn1 Hn2]; case Hn2; auto with zarith. + now apply Hp2; intuition; apply Z.lt_le_incl. + right; intros H3; inversion_clear H3 as [Hp1 Hp2]; case H1; auto. Defined. @@ -856,10 +939,15 @@ Proof. subst n; constructor; auto with zarith. - case H1; intros n (Hn1,Hn2). destruct (Z_0_1_more _ (Z.gcd_nonneg n p)) as [H|[H|H]]. - + exfalso. apply Z.gcd_eq_0_l in H. omega. + + exfalso. apply Z.gcd_eq_0_l in H. + absurd (1 < n). + * rewrite H; discriminate. + * now intuition. + elim Hn2. red. rewrite <- H. apply Zgcd_is_gcd. + exists (Z.gcd n p); split; [ split; auto | apply Z.gcd_divide_r ]. apply Z.le_lt_trans with n; auto with zarith. - apply Z.divide_pos_le; auto with zarith. - apply Z.gcd_divide_l. + * apply Z.divide_pos_le; auto with zarith. + -- apply Z.lt_trans with 1; intuition. + -- apply Z.gcd_divide_l. + * intuition. Qed. diff --git a/theories/ZArith/Zpow_facts.v b/theories/ZArith/Zpow_facts.v index 66e246616f..e65eb7cdc7 100644 --- a/theories/ZArith/Zpow_facts.v +++ b/theories/ZArith/Zpow_facts.v @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -Require Import ZArith_base ZArithRing Zcomplements Zdiv Znumtheory. +Require Import ZArith_base ZArithRing Omega Zcomplements Zdiv Znumtheory. Require Export Zpower. Local Open Scope Z_scope. diff --git a/theories/ZArith/Zpower.v b/theories/ZArith/Zpower.v index f80d075b67..da8a9402dd 100644 --- a/theories/ZArith/Zpower.v +++ b/theories/ZArith/Zpower.v @@ -8,7 +8,7 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -Require Import Wf_nat ZArith_base Omega Zcomplements. +Require Import Wf_nat ZArith_base Zcomplements. Require Export Zpow_def. Local Open Scope Z_scope. @@ -220,7 +220,8 @@ Section Powers_of_2. Lemma two_p_pred x : 0 <= x -> two_p (Z.pred x) < two_p x. Proof. - rewrite !two_p_equiv. intros. apply Z.pow_lt_mono_r; auto with zarith. + rewrite !two_p_equiv. intros. apply Z.pow_lt_mono_r; auto using Z.lt_pred_l. + reflexivity. Qed. End Powers_of_2. @@ -265,17 +266,45 @@ Section power_div_with_rest. let '(q,r,d) := Pos.iter Zdiv_rest_aux (x, 0, 1) p in x = q * d + r /\ 0 <= r < d. Proof. - apply Pos.iter_invariant; [|omega]. - intros ((q,r),d) (H,H'). unfold Zdiv_rest_aux. - destruct q as [ |[q|q| ]|[q|q| ]]; try omega. + apply Pos.iter_invariant; [|rewrite Z.mul_1_r, Z.add_0_r; repeat split; auto; discriminate]. + intros ((q,r),d) (H,(H1',H2')). unfold Zdiv_rest_aux. + assert (H1 : 0 < d) by now apply Z.le_lt_trans with (1 := H1'). + assert (H2 : 0 <= d + r) by now apply Z.add_nonneg_nonneg; auto; apply Z.lt_le_incl. + assert (H3 : d + r < 2 * d) + by now rewrite <-Z.add_diag; apply Zplus_lt_compat_l. + assert (H4 : r < 2 * d) by now + apply Z.lt_le_trans with (1 * d); [ + rewrite Z.mul_1_l; auto | + apply Zmult_le_compat_r; try discriminate; + now apply Z.lt_le_incl]. + destruct q as [ |[q|q| ]|[q|q| ]]. + - repeat split; auto. - rewrite Pos2Z.inj_xI, Z.mul_add_distr_r in H. - rewrite Z.mul_shuffle3, Z.mul_assoc. omega. + rewrite Z.mul_shuffle3, Z.mul_assoc. + rewrite Z.mul_1_l in H; rewrite Z.add_assoc. + repeat split; auto with zarith. - rewrite Pos2Z.inj_xO in H. - rewrite Z.mul_shuffle3, Z.mul_assoc. omega. + rewrite Z.mul_shuffle3, Z.mul_assoc. + repeat split; auto. + - rewrite Z.mul_1_l in H; repeat split; auto. - rewrite Pos2Z.neg_xI, Z.mul_sub_distr_r in H. - rewrite Z.mul_sub_distr_r, Z.mul_shuffle3, Z.mul_assoc. omega. + rewrite Z.mul_sub_distr_r, Z.mul_shuffle3, Z.mul_assoc. + repeat split; auto. + rewrite !Z.mul_1_l, H, Z.add_assoc. + apply f_equal2 with (f := Z.add); auto. + rewrite <- Z.sub_sub_distr, <- !Z.add_diag, Z.add_simpl_r. + now rewrite Z.mul_1_l. - rewrite Pos2Z.neg_xO in H. - rewrite Z.mul_shuffle3, Z.mul_assoc. omega. + rewrite Z.mul_shuffle3, Z.mul_assoc. + repeat split; auto. + - repeat split; auto. + rewrite H, (Z.mul_opp_l 1), Z.mul_1_l, Z.add_assoc. + apply f_equal2 with (f := Z.add); auto. + rewrite Z.add_comm, <- Z.add_diag. + rewrite Z.mul_add_distr_l. + replace (-1 * d) with (-d). + + now rewrite Z.add_assoc, Z.add_opp_diag_r . + + now rewrite (Z.mul_opp_l 1), <-(Z.mul_opp_l 1). Qed. (** Old-style rich specification by proof of existence *) diff --git a/tools/CoqMakefile.in b/tools/CoqMakefile.in index d37d2bea94..08253e5a8f 100644 --- a/tools/CoqMakefile.in +++ b/tools/CoqMakefile.in @@ -266,7 +266,7 @@ CMIFILES = \ $(CMOFILES:.cmo=.cmi) \ $(MLIFILES:.mli=.cmi) # the /if/ is because old _CoqProject did not list a .ml(pack|lib) but just -# a .ml4 file +# a .mlg file CMXSFILES = \ $(MLPACKFILES:.mlpack=.cmxs) \ $(CMXAFILES:.cmxa=.cmxs) \ diff --git a/tools/coq_dune.ml b/tools/coq_dune.ml index adb416e3ce..ab180769b6 100644 --- a/tools/coq_dune.ml +++ b/tools/coq_dune.ml @@ -127,7 +127,6 @@ module Options = struct let all_opts = [ { enabled = false; cmd = "-debug"; } ; { enabled = false; cmd = "-native_compiler"; } - ; { enabled = true; cmd = "-allow-sprop"; } ; { enabled = true; cmd = "-w +default"; } ] diff --git a/toplevel/coqargs.ml b/toplevel/coqargs.ml index 113b1fb5d7..1529959cc6 100644 --- a/toplevel/coqargs.ml +++ b/toplevel/coqargs.ml @@ -113,7 +113,7 @@ let default_logic_config = { impredicative_set = Declarations.PredicativeSet; indices_matter = false; toplevel_name = Stm.TopLogical default_toplevel; - allow_sprop = false; + allow_sprop = true; cumulative_sprop = false; } @@ -178,7 +178,8 @@ let add_compat_require opts v = match v with | Flags.V8_8 -> add_vo_require opts "Coq.Compat.Coq88" None (Some false) | Flags.V8_9 -> add_vo_require opts "Coq.Compat.Coq89" None (Some false) - | Flags.Current -> add_vo_require opts "Coq.Compat.Coq810" None (Some false) + | Flags.V8_10 -> add_vo_require opts "Coq.Compat.Coq810" None (Some false) + | Flags.Current -> add_vo_require opts "Coq.Compat.Coq811" None (Some false) let add_load_vernacular opts verb s = { opts with pre = { opts.pre with load_vernacular_list = (CUnix.make_suffix s ".v",verb) :: opts.pre.load_vernacular_list }} @@ -497,7 +498,7 @@ let parse_args ~help ~init arglist : t * string list = { oval with config = { oval.config with stm_flags = { oval.config.stm_flags with Stm.AsyncOpts.async_proofs_never_reopen_branch = true }}} - |"-test-mode" -> Vernacentries.test_mode := true; oval + |"-test-mode" -> Vernacinterp.test_mode := true; oval |"-beautify" -> Flags.beautify := true; oval |"-bt" -> Backtrace.record_backtrace true; oval |"-color" -> set_color oval (next ()) diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 07466d641e..1f319d2bfd 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -405,7 +405,17 @@ let rec vernac_loop ~state = | Some (VernacShowGoal {gid; sid}) -> let proof = Stm.get_proof ~doc:state.doc (Stateid.of_int sid) in - Feedback.msg_notice (Printer.pr_goal_emacs ~proof gid sid); + let goal = Printer.pr_goal_emacs ~proof gid sid in + let evars = + match proof with + | None -> mt() + | Some p -> + let gl = (Evar.unsafe_of_int gid) in + let { Proof.sigma } = Proof.data p in + try Printer.print_dependent_evars (Some gl) sigma [ gl ] + with Not_found -> mt() + in + Feedback.msg_notice (v 0 (goal ++ evars)); vernac_loop ~state | None -> diff --git a/toplevel/usage.ml b/toplevel/usage.ml index 8555d78156..b17ca71f4c 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -79,6 +79,7 @@ let print_usage_common co command = \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\ diff --git a/user-contrib/Ltac2/Bool.v b/user-contrib/Ltac2/Bool.v index d808436e13..d808436e13 100755..100644 --- a/user-contrib/Ltac2/Bool.v +++ b/user-contrib/Ltac2/Bool.v diff --git a/user-contrib/Ltac2/Init.v b/user-contrib/Ltac2/Init.v index 88454ff2fb..88454ff2fb 100755..100644 --- a/user-contrib/Ltac2/Init.v +++ b/user-contrib/Ltac2/Init.v diff --git a/user-contrib/Ltac2/g_ltac2.mlg b/user-contrib/Ltac2/g_ltac2.mlg index adc1606016..8a878bb0d0 100644 --- a/user-contrib/Ltac2/g_ltac2.mlg +++ b/user-contrib/Ltac2/g_ltac2.mlg @@ -109,6 +109,7 @@ let tac2def_mut = Entry.create "tactic:tac2def_mut" let tac2mode = Entry.create "vernac:ltac2_command" let ltac1_expr = Pltac.tactic_expr +let tac2expr_in_env = Tac2entries.Pltac.tac2expr_in_env let inj_wit wit loc x = CAst.make ~loc @@ CTacExt (wit, x) let inj_open_constr loc c = inj_wit Tac2quote.wit_open_constr loc c @@ -129,7 +130,7 @@ let pattern_of_qualid qid = GRAMMAR EXTEND Gram GLOBAL: tac2expr tac2type tac2def_val tac2def_typ tac2def_ext tac2def_syn - tac2def_mut; + tac2def_mut tac2expr_in_env; tac2pat: [ "1" LEFTA [ qid = Prim.qualid; pl = LIST1 tac2pat LEVEL "0" -> { @@ -248,6 +249,18 @@ GRAMMAR EXTEND Gram | e = ltac1_expr -> { [], e } ] ] ; + tac2expr_in_env : + [ [ test_ltac1_env; ids = LIST0 locident; "|-"; e = tac2expr -> + { let check { CAst.v = id; CAst.loc = loc } = + if Tac2env.is_constructor (Libnames.qualid_of_ident ?loc id) then + CErrors.user_err ?loc Pp.(str "Invalid bound Ltac2 identifier " ++ Id.print id) + in + let () = List.iter check ids in + (ids, e) + } + | tac = tac2expr -> { [], tac } + ] ] + ; let_clause: [ [ binder = let_binder; ":="; te = tac2expr -> { let (pat, fn) = binder in @@ -860,7 +873,7 @@ let rules = [ Stop ++ Aentry test_ampersand_ident ++ Atoken (PKEYWORD "&") ++ Aentry Prim.ident, begin fun id _ _ loc -> let tac = Tac2quote.of_exact_hyp ~loc (CAst.make ~loc id) in - let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in + let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) ([], tac) in CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) end ); @@ -869,7 +882,7 @@ let rules = [ Stop ++ Atoken (PIDENT (Some "ltac2")) ++ Atoken (PKEYWORD ":") ++ Atoken (PKEYWORD "(") ++ Aentry tac2expr ++ Atoken (PKEYWORD ")"), begin fun _ tac _ _ _ loc -> - let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) tac in + let arg = Genarg.in_gen (Genarg.rawwit Tac2env.wit_ltac2) ([], tac) in CAst.make ~loc (CHole (None, Namegen.IntroAnonymous, Some arg)) end ) diff --git a/user-contrib/Ltac2/tac2core.ml b/user-contrib/Ltac2/tac2core.ml index f6775ddd1f..34870345a5 100644 --- a/user-contrib/Ltac2/tac2core.ml +++ b/user-contrib/Ltac2/tac2core.ml @@ -1220,7 +1220,9 @@ let () = (** Ltac2 in terms *) let () = - let interp ist poly env sigma concl tac = + let interp ist poly env sigma concl (ids, tac) = + (* Syntax prevents bound variables in constr quotations *) + let () = assert (List.is_empty ids) in let ist = Tac2interp.get_env ist in let tac = Proofview.tclIGNORE (Tac2interp.interp ist tac) in let name, poly = Id.of_string "ltac2", poly in @@ -1248,25 +1250,73 @@ let () = (** Ltac2 in Ltac1 *) let () = - let e = Tac2entries.Pltac.tac2expr in + let e = Tac2entries.Pltac.tac2expr_in_env in let inject (loc, v) = Ltac_plugin.Tacexpr.TacGeneric (in_gen (rawwit wit_ltac2) v) in Ltac_plugin.Tacentries.create_ltac_quotation "ltac2" inject (e, None) +(* Ltac1 runtime representation of Ltac2 closure quotations *) +let typ_ltac2 : (Id.t list * glb_tacexpr) Geninterp.Val.typ = + Geninterp.Val.create "ltac2:ltac2_eval" + +let ltac2_eval = + let open Ltac_plugin in + let ml_name = { + Tacexpr.mltac_plugin = "ltac2"; + mltac_tactic = "ltac2_eval"; + } in + let eval_fun args ist = match args with + | [] -> assert false + | tac :: args -> + (* By convention the first argument is the tactic being applied, the rest + being the arguments it should be fed with *) + let Geninterp.Val.Dyn (tag, tac) = tac in + let (ids, tac) : Id.t list * glb_tacexpr = match Geninterp.Val.eq tag typ_ltac2 with + | None -> assert false + | Some Refl -> tac + in + let fold accu id = match Id.Map.find id ist.Geninterp.lfun with + | v -> Id.Map.add id (Tac2ffi.of_ext val_ltac1 v) accu + | exception Not_found -> assert false + in + let env_ist = List.fold_left fold Id.Map.empty ids in + Proofview.tclIGNORE (Tac2interp.interp { env_ist } tac) + in + let () = Tacenv.register_ml_tactic ml_name [|eval_fun|] in + { Tacexpr.mltac_name = ml_name; mltac_index = 0 } + let () = let open Ltac_plugin in let open Tacinterp in - let idtac = Value.of_closure (default_ist ()) (Tacexpr.TacId []) in - let interp ist tac = -(* let ist = Tac2interp.get_env ist.Geninterp.lfun in *) + let interp ist (ids, tac as self) = match ids with + | [] -> + (* Evaluate the Ltac2 quotation eagerly *) + let idtac = Value.of_closure { ist with lfun = Id.Map.empty } (Tacexpr.TacId []) in let ist = { env_ist = Id.Map.empty } in Tac2interp.interp ist tac >>= fun _ -> Ftactic.return idtac + | _ :: _ -> + (* Return a closure [@f := {blob} |- fun ids => ltac2_eval(f, ids) ] *) + (* This name cannot clash with Ltac2 variables which are all lowercase *) + let self_id = Id.of_string "F" in + let nas = List.map (fun id -> Name id) ids in + let mk_arg id = Tacexpr.Reference (Locus.ArgVar (CAst.make id)) in + let args = List.map mk_arg ids in + let clos = Tacexpr.TacFun (nas, Tacexpr.TacML (CAst.make (ltac2_eval, mk_arg self_id :: args))) in + let self = Geninterp.Val.inject (Geninterp.Val.Base typ_ltac2) self in + let ist = { ist with lfun = Id.Map.singleton self_id self } in + Ftactic.return (Value.of_closure ist clos) in Geninterp.register_interp0 wit_ltac2 interp let () = let pr_raw _ = Genprint.PrinterBasic (fun _env _sigma -> mt ()) in - let pr_glb e = Genprint.PrinterBasic (fun _env _sigma -> Tac2print.pr_glbexpr e) in + let pr_glb (ids, e) = + let ids = + if List.is_empty ids then mt () + else pr_sequence Id.print ids ++ str " |- " + in + Genprint.PrinterBasic Pp.(fun _env _sigma -> ids ++ Tac2print.pr_glbexpr e) + in let pr_top _ = Genprint.TopPrinterBasic mt in Genprint.register_print0 wit_ltac2 pr_raw pr_glb pr_top diff --git a/user-contrib/Ltac2/tac2entries.ml b/user-contrib/Ltac2/tac2entries.ml index 17004bb012..6b7b75f0d4 100644 --- a/user-contrib/Ltac2/tac2entries.ml +++ b/user-contrib/Ltac2/tac2entries.ml @@ -25,6 +25,7 @@ open Tac2intern module Pltac = struct let tac2expr = Pcoq.Entry.create "tactic:tac2expr" +let tac2expr_in_env = Pcoq.Entry.create "tactic:tac2expr_in_env" let q_ident = Pcoq.Entry.create "tactic:q_ident" let q_bindings = Pcoq.Entry.create "tactic:q_bindings" diff --git a/user-contrib/Ltac2/tac2entries.mli b/user-contrib/Ltac2/tac2entries.mli index a913a62e45..d96a6a95c5 100644 --- a/user-contrib/Ltac2/tac2entries.mli +++ b/user-contrib/Ltac2/tac2entries.mli @@ -64,6 +64,7 @@ val backtrace : backtrace Exninfo.t module Pltac : sig val tac2expr : raw_tacexpr Pcoq.Entry.t +val tac2expr_in_env : (Id.t CAst.t list * raw_tacexpr) Pcoq.Entry.t (** Quoted entries. To be used for complex notations. *) diff --git a/user-contrib/Ltac2/tac2env.mli b/user-contrib/Ltac2/tac2env.mli index 2dbb16e184..2f4a49a0f5 100644 --- a/user-contrib/Ltac2/tac2env.mli +++ b/user-contrib/Ltac2/tac2env.mli @@ -140,7 +140,7 @@ val ltac1_prefix : ModPath.t (** {5 Generic arguments} *) -val wit_ltac2 : (raw_tacexpr, glb_tacexpr, Util.Empty.t) genarg_type +val wit_ltac2 : (Id.t CAst.t list * raw_tacexpr, Id.t list * glb_tacexpr, Util.Empty.t) genarg_type val wit_ltac2_quotation : (Id.t Loc.located, Id.t, Util.Empty.t) genarg_type (** {5 Helper functions} *) diff --git a/user-contrib/Ltac2/tac2intern.ml b/user-contrib/Ltac2/tac2intern.ml index 0961e9c9c9..5b3aa799a1 100644 --- a/user-contrib/Ltac2/tac2intern.ml +++ b/user-contrib/Ltac2/tac2intern.ml @@ -22,10 +22,12 @@ open Tac2expr (** Hardwired types and constants *) let coq_type n = KerName.make Tac2env.coq_prefix (Label.make n) +let ltac1_type n = KerName.make Tac2env.ltac1_prefix (Label.make n) let t_int = coq_type "int" let t_string = coq_type "string" let t_constr = coq_type "constr" +let t_ltac1 = ltac1_type "t" (** Union find *) @@ -1505,7 +1507,8 @@ let rec subst_rawexpr subst ({loc;v=tr} as t) = match tr with let () = let open Genintern in - let intern ist tac = + let intern ist (ids, tac) = + let ids = List.map (fun { CAst.v = id } -> id) ids in let env = match Genintern.Store.get ist.extra ltac2_env with | None -> (* Only happens when Ltac2 is called from a constr or ltac1 quotation *) @@ -1514,13 +1517,17 @@ let () = else { env with env_str = false } | Some env -> env in + let fold env id = + push_name (Name id) (monomorphic (GTypRef (Other t_ltac1, []))) env + in + let env = List.fold_left fold env ids in let loc = tac.loc in let (tac, t) = intern_rec env tac in let () = check_elt_unit loc env t in - (ist, tac) + (ist, (ids, tac)) in Genintern.register_intern0 wit_ltac2 intern -let () = Genintern.register_subst0 wit_ltac2 subst_expr +let () = Genintern.register_subst0 wit_ltac2 (fun s (ids, e) -> ids, subst_expr s e) let () = let open Genintern in diff --git a/vernac/comAssumption.ml b/vernac/comAssumption.ml index e3f90ab98c..a0b0dcf4c8 100644 --- a/vernac/comAssumption.ml +++ b/vernac/comAssumption.ml @@ -11,7 +11,6 @@ open CErrors open Util open Vars -open Declare open Names open Context open Constrexpr_ops @@ -41,27 +40,24 @@ let should_axiom_into_instance = let open Decls in function true | Definitional | Logical | Conjectural -> !axiom_into_instance -let declare_assumption is_coe ~poly ~scope ~kind typ univs pl imps impl nl {CAst.v=name} = -let open DeclareDef in -match scope with -| Discharge -> - let univs = match univs with - | Monomorphic_entry univs -> univs - | Polymorphic_entry (_, univs) -> Univ.ContextSet.of_context univs - in +let declare_variable is_coe ~kind typ imps impl {CAst.v=name} = let kind = Decls.IsAssumption kind in - let decl = SectionLocalAssum {typ; univs; poly; impl} in - let () = declare_variable ~name ~kind decl in - let () = assumption_message name in + let decl = Declare.SectionLocalAssum {typ; impl} in + let () = Declare.declare_variable ~name ~kind decl in + let () = Declare.assumption_message name in let r = GlobRef.VarRef name in let () = maybe_declare_manual_implicits true r imps in let env = Global.env () in let sigma = Evd.from_env env in let () = Classes.declare_instance env sigma None true r in let () = if is_coe then Class.try_add_new_coercion r ~local:true ~poly:false in - (r,Univ.Instance.empty) + () -| Global local -> +let instance_of_univ_entry = function + | Polymorphic_entry (_, univs) -> Univ.UContext.instance univs + | Monomorphic_entry _ -> Univ.Instance.empty + +let declare_axiom is_coe ~poly ~local ~kind typ (univs, pl) imps nl {CAst.v=name} = let do_instance = should_axiom_into_instance kind in let inl = let open Declaremods in match nl with | NoInline -> None @@ -70,42 +66,65 @@ match scope with in let kind = Decls.IsAssumption kind in let decl = Declare.ParameterEntry (None,(typ,univs),inl) in - let kn = declare_constant ~name ~local ~kind decl in + let kn = Declare.declare_constant ~name ~local ~kind decl in let gr = GlobRef.ConstRef kn in let () = maybe_declare_manual_implicits false gr imps in let () = Declare.declare_univ_binders gr pl in - let () = assumption_message name in + let () = Declare.assumption_message name in let env = Global.env () in let sigma = Evd.from_env env in let () = if do_instance then Classes.declare_instance env sigma None false gr in - let local = match local with ImportNeedQualified -> true | ImportDefaultBehavior -> false in - let () = if is_coe then Class.try_add_new_coercion gr ~local ~poly in - let inst = match univs with - | Polymorphic_entry (_, univs) -> Univ.UContext.instance univs - | Monomorphic_entry _ -> Univ.Instance.empty + let local = match local with + | Declare.ImportNeedQualified -> true + | Declare.ImportDefaultBehavior -> false in + let () = if is_coe then Class.try_add_new_coercion gr ~local ~poly in + let inst = instance_of_univ_entry univs in (gr,inst) let interp_assumption ~program_mode sigma env impls c = let sigma, (ty, impls) = interp_type_evars_impls ~program_mode env sigma ~impls c in sigma, (ty, impls) -(* When monomorphic the universe constraints are declared with the first declaration only. *) -let next_uctx = - let empty_uctx = Monomorphic_entry Univ.ContextSet.empty in +(* When monomorphic the universe constraints and universe names are + declared with the first declaration only. *) +let next_univs = + let empty_univs = Monomorphic_entry Univ.ContextSet.empty, UnivNames.empty_binders in function - | Polymorphic_entry _ as uctx -> uctx - | Monomorphic_entry _ -> empty_uctx + | Polymorphic_entry _, _ as univs -> univs + | Monomorphic_entry _, _ -> empty_univs -let declare_assumptions idl is_coe ~scope ~poly ~kind typ uctx pl imps nl = - let refs, _ = - List.fold_left (fun (refs,uctx) id -> - let ref = declare_assumption is_coe ~scope ~poly ~kind typ uctx pl imps Glob_term.Explicit nl id in - ref::refs, next_uctx uctx) - ([],uctx) idl - in - List.rev refs +let context_set_of_entry = function + | Polymorphic_entry (_,uctx) -> Univ.ContextSet.of_context uctx + | Monomorphic_entry uctx -> uctx +let declare_assumptions ~poly ~scope ~kind univs nl l = + let open DeclareDef in + let () = match scope with + | Discharge -> + (* declare universes separately for variables *) + Declare.declare_universe_context ~poly (context_set_of_entry (fst univs)) + | Global _ -> () + in + let _, _ = List.fold_left (fun (subst,univs) ((is_coe,idl),typ,imps) -> + (* NB: here univs are ignored when scope=Discharge *) + let typ = replace_vars subst typ in + let univs,subst' = + List.fold_left_map (fun univs id -> + let refu = match scope with + | Discharge -> + declare_variable is_coe ~kind typ imps Glob_term.Explicit id; + GlobRef.VarRef id.CAst.v, Univ.Instance.empty + | Global local -> + declare_axiom is_coe ~local ~poly ~kind typ univs imps nl id + in + next_univs univs, (id.CAst.v, Constr.mkRef refu)) + univs idl + in + subst'@subst, next_univs univs) + ([], univs) l + in + () let maybe_error_many_udecls = function | ({CAst.loc;v=id}, Some _) -> @@ -175,139 +194,114 @@ let do_assumptions ~program_mode ~poly ~scope ~kind nl l = IMO, thus I think we should adapt `prepare_parameter` to handle this case too. *) let sigma = Evd.restrict_universe_context sigma uvars in - let uctx = Evd.check_univ_decl ~poly sigma udecl in + let univs = Evd.check_univ_decl ~poly sigma udecl in let ubinders = Evd.universe_binders sigma in - let _, _ = List.fold_left (fun (subst,uctx) ((is_coe,idl),typ,imps) -> - let typ = replace_vars subst typ in - let refs = declare_assumptions idl is_coe ~poly ~scope ~kind typ uctx ubinders imps nl in - let subst' = List.map2 - (fun {CAst.v=id} (c,u) -> (id, Constr.mkRef (c,u))) - idl refs - in - subst'@subst, next_uctx uctx) - ([], uctx) l + declare_assumptions ~poly ~scope ~kind (univs,ubinders) nl l + +let context_subst subst (name,b,t,impl) = + name, Option.map (Vars.substl subst) b, Vars.substl subst t, impl + +let context_insection sigma ~poly ctx = + let uctx = Evd.universe_context_set sigma in + let () = Declare.declare_universe_context ~poly uctx in + let fn subst (name,_,_,_ as d) = + let d = context_subst subst d in + let () = match d with + | name, None, t, impl -> + let kind = Decls.Context in + declare_variable false ~kind t [] impl (CAst.make name) + | name, Some b, t, impl -> + (* We need to get poly right for check_same_poly *) + let univs = if poly then Polymorphic_entry ([| |], Univ.UContext.empty) + else Monomorphic_entry Univ.ContextSet.empty + in + let entry = Declare.definition_entry ~univs ~types:t b in + let _ : GlobRef.t = DeclareDef.declare_definition ~name ~scope:DeclareDef.Discharge + ~kind:Decls.(IsDefinition Definition) UnivNames.empty_binders entry [] + in + () + in + Constr.mkVar name :: subst in + let _ : Vars.substl = List.fold_left fn [] ctx in () -let do_primitive id prim typopt = - if Lib.sections_are_opened () then - CErrors.user_err Pp.(str "Declaring a primitive is not allowed in sections."); - if Dumpglob.dump () then Dumpglob.dump_definition id false "ax"; - let env = Global.env () in - let evd = Evd.from_env env in - let evd, typopt = Option.fold_left_map - (interp_type_evars_impls ~impls:empty_internalization_env env) - evd typopt - in - let evd = Evd.minimize_universes evd in - let uvars, impls, typopt = match typopt with - | None -> Univ.LSet.empty, [], None - | Some (ty,impls) -> - EConstr.universes_of_constr evd ty, impls, Some (EConstr.to_constr evd ty) +let context_nosection sigma ~poly ctx = + let univs = + match ctx, poly with + | [_], _ | _, true -> Evd.univ_entry ~poly sigma + | _, false -> + (* Multiple monomorphic axioms: declare universes separately to + avoid redeclaring them. *) + let uctx = Evd.universe_context_set sigma in + let () = Declare.declare_universe_context ~poly uctx in + Monomorphic_entry Univ.ContextSet.empty in - let evd = Evd.restrict_universe_context evd uvars in - let uctx = UState.check_mono_univ_decl (Evd.evar_universe_context evd) UState.default_univ_decl in - let entry = { prim_entry_type = typopt; - prim_entry_univs = uctx; - prim_entry_content = prim; - } + let fn subst d = + let (name,b,t,_impl) = context_subst subst d in + let kind = Decls.(IsAssumption Logical) in + let decl = match b with + | None -> + Declare.ParameterEntry (None,(t,univs),None) + | Some b -> + let entry = Declare.definition_entry ~univs ~types:t b in + Declare.DefinitionEntry entry + in + let local = if Lib.is_modtype () then Declare.ImportDefaultBehavior + else Declare.ImportNeedQualified + in + let cst = Declare.declare_constant ~name ~kind ~local decl in + let () = Declare.assumption_message name in + let env = Global.env () in + (* why local when is_modtype? *) + let () = if Lib.is_modtype() || Option.is_empty b then + Classes.declare_instance env sigma None (Lib.is_modtype()) (GlobRef.ConstRef cst) + in + Constr.mkConstU (cst,instance_of_univ_entry univs) :: subst in - let _kn : Names.Constant.t = - declare_constant ~name:id.CAst.v ~kind:Decls.IsPrimitive (PrimitiveEntry entry) in - Flags.if_verbose Feedback.msg_info Pp.(Id.print id.CAst.v ++ str " is declared") - -let named_of_rel_context l = - let open EConstr.Vars in - let open RelDecl in - let acc, ctx = - List.fold_right - (fun decl (subst, ctx) -> - let id = match get_name decl with Anonymous -> invalid_arg "named_of_rel_context" | Name id -> id in - let d = match decl with - | LocalAssum (_,t) -> id, None, substl subst t - | LocalDef (_,b,t) -> id, Some (substl subst b), substl subst t in - (EConstr.mkVar id :: subst, d :: ctx)) - l ([], []) - in ctx + let _ : Vars.substl = List.fold_left fn [] ctx in + () let context ~poly l = let env = Global.env() in let sigma = Evd.from_env env in - let sigma, (_, ((env', fullctx), impls)) = interp_context_evars ~program_mode:false env sigma l in + let sigma, (_, ((_env, ctx), impls)) = interp_context_evars ~program_mode:false env sigma l in (* Note, we must use the normalized evar from now on! *) let sigma = Evd.minimize_universes sigma in let ce t = Pretyping.check_evars env (Evd.from_env env) sigma t in - let () = List.iter (fun decl -> Context.Rel.Declaration.iter_constr ce decl) fullctx in - let ctx = - try named_of_rel_context fullctx - with e when CErrors.noncritical e -> - user_err Pp.(str "Anonymous variables not allowed in contexts.") - in - let univs = - match ctx with - | [] -> assert false - | [_] -> Evd.univ_entry ~poly sigma - | _::_::_ -> - if Lib.sections_are_opened () - then - (* More than 1 variable in a section: we can't associate - universes to any specific variable so we declare them - separately. *) - begin - let uctx = Evd.universe_context_set sigma in - Declare.declare_universe_context ~poly uctx; - if poly then Polymorphic_entry ([||], Univ.UContext.empty) - else Monomorphic_entry Univ.ContextSet.empty - end - else if poly then - (* Multiple polymorphic axioms: they are all polymorphic the same way. *) - Evd.univ_entry ~poly sigma - else - (* Multiple monomorphic axioms: declare universes separately - to avoid redeclaring them. *) - begin - let uctx = Evd.universe_context_set sigma in - Declare.declare_universe_context ~poly uctx; - Monomorphic_entry Univ.ContextSet.empty - end - in - let fn (name, b, t) = - let b, t = Option.map (EConstr.to_constr sigma) b, EConstr.to_constr sigma t in - if Lib.is_modtype () && not (Lib.sections_are_opened ()) then - (* Declare the universe context once *) - let kind = Decls.(IsAssumption Logical) in - let decl = match b with - | None -> - Declare.ParameterEntry (None,(t,univs),None) - | Some b -> - let entry = Declare.definition_entry ~univs ~types:t b in - Declare.DefinitionEntry entry + let () = List.iter (fun decl -> Context.Rel.Declaration.iter_constr ce decl) ctx in + (* reorder, evar-normalize and add implicit status *) + let ctx = List.rev_map (fun d -> + let {binder_name=name}, b, t = RelDecl.to_tuple d in + let name = match name with + | Anonymous -> user_err Pp.(str "Anonymous variables not allowed in contexts.") + | Name id -> id in - let cst = Declare.declare_constant ~name ~kind decl in - let env = Global.env () in - Classes.declare_instance env sigma (Some Hints.empty_hint_info) true (GlobRef.ConstRef cst); - () - else + let b = Option.map (EConstr.to_constr sigma) b in + let t = EConstr.to_constr sigma t in let test x = match x.CAst.v with | Some (Name id',_) -> Id.equal name id' | _ -> false in - let impl = if List.exists test impls then Glob_term.Implicit else Glob_term.Explicit in - let scope = - if Lib.sections_are_opened () then DeclareDef.Discharge else DeclareDef.Global ImportDefaultBehavior in - match b with - | None -> - let _, _ = - declare_assumption false ~scope ~poly ~kind:Decls.Context t - univs UnivNames.empty_binders [] impl - Declaremods.NoInline (CAst.make name) - in - () - | Some b -> - let entry = Declare.definition_entry ~univs ~types:t b in - let _gr = DeclareDef.declare_definition - ~name ~scope:DeclareDef.Discharge - ~kind:Decls.Definition UnivNames.empty_binders entry [] in - () + let impl = Glob_term.(if List.exists test impls then Implicit else Explicit) in + name,b,t,impl) + ctx in - List.iter fn (List.rev ctx) + if Global.sections_are_opened () + then context_insection sigma ~poly ctx + else context_nosection sigma ~poly ctx + +(* Deprecated *) +let declare_assumption is_coe ~poly ~scope ~kind typ univs pl imps impl nl name = +let open DeclareDef in +match scope with +| Discharge -> + let univs = match univs with + | Monomorphic_entry univs -> univs + | Polymorphic_entry (_, univs) -> Univ.ContextSet.of_context univs + in + let () = Declare.declare_universe_context ~poly univs in + declare_variable is_coe ~kind typ imps impl name; + GlobRef.VarRef name.CAst.v, Univ.Instance.empty +| Global local -> + declare_axiom is_coe ~poly ~local ~kind typ (univs, pl) imps nl name diff --git a/vernac/comAssumption.mli b/vernac/comAssumption.mli index 2715bd8305..ae9edefcac 100644 --- a/vernac/comAssumption.mli +++ b/vernac/comAssumption.mli @@ -23,29 +23,46 @@ val do_assumptions -> (ident_decl list * constr_expr) with_coercion list -> unit -(** returns [false] if the assumption is neither local to a section, - nor in a module type and meant to be instantiated. *) -val declare_assumption +val declare_variable : coercion_flag - -> poly:bool - -> scope:DeclareDef.locality -> kind:Decls.assumption_object_kind -> Constr.types - -> Entries.universes_entry - -> UnivNames.universe_binders -> Impargs.manual_implicits -> Glob_term.binding_kind + -> variable CAst.t + -> unit + +val declare_axiom + : coercion_flag + -> poly:bool + -> local:Declare.import_status + -> kind:Decls.assumption_object_kind + -> Constr.types + -> Entries.universes_entry * UnivNames.universe_binders + -> Impargs.manual_implicits -> Declaremods.inline -> variable CAst.t -> GlobRef.t * Univ.Instance.t (** Context command *) -(** returns [false] if, for lack of section, it declares an assumption - (unless in a module type). *) val context : poly:bool -> local_binder_expr list -> unit -val do_primitive : lident -> CPrimitives.op_or_type -> constr_expr option -> unit +(** Deprecated *) +val declare_assumption + : coercion_flag + -> poly:bool + -> scope:DeclareDef.locality + -> kind:Decls.assumption_object_kind + -> Constr.types + -> Entries.universes_entry + -> UnivNames.universe_binders + -> Impargs.manual_implicits + -> Glob_term.binding_kind + -> Declaremods.inline + -> variable CAst.t + -> GlobRef.t * Univ.Instance.t +[@@ocaml.deprecated "Use declare_variable or declare_axiom instead."] diff --git a/vernac/comDefinition.ml b/vernac/comDefinition.ml index 9745358ba2..5b3f15a08c 100644 --- a/vernac/comDefinition.ml +++ b/vernac/comDefinition.ml @@ -104,4 +104,5 @@ let do_definition ~program_mode ?hook ~name ~scope ~poly ~kind univdecl bl red_o let ce = check_definition ~program_mode def in let uctx = Evd.evar_universe_context evd in let hook_data = Option.map (fun hook -> hook, uctx, []) hook in + let kind = Decls.IsDefinition kind in ignore(DeclareDef.declare_definition ~name ~scope ~kind ?hook_data (Evd.universe_binders evd) ce imps) diff --git a/vernac/comPrimitive.ml b/vernac/comPrimitive.ml new file mode 100644 index 0000000000..b66ff876d3 --- /dev/null +++ b/vernac/comPrimitive.ml @@ -0,0 +1,37 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \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) *) +(************************************************************************) + +let do_primitive id prim typopt = + if Global.sections_are_opened () then + CErrors.user_err Pp.(str "Declaring a primitive is not allowed in sections."); + if Dumpglob.dump () then Dumpglob.dump_definition id false "ax"; + let env = Global.env () in + let evd = Evd.from_env env in + let evd, typopt = Option.fold_left_map + Constrintern.(interp_type_evars_impls ~impls:empty_internalization_env env) + evd typopt + in + let evd = Evd.minimize_universes evd in + let uvars, impls, typopt = match typopt with + | None -> Univ.LSet.empty, [], None + | Some (ty,impls) -> + EConstr.universes_of_constr evd ty, impls, Some (EConstr.to_constr evd ty) + in + let evd = Evd.restrict_universe_context evd uvars in + let uctx = UState.check_mono_univ_decl (Evd.evar_universe_context evd) UState.default_univ_decl in + let entry = Entries.{ + prim_entry_type = typopt; + prim_entry_univs = uctx; + prim_entry_content = prim; + } + in + let _kn : Names.Constant.t = + Declare.declare_constant ~name:id.CAst.v ~kind:Decls.IsPrimitive (Declare.PrimitiveEntry entry) in + Flags.if_verbose Feedback.msg_info Pp.(Names.Id.print id.CAst.v ++ str " is declared") diff --git a/vernac/comPrimitive.mli b/vernac/comPrimitive.mli new file mode 100644 index 0000000000..c0db1cc464 --- /dev/null +++ b/vernac/comPrimitive.mli @@ -0,0 +1,11 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +val do_primitive : Names.lident -> CPrimitives.op_or_type -> Constrexpr.constr_expr option -> unit diff --git a/vernac/declareDef.ml b/vernac/declareDef.ml index 1926faaf0e..67733c95a1 100644 --- a/vernac/declareDef.ml +++ b/vernac/declareDef.ml @@ -48,11 +48,11 @@ let declare_definition ~name ~scope ~kind ?hook_data udecl ce imps = let gr = match scope with | Discharge -> let () = - declare_variable ~name ~kind:Decls.(IsDefinition kind) (SectionLocalDef ce) + declare_variable ~name ~kind (SectionLocalDef ce) in Names.GlobRef.VarRef name | Global local -> - let kn = declare_constant ~name ~local ~kind:Decls.(IsDefinition kind) (DefinitionEntry ce) in + let kn = declare_constant ~name ~local ~kind (DefinitionEntry ce) in let gr = Names.GlobRef.ConstRef kn in let () = Declare.declare_univ_binders gr udecl in gr @@ -69,6 +69,7 @@ let declare_definition ~name ~scope ~kind ?hook_data udecl ce imps = let declare_fix ?(opaque = false) ?hook_data ~name ~scope ~kind udecl univs ((def,_),eff) t imps = let ce = definition_entry ~opaque ~types:t ~univs ~eff def in + let kind = Decls.IsDefinition kind in declare_definition ~name ~scope ~kind ?hook_data udecl ce imps let check_definition_evars ~allow_evars sigma = diff --git a/vernac/declareDef.mli b/vernac/declareDef.mli index 54a0c9a7e8..d6001f5970 100644 --- a/vernac/declareDef.mli +++ b/vernac/declareDef.mli @@ -42,7 +42,7 @@ end val declare_definition : name:Id.t -> scope:locality - -> kind:Decls.definition_object_kind + -> kind:Decls.logical_kind -> ?hook_data:(Hook.t * UState.t * (Id.t * Constr.t) list) -> UnivNames.universe_binders -> Evd.side_effects Declare.proof_entry diff --git a/vernac/declareObl.ml b/vernac/declareObl.ml index 8fd6bc7eab..2c56f707f1 100644 --- a/vernac/declareObl.ml +++ b/vernac/declareObl.ml @@ -351,7 +351,8 @@ let declare_definition prg = let ubinders = UState.universe_binders uctx in let hook_data = Option.map (fun hook -> hook, uctx, obls) prg.prg_hook in DeclareDef.declare_definition - ~name:prg.prg_name ~scope:prg.prg_scope ubinders ~kind:prg.prg_kind ce + ~name:prg.prg_name ~scope:prg.prg_scope ubinders + ~kind:Decls.(IsDefinition prg.prg_kind) ce prg.prg_implicits ?hook_data let rec lam_index n t acc = diff --git a/vernac/declaremods.ml b/vernac/declaremods.ml index 58a7dff5fd..c7b68d18c2 100644 --- a/vernac/declaremods.ml +++ b/vernac/declaremods.ml @@ -211,7 +211,7 @@ let compute_visibility exists i = (** Iterate some function [iter_objects] on all components of a module *) let do_module exists iter_objects i obj_dir obj_mp sobjs kobjs = - let prefix = Nametab.{ obj_dir ; obj_mp; obj_sec = DirPath.empty } in + let prefix = Nametab.{ obj_dir ; obj_mp; } in let dirinfo = Nametab.GlobDirRef.DirModule prefix in consistency_checks exists obj_dir dirinfo; Nametab.push_dir (compute_visibility exists i) obj_dir dirinfo; @@ -266,14 +266,14 @@ and load_objects i prefix objs = and load_include i ((sp,kn), aobjs) = let obj_dir = Libnames.dirpath sp in let obj_mp = KerName.modpath kn in - let prefix = Nametab.{ obj_dir; obj_mp; obj_sec = DirPath.empty } in + let prefix = Nametab.{ obj_dir; obj_mp; } in let o = expand_aobjs aobjs in load_objects i prefix o and load_keep i ((sp,kn),kobjs) = (* Invariant : seg isn't empty *) let obj_dir = dir_of_sp sp and obj_mp = mp_of_kn kn in - let prefix = Nametab.{ obj_dir ; obj_mp; obj_sec = DirPath.empty } in + let prefix = Nametab.{ obj_dir ; obj_mp; } in let modobjs = try ModObjs.get obj_mp with Not_found -> assert false (* a substobjs should already be loaded *) @@ -327,7 +327,7 @@ let rec open_object i (name, obj) = | KeepObject objs -> open_keep i (name, objs) and open_module i obj_dir obj_mp sobjs = - let prefix = Nametab.{ obj_dir ; obj_mp; obj_sec = DirPath.empty } in + let prefix = Nametab.{ obj_dir ; obj_mp; } in let dirinfo = Nametab.GlobDirRef.DirModule prefix in consistency_checks true obj_dir dirinfo; Nametab.push_dir (Nametab.Exactly i) obj_dir dirinfo; @@ -353,7 +353,7 @@ and open_modtype i ((sp,kn),_) = and open_include i ((sp,kn), aobjs) = let obj_dir = Libnames.dirpath sp in let obj_mp = KerName.modpath kn in - let prefix = Nametab.{ obj_dir; obj_mp; obj_sec = DirPath.empty } in + let prefix = Nametab.{ obj_dir; obj_mp; } in let o = expand_aobjs aobjs in open_objects i prefix o @@ -363,7 +363,7 @@ and open_export i mpl = and open_keep i ((sp,kn),kobjs) = let obj_dir = dir_of_sp sp and obj_mp = mp_of_kn kn in - let prefix = Nametab.{ obj_dir; obj_mp; obj_sec = DirPath.empty } in + let prefix = Nametab.{ obj_dir; obj_mp; } in open_objects i prefix kobjs let rec cache_object (name, obj) = @@ -380,7 +380,7 @@ let rec cache_object (name, obj) = and cache_include ((sp,kn), aobjs) = let obj_dir = Libnames.dirpath sp in let obj_mp = KerName.modpath kn in - let prefix = Nametab.{ obj_dir; obj_mp; obj_sec = DirPath.empty } in + let prefix = Nametab.{ obj_dir; obj_mp; } in let o = expand_aobjs aobjs in load_objects 1 prefix o; open_objects 1 prefix o diff --git a/vernac/g_vernac.mlg b/vernac/g_vernac.mlg index 8a94a010a0..efcb2635be 100644 --- a/vernac/g_vernac.mlg +++ b/vernac/g_vernac.mlg @@ -62,7 +62,8 @@ let make_bullet s = | _ -> assert false let parse_compat_version = let open Flags in function - | "8.10" -> Current + | "8.11" -> Current + | "8.10" -> V8_10 | "8.9" -> V8_9 | "8.8" -> V8_8 | ("8.7" | "8.6" | "8.5" | "8.4" | "8.3" | "8.2" | "8.1" | "8.0") as s -> diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml index 42d1a1f3fc..e49277c51b 100644 --- a/vernac/lemmas.ml +++ b/vernac/lemmas.ml @@ -265,7 +265,8 @@ let save_remaining_recthms env sigma ~poly ~scope ~udecl uctx body opaq i { Rect Univ.ContextSet.of_context univs | Monomorphic_entry univs -> univs in - let c = Declare.SectionLocalAssum {typ=t_i; univs; poly; impl} in + let () = Declare.declare_universe_context ~poly univs in + let c = Declare.SectionLocalAssum {typ=t_i; impl} in let () = Declare.declare_variable ~name ~kind c in GlobRef.VarRef name, impargs | Global local -> @@ -359,7 +360,7 @@ let save_lemma_admitted ~(lemma : t) : unit = let env = Global.env () in let ids_typ = Environ.global_vars_set env typ in let ids_def = Environ.global_vars_set env pproof in - Some (Environ.keep_hyps env (Id.Set.union ids_typ ids_def)) + Some (Environ.really_needed env (Id.Set.union ids_typ ids_def)) | _ -> None in let universes = Proof_global.get_initial_euctx lemma.proof in let ctx = UState.check_univ_decl ~poly universes udecl in diff --git a/vernac/locality.ml b/vernac/locality.ml index f033d32874..5862f51b43 100644 --- a/vernac/locality.ml +++ b/vernac/locality.ml @@ -39,7 +39,7 @@ let enforce_locality_exp locality_flag discharge = match locality_flag, discharge with | Some b, NoDischarge -> Global (importability_of_bool b) | None, NoDischarge -> Global Declare.ImportDefaultBehavior - | None, DoDischarge when not (Lib.sections_are_opened ()) -> + | None, DoDischarge when not (Global.sections_are_opened ()) -> (* If a Let/Variable is defined outside a section, then we consider it as a local definition *) warn_local_declaration (); Global Declare.ImportNeedQualified @@ -55,7 +55,7 @@ let enforce_locality locality_flag = Local in sections is the default, Local not in section forces non-export *) let make_section_locality = - function Some b -> b | None -> Lib.sections_are_opened () + function Some b -> b | None -> Global.sections_are_opened () let enforce_section_locality locality_flag = make_section_locality locality_flag @@ -68,7 +68,7 @@ let enforce_section_locality locality_flag = let make_module_locality = function | Some false -> - if Lib.sections_are_opened () then + if Global.sections_are_opened () then CErrors.user_err Pp.(str "This command does not support the Global option in sections."); false diff --git a/vernac/vernac.mllib b/vernac/vernac.mllib index 4868182bb3..afc701edbc 100644 --- a/vernac/vernac.mllib +++ b/vernac/vernac.mllib @@ -26,16 +26,16 @@ Indschemes Obligations ComDefinition Classes +ComPrimitive ComAssumption ComInductive ComFixpoint ComProgramFixpoint Record Assumptions -Vernacstate Mltop Topfmt Loadpath Vernacentries - -Misctypes +Vernacstate +Vernacinterp diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml index ca29a6afb9..430cee62c2 100644 --- a/vernac/vernacentries.ml +++ b/vernac/vernacentries.ml @@ -35,12 +35,6 @@ module NamedDecl = Context.Named.Declaration (** TODO: make this function independent of Ltac *) let (f_interp_redexp, interp_redexp_hook) = Hook.make () -let debug = false - -(* XXX Should move to a common library *) -let vernac_pperr_endline pp = - if debug then Format.eprintf "@[%a@]@\n%!" Pp.pp_with (pp ()) else () - (* Utility functions, at some point they should all disappear and instead enviroment/state selection should be done at the Vernac DSL level. *) @@ -468,28 +462,6 @@ let vernac_notation ~atts = let vernac_custom_entry ~module_local s = Metasyntax.declare_custom_entry module_local s -(* Default proof mode, to be set at the beginning of proofs for - programs that cannot be statically classified. *) -let default_proof_mode = ref (Pvernac.register_proof_mode "Noedit" Pvernac.Vernac_.noedit_mode) -let get_default_proof_mode () = !default_proof_mode - -let get_default_proof_mode_opt () = Pvernac.proof_mode_to_string !default_proof_mode -let set_default_proof_mode_opt name = - default_proof_mode := - match Pvernac.lookup_proof_mode name with - | Some pm -> pm - | None -> CErrors.user_err Pp.(str (Format.sprintf "No proof mode named \"%s\"." name)) - -let proof_mode_opt_name = ["Default";"Proof";"Mode"] -let () = - Goptions.declare_string_option Goptions.{ - optdepr = false; - optname = "default proof mode" ; - optkey = proof_mode_opt_name; - optread = get_default_proof_mode_opt; - optwrite = set_default_proof_mode_opt; - } - (***********) (* Gallina *) @@ -838,14 +810,14 @@ let vernac_combined_scheme lid l = Indschemes.do_combined_scheme lid l let vernac_universe ~poly l = - if poly && not (Lib.sections_are_opened ()) then + if poly && not (Global.sections_are_opened ()) then user_err ~hdr:"vernac_universe" (str"Polymorphic universes can only be declared inside sections, " ++ str "use Monomorphic Universe instead"); Declare.do_universe ~poly l let vernac_constraint ~poly l = - if poly && not (Lib.sections_are_opened ()) then + if poly && not (Global.sections_are_opened ()) then user_err ~hdr:"vernac_constraint" (str"Polymorphic universe constraints can only be declared" ++ str " inside sections, use Monomorphic Constraint instead"); @@ -865,7 +837,7 @@ let vernac_import export refl = let vernac_declare_module export {loc;v=id} binders_ast mty_ast = (* We check the state of the system (in section, in module type) and what module information is supplied *) - if Lib.sections_are_opened () then + if Global.sections_are_opened () then user_err Pp.(str "Modules and Module Types are not allowed inside sections."); let binders_ast = List.map (fun (export,idl,ty) -> @@ -880,7 +852,7 @@ let vernac_declare_module export {loc;v=id} binders_ast mty_ast = let vernac_define_module export {loc;v=id} (binders_ast : module_binder list) mty_ast_o mexpr_ast_l = (* We check the state of the system (in section, in module type) and what module information is supplied *) - if Lib.sections_are_opened () then + if Global.sections_are_opened () then user_err Pp.(str "Modules and Module Types are not allowed inside sections."); match mexpr_ast_l with | [] -> @@ -921,7 +893,7 @@ let vernac_end_module export {loc;v=id} = Option.iter (fun export -> vernac_import export [qualid_of_ident ?loc id]) export let vernac_declare_module_type {loc;v=id} binders_ast mty_sign mty_ast_l = - if Lib.sections_are_opened () then + if Global.sections_are_opened () then user_err Pp.(str "Modules and Module Types are not allowed inside sections."); match mty_ast_l with @@ -967,7 +939,9 @@ let vernac_include l = Declaremods.declare_include l let vernac_begin_section ~poly ({v=id} as lid) = Dumpglob.dump_definition lid true "sec"; - Lib.open_section ~poly id; + Lib.open_section id; + (* If there was no polymorphism attribute this just sets the option + to its current value ie noop. *) set_bool_option_value_gen ~locality:OptLocal ["Universe"; "Polymorphism"] poly let vernac_end_section {CAst.loc} = @@ -995,7 +969,7 @@ let warn_require_in_section = (fun () -> strbrk "Use of “Require” inside a section is deprecated.") let vernac_require from import qidl = - if Lib.sections_are_opened () then warn_require_in_section (); + if Global.sections_are_opened () then warn_require_in_section (); let root = match from with | None -> None | Some from -> @@ -2124,7 +2098,7 @@ let vernac_register qid r = | RegisterCoqlib n -> let ns, id = Libnames.repr_qualid n in if DirPath.equal (dirpath_of_string "kernel") ns then begin - if Lib.sections_are_opened () then + if Global.sections_are_opened () then user_err Pp.(str "Registering a kernel type is not allowed in sections"); let pind = match Id.to_string id with | "ind_bool" -> CPrimitives.PIT_bool @@ -2235,115 +2209,9 @@ let vernac_check_guard ~pstate = (str ("Condition violated: ") ++s) in message -(** A global default timeout, controlled by option "Set Default Timeout n". - Use "Unset Default Timeout" to deactivate it (or set it to 0). *) - -let default_timeout = ref None - -(* Timeout *) -let vernac_timeout ?timeout (f : 'a -> 'b) (x : 'a) : 'b = - match !default_timeout, timeout with - | _, Some n - | Some n, None -> - Control.timeout n f x Timeout - | None, None -> - f x - -(* Fail *) -let test_mode = ref false - -(* Restoring the state is the caller's responsibility *) -let with_fail f : (Pp.t, unit) result = - try - let _ = f () in - Error () - with - (* Fail Timeout is a common pattern so we need to support it. *) - | e when CErrors.noncritical e || e = Timeout -> - (* The error has to be printed in the failing state *) - Ok CErrors.(iprint (push e)) - -(* We restore the state always *) -let with_fail ~st f = - let res = with_fail f in - Vernacstate.invalidate_cache (); - Vernacstate.unfreeze_interp_state st; - match res with - | Error () -> - user_err ~hdr:"Fail" (str "The command has not failed!") - | Ok msg -> - if not !Flags.quiet || !test_mode - then Feedback.msg_notice (str "The command has indeed failed with message:" ++ fnl () ++ msg) - -let locate_if_not_already ?loc (e, info) = - match Loc.get_loc info with - | None -> (e, Option.cata (Loc.add_loc info) info loc) - | Some l -> (e, info) - -let mk_time_header = - (* Drop the time header to print the command, we should indeed use a - different mechanism to `-time` commands than the current hack of - adding a time control to the AST. *) - let pr_time_header vernac = - let vernac = match vernac with - | { v = { control = ControlTime _ :: control; attrs; expr }; loc } -> - CAst.make ?loc { control; attrs; expr } - | _ -> vernac - in - Topfmt.pr_cmd_header vernac - in - fun vernac -> Lazy.from_fun (fun () -> pr_time_header vernac) - -let interp_control_flag ~time_header (f : control_flag) ~st - (fn : st:Vernacstate.t -> Vernacstate.LemmaStack.t option) = - match f with - | ControlFail -> - with_fail ~st (fun () -> fn ~st); - st.Vernacstate.lemmas - | ControlTimeout timeout -> - vernac_timeout ~timeout (fun () -> fn ~st) () - | ControlTime batch -> - let header = if batch then Lazy.force time_header else Pp.mt () in - System.with_time ~batch ~header (fun () -> fn ~st) () - | ControlRedirect s -> - Topfmt.with_output_to_file s (fun () -> fn ~st) () - -(* EJGA: We may remove this, only used twice below *) -let vernac_require_open_lemma ~stack f = - match stack with - | Some stack -> f stack - | None -> user_err Pp.(str "Command not supported (No proof-editing in progress)") - -let interp_typed_vernac c ~stack = - let open Vernacextend in - match c with - | VtDefault f -> f (); stack - | VtNoProof f -> - if Option.has_some stack then - user_err Pp.(str "Command not supported (Open proofs remain)"); - let () = f () in - stack - | VtCloseProof f -> - vernac_require_open_lemma ~stack (fun stack -> - let lemma, stack = Vernacstate.LemmaStack.pop stack in - f ~lemma; - stack) - | VtOpenProof f -> - Some (Vernacstate.LemmaStack.push stack (f ())) - | VtModifyProof f -> - Option.map (Vernacstate.LemmaStack.map_top_pstate ~f:(fun pstate -> f ~pstate)) stack - | VtReadProofOpt f -> - let pstate = Option.map (Vernacstate.LemmaStack.with_top_pstate ~f:(fun x -> x)) stack in - f ~pstate; - stack - | VtReadProof f -> - vernac_require_open_lemma ~stack - (Vernacstate.LemmaStack.with_top_pstate ~f:(fun pstate -> f ~pstate)); - stack - (* We interpret vernacular commands to a DSL that specifies their allowed actions on proof states *) -let rec translate_vernac ~atts v = let open Vernacextend in match v with +let translate_vernac ~atts v = let open Vernacextend in match v with | VernacAbortAll | VernacRestart | VernacUndo _ @@ -2353,6 +2221,9 @@ let rec translate_vernac ~atts v = let open Vernacextend in match v with | VernacBack _ | VernacAbort _ -> anomaly (str "type_vernac") + | VernacLoad _ -> + anomaly (str "Load is not supported recursively") + (* Syntax *) | VernacSyntaxExtension (infix, sl) -> VtDefault(fun () -> with_module_locality ~atts vernac_syntax_extension infix sl) @@ -2605,7 +2476,7 @@ let rec translate_vernac ~atts v = let open Vernacextend in match v with | VernacPrimitive (id, prim, typopt) -> VtDefault(fun () -> unsupported_attributes atts; - ComAssumption.do_primitive id prim typopt) + ComPrimitive.do_primitive id prim typopt) | VernacComments l -> VtDefault(fun () -> unsupported_attributes atts; @@ -2654,141 +2525,6 @@ let rec translate_vernac ~atts v = let open Vernacextend in match v with | VernacEndProof pe -> VtCloseProof (vernac_end_proof pe) - | VernacLoad (verbosely,fname) -> - VtNoProof(fun () -> - unsupported_attributes atts; - vernac_load ~verbosely fname) - (* Extensions *) | VernacExtend (opn,args) -> Vernacextend.type_vernac ~atts opn args - -(* "locality" is the prefix "Local" attribute, while the "local" component - * 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. *) -and interp_expr ~atts ~st c = - let stack = st.Vernacstate.lemmas in - vernac_pperr_endline (fun () -> str "interpreting: " ++ Ppvernac.pr_vernac_expr c); - match c with - - (* The STM should handle that, but LOAD bypasses the STM... *) - | VernacAbortAll -> CErrors.user_err (str "AbortAll cannot be used through the Load command") - | VernacRestart -> CErrors.user_err (str "Restart cannot be used through the Load command") - | VernacUndo _ -> CErrors.user_err (str "Undo cannot be used through the Load command") - | VernacUndoTo _ -> CErrors.user_err (str "UndoTo cannot be used through the Load command") - - (* Resetting *) - | VernacResetName _ -> anomaly (str "VernacResetName not handled by Stm.") - | VernacResetInitial -> anomaly (str "VernacResetInitial not handled by Stm.") - | VernacBack _ -> anomaly (str "VernacBack not handled by Stm.") - - (* This one is possible to handle here *) - | VernacAbort id -> CErrors.user_err (str "Abort cannot be used through the Load command") - - | v -> - let fv = translate_vernac ~atts v in - interp_typed_vernac ~stack fv - -(* XXX: This won't properly set the proof mode, as of today, it is - controlled by the STM. Thus, we would need access information from - the classifier. The proper fix is to move it to the STM, however, - the way the proof mode is set there makes the task non trivial - without a considerable amount of refactoring. -*) -and vernac_load ~verbosely fname = - let exception End_of_input in - - (* Note that no proof should be open here, so the state here is just token for now *) - let st = Vernacstate.freeze_interp_state ~marshallable:false in - let fname = - Envars.expand_path_macros ~warn:(fun x -> Feedback.msg_warning (str x)) fname in - let fname = CUnix.make_suffix fname ".v" in - let input = - let longfname = Loadpath.locate_file fname in - let in_chan = open_utf8_file_in longfname in - Pcoq.Parsable.make ~loc:(Loc.initial (Loc.InFile longfname)) (Stream.of_channel in_chan) in - (* Parsing loop *) - let v_mod = if verbosely then Flags.verbosely else Flags.silently in - let parse_sentence proof_mode = Flags.with_option Flags.we_are_parsing - (fun po -> - match Pcoq.Entry.parse (Pvernac.main_entry proof_mode) po with - | Some x -> x - | None -> raise End_of_input) in - let rec load_loop ~stack = - try - let proof_mode = Option.map (fun _ -> get_default_proof_mode ()) stack in - let stack = - v_mod (interp_control ~st:{ st with Vernacstate.lemmas = stack }) - (parse_sentence proof_mode input) in - load_loop ~stack - with - End_of_input -> - stack - in - let stack = load_loop ~stack:st.Vernacstate.lemmas in - (* If Load left a proof open, we fail too. *) - if Option.has_some stack then - CErrors.user_err Pp.(str "Files processed by Load cannot leave open proofs."); - () - -and interp_control ~st ({ v = cmd } 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 = interp_expr ~atts:cmd.attrs ~st cmd.expr in - if before_univs == Global.universes () then pstack - else Option.map (Vernacstate.LemmaStack.map_top_pstate ~f:Proof_global.update_global_env) pstack) - ~st - -(* Interpreting a possibly delayed proof *) -let interp_qed_delayed ~proof ~info ~st pe : Vernacstate.LemmaStack.t option = - let stack = st.Vernacstate.lemmas in - let stack = Option.cata (fun stack -> snd @@ Vernacstate.LemmaStack.pop stack) None stack in - let () = match pe with - | Admitted -> - save_lemma_admitted_delayed ~proof ~info - | Proved (_,idopt) -> - save_lemma_proved_delayed ~proof ~info ~idopt in - stack - -let interp_qed_delayed_control ~proof ~info ~st ~control { loc; v=pe } = - let time_header = mk_time_header (CAst.make ?loc { control; attrs = []; expr = VernacEndProof pe }) in - List.fold_right (fun flag fn -> interp_control_flag ~time_header flag fn) - control - (fun ~st -> interp_qed_delayed ~proof ~info ~st pe) - ~st - -(* General interp with management of state *) -let () = - declare_int_option - { optdepr = false; - optname = "the default timeout"; - optkey = ["Default";"Timeout"]; - optread = (fun () -> !default_timeout); - optwrite = ((:=) default_timeout) } - -(* Be careful with the cache here in case of an exception. *) -let interp_gen ~verbosely ~st ~interp_fn cmd = - Vernacstate.unfreeze_interp_state st; - try vernac_timeout (fun st -> - let v_mod = if verbosely then Flags.verbosely else Flags.silently in - let ontop = v_mod (interp_fn ~st) cmd in - Vernacstate.Proof_global.set ontop [@ocaml.warning "-3"]; - Vernacstate.freeze_interp_state ~marshallable:false - ) st - with exn -> - let exn = CErrors.push exn in - let exn = locate_if_not_already ?loc:cmd.CAst.loc exn in - Vernacstate.invalidate_cache (); - iraise exn - -(* Regular interp *) -let interp ?(verbosely=true) ~st cmd = - interp_gen ~verbosely ~st ~interp_fn:interp_control cmd - -let interp_qed_delayed_proof ~proof ~info ~st ~control pe : Vernacstate.t = - interp_gen ~verbosely:false ~st - ~interp_fn:(interp_qed_delayed_control ~proof ~info ~control) pe diff --git a/vernac/vernacentries.mli b/vernac/vernacentries.mli index e65f9d3cfe..6368ebeed8 100644 --- a/vernac/vernacentries.mli +++ b/vernac/vernacentries.mli @@ -8,25 +8,11 @@ (* * (see LICENSE file for the text of the license) *) (************************************************************************) -(** The main interpretation function of vernacular expressions *) -val interp : ?verbosely:bool -> st:Vernacstate.t -> Vernacexpr.vernac_control -> Vernacstate.t - -(** Execute a Qed but with a proof_object which may contain a delayed - proof and won't be forced *) -val interp_qed_delayed_proof - : proof:Proof_global.proof_object - -> info:Lemmas.Info.t - -> st:Vernacstate.t - -> control:Vernacexpr.control_flag list - -> Vernacexpr.proof_end CAst.t - -> Vernacstate.t - -(** [with_fail ~st f] runs [f ()] and expects it to fail, otherwise it fails. *) -val with_fail : st:Vernacstate.t -> (unit -> 'a) -> unit - -(** Flag set when the test-suite is called. Its only effect to display - verbose information for [Fail] *) -val test_mode : bool ref +(** Vernac Translation into the Vernac DSL *) +val translate_vernac + : atts:Attributes.vernac_flags + -> Vernacexpr.vernac_expr + -> Vernacextend.typed_vernac (** Vernacular require command *) val vernac_require : @@ -38,8 +24,3 @@ val interp_redexp_hook : (Environ.env -> Evd.evar_map -> Genredexpr.raw_red_expr (** Miscellaneous stuff *) val command_focus : unit Proof.focus_kind - -(** Default proof mode set by `start_proof` *) -val get_default_proof_mode : unit -> Pvernac.proof_mode - -val proof_mode_opt_name : string list diff --git a/vernac/vernacextend.ml b/vernac/vernacextend.ml index 2725516a76..e29086d726 100644 --- a/vernac/vernacextend.ml +++ b/vernac/vernacextend.ml @@ -54,7 +54,6 @@ and proof_block_name = string (** open type of delimiters *) type typed_vernac = | VtDefault of (unit -> unit) - | VtNoProof of (unit -> unit) | VtCloseProof of (lemma:Lemmas.t -> unit) | VtOpenProof of (unit -> Lemmas.t) diff --git a/vernac/vernacinterp.ml b/vernac/vernacinterp.ml new file mode 100644 index 0000000000..c14fc78462 --- /dev/null +++ b/vernac/vernacinterp.ml @@ -0,0 +1,278 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) +(************************************************************************) + +open Vernacexpr + +(* XXX Should move to a common library *) +let debug = false +let vernac_pperr_endline pp = + if debug then Format.eprintf "@[%a@]@\n%!" Pp.pp_with (pp ()) else () + +(* EJGA: We may remove this, only used twice below *) +let vernac_require_open_lemma ~stack f = + match stack with + | Some stack -> f stack + | None -> + CErrors.user_err (Pp.str "Command not supported (No proof-editing in progress)") + +let interp_typed_vernac c ~stack = + let open Vernacextend in + match c with + | VtDefault f -> f (); stack + | VtNoProof f -> + if Option.has_some stack then + CErrors.user_err (Pp.str "Command not supported (Open proofs remain)"); + let () = f () in + stack + | VtCloseProof f -> + vernac_require_open_lemma ~stack (fun stack -> + let lemma, stack = Vernacstate.LemmaStack.pop stack in + f ~lemma; + stack) + | VtOpenProof f -> + Some (Vernacstate.LemmaStack.push stack (f ())) + | VtModifyProof f -> + Option.map (Vernacstate.LemmaStack.map_top_pstate ~f:(fun pstate -> f ~pstate)) stack + | VtReadProofOpt f -> + let pstate = Option.map (Vernacstate.LemmaStack.with_top_pstate ~f:(fun x -> x)) stack in + f ~pstate; + stack + | VtReadProof f -> + vernac_require_open_lemma ~stack + (Vernacstate.LemmaStack.with_top_pstate ~f:(fun pstate -> f ~pstate)); + stack + +(* Default proof mode, to be set at the beginning of proofs for + programs that cannot be statically classified. *) +let default_proof_mode = ref (Pvernac.register_proof_mode "Noedit" Pvernac.Vernac_.noedit_mode) +let get_default_proof_mode () = !default_proof_mode + +let get_default_proof_mode_opt () = Pvernac.proof_mode_to_string !default_proof_mode +let set_default_proof_mode_opt name = + default_proof_mode := + match Pvernac.lookup_proof_mode name with + | Some pm -> pm + | None -> CErrors.user_err Pp.(str (Format.sprintf "No proof mode named \"%s\"." name)) + +let proof_mode_opt_name = ["Default";"Proof";"Mode"] +let () = + Goptions.declare_string_option Goptions.{ + optdepr = false; + optname = "default proof mode" ; + optkey = proof_mode_opt_name; + optread = get_default_proof_mode_opt; + optwrite = set_default_proof_mode_opt; + } + +(** A global default timeout, controlled by option "Set Default Timeout n". + Use "Unset Default Timeout" to deactivate it (or set it to 0). *) + +let default_timeout = ref None + +(* Timeout *) +let vernac_timeout ?timeout (f : 'a -> 'b) (x : 'a) : 'b = + match !default_timeout, timeout with + | _, Some n + | Some n, None -> + Control.timeout n f x CErrors.Timeout + | None, None -> + f x + +(* Fail *) +let test_mode = ref false + +(* Restoring the state is the caller's responsibility *) +let with_fail f : (Pp.t, unit) result = + try + let _ = f () in + Error () + with + (* Fail Timeout is a common pattern so we need to support it. *) + | e when CErrors.noncritical e || e = CErrors.Timeout -> + (* The error has to be printed in the failing state *) + Ok CErrors.(iprint (push e)) + +(* We restore the state always *) +let with_fail ~st f = + let res = with_fail f in + Vernacstate.invalidate_cache (); + Vernacstate.unfreeze_interp_state st; + match res with + | Error () -> + CErrors.user_err ~hdr:"Fail" (Pp.str "The command has not failed!") + | Ok msg -> + if not !Flags.quiet || !test_mode + then Feedback.msg_notice Pp.(str "The command has indeed failed with message:" ++ fnl () ++ msg) + +let locate_if_not_already ?loc (e, info) = + match Loc.get_loc info with + | None -> (e, Option.cata (Loc.add_loc info) info loc) + | Some l -> (e, info) + +let mk_time_header = + (* Drop the time header to print the command, we should indeed use a + different mechanism to `-time` commands than the current hack of + adding a time control to the AST. *) + let pr_time_header vernac = + let vernac = match vernac with + | { CAst.v = { control = ControlTime _ :: control; attrs; expr }; loc } -> + CAst.make ?loc { control; attrs; expr } + | _ -> vernac + in + Topfmt.pr_cmd_header vernac + in + fun vernac -> Lazy.from_fun (fun () -> pr_time_header vernac) + +let interp_control_flag ~time_header (f : control_flag) ~st + (fn : st:Vernacstate.t -> Vernacstate.LemmaStack.t option) = + match f with + | ControlFail -> + with_fail ~st (fun () -> fn ~st); + st.Vernacstate.lemmas + | ControlTimeout timeout -> + vernac_timeout ~timeout (fun () -> fn ~st) () + | ControlTime batch -> + let header = if batch then Lazy.force time_header else Pp.mt () in + System.with_time ~batch ~header (fun () -> fn ~st) () + | ControlRedirect s -> + Topfmt.with_output_to_file s (fun () -> fn ~st) () + +(* "locality" is the prefix "Local" attribute, while the "local" component + * 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 stack = st.Vernacstate.lemmas in + vernac_pperr_endline Pp.(fun () -> str "interpreting: " ++ Ppvernac.pr_vernac_expr c); + match c with + + (* The STM should handle that, but LOAD bypasses the STM... *) + | VernacAbortAll -> CErrors.user_err (Pp.str "AbortAll cannot be used through the Load command") + | VernacRestart -> CErrors.user_err (Pp.str "Restart cannot be used through the Load command") + | VernacUndo _ -> CErrors.user_err (Pp.str "Undo cannot be used through the Load command") + | VernacUndoTo _ -> CErrors.user_err (Pp.str "UndoTo cannot be used through the Load command") + + (* Resetting *) + | VernacResetName _ -> CErrors.anomaly (Pp.str "VernacResetName not handled by Stm.") + | VernacResetInitial -> CErrors.anomaly (Pp.str "VernacResetInitial not handled by Stm.") + | VernacBack _ -> CErrors.anomaly (Pp.str "VernacBack not handled by Stm.") + + (* This one is possible to handle here *) + | VernacAbort id -> CErrors.user_err (Pp.str "Abort cannot be used through the Load command") + | VernacLoad (verbosely, fname) -> + Attributes.unsupported_attributes atts; + vernac_load ~verbosely fname + | v -> + let fv = Vernacentries.translate_vernac ~atts v in + interp_typed_vernac ~stack fv + +and vernac_load ~verbosely fname = + let exception End_of_input in + + (* Note that no proof should be open here, so the state here is just token for now *) + let st = Vernacstate.freeze_interp_state ~marshallable:false in + let fname = + Envars.expand_path_macros ~warn:(fun x -> Feedback.msg_warning (Pp.str x)) fname in + let fname = CUnix.make_suffix fname ".v" in + let input = + let longfname = Loadpath.locate_file fname in + let in_chan = Util.open_utf8_file_in longfname in + Pcoq.Parsable.make ~loc:(Loc.initial (Loc.InFile longfname)) (Stream.of_channel in_chan) in + (* Parsing loop *) + let v_mod = if verbosely then Flags.verbosely else Flags.silently in + let parse_sentence proof_mode = Flags.with_option Flags.we_are_parsing + (fun po -> + match Pcoq.Entry.parse (Pvernac.main_entry proof_mode) po with + | Some x -> x + | None -> raise End_of_input) in + let rec load_loop ~stack = + try + let proof_mode = Option.map (fun _ -> get_default_proof_mode ()) stack in + let stack = + v_mod (interp_control ~st:{ st with Vernacstate.lemmas = stack }) + (parse_sentence proof_mode input) in + load_loop ~stack + with + End_of_input -> + stack + in + let stack = load_loop ~stack:st.Vernacstate.lemmas in + (* If Load left a proof open, we fail too. *) + if Option.has_some stack then + CErrors.user_err Pp.(str "Files processed by Load cannot leave open proofs."); + stack + +and interp_control ~st ({ CAst.v = cmd } 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 = interp_expr ~atts:cmd.attrs ~st cmd.expr in + if before_univs == Global.universes () then pstack + else Option.map (Vernacstate.LemmaStack.map_top_pstate ~f:Proof_global.update_global_env) pstack) + ~st + +(* XXX: This won't properly set the proof mode, as of today, it is + controlled by the STM. Thus, we would need access information from + the classifier. The proper fix is to move it to the STM, however, + the way the proof mode is set there makes the task non trivial + without a considerable amount of refactoring. +*) + +(* Interpreting a possibly delayed proof *) +let interp_qed_delayed ~proof ~info ~st pe : Vernacstate.LemmaStack.t option = + let stack = st.Vernacstate.lemmas in + let stack = Option.cata (fun stack -> snd @@ Vernacstate.LemmaStack.pop stack) None stack in + let () = match pe with + | Admitted -> + Lemmas.save_lemma_admitted_delayed ~proof ~info + | Proved (_,idopt) -> + Lemmas.save_lemma_proved_delayed ~proof ~info ~idopt in + stack + +let interp_qed_delayed_control ~proof ~info ~st ~control { CAst.loc; v=pe } = + let time_header = mk_time_header (CAst.make ?loc { control; attrs = []; expr = VernacEndProof pe }) in + List.fold_right (fun flag fn -> interp_control_flag ~time_header flag fn) + control + (fun ~st -> interp_qed_delayed ~proof ~info ~st pe) + ~st + +(* General interp with management of state *) +let () = let open Goptions in + declare_int_option + { optdepr = false; + optname = "the default timeout"; + optkey = ["Default";"Timeout"]; + optread = (fun () -> !default_timeout); + optwrite = ((:=) default_timeout) } + +(* Be careful with the cache here in case of an exception. *) +let interp_gen ~verbosely ~st ~interp_fn cmd = + Vernacstate.unfreeze_interp_state st; + try vernac_timeout (fun st -> + let v_mod = if verbosely then Flags.verbosely else Flags.silently in + let ontop = v_mod (interp_fn ~st) cmd in + Vernacstate.Proof_global.set ontop [@ocaml.warning "-3"]; + Vernacstate.freeze_interp_state ~marshallable:false + ) st + with exn -> + let exn = CErrors.push exn in + let exn = locate_if_not_already ?loc:cmd.CAst.loc exn in + Vernacstate.invalidate_cache (); + Util.iraise exn + +(* Regular interp *) +let interp ?(verbosely=true) ~st cmd = + interp_gen ~verbosely ~st ~interp_fn:interp_control cmd + +let interp_qed_delayed_proof ~proof ~info ~st ~control pe : Vernacstate.t = + interp_gen ~verbosely:false ~st + ~interp_fn:(interp_qed_delayed_control ~proof ~info ~control) pe diff --git a/vernac/vernacinterp.mli b/vernac/vernacinterp.mli new file mode 100644 index 0000000000..16849686da --- /dev/null +++ b/vernac/vernacinterp.mli @@ -0,0 +1,33 @@ +(************************************************************************) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2019 *) +(* <O___,, * (see CREDITS file for the list of authors) *) +(* \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) *) +(************************************************************************) + +(** The main interpretation function of vernacular expressions *) +val interp : ?verbosely:bool -> st:Vernacstate.t -> Vernacexpr.vernac_control -> Vernacstate.t + +(** Execute a Qed but with a proof_object which may contain a delayed + proof and won't be forced *) +val interp_qed_delayed_proof + : proof:Proof_global.proof_object + -> info:Lemmas.Info.t + -> st:Vernacstate.t + -> control:Vernacexpr.control_flag list + -> Vernacexpr.proof_end CAst.t + -> Vernacstate.t + +(** [with_fail ~st f] runs [f ()] and expects it to fail, otherwise it fails. *) +val with_fail : st:Vernacstate.t -> (unit -> 'a) -> unit + +(** Flag set when the test-suite is called. Its only effect to display + verbose information for [Fail] *) +val test_mode : bool ref + +(** Default proof mode set by `start_proof` *) +val get_default_proof_mode : unit -> Pvernac.proof_mode +val proof_mode_opt_name : string list |