diff options
446 files changed, 10762 insertions, 3370 deletions
diff --git a/.gitignore b/.gitignore index 4acd9930e3..bea12162c4 100644 --- a/.gitignore +++ b/.gitignore @@ -52,9 +52,9 @@ dev/ocamldebug-coq plugins/micromega/csdpcert kernel/byterun/dllcoqrun.so coqdoc.sty -csdp.cache -test-suite/lia.cache -test-suite/nra.cache +.csdp.cache +test-suite/.lia.cache +test-suite/.nra.cache test-suite/trace test-suite/misc/universes/all_stdlib.v test-suite/misc/universes/universes.txt @@ -68,7 +68,7 @@ doc/faq/axioms.eps_t doc/faq/axioms.pdf doc/faq/axioms.pdf_t doc/faq/axioms.png -doc/refman/csdp.cache +doc/refman/.csdp.cache doc/refman/trace doc/refman/Reference-Manual.pdf doc/refman/Reference-Manual.ps @@ -135,7 +135,7 @@ kernel/copcodes.ml tools/tolink.ml theories/Numbers/Natural/BigN/NMake_gen.v ide/index_urls.txt -lia.cache +.lia.cache checker/names.ml checker/names.mli checker/esubst.ml @@ -2,6 +2,8 @@ FLG -rectypes -thread S config B config +S ide +B ide S lib B lib S intf diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000000..f609852bc3 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,119 @@ +dist: trusty +sudo: required +# Until Ocaml becomes a language, we set a known one. +language: c +cache: + apt: true + directories: + - $HOME/.opam +addons: + apt: + sources: + - avsm + packages: + - opam + - aspcud + - gcc-multilib +env: + global: + - NJOBS=2 + # system is == 4.02.3 + - COMPILER="system" + # Main test suites + matrix: + - TEST_TARGET="test-suite" COMPILER="4.02.3+32bit" + - TEST_TARGET="validate" TW="travis_wait" + - TEST_TARGET="validate" COMPILER="4.02.3+32bit" TW="travis_wait" + - TEST_TARGET="ci-color" + - TEST_TARGET="ci-compcert" + - TEST_TARGET="ci-coquelicot" + - TEST_TARGET="ci-geocoq" + - TEST_TARGET="ci-fiat-crypto" + - TEST_TARGET="ci-flocq" + - TEST_TARGET="ci-hott" + - TEST_TARGET="ci-iris-coq" + - TEST_TARGET="ci-math-classes" + - TEST_TARGET="ci-math-comp" + - TEST_TARGET="ci-sf" + - TEST_TARGET="ci-unimath" + # Not ready yet for 8.7 + # - TEST_TARGET="ci-cpdt" + # - TEST_TARGET="ci-metacoq" + # - TEST_TARGET="ci-tlc" + +matrix: + + allow_failures: + - env: TEST_TARGET="ci-geocoq" + + # Full Coq test-suite with two compilers + # [TODO: use yaml refs and avoid duplication for packages list] + include: + - env: + - TEST_TARGET="test-suite" + - EXTRA_CONF="-coqide opt -with-doc yes" + - EXTRA_OPAM="lablgtk-extras hevea" + addons: + apt: + sources: + - avsm + packages: + - opam + - aspcud + - libgtk2.0-dev + - libgtksourceview2.0-dev + - texlive-latex-base + - texlive-latex-recommended + - texlive-latex-extra + - texlive-math-extra + - texlive-fonts-recommended + - texlive-fonts-extra + - latex-xcolor + - ghostscript + - transfig + - imagemagick + - env: + - TEST_TARGET="test-suite" + - COMPILER="4.04.0" + - EXTRA_CONF="-coqide opt -with-doc yes" + - EXTRA_OPAM="lablgtk-extras hevea" + addons: + apt: + sources: + - avsm + packages: + - opam + - aspcud + - libgtk2.0-dev + - libgtksourceview2.0-dev + - texlive-latex-base + - texlive-latex-recommended + - texlive-latex-extra + - texlive-math-extra + - texlive-fonts-recommended + - texlive-fonts-extra + - latex-xcolor + - ghostscript + - transfig + - imagemagick + +install: +- opam init -j ${NJOBS} --compiler=${COMPILER} -n -y +- eval $(opam config env) +- opam config var root +- opam install -j ${NJOBS} -y camlp5 ocamlfind ${EXTRA_OPAM} +- opam list + +script: + +- echo 'Configuring Coq...' && echo -en 'travis_fold:start:coq.config\\r' +- ./configure -local -usecamlp5 -native-compiler yes ${EXTRA_CONF} +- echo -en 'travis_fold:end:coq.config\\r' + +- echo 'Building Coq...' && echo -en 'travis_fold:start:coq.build\\r' +- make -j ${NJOBS} +- echo -en 'travis_fold:end:coq.build\\r' + +- echo 'Running tests...' && echo -en 'travis_fold:start:coq.test\\r' +- ${TW} make -j ${NJOBS} ${TEST_TARGET} +- echo -en 'travis_fold:end:coq.test\\r' @@ -1,19 +1,19 @@ -Changes beyond V8.5 -=================== - -Bugfixes - -- #4527: when typechecking the statement of a lemma using universe polymorphic - definitions with explicit universe binders, check that the type can indeed be - typechecked using only those universes (after minimization of the other, - flexible universes), or raise an error (fixed scripts can be made forward - compatible). -- #4726: treat user-provided sorts of universe polymorphic records as rigid - (i.e. non-minimizable). -- #4592, #4932: notations sharing recursive patterns or sharing - binders made more robust. -- #4780: Induction with universe polymorphism on was creating ill-typed terms. -- #3070: fixing "subst" in the presence of a chain of dependencies. +Changes from V8.6beta1 to V8.6 +============================== + +Kernel + +- Fixed critical bug #5248 in VM long multiplication on 32-bit + architectures. Was there only since 8.6beta1, so no stable release impacted. + +Other bug fixes in universes, type class shelving,... + +Changes from V8.5 to V8.6beta1 +============================== + +Kernel + +- A new, faster state-of-the-art universe constraint checker. Specification language @@ -27,7 +27,10 @@ Specification language Tactics - Flag "Bracketing Last Introduction Pattern" is now on by default. -- Flag "Regular Subst Tactic" is now on by default. +- Flag "Regular Subst Tactic" is now on by default: it respects the + initial order of hypothesis, it contracts cycles, it unfolds no + local definitions (common source of incompatibilities, fixable by + "Unset Regular Subst Tactic"). - New flag "Refolding Reduction", now disabled by default, which turns on refolding of constants/fixpoints (as in cbn) during the reductions done during type inference and tactic retyping. Can be extremely @@ -54,9 +57,9 @@ Tactics given a free identifier, it is not bound in subsequent tactics anymore. In order to introduce a binding, use e.g. the "fresh" primitive instead (potential source of incompatibilities). -- New tactics is_ind, is_const, is_proj, is_constructor for use in Ltac (DOC TODO). -- New goal selectors. Sets of goals can be selected by select by listing - integers ranges. Example: "1,4-7,24: tac" focuses "tac" on goals 1,4,5,6,7,24. +- New tactics is_ind, is_const, is_proj, is_constructor for use in Ltac. +- New goal selectors. Sets of goals can be selected by listing integers + ranges. Example: "1,4-7,24: tac" focuses "tac" on goals 1,4,5,6,7,24. - For uniformity with "destruct"/"induction" and for a more natural behavior, "injection" can now work in place by activating option "Structural Injection". In this case, hypotheses are also put in the @@ -66,6 +69,20 @@ Tactics hypotheses of the form "~True" or "t<>t" (possible source of incompatibilities because of more successes in automation, but generally a more intuitive strategy). +- Option "Injection On Proofs" was renamed "Keep Proof Equalities". When + enabled, injection and inversion do not drop equalities between objects + in Prop. Still disabled by default. +- New tactics "notypeclasses refine" and "simple notypeclasses refine" that + disallow typeclass resolution when typechecking their argument, for use + in typeclass hints. +- Integration of LtacProf, a profiler for Ltac. +- Reduction tactics now accept more fine-grained flags: iota is now a shorthand + for the new flags match, fix and cofix. +- The ssreflect subterm selection algorithm is now accessible to tactic writers + through the ssrmatching plugin. +- When used as an argument of an ltac function, "auto" without "with" + nor "using" clause now correctly uses only the core hint database by + default. Hints @@ -73,6 +90,16 @@ Hints - Hint Mode now accepts "!" which means that the mode matches only if the argument's head is not an evar (it goes under applications, casts, and scrutinees of matches and projections). +- Hints can now take an optional user-given pattern, used only by + [typeclasses eauto] with the [Filtered Unification] option on. + +Typeclasses + +- Many new options and new engine based on the proof monad. The + [typeclasses eauto] tactic is now a multi-goal, multi-success tactic. + See reference manual for more information. It is planned to + replace auto and eauto in the following version. The 8.5 resolution + engine is still available to help solve compatibility issues. Program @@ -86,6 +113,14 @@ Notations - "Bind Scope" can once again bind "Funclass" and "Sortclass". +General infrastructure + +- New configurable warning system which can be controlled with the vernacular + command "Set Warnings", or, under coqc/coqtop, with the flag "-w". In + particular, the default is now that warnings are printed by coqc. +- In asynchronous mode, Coq is now capable of recovering from errors and + continue processing the document. + Tools - coqc accepts a -o option to specify the output file name @@ -94,11 +129,22 @@ Tools - Setting [Printing Dependent Evars Line] can be unset to disable the computation associated with printing the "dependent evars: " line in -emacs mode +- Removed the -verbose-compat-notations flag and the corresponding Set + Verbose Compat vernacular, since these warnings can now be silenced or + turned into errors using "-w". + +XML protocol + +- message format has changed, see dev/doc/changes.txt for more details. + +Many bug fixes, minor changes and documentation improvements are not mentioned +here. Changes from V8.5pl2 to V8.5pl3 =============================== Critical bugfix + - #4876: Guard checker incompleteness when using primitive projections Other bugfixes @@ -107,7 +153,50 @@ Other bugfixes - #4673: regression in setoid_rewrite, unfolding let-ins for type unification. - #4754: Regression in setoid_rewrite, allow postponed unification problems to remain. - #4769: Anomaly with universe polymorphic schemes defined inside sections. -- #3886: Program: duplicate obligations of mutual fixpoints +- #3886: Program: duplicate obligations of mutual fixpoints. +- #4994: Documentation typo. +- #5008: Use the "md5" command on OpenBSD. +- #5007: Do not assume the "TERM" environment variable is always set. +- #4606: Output a break before a list only if there was an empty line. +- #5001: metas not cleaned properly in clenv_refine_in. +- #2336: incorrect glob data for module symbols (bug #2336). +- #4832: Remove extraneous dot in error message. +- Anomaly in printing a unification error message. +- #4947: Options which take string arguments are not backwards compatible. +- #4156: micromega cache files are now hidden files. +- #4871: interrupting par:abstract kills coqtop. +- #5043: [Admitted] lemmas pick up section variables. +- Fix name of internal refine ("simple refine"). +- #5062: probably a typo in Strict Proofs mode. +- #5065: Anomaly: Not a proof by induction. +- Restore native compiler optimizations, they were disabled since 8.5! +- #5077: failure on typing a fixpoint with evars in its type. +- Fix recursive notation bug. +- #5095: non relevant too strict test in let-in abstraction. +- Ensuring that the evar name is preserved by "rename". +- #4887: confusion between using and with in documentation of firstorder. +- Bug in subst with let-ins. +- #4762: eauto weaker than auto. +- Remove if_then_else (was buggy). Use tryif instead. +- #4970: confusion between special "{" and non special "{{" in notations. +- #4529: primitive projections unfolding. +- #4416: Incorrect "Error: Incorrect number of goals". +- #4863: abstract in typeclass hint fails. +- #5123: unshelve can impact typeclass resolution +- Fix a collision about the meta-variable ".." in recursive notations. +- Fix printing of info_auto. +- #3209: Not_found due to an occur-check cycle. +- #5097: status of evars refined by "clear" in ltac: closed wrt evars. +- #5150: Missing dependency of the test-suite subsystems in prerequisite. +- Fix a bug in error printing of unif constraints +- #3941: Do not stop propagation of signals when Coq is busy. +- #4822: Incorrect assertion in cbn. +- #3479 parsing of "{" and "}" when a keyword starts with "{" or "}". +- #5127: Memory corruption with the VM. +- #5102: bullets parsing broken by calls to parse_entry. + +Various documentation improvements + Changes from V8.5pl1 to V8.5pl2 =============================== @@ -1051,7 +1140,7 @@ Extraction instead of accessing their body, they are now considered as axioms. The previous behaviour can be reactivated via the option "Set Extraction AccessOpaque". -- The pretty-printer for Haskell now produces layout-independant code +- The pretty-printer for Haskell now produces layout-independent code - A new command "Separate Extraction cst1 cst2 ..." that mixes a minimal extracted environment a la "Recursive Extraction" and the production of several files (one per coq source) a la "Extraction Library" @@ -1736,7 +1825,7 @@ Tactics Moreover, romega now has a variant "romega with *" that can be also used on non-Z goals (nat, N, positive) via a call to a translation tactic named zify (its purpose is to Z-ify your goal...). This zify may also be used - independantly of romega. + independently of romega. - Tactic "remember" now supports an "in" clause to remember only selected occurrences of a term. - Tactic "pose proof" supports name overwriting in case of specialization of an diff --git a/COMPATIBILITY b/COMPATIBILITY index 892eaa599e..d423e71df3 100644 --- a/COMPATIBILITY +++ b/COMPATIBILITY @@ -11,6 +11,12 @@ Remedy: instead (compatible with 8.4). - Unset the option for the program/proof the obligation/subproof originates from. + +Symptom: In a goal, order of hypotheses, or absence of an equality of +the form "x = t" or "t = x", or no unfolding of a local definition. +Cause: This might be connected to a number of fixes in the tactic +"subst". The former behavior can be reactivated by issuing "Unset +Regular Subst Tactic". Potential sources of incompatibilities between Coq V8.4 and V8.5 ---------------------------------------------------------------- @@ -1,5 +1,5 @@ - INSTALLATION PROCEDURES FOR THE COQ V8.5 SYSTEM + INSTALLATION PROCEDURES FOR THE COQ V8.6 SYSTEM ----------------------------------------------- @@ -27,7 +27,7 @@ WHAT DO YOU NEED ? port install coq - To compile Coq V8.5 yourself, you need: + To compile Coq V8.6 yourself, you need: - Objective Caml version 4.01.0 or later (available at http://caml.inria.fr/) diff --git a/META.coq b/META.coq new file mode 100644 index 0000000000..5be69d5fdc --- /dev/null +++ b/META.coq @@ -0,0 +1,249 @@ +description = "The Coq Proof Assistant Plugin API" +version = "8.6" + +directory = "" +requires = "camlp5" + +package "config" ( + + description = "Coq Configuration Variables" + version = "8.6" + + directory = "config" + +) + +package "lib" ( + + description = "Base Coq Library" + version = "8.6" + + directory = "lib" + + requires = "coq.config" + + archive(byte) = "clib.cma" + archive(byte) += "lib.cma" + + archive(native) = "clib.cmxa" + archive(native) += "lib.cmxa" + +) + +package "vm" ( + + description = "Coq VM" + + version = "8.6" + +# EJGA FIXME: Unfortunately dllpath is dependent on the type of Coq +# install. In a local one we'll want kernel/byterun, in a non-local +# one we want to set it to coqlib. We should thus generate this file +# at configure time, but let's hear for some more feedback from +# experts. + +# Enable for local native & byte builds +# directory = "kernel/byterun" + +# Enable for local byte builds and set up properly +# linkopts(byte) = "-dllpath /path/to/coq/kernel/byterun/ -dllib -lcoqrun" + +# Disable for local byte builds + linkopts(byte) = "-dllib -lcoqrun" + linkopts(native) = "-cclib -lcoqrun" + +) + +package "kernel" ( + + description = "The Coq's Kernel" + version = "8.6" + + directory = "kernel" + + requires = "coq.lib, coq.vm" + + archive(byte) = "kernel.cma" + archive(native) = "kernel.cmxa" + +) + +package "library" ( + + description = "Coq Libraries (vo) support" + version = "8.6" + + requires = "coq.kernel" + + directory = "library" + + archive(byte) = "library.cma" + archive(native) = "library.cmxa" + +) + +package "intf" ( + + description = "Coq Public Data Types" + version = "8.6" + + requires = "coq.library" + + directory = "intf" + +) + +package "engine" ( + + description = "Coq Libraries (vo) support" + version = "8.6" + + requires = "coq.library" + directory = "engine" + + archive(byte) = "engine.cma" + archive(native) = "engine.cmxa" + +) + +package "pretyping" ( + + description = "Coq Pretyper" + version = "8.6" + + requires = "coq.engine" + directory = "pretyping" + + archive(byte) = "pretyping.cma" + archive(native) = "pretyping.cmxa" + +) + +package "interp" ( + + description = "Coq Term Interpretation" + version = "8.6" + + requires = "coq.pretyping" + directory = "interp" + + archive(byte) = "interp.cma" + archive(native) = "interp.cmxa" + +) + +package "grammar" ( + + description = "Coq Base Grammar" + version = "8.6" + + requires = "coq.interp" + directory = "grammar" + + archive(byte) = "grammar.cma" + archive(native) = "grammar.cmxa" +) + +package "proofs" ( + + description = "Coq Proof Engine" + version = "8.6" + + requires = "coq.interp" + directory = "proofs" + + archive(byte) = "proofs.cma" + archive(native) = "proofs.cmxa" + +) + +package "parsing" ( + + description = "Coq Parsing Engine" + version = "8.6" + + requires = "coq.proofs" + directory = "parsing" + + archive(byte) = "parsing.cma" + archive(native) = "parsing.cmxa" + +) + +package "printing" ( + + description = "Coq Printing Libraries" + version = "8.6" + + requires = "coq.parsing" + directory = "printing" + + archive(byte) = "printing.cma" + archive(native) = "printing.cmxa" + +) + +package "tactics" ( + + description = "Coq Tactics" + version = "8.6" + + requires = "coq.printing" + directory = "tactics" + + archive(byte) = "tactics.cma" + archive(native) = "tactics.cmxa" + +) + +package "stm" ( + + description = "Coq State Transactional Machine" + version = "8.6" + + requires = "coq.tactics" + directory = "stm" + + archive(byte) = "stm.cma" + archive(native) = "stm.cmxa" + +) + +package "toplevel" ( + + description = "Coq Toplevel" + version = "8.6" + + requires = "coq.stm" + directory = "toplevel" + + archive(byte) = "toplevel.cma" + archive(native) = "toplevel.cmxa" + +) + +package "highparsing" ( + + description = "Coq Extra Parsing" + version = "8.6" + + requires = "coq.toplevel" + directory = "parsing" + + archive(byte) = "highparsing.cma" + archive(native) = "highparsing.cmxa" + +) + +package "ltac" ( + + description = "Coq LTAC Plugin" + version = "8.6" + + requires = "coq.highparsing" + directory = "ltac" + + archive(byte) = "ltac.cma" + archive(native) = "ltac.cmxa" + +) @@ -59,6 +59,10 @@ define find $(shell find . $(FIND_VCS_CLAUSE) '(' -name $(1) ')' -print | sed 's|^\./||') endef +define findindir + $(shell find $(1) $(FIND_VCS_CLAUSE) '(' -name $(2) ')' -print | sed 's|^\./||') +endef + define findx $(shell find . $(FIND_VCS_CLAUSE) '(' -name $(1) ')' -exec $(2) {} \; | sed 's|^\./||') endef @@ -68,7 +72,7 @@ endef LEXFILES := $(call find, '*.mll') export MLLIBFILES := $(call find, '*.mllib') $(call find, '*.mlpack') export ML4FILES := $(call find, '*.ml4') -export CFILES := $(call find, '*.c') +export CFILES := $(call findindir, 'kernel/byterun', '*.c') # NB: The lists of currently existing .ml and .mli files will change # before and after a build or a make clean. Hence we do not export @@ -242,6 +246,11 @@ devdocclean: rm -f $(OCAMLDOCDIR)/html/*.html ########################################################################### +# Continuous Intregration Tests +########################################################################### +include Makefile.ci + +########################################################################### # Emacs tags ########################################################################### diff --git a/Makefile.ci b/Makefile.ci new file mode 100644 index 0000000000..e4b5832f60 --- /dev/null +++ b/Makefile.ci @@ -0,0 +1,11 @@ +CI_TARGETS=ci-all ci-hott ci-math-comp ci-compcert ci-sf ci-cpdt \ + ci-color ci-math-classes ci-tlc ci-fiat-crypto \ + ci-coquelicot ci-flocq ci-iris-coq ci-metacoq ci-geocoq \ + ci-unimath + +.PHONY: $(CI_TARGETS) + +# Generic rule, we use make to easy travis integraton with mixed rules +$(CI_TARGETS): ci-%: + ./dev/ci/ci-$*.sh + diff --git a/Makefile.common b/Makefile.common index 49fe1fd939..a2b59a93b2 100644 --- a/Makefile.common +++ b/Makefile.common @@ -62,7 +62,7 @@ PLUGINDIRS:=\ setoid_ring extraction fourier \ cc funind firstorder derive \ rtauto nsatz syntax decl_mode btauto \ - ssrmatching + ssrmatching ltac SRCDIRS:=\ $(CORESRCDIRS) \ @@ -120,6 +120,7 @@ OTHERSYNTAXCMO:=$(addprefix plugins/syntax/, \ string_syntax_plugin.cmo ) DECLMODECMO:=plugins/decl_mode/decl_mode_plugin.cmo DERIVECMO:=plugins/derive/derive_plugin.cmo +LTACCMO:=plugins/ltac/ltac_plugin.cmo SSRMATCHINGCMO:=plugins/ssrmatching/ssrmatching_plugin.cmo PLUGINSCMO:=$(OMEGACMO) $(ROMEGACMO) $(MICROMEGACMO) $(DECLMODECMO) \ @@ -127,7 +128,7 @@ PLUGINSCMO:=$(OMEGACMO) $(ROMEGACMO) $(MICROMEGACMO) $(DECLMODECMO) \ $(FOURIERCMO) $(EXTRACTIONCMO) \ $(CCCMO) $(FOCMO) $(RTAUTOCMO) $(BTAUTOCMO) \ $(FUNINDCMO) $(NSATZCMO) $(NATSYNTAXCMO) $(OTHERSYNTAXCMO) \ - $(DERIVECMO) $(SSRMATCHINGCMO) + $(DERIVECMO) $(SSRMATCHINGCMO) $(LTACCMO) ifeq ($(HASNATDYNLINK)-$(BEST),false-opt) STATICPLUGINS:=$(PLUGINSCMO) diff --git a/Makefile.doc b/Makefile.doc index aa6e478a80..9ae20ba765 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -124,7 +124,7 @@ endif (cd `dirname $<`; $(DVIPS) -q -o `basename $@` `basename $<`) %.png: %.fig - $(FIG2DEV) -m 2 -L png $< $@ + $(FIG2DEV) -L png -m 2 $< $@ %.pdf: %.fig $(FIG2DEV) -L pdftex $< $@ @@ -201,15 +201,17 @@ doc/refman/styles.hva: doc/common/styles/html/$(HTMLSTYLE)/styles.hva $(INSTALLLIB) $< doc/refman INDEXES:= doc/refman/html/command-index.html doc/refman/html/tactic-index.html -ALLINDEXES:= doc/refman/html/index.html $(INDEXES) -refman-html-dir $(ALLINDEXES): doc/refman/Reference-Manual.html $(REFMANPNGFILES) \ +refman-html-dir $(INDEXES): doc/refman/html/index.html ; + +doc/refman/html/index.html: doc/refman/Reference-Manual.html $(REFMANPNGFILES) \ doc/refman/cover.html doc/refman/styles.hva doc/refman/index.html - rm -rf doc/refman/html $(MKDIR) doc/refman/html $(INSTALLLIB) $(REFMANPNGFILES) doc/refman/html (cd doc/refman/html; $(HACHA) -nolinks -tocbis -o toc.html ../styles.hva ../Reference-Manual.html) $(INSTALLLIB) doc/refman/cover.html doc/refman/html/index.html + @touch $(INDEXES) -$(INSTALLLIB) doc/common/styles/html/$(HTMLSTYLE)/*.css doc/refman/html refman-quick: diff --git a/Makefile.install b/Makefile.install index 4dad8cf0d4..4800ea0b96 100644 --- a/Makefile.install +++ b/Makefile.install @@ -18,7 +18,7 @@ ifeq ($(LOCAL),true) install: @echo "Nothing to install in a local build!" else -install: install-coq install-coqide install-doc-$(WITHDOC) +install: install-coq install-coqide install-doc-$(WITHDOC) install-meta endif # NOTA: for install-coqide, see Makefile.ide @@ -58,6 +58,7 @@ endif .PHONY: install-coq install-binaries install-byte install-opt .PHONY: install-tools install-library install-devfiles .PHONY: install-coq-info install-coq-manpages install-emacs install-latex +.PHONY: install-meta install-coq: install-binaries install-library install-coq-info install-devfiles @@ -140,6 +141,9 @@ install-latex: $(INSTALLLIB) tools/coqdoc/coqdoc.sty $(FULLCOQDOCDIR) # -$(UPDATETEX) +install-meta: META.coq + $(INSTALLLIB) META.coq $(FULLCOQLIB)/META + # For emacs: # Local Variables: # mode: makefile diff --git a/README.win b/README.win deleted file mode 100644 index 8302a707f6..0000000000 --- a/README.win +++ /dev/null @@ -1,44 +0,0 @@ -THE COQ V8 SYSTEM -================= - - This file contains remarks specific to the windows port of Coq. - -INSTALLATION. -============= - - The Coq package for Windows comes with an auto-installer. It will -install Coq binaries and libraries under any directory you specify -(C:\Coq is the default path). It also creates shortcuts -in the Windows menus. Binaries, like coqc.exe, -are in the bin sub-directory of the installation -(C:\Coq\bin by default). - -COMPILATION. -============ - - If you want to install coq, you had better transfer the precompiled - distribution. If you really need to recompile under Windows, here - are some indications: - - 1- Install cygwin and the wget package - See: http://cygwin.com - - 2- Download and unzip in C:\ the SDK for windows - See: https://coq.inria.fr/distrib/current/files/ - - 3- From the cygwin prompt type - - . /cygdrive/c/CoqSDK-85-1/environ - - The first time the script installs the C toolchain. - - 4- Then Coq can be compiled as follows: - - ./configure -local - make - - 5- To build the installer, type: - - dev/make-installer-win32.sh - - The Coq Team. diff --git a/checker/check.ml b/checker/check.ml index 863cf7b2cd..8b299bf2a2 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -11,6 +11,8 @@ open CErrors open Util open Names +let chk_pp = Pp.pp_with Format.std_formatter + let pr_dirpath dp = str (DirPath.to_string dp) let default_root_prefix = DirPath.empty let split_dirpath d = @@ -118,7 +120,6 @@ let check_one_lib admit (dir,m) = (Flags.if_verbose Feedback.msg_notice (str "Checking library: " ++ pr_dirpath dir); Safe_typing.import file md m.library_extra_univs dig); - Flags.if_verbose Feedback.msg_notice (fnl()); register_loaded_library m (*************************************************************************) @@ -298,7 +299,7 @@ let name_clash_message dir mdir f = let depgraph = ref LibraryMap.empty let intern_from_file (dir, f) = - Flags.if_verbose Feedback.msg_notice(str"[intern "++str f++str" ..."); + Flags.if_verbose chk_pp (str"[intern "++str f++str" ..."); let (sd,md,table,opaque_csts,digest) = try let ch = System.with_magic_number_check raw_intern_library f in @@ -322,7 +323,7 @@ let intern_from_file (dir, f) = errorlabstrm "intern_from_file" (str "The file "++str f++str " contains unfinished tasks"); if opaque_csts <> None then begin - Feedback.msg_notice(str " (was a vio file) "); + chk_pp (str " (was a vio file) "); Option.iter (fun (_,_,b) -> if not b then errorlabstrm "intern_from_file" (str "The file "++str f++str " is still a .vio")) @@ -333,12 +334,12 @@ let intern_from_file (dir, f) = Validate.validate !Flags.debug Values.v_libsum sd; Validate.validate !Flags.debug Values.v_lib md; Validate.validate !Flags.debug Values.v_opaques table; - Flags.if_verbose Feedback.msg_notice (str" done]"); + Flags.if_verbose chk_pp (str" done]" ++ fnl ()); let digest = if opaque_csts <> None then Cic.Dviovo (digest,udg) else (Cic.Dvo digest) in sd,md,table,opaque_csts,digest - with e -> Flags.if_verbose Feedback.msg_notice (str" failed!]"); raise e in + with e -> Flags.if_verbose chk_pp (str" failed!]" ++ fnl ()); raise e in depgraph := LibraryMap.add sd.md_name sd.md_deps !depgraph; opaque_tables := LibraryMap.add sd.md_name table !opaque_tables; Option.iter (fun (opaque_csts,_,_) -> diff --git a/checker/check_stat.ml b/checker/check_stat.ml index f196746a57..741f532848 100644 --- a/checker/check_stat.ml +++ b/checker/check_stat.ml @@ -57,8 +57,7 @@ let print_context env = (fnl() ++ str"CONTEXT SUMMARY" ++ fnl() ++ str"===============" ++ fnl() ++ fnl() ++ str "* " ++ hov 0 (pr_engagement engt ++ fnl()) ++ fnl() ++ - str "* " ++ hov 0 (pr_ax csts) ++ - fnl())); + str "* " ++ hov 0 (pr_ax csts))); end let stats () = diff --git a/checker/checker.ml b/checker/checker.ml index 0c411ae44d..8dbb7e0119 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -16,6 +16,8 @@ open Check let () = at_exit flush_all +let chk_pp = Pp.pp_with Format.std_formatter + let fatal_error info anomaly = flush_all (); Feedback.msg_error info; flush_all (); exit (if anomaly then 129 else 1) @@ -209,7 +211,8 @@ let usage () = open Type_errors let anomaly_string () = str "Anomaly: " -let report () = (str "." ++ spc () ++ str "Please report.") +let report () = (str "." ++ spc () ++ str "Please report" ++ + strbrk "at " ++ str Coq_config.wwwbugtracker ++ str ".") let guill s = str "\"" ++ str s ++ str "\"" @@ -282,7 +285,8 @@ let rec explain_exn = function Format.printf "@\nis not convertible with@\n"; Print.print_pure_constr a; Format.printf "@\n====== universes ====@\n"; - Feedback.msg_notice (Univ.pr_universes + chk_pp + (Univ.pr_universes (ctx.Environ.env_stratification.Environ.env_universes)); str "\nCantApplyBadType at argument " ++ int n | CantApplyNonFunctional _ -> str"CantApplyNonFunctional" diff --git a/checker/print.ml b/checker/print.ml index c0d1ac3688..7ef752b002 100644 --- a/checker/print.ml +++ b/checker/print.ml @@ -10,7 +10,9 @@ open Format open Cic open Names -let print_instance i = Feedback.msg_notice (Univ.Instance.pr i) +let chk_pp = Pp.pp_with Format.std_formatter + +let print_instance i = chk_pp (Univ.Instance.pr i) let print_pure_constr csr = let rec term_display c = match c with @@ -108,7 +110,7 @@ let print_pure_constr csr = and sort_display = function | Prop(Pos) -> print_string "Set" | Prop(Null) -> print_string "Prop" - | Type u -> print_string "Type("; Feedback.msg_notice (Univ.pr_uni u); print_string ")" + | Type u -> print_string "Type("; chk_pp (Univ.pr_uni u); print_string ")" and name_display = function | Name id -> print_string (Id.to_string id) diff --git a/config/coq_config.mli b/config/coq_config.mli index a0e1019fa8..c171bd3553 100644 --- a/config/coq_config.mli +++ b/config/coq_config.mli @@ -32,7 +32,7 @@ val cflags : string (* arguments passed to gcc *) val best : string (* byte/opt *) val arch : string (* architecture *) val arch_is_win32 : bool -val osdeplibs : string (* OS dependant link options for ocamlc *) +val osdeplibs : string (* OS dependent link options for ocamlc *) val vmbyteflags : string list (* -custom/-dllib -lcoqrun *) @@ -51,7 +51,7 @@ val exec_extension : string (* "" under Unix, ".exe" under MS-windows *) val with_geoproof : bool ref (* to (de)activate functions specific to Geoproof with Coqide *) val browser : string -(** default web browser to use, may be overriden by environment +(** default web browser to use, may be overridden by environment variable COQREMOTEBROWSER *) val has_coqide : string @@ -62,6 +62,7 @@ val natdynlinkflag : string (* special cases of natdynlink (e.g. MacOS 10.5) *) val wwwcoq : string val wwwrefman : string +val wwwbugtracker : string val wwwstdlib : string val localwwwrefman : string diff --git a/configure.ml b/configure.ml index 2c1d531ead..04b04979d9 100644 --- a/configure.ml +++ b/configure.ml @@ -11,11 +11,11 @@ #load "str.cma" open Printf -let coq_version = "8.6.0" -let coq_macos_version = "8.4.90" (** "[...] should be a string comprised of +let coq_version = "8.6" +let coq_macos_version = "8.6.00" (** "[...] should be a string comprised of three non-negative, period-separated integers [...]" *) -let vo_magic = 8511 -let state_magic = 58511 +let vo_magic = 8600 +let state_magic = 58600 let distributed_exec = ["coqtop";"coqc";"coqchk";"coqdoc";"coqmktop";"coqworkmgr"; "coqdoc";"coq_makefile";"coq-tex";"gallina";"coqwc";"csdpcert";"coqdep"] @@ -430,7 +430,7 @@ let dll = if os_type_win32 then ".dll" else ".so" let vcs = let git_dir = try Sys.getenv "GIT_DIR" with Not_found -> ".git" in - if dir_exists git_dir then "git" + if Sys.file_exists git_dir then "git" else if Sys.file_exists ".svn/entries" then "svn" else if dir_exists "{arch}" then "gnuarch" else "none" @@ -514,6 +514,20 @@ let camltag = match caml_version_list with (** * CamlpX configuration *) (* Convention: we use camldir as a prioritary location for camlpX, if given *) +(* i.e., in the case of camlp5, we search for a copy of camlp5o which *) +(* answers the right camlp5 lib dir *) + +let strip_slash dir = + let n = String.length dir in + if n>0 && dir.[n - 1] = '/' then String.sub dir 0 (n-1) else dir + +let which_camlp5o_for camlp5lib = + let camlp5o = Filename.concat camlbin "camlp5o" in + let camlp5lib = strip_slash camlp5lib in + if fst (tryrun camlp5o ["-where"]) = camlp5lib then camlp5o else + let camlp5o = which "camlp5o" in + if fst (tryrun camlp5o ["-where"]) = camlp5lib then camlp5o else + die ("Error: cannot find Camlp5 binaries corresponding to Camlp5 library " ^ camlp5lib) let which_camlpX base = let file = Filename.concat camlbin base in @@ -528,7 +542,7 @@ let check_camlp5 testcma = match !Prefs.camlp5dir with | Some dir -> if Sys.file_exists (dir/testcma) then let camlp5o = - try which_camlpX "camlp5o" + try which_camlp5o_for dir with Not_found -> die "Error: cannot find Camlp5 binaries in path.\n" in dir, camlp5o else @@ -549,7 +563,7 @@ let check_camlp5 testcma = match !Prefs.camlp5dir with let check_camlp5_version camlp5o = let version_line, _ = run ~err:StdOut camlp5o ["-v"] in let version = List.nth (string_split ' ' version_line) 2 in - match string_split '.' version with + match numeric_prefix_list version with | major::minor::_ when s2i major > 6 || (s2i major, s2i minor) >= (6,6) -> printf "You have Camlp5 %s. Good!\n" version; version | _ -> die "Error: unsupported Camlp5 (version < 6.06 or unrecognized).\n" @@ -1043,6 +1057,7 @@ let write_configml f = pr "let with_geoproof = ref %B\n" !Prefs.geoproof; pr_s "browser" browser; pr_s "wwwcoq" !Prefs.coqwebsite; + pr_s "wwwbugtracker" (!Prefs.coqwebsite ^ "bugs/"); pr_s "wwwrefman" (!Prefs.coqwebsite ^ "distrib/" ^ coq_version ^ "/refman/"); pr_s "wwwstdlib" (!Prefs.coqwebsite ^ "distrib/" ^ coq_version ^ "/stdlib/"); pr_s "localwwwrefman" ("file:/" ^ docdir ^ "/html/refman"); diff --git a/dev/make-macos-dmg.sh b/dev/build/osx/make-macos-dmg.sh index b43ada9076..b43ada9076 100755 --- a/dev/make-macos-dmg.sh +++ b/dev/build/osx/make-macos-dmg.sh diff --git a/dev/build/windows/CAVEATS.txt b/dev/build/windows/CAVEATS.txt new file mode 100644 index 0000000000..cb1ae3aaaf --- /dev/null +++ b/dev/build/windows/CAVEATS.txt @@ -0,0 +1,22 @@ +===== Environemt SIZE =====
+
+find and xargs can fail if the environment is to large. I think the limit is 8k.
+
+xargs --show-limits
+
+shows the actual environment size
+
+The configure_profile.sh script sets ORIGINAL_PATH (set by cygwin) to "" to
+avoid issues
+
+===== OCAMLLIB =====
+
+If the environment variable OCAMLLIB is defined, it takes precedence over the
+internal paths of ocaml tools. This usually messes up things considerably. A
+typical failure is
+
+Error: Error on dynamically loaded library: .\dlllablgtk2.dll: %1 is not a valid Win32 application.
+
+The configure_profile.sh script clears OCAMLLIB, but if you use the ocaml
+compiler from outside the provided cygwin shell, OCAMLLIB might be defined.
+
diff --git a/dev/build/windows/MakeCoq_84pl6_abs_ocaml.bat b/dev/build/windows/MakeCoq_84pl6_abs_ocaml.bat new file mode 100644 index 0000000000..bdcb01db92 --- /dev/null +++ b/dev/build/windows/MakeCoq_84pl6_abs_ocaml.bat @@ -0,0 +1,10 @@ +call MakeCoq_SetRootPath
+
+call MakeCoq_MinGW.bat ^
+ -arch=64 ^
+ -mode=absolute ^
+ -ocaml=Y ^
+ -make=Y ^
+ -coqver=8.4pl6 ^
+ -destcyg=%ROOTPATH%\cygwin_coq64_84pl6_abs ^
+ -destcoq=%ROOTPATH%\coq64_84pl6_abs
diff --git a/dev/build/windows/MakeCoq_85pl2_abs_ocaml.bat b/dev/build/windows/MakeCoq_85pl2_abs_ocaml.bat new file mode 100644 index 0000000000..2e4a692e9c --- /dev/null +++ b/dev/build/windows/MakeCoq_85pl2_abs_ocaml.bat @@ -0,0 +1,10 @@ +call MakeCoq_SetRootPath
+
+call MakeCoq_MinGW.bat ^
+ -arch=64 ^
+ -mode=absolute ^
+ -ocaml=Y ^
+ -make=Y ^
+ -coqver=8.5pl2 ^
+ -destcyg=%ROOTPATH%\cygwin_coq64_85pl2_abs ^
+ -destcoq=%ROOTPATH%\coq64_85pl2_abs
diff --git a/dev/build/windows/MakeCoq_85pl3_abs_ocaml.bat b/dev/build/windows/MakeCoq_85pl3_abs_ocaml.bat new file mode 100644 index 0000000000..6e4e440a2c --- /dev/null +++ b/dev/build/windows/MakeCoq_85pl3_abs_ocaml.bat @@ -0,0 +1,10 @@ +call MakeCoq_SetRootPath
+
+call MakeCoq_MinGW.bat ^
+ -arch=64 ^
+ -mode=absolute ^
+ -ocaml=Y ^
+ -make=Y ^
+ -coqver=8.5pl3 ^
+ -destcyg=%ROOTPATH%\cygwin_coq64_85pl3_abs ^
+ -destcoq=%ROOTPATH%\coq64_85pl3_abs
diff --git a/dev/build/windows/MakeCoq_85pl3_installer.bat b/dev/build/windows/MakeCoq_85pl3_installer.bat new file mode 100644 index 0000000000..c305e2f52d --- /dev/null +++ b/dev/build/windows/MakeCoq_85pl3_installer.bat @@ -0,0 +1,8 @@ +call MakeCoq_SetRootPath
+
+call MakeCoq_MinGW.bat ^
+ -arch=64 ^
+ -installer=Y ^
+ -coqver=8.5pl3 ^
+ -destcyg=%ROOTPATH%\cygwin_coq64_85pl3_inst ^
+ -destcoq=%ROOTPATH%\coq64_85pl3_inst
diff --git a/dev/build/windows/MakeCoq_85pl3_installer_32.bat b/dev/build/windows/MakeCoq_85pl3_installer_32.bat new file mode 100644 index 0000000000..d87ff59197 --- /dev/null +++ b/dev/build/windows/MakeCoq_85pl3_installer_32.bat @@ -0,0 +1,8 @@ +call MakeCoq_SetRootPath
+
+call MakeCoq_MinGW.bat ^
+ -arch=32 ^
+ -installer=Y ^
+ -coqver=8.5pl3 ^
+ -destcyg=%ROOTPATH%\cygwin_coq32_85pl3_inst ^
+ -destcoq=%ROOTPATH%\coq32_85pl3_inst
diff --git a/dev/build/windows/MakeCoq_86_abs_ocaml.bat b/dev/build/windows/MakeCoq_86_abs_ocaml.bat new file mode 100644 index 0000000000..50483c4d4a --- /dev/null +++ b/dev/build/windows/MakeCoq_86_abs_ocaml.bat @@ -0,0 +1,10 @@ +call MakeCoq_SetRootPath
+
+call MakeCoq_MinGW.bat ^
+ -arch=64 ^
+ -mode=absolute ^
+ -ocaml=Y ^
+ -make=Y ^
+ -coqver=8.6 ^
+ -destcyg=%ROOTPATH%\cygwin_coq64_86_abs ^
+ -destcoq=%ROOTPATH%\coq64_86_abs
diff --git a/dev/build/windows/MakeCoq_86_installer.bat b/dev/build/windows/MakeCoq_86_installer.bat new file mode 100644 index 0000000000..263520ff14 --- /dev/null +++ b/dev/build/windows/MakeCoq_86_installer.bat @@ -0,0 +1,8 @@ +call MakeCoq_SetRootPath
+
+call MakeCoq_MinGW.bat ^
+ -arch=64 ^
+ -installer=Y ^
+ -coqver=8.6 ^
+ -destcyg=%ROOTPATH%\cygwin_coq64_86_inst ^
+ -destcoq=%ROOTPATH%\coq64_86_inst
diff --git a/dev/build/windows/MakeCoq_86_installer_32.bat b/dev/build/windows/MakeCoq_86_installer_32.bat new file mode 100644 index 0000000000..14921dd7c3 --- /dev/null +++ b/dev/build/windows/MakeCoq_86_installer_32.bat @@ -0,0 +1,8 @@ +call MakeCoq_SetRootPath
+
+call MakeCoq_MinGW.bat ^
+ -arch=32 ^
+ -installer=Y ^
+ -coqver=8.6 ^
+ -destcyg=%ROOTPATH%\cygwin_coq32_86_inst ^
+ -destcoq=%ROOTPATH%\coq32_86_inst
diff --git a/dev/build/windows/MakeCoq_86beta1_abs_ocaml.bat b/dev/build/windows/MakeCoq_86beta1_abs_ocaml.bat new file mode 100644 index 0000000000..914c332f46 --- /dev/null +++ b/dev/build/windows/MakeCoq_86beta1_abs_ocaml.bat @@ -0,0 +1,10 @@ +call MakeCoq_SetRootPath
+
+call MakeCoq_MinGW.bat ^
+ -arch=64 ^
+ -mode=absolute ^
+ -ocaml=Y ^
+ -make=Y ^
+ -coqver=8.6beta1 ^
+ -destcyg=%ROOTPATH%\cygwin_coq64_86beta1_abs ^
+ -destcoq=%ROOTPATH%\coq64_86beta1_abs
diff --git a/dev/build/windows/MakeCoq_86beta1_installer.bat b/dev/build/windows/MakeCoq_86beta1_installer.bat new file mode 100644 index 0000000000..76a5bb35ac --- /dev/null +++ b/dev/build/windows/MakeCoq_86beta1_installer.bat @@ -0,0 +1,8 @@ +call MakeCoq_SetRootPath
+
+call MakeCoq_MinGW.bat ^
+ -arch=64 ^
+ -installer=Y ^
+ -coqver=8.6beta1 ^
+ -destcyg=%ROOTPATH%\cygwin_coq64_86beta1_inst ^
+ -destcoq=%ROOTPATH%\coq64_86beta1_inst
diff --git a/dev/build/windows/MakeCoq_86beta1_installer_32.bat b/dev/build/windows/MakeCoq_86beta1_installer_32.bat new file mode 100644 index 0000000000..f53232b651 --- /dev/null +++ b/dev/build/windows/MakeCoq_86beta1_installer_32.bat @@ -0,0 +1,8 @@ +call MakeCoq_SetRootPath
+
+call MakeCoq_MinGW.bat ^
+ -arch=32 ^
+ -installer=Y ^
+ -coqver=8.6beta1 ^
+ -destcyg=%ROOTPATH%\cygwin_coq32_86beta1_inst ^
+ -destcoq=%ROOTPATH%\coq32_86beta1_inst
diff --git a/dev/build/windows/MakeCoq_86git_abs_ocaml.bat b/dev/build/windows/MakeCoq_86git_abs_ocaml.bat new file mode 100644 index 0000000000..f1d855a028 --- /dev/null +++ b/dev/build/windows/MakeCoq_86git_abs_ocaml.bat @@ -0,0 +1,10 @@ +call MakeCoq_SetRootPath
+
+call MakeCoq_MinGW.bat ^
+ -arch=64 ^
+ -mode=absolute ^
+ -ocaml=Y ^
+ -make=Y ^
+ -coqver=git-v8.6 ^
+ -destcyg=%ROOTPATH%\cygwin_coq64_86git_abs ^
+ -destcoq=%ROOTPATH%\coq64_86git_abs
diff --git a/dev/build/windows/MakeCoq_86git_abs_ocaml_gtksrc.bat b/dev/build/windows/MakeCoq_86git_abs_ocaml_gtksrc.bat new file mode 100644 index 0000000000..70ab42bc36 --- /dev/null +++ b/dev/build/windows/MakeCoq_86git_abs_ocaml_gtksrc.bat @@ -0,0 +1,11 @@ +call MakeCoq_SetRootPath
+
+call MakeCoq_MinGW.bat ^
+ -arch=64 ^
+ -mode=absolute ^
+ -ocaml=Y ^
+ -make=Y ^
+ -gtksrc=Y ^
+ -coqver=git-v8.6 ^
+ -destcyg=%ROOTPATH%\cygwin_coq64_86git_abs_gtksrc ^
+ -destcoq=%ROOTPATH%\coq64_86git_abs_gtksrc
diff --git a/dev/build/windows/MakeCoq_86git_installer.bat b/dev/build/windows/MakeCoq_86git_installer.bat new file mode 100644 index 0000000000..40506318e1 --- /dev/null +++ b/dev/build/windows/MakeCoq_86git_installer.bat @@ -0,0 +1,8 @@ +call MakeCoq_SetRootPath
+
+call MakeCoq_MinGW.bat ^
+ -arch=64 ^
+ -installer=Y ^
+ -coqver=git-v8.6 ^
+ -destcyg=%ROOTPATH%\cygwin_coq64_86git_inst ^
+ -destcoq=%ROOTPATH%\coq64_86git_inst
diff --git a/dev/build/windows/MakeCoq_86git_installer2.bat b/dev/build/windows/MakeCoq_86git_installer2.bat new file mode 100644 index 0000000000..d184f0e30e --- /dev/null +++ b/dev/build/windows/MakeCoq_86git_installer2.bat @@ -0,0 +1,8 @@ +call MakeCoq_SetRootPath
+
+call MakeCoq_MinGW.bat ^
+ -arch=64 ^
+ -installer=Y ^
+ -coqver=git-v8.6 ^
+ -destcyg=%ROOTPATH%\cygwin_coq64_86git_inst2 ^
+ -destcoq=%ROOTPATH%\coq64_86git_inst2
diff --git a/dev/build/windows/MakeCoq_86git_installer_32.bat b/dev/build/windows/MakeCoq_86git_installer_32.bat new file mode 100644 index 0000000000..b9127c9454 --- /dev/null +++ b/dev/build/windows/MakeCoq_86git_installer_32.bat @@ -0,0 +1,8 @@ +call MakeCoq_SetRootPath
+
+call MakeCoq_MinGW.bat ^
+ -arch=32 ^
+ -installer=Y ^
+ -coqver=git-v8.6 ^
+ -destcyg=%ROOTPATH%\cygwin_coq32_86git_inst ^
+ -destcoq=%ROOTPATH%\coq32_86git_inst
diff --git a/dev/build/windows/MakeCoq_86rc1_abs_ocaml.bat b/dev/build/windows/MakeCoq_86rc1_abs_ocaml.bat new file mode 100644 index 0000000000..c0669f01d2 --- /dev/null +++ b/dev/build/windows/MakeCoq_86rc1_abs_ocaml.bat @@ -0,0 +1,10 @@ +call MakeCoq_SetRootPath
+
+call MakeCoq_MinGW.bat ^
+ -arch=64 ^
+ -mode=absolute ^
+ -ocaml=Y ^
+ -make=Y ^
+ -coqver=8.6rc1 ^
+ -destcyg=%ROOTPATH%\cygwin_coq64_86rc1_abs ^
+ -destcoq=%ROOTPATH%\coq64_86rc1_abs
diff --git a/dev/build/windows/MakeCoq_86rc1_installer.bat b/dev/build/windows/MakeCoq_86rc1_installer.bat new file mode 100644 index 0000000000..66234ebbde --- /dev/null +++ b/dev/build/windows/MakeCoq_86rc1_installer.bat @@ -0,0 +1,8 @@ +call MakeCoq_SetRootPath
+
+call MakeCoq_MinGW.bat ^
+ -arch=64 ^
+ -installer=Y ^
+ -coqver=8.6rc1 ^
+ -destcyg=%ROOTPATH%\cygwin_coq64_86rc1_inst ^
+ -destcoq=%ROOTPATH%\coq64_86rc1_inst
diff --git a/dev/build/windows/MakeCoq_86rc1_installer_32.bat b/dev/build/windows/MakeCoq_86rc1_installer_32.bat new file mode 100644 index 0000000000..96f43e16a5 --- /dev/null +++ b/dev/build/windows/MakeCoq_86rc1_installer_32.bat @@ -0,0 +1,8 @@ +call MakeCoq_SetRootPath
+
+call MakeCoq_MinGW.bat ^
+ -arch=32 ^
+ -installer=Y ^
+ -coqver=8.6rc1 ^
+ -destcyg=%ROOTPATH%\cygwin_coq32_86rc1_inst ^
+ -destcoq=%ROOTPATH%\coq32_86rc1_inst
diff --git a/dev/build/windows/MakeCoq_MinGW.bat b/dev/build/windows/MakeCoq_MinGW.bat new file mode 100644 index 0000000000..1e08cc5a3c --- /dev/null +++ b/dev/build/windows/MakeCoq_MinGW.bat @@ -0,0 +1,445 @@ +@ECHO OFF + +REM ========== COPYRIGHT/COPYLEFT ========== + +REM (C) 2016 Intel Deutschland GmbH +REM Author: Michael Soegtrop + +REM Released to the public by Intel under the +REM GNU Lesser General Public License Version 2.1 or later +REM See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html + +REM ========== NOTES ========== + +REM For Cygwin setup command line options +REM see https://cygwin.com/faq/faq.html#faq.setup.cli + +REM ========== DEFAULT VALUES FOR PARAMETERS ========== + +REM For a description of all parameters, see ReadMe.txt + +SET BATCHFILE=%0 +SET BATCHDIR=%~dp0 + +REM see -arch in ReadMe.txt, but values are x86_64 or i686 (not 64 or 32) +SET ARCH=x86_64 + +REM see -mode in ReadMe.txt +SET INSTALLMODE=absolute + +REM see -installer in ReadMe.txt +SET MAKEINSTALLER=N + +REM see -ocaml in ReadMe.txt +SET INSTALLOCAML=N + +REM see -make in ReadMe.txt +SET INSTALLMAKE=Y + +REM see -destcyg in ReadMe.txt +SET DESTCYG=C:\bin\cygwin_coq + +REM see -destcoq in ReadMe.txt +SET DESTCOQ=C:\bin\coq + +REM see -setup in ReadMe.txt +SET SETUP=setup-x86_64.exe + +REM see -proxy in ReadMe.txt +IF DEFINED HTTP_PROXY ( + SET PROXY="%HTTP_PROXY:http://=%" +) else ( + SET PROXY="" +) + +REM see -cygrepo in ReadMe.txt +SET CYGWIN_REPOSITORY=http://ftp.inf.tu-dresden.de/software/windows/cygwin32 + +REM see -cygcache in ReadMe.txt +SET CYGWIN_LOCAL_CACHE_WFMT=%BATCHDIR%cygwin_cache + +REM see -cyglocal in ReadMe.txt +SET CYGWIN_FROM_CACHE=N + +REM see -cygquiet in ReadMe.txt +SET CYGWIN_QUIET=Y + +REM see -srccache in ReadMe.txt +SET SOURCE_LOCAL_CACHE_WFMT=%BATCHDIR%source_cache + +REM see -coqver in ReadMe.txt +SET COQ_VERSION=8.5pl3 + +REM see -gtksrc in ReadMe.txt +SET GTK_FROM_SOURCES=N + +REM see -threads in ReadMe.txt +SET MAKE_THREADS=8 + +REM ========== PARSE COMMAND LINE PARAMETERS ========== + +SHIFT + +:Parse + +IF "%0" == "-arch" ( + IF "%1" == "32" ( + SET ARCH=i686 + SET SETUP=setup-x86.exe + ) ELSE ( + IF "%1" == "64" ( + SET ARCH=x86_64 + SET SETUP=setup-x86_64.exe + ) ELSE ( + ECHO "Invalid -arch, valid are 32 and 64" + GOTO :EOF + ) + ) + SHIFT + SHIFT + GOTO Parse +) + +IF "%0" == "-mode" ( + IF "%1" == "mingwincygwin" ( + SET INSTALLMODE=%1 + ) ELSE ( + IF "%1" == "absolute" ( + SET INSTALLMODE=%1 + ) ELSE ( + IF "%1" == "relocatable" ( + SET INSTALLMODE=%1 + ) ELSE ( + ECHO "Invalid -mode, valid are mingwincygwin, absolute and relocatable" + GOTO :EOF + ) + ) + ) + SHIFT + SHIFT + GOTO Parse +) + +IF "%0" == "-installer" ( + SET MAKEINSTALLER=%1 + SHIFT + SHIFT + GOTO Parse +) + +IF "%0" == "-ocaml" ( + SET INSTALLOCAML=%1 + SHIFT + SHIFT + GOTO Parse +) + +IF "%0" == "-make" ( + SET INSTALLMAKE=%1 + SHIFT + SHIFT + GOTO Parse +) + +IF "%0" == "-destcyg" ( + SET DESTCYG=%1 + SHIFT + SHIFT + GOTO Parse +) + +IF "%0" == "-destcoq" ( + SET DESTCOQ=%1 + SHIFT + SHIFT + GOTO Parse +) + +IF "%0" == "-setup" ( + SET SETUP=%1 + SHIFT + SHIFT + GOTO Parse +) + +IF "%0" == "-proxy" ( + SET PROXY="%1" + SHIFT + SHIFT + GOTO Parse +) + +IF "%0" == "-cygrepo" ( + SET CYGWIN_REPOSITORY="%1" + SHIFT + SHIFT + GOTO Parse +) + +IF "%0" == "-cygcache" ( + SET CYGWIN_LOCAL_CACHE_WFMT="%1" + SHIFT + SHIFT + GOTO Parse +) + +IF "%0" == "-cyglocal" ( + SET CYGWIN_FROM_CACHE=%1 + SHIFT + SHIFT + GOTO Parse +) + +IF "%0" == "-cygquiet" ( + SET CYGWIN_QUIET=%1 + SHIFT + SHIFT + GOTO Parse +) + +IF "%0" == "-srccache" ( + SET SOURCE_LOCAL_CACHE_WFMT="%1" + SHIFT + SHIFT + GOTO Parse +) + +IF "%0" == "-coqver" ( + SET COQ_VERSION=%1 + SHIFT + SHIFT + GOTO Parse +) + +IF "%0" == "-gtksrc" ( + SET GTK_FROM_SOURCES=%1 + SHIFT + SHIFT + GOTO Parse +) + +IF "%0" == "-threads" ( + SET MAKE_THREADS=%1 + SHIFT + SHIFT + GOTO Parse +) + +IF NOT "%0" == "" ( + ECHO Install cygwin and download, compile and install OCaml and Coq for MinGW + ECHO !!! Illegal parameter %0 + ECHO Usage: + ECHO MakeCoq_MinGW + CALL :PrintPars + goto :EOF +) + +IF NOT EXIST %SETUP% ( + ECHO The cygwin setup program %SETUP% doesn't exist. You must download it from https://cygwin.com/install.html. + GOTO :EOF +) + +REM ========== ADJUST PARAMETERS ========== + +IF "%INSTALLMODE%" == "mingwincygwin" ( + SET DESTCOQ=%DESTCYG%\usr\%ARCH%-w64-mingw32\sys-root\mingw +) + +IF "%MAKEINSTALLER%" == "Y" ( + SET INSTALLMODE=relocatable + SET INSTALLOCAML=Y + SET INSTALLMAKE=Y +) + +REM ========== CONFIRM PARAMETERS ========== + +CALL :PrintPars +REM Note: DOS batch replaces variables on parsing, so one can't use a variable just set in an () block +IF "%COQREGTESTING%"=="Y" (GOTO :DontAsk) + SET /p ANSWER=Is this correct? y/n + IF NOT "%ANSWER%"=="y" (GOTO :EOF) +:DontAsk + +REM ========== DERIVED VARIABLES ========== + +SET CYGWIN_INSTALLDIR_WFMT=%DESTCYG% +SET RESULT_INSTALLDIR_WFMT=%DESTCOQ% +SET TARGET_ARCH=%ARCH%-w64-mingw32 +SET BASH=%CYGWIN_INSTALLDIR_WFMT%\bin\bash + +REM Convert pathes to various formats +REM WFMT = windows format (C:\..) Used in this batch file. +REM CFMT = cygwin format (\cygdrive\c\..) Used for Cygwin PATH varible, which is : separated, so C: doesn't work. +REM MFMT = MinGW format (C:/...) Used for the build, because \\ requires escaping. Mingw can handle \ and /. + +SET CYGWIN_INSTALLDIR_MFMT=%CYGWIN_INSTALLDIR_WFMT:\=/% +SET RESULT_INSTALLDIR_MFMT=%RESULT_INSTALLDIR_WFMT:\=/% +SET SOURCE_LOCAL_CACHE_MFMT=%SOURCE_LOCAL_CACHE_WFMT:\=/% + +SET CYGWIN_INSTALLDIR_CFMT=%CYGWIN_INSTALLDIR_MFMT:C:/=/cygdrive/c/% +SET RESULT_INSTALLDIR_CFMT=%RESULT_INSTALLDIR_MFMT:C:/=/cygdrive/c/% +SET SOURCE_LOCAL_CACHE_CFMT=%SOURCE_LOCAL_CACHE_MFMT:C:/=/cygdrive/c/% + +SET CYGWIN_INSTALLDIR_CFMT=%CYGWIN_INSTALLDIR_CFMT:D:/=/cygdrive/d/% +SET RESULT_INSTALLDIR_CFMT=%RESULT_INSTALLDIR_CFMT:D:/=/cygdrive/d/% +SET SOURCE_LOCAL_CACHE_CFMT=%SOURCE_LOCAL_CACHE_CFMT:D:/=/cygdrive/d/% + +SET CYGWIN_INSTALLDIR_CFMT=%CYGWIN_INSTALLDIR_CFMT:E:/=/cygdrive/e/% +SET RESULT_INSTALLDIR_CFMT=%RESULT_INSTALLDIR_CFMT:E:/=/cygdrive/e/% +SET SOURCE_LOCAL_CACHE_CFMT=%SOURCE_LOCAL_CACHE_CFMT:E:/=/cygdrive/e/% + +ECHO CYGWIN INSTALL DIR (WIN) = %CYGWIN_INSTALLDIR_WFMT% +ECHO CYGWIN INSTALL DIR (MINGW) = %CYGWIN_INSTALLDIR_MFMT% +ECHO CYGWIN INSTALL DIR (CYGWIN) = %CYGWIN_INSTALLDIR_CFMT% +ECHO RESULT INSTALL DIR (WIN) = %RESULT_INSTALLDIR_WFMT% +ECHO RESULT INSTALL DIR (MINGW) = %RESULT_INSTALLDIR_MFMT% +ECHO RESULT INSTALL DIR (CYGWIN) = %RESULT_INSTALLDIR_CFMT% + +REM WARNING: Add a space after the = in case you want set this to empty, otherwise the variable will be unset +SET MAKE_OPT=-j %MAKE_THREADS% + +REM ========== DERIVED CYGWIN SETUP OPTIONS ========== + +REM WARNING: Add a space after the = otherwise the variable will be unset +SET CYGWIN_OPT= + +IF "%CYGWIN_FROM_CACHE%" == "Y" ( + SET CYGWIN_OPT= %CYGWIN_OPT% -L +) + +IF "%CYGWIN_QUIET%" == "Y" ( + SET CYGWIN_OPT= %CYGWIN_OPT% -q --no-admin +) + +IF "%GTK_FROM_SOURCES%"=="N" ( + SET CYGWIN_OPT= %CYGWIN_OPT% -P mingw64-%ARCH%-gtk2.0,mingw64-%ARCH%-gtksourceview2.0 +) + +ECHO ========== INSTALL CYGWIN ========== + +REM Cygwin setup sets proper ACLs (permissions) for folders it CREATES. +REM Otherwise chmod won't work and e.g. the ocaml build will fail. +REM Cygwin setup does not touch the ACLs of existing folders. +REM => Create the setup log in a temporary location and move it later. + +REM Get Unique temporary file name +:logfileloop +SET LOGFILE=%TEMP%\CygwinSetUp%RANDOM%-%RANDOM%-%RANDOM%-%RANDOM%.log +if exist "%LOGFILE%" goto :logfileloop + +REM Run Cygwin Setup + +SET RUNSETUP=Y +IF EXIST "%CYGWIN_INSTALLDIR_WFMT%\etc\setup\installed.db" ( + SET RUNSETUP=N +) +IF NOT "%CYGWIN_QUIET%" == "Y" ( + SET RUNSETUP=Y +) + +IF "%RUNSETUP%"=="Y" ( + %SETUP% ^ + --proxy %PROXY% ^ + --site %CYGWIN_REPOSITORY% ^ + --root %CYGWIN_INSTALLDIR_WFMT% ^ + --local-package-dir %CYGWIN_LOCAL_CACHE_WFMT% ^ + --no-shortcuts ^ + %CYGWIN_OPT% ^ + -P wget,curl,git,make,unzip ^ + -P gcc-core,gcc-g++ ^ + -P gdb,liblzma5 ^ + -P patch,automake1.14,automake1.15 ^ + -P mingw64-%ARCH%-binutils,mingw64-%ARCH%-gcc-core,mingw64-%ARCH%-gcc-g++,mingw64-%ARCH%-pkg-config,mingw64-%ARCH%-windows_default_manifest ^ + -P mingw64-%ARCH%-headers,mingw64-%ARCH%-runtime,mingw64-%ARCH%-pthreads,mingw64-%ARCH%-zlib ^ + -P libiconv-devel,libunistring-devel,libncurses-devel ^ + -P gettext-devel,libgettextpo-devel ^ + -P libglib2.0-devel,libgdk_pixbuf2.0-devel ^ + -P libfontconfig1 ^ + -P gtk-update-icon-cache ^ + -P libtool,automake ^ + -P intltool ^ + > "%LOGFILE%" ^ + || GOTO :Error + + MKDIR %CYGWIN_INSTALLDIR_WFMT%\build + MKDIR %CYGWIN_INSTALLDIR_WFMT%\build\buildlogs + MOVE "%LOGFILE%" %CYGWIN_INSTALLDIR_WFMT%\build\buildlogs\cygwinsetup.log || GOTO :Error +) + + +IF NOT "%CYGWIN_QUIET%" == "Y" ( + REM Like most setup programs, cygwin setup starts the real setup as a separate process, so wait for it. + REM This is not required with the -cygquiet=Y and the resulting --no-admin option. + :waitsetup + tasklist /fi "imagename eq %SETUP%" | find ":" > NUL + IF ERRORLEVEL 1 GOTO waitsetup +) + +ECHO ========== CONFIGURE CYGWIN USER ACCOUNT ========== + +copy %BATCHDIR%\configure_profile.sh %CYGWIN_INSTALLDIR_WFMT%\var\tmp || GOTO :Error +%BASH% --login %CYGWIN_INSTALLDIR_CFMT%\var\tmp\configure_profile.sh %PROXY% || GOTO :Error + +ECHO ========== BUILD COQ ========== + +MKDIR %CYGWIN_INSTALLDIR_WFMT%\build +MKDIR %CYGWIN_INSTALLDIR_WFMT%\build\patches + +COPY %BATCHDIR%\makecoq_mingw.sh %CYGWIN_INSTALLDIR_WFMT%\build || GOTO :Error +COPY %BATCHDIR%\patches_coq\*.* %CYGWIN_INSTALLDIR_WFMT%\build\patches || GOTO :Error + +%BASH% --login %CYGWIN_INSTALLDIR_CFMT%\build\makecoq_mingw.sh || GOTO :Error + +ECHO ========== FINISHED ========== + +GOTO :EOF + +ECHO ========== BATCH FUNCTIONS ========== + +:PrintPars + REM 01234567890123456789012345678901234567890123456789012345678901234567890123456789 + ECHO -arch ^<i686 or x86_64^> Set cygwin, ocaml and coq to 32 or 64 bit + ECHO -mode ^<mingwincygwin = install coq in default cygwin mingw sysroot^> + ECHO ^<absoloute = install coq in -destcoq absulute path^> + ECHO ^<relocatable = install relocatable coq in -destcoq path^> + ECHO -installer^<Y or N^> create a windows installer (will be in /build/coq/dev/nsis) + ECHO -ocaml ^<Y or N^> install OCaml in Coq folder (Y) or just in cygwin folder (N) + ECHO -make ^<Y or N^> install GNU Make in Coq folder (Y) or not (N) + ECHO -destcyg ^<path to cygwin destination folder^> + ECHO -destcoq ^<path to coq destination folder (mode=absoloute/relocatable)^> + ECHO -setup ^<cygwin setup program name^> (auto adjusted to -arch) + ECHO -proxy ^<internet proxy^> + ECHO -cygrepo ^<cygwin download repository^> + ECHO -cygcache ^<local cygwin repository/cache^> + ECHO -cyglocal ^<Y or N^> install cygwin from cache + ECHO -cygquiet ^<Y or N^> install cygwin without user interaction + ECHO -srccache ^<local source code repository/cache^> + ECHO -coqver ^<Coq version to install^> + ECHO -gtksrc ^<Y or N^> build GTK ^(90 min^) or use cygwin version + ECHO -threads ^<1..N^> Number of make threads + ECHO( + ECHO See ReadMe.txt for a detailed description of all parameters + ECHO( + ECHO Parameter values (default or currently set): + ECHO -arch = %ARCH% + ECHO -mode = %INSTALLMODE% + ECHO -ocaml = %INSTALLOCAML% + ECHO -installer= %MAKEINSTALLER% + ECHO -make = %INSTALLMAKE% + ECHO -destcyg = %DESTCYG% + ECHO -destcoq = %DESTCOQ% + ECHO -setup = %SETUP% + ECHO -proxy = %PROXY% + ECHO -cygrepo = %CYGWIN_REPOSITORY% + ECHO -cygcache = %CYGWIN_LOCAL_CACHE_WFMT% + ECHO -cyglocal = %CYGWIN_FROM_CACHE% + ECHO -cygquiet = %CYGWIN_QUIET% + ECHO -srccache = %SOURCE_LOCAL_CACHE_WFMT% + ECHO -coqver = %COQ_VERSION% + ECHO -gtksrc = %GTK_FROM_SOURCES% + ECHO -threads = %MAKE_THREADS% + GOTO :EOF + +:Error +ECHO Building Coq failed with error code %errorlevel% +EXIT /b %errorlevel% diff --git a/dev/build/windows/MakeCoq_SetRootPath.bat b/dev/build/windows/MakeCoq_SetRootPath.bat new file mode 100644 index 0000000000..3a3711724f --- /dev/null +++ b/dev/build/windows/MakeCoq_SetRootPath.bat @@ -0,0 +1,16 @@ +@ ECHO OFF + +REM Figure out a root path for coq and cygwin + +REM For the \nul trick for testing folders see +REM https://support.microsoft.com/en-us/kb/65994 + +IF EXIST D:\bin\nul ( + SET ROOTPATH=D:\bin +) else if EXIST C:\bin ( + SET ROOTPATH=C:\bin +) else ( + SET ROOTPATH=C: +) + +ECHO ROOTPATH set to %ROOTPATH% diff --git a/dev/build/windows/MakeCoq_regtest_noproxy.bat b/dev/build/windows/MakeCoq_regtest_noproxy.bat new file mode 100644 index 0000000000..2b0b83fed5 --- /dev/null +++ b/dev/build/windows/MakeCoq_regtest_noproxy.bat @@ -0,0 +1,18 @@ +call MakeCoq_SetRootPath
+
+SET HTTP_PROXY=
+EXPORT HTTP_PROXY=
+MKDIR C:\Temp\srccache
+
+call MakeCoq_MinGW.bat ^
+ -arch=64 ^
+ -mode=absolute ^
+ -ocaml=Y ^
+ -make=Y ^
+ -coqver 8.5pl2 ^
+ -srccache C:\Temp\srccache ^
+ -cygquiet=Y ^
+ -destcyg %ROOTPATH%\cygwin_coq64_85pl2_abs ^
+ -destcoq %ROOTPATH%\coq64_85pl2_abs
+ +pause
\ No newline at end of file diff --git a/dev/build/windows/MakeCoq_regtests.bat b/dev/build/windows/MakeCoq_regtests.bat new file mode 100644 index 0000000000..6e36d01404 --- /dev/null +++ b/dev/build/windows/MakeCoq_regtests.bat @@ -0,0 +1,16 @@ +SET COQREGTESTING=Y + +REM Bleeding edge +call MakeCoq_86git_abs_ocaml.bat +call MakeCoq_86git_installer.bat +call MakeCoq_86git_installer_32.bat +call MakeCoq_86git_abs_ocaml_gtksrc.bat + +REM Current stable +call MakeCoq_85pl3_abs_ocaml.bat +call MakeCoq_85pl3_installer.bat +call MakeCoq_85pl3_installer_32.bat + +REM Old but might still be used +call MakeCoq_85pl2_abs_ocaml.bat +call MakeCoq_84pl6_abs_ocaml.bat diff --git a/dev/build/windows/ReadMe.txt b/dev/build/windows/ReadMe.txt new file mode 100644 index 0000000000..0faf5bc53f --- /dev/null +++ b/dev/build/windows/ReadMe.txt @@ -0,0 +1,460 @@ +==================== Purpose / Goal ==================== + +The main purpose of these scripts is to build Coq for Windows in a reproducible +and at least by this script documented way without using binary libraries and +executables from various sources. These scripts use only MinGW libraries +provided by Cygwin or compile things from sources. For some libraries there are +options to build them from sources or to use the Cygwin version. + +Another goal (which is not yet achieved) is to have a Coq installer for +Windows, which includes all tools required for native compute and Coq plugin +development without Cygwin. + +Coq requires OCaml for this and OCaml requires binutils, gcc and a posix shell. +Since the standard Windows OCaml installation requires Cygwin to deliver some of +these components, you might be able to imagine that this is not so easy. + +These scripts can produce the following: + +- Coq running on MinGW + +- OCaml producing MinGW code and running on MinGW + +- GCC producing MinGW code and running on MinGW + +- binutils producing MinGW code and running on MinGW + +With "running on MinGW" I mean that the tools accept paths like +"C:\myfolder\myfile.txt" and that they don't link to a Cygwin or msys DLL. The +MinGW gcc and binutils provided by Cygwin produce MinGW code, but they run only +on Cygwin. + +With "producing MinGW code" I mean that the programs created by the tools accept +paths like "C:\myfolder\myfile.txt" and that they don't link to a Cygwin or msys +DLL. + +The missing piece is a posix shell running on plain Windows (without msys or +Cygwin DLL) and not beeing a binary from obscure sources. I am working on it ... + +Since compiling gcc and binutils takes a while and it is not of much use without +a shell, the building of these components is currently disabled. OCaml is built +anyway, because this MinGW/MinGW OCaml (rather than a Cygwin/MinGW OCaml) is +used to compile Coq. + +Until the shell is there, the Cygwin created by these scripts is required to run +OCaml tools. When everything is finished, this will no longer be required. + +==================== Usage ==================== + +The Script MakeCoq_MinGW does: +- download Cygwin (except the Setup.exe or Setup64.exe) +- install Cygwin +- either installs MinGW GTK via Cygwin or compiles it fom sources +- download, compile and install OCaml, CamlP5, Menhir, lablgtk +- download, compile and install Coq +- create a Windows installer (NSIS based) + +The parameters are described below. Mostly paths and the HTTP proxy need to be +set. + +There are two main usages: + +- Compile and install OCaml and Coq in a given folder + + This works reliably, because absolute library paths can be compiled into Coq + and OCaml. + + WARNING: See the "Purpose / Goal" section above for status. + + See MakeCoq_85pl2_abs_ocaml.bat for parameters. + +- Create a Windows installer. + + This works well for Coq but not so well for OCaml. + + WARNING: See the "Purpose / Goal" section above for status. + + See MakeCoq_85pl2_installer.bat for parameters. + +There is also an option to compile OCaml and Coq inside Cygwin, but this is +currently not recommended. The resulting Coq and OCaml work, but Coq is slow +because it scans the largish Cygwin share folder. This will be fixed in a future +version. + +Procedure: + +- Unzip contents of CoqSetup.zip in a folder + +- Adjust parameters in MakeCoq_85pl2_abs_ocaml.bat or in MakeCoq_85pl2_installer.bat. + +- Download Cygwin setup from https://Cygwin.com/install.html + For 32 bit Coq : setup-x86.exe (https://Cygwin.com/setup-x86.exe) + For 64 bit Coq : setup-x86_64.exe (https://Cygwin.com/setup-x86_64.exe) + +- Run MakeCoq_85pl3_abs_ocaml.bat or MakeCoq_85pl3_installer.bat + +- Check MakeCoq_regtests.bat to see what combinations of options are tested + +==================== MakeCoq_MinGW Parameters ==================== + +===== -arch ===== + +Set the target architecture. + +Possible values: + +32: Install/build Cygwin, ocaml and coq for 32 bit windows + +64: Install/build Cygwin, ocaml and coq for 64 bit windows + +Default value: 64 + + +===== -mode ===== + +Set the installation mode / target folder structure. + +Possible values: + +mingwinCygwin: Install coq in the default Cygwin mingw sysroot folder. + This is %DESTCYG%\usr\%ARCH%-w64-mingw32\sys-root\mingw. + Todo: The coq share folder should be configured to e.g. /share/coq. + As is, coqc scans the complete share folder, which slows it down 5x for short files. + +absoloute: Install coq in the absolute path given with -destcoq. + The resulting Coq will not be relocatable. + That is the root folder must not be renamed/moved. + +relocatable: Install coq in the absolute path given with -destcoq. + The resulting Coq will be relocatable. + That is the root folder may be renamed/moved. + If OCaml is installed, please note that OCaml cannot be build really relocatable. + If the root folder is moved, the environment variable OCAMLLIB must be set to the libocaml sub folder. + Also the file <root>\libocaml\ld.conf must be adjusted. + +Default value: absolute + + +===== -installer ===== + +Create a Windows installer (it will be in build/coq-8.xplx/dev/nsis) + +Possible values: + +Y: Create a windows installer - this forces -mode=relocatable. + +N: Don't create a windows installer - use the created Coq installation as is. + +Default value: N + + +===== -ocaml ===== + +Install OCaml for later use with Coq or just for building. + +Possible values: + +Y: Install OCaml in the same root as Coq (as given with -coqdest) + This also copies all .o, .cmo, .a, .cmxa files in the lib folder required for compiling plugins. + +N: Install OCaml in the default Cygwin mingw sysroot folder. + This is %DESTCYG%\usr\%ARCH%-w64-mingw32\sys-root\mingw. + +Default value: N + + +===== -make ===== + +Build and install MinGW GNU make + +Possible values: + +Y: Install MinGW GNU make in the same root as Coq (as given with -coqdest). + +N: Don't build or install MinGW GNU make. + For building everything always Cygwin GNU make is used. + +Default value: Y + + +===== -destcyg ===== + +Destination folder in which Cygwin is installed. + +This must be an absolute path in Windows format (with drive letter and \\). + +>>>>> This folder may be deleted after the Coq build is finished! <<<<< + +Default value: C:\bin\Cygwin_coq + + +===== -destcoq ===== + +Destination folder in which Coq is installed. + +This must be an absolute path in Windows format (with drive letter and \\). + +This option is not required if -mode mingwinCygwin is used. + +Default value: C:\bin\coq + + +===== -setup ===== + +Name/path of the Cygwin setup program. + +The Cygwin setup program is called setup-x86.exe or setup-x86_64.exe. +It can be downloaded from: https://Cygwin.com/install.html. + +Default value: setup-x86.exe or setup-x86_64.exe, depending on -arch. + + +===== -proxy ===== + +Internet proxy setting for downloading Cygwin, ocaml and coq. + +The format is <server>:<port>, e.g. proxy.mycompany.com:911 + +The same proxy is used for HTTP, HTTPS and FTP. +If you need separate proxies for separate protocols, you please put your proxies directly into configure_profile.sh (line 11..13). + +Default value: Value of HTTP_PROXY environment variable or none if this variable does not exist. + +ATTENTION: With the --proxy setting of the Cygwin setup, it is possible to +supply a proxy server, but if this parameter is "", Cygwin setup might use proxy +settings from previous setups. If you once did a Cygwin setup behind a firewall +and now want to do a Cygwin setup without a firewall, use the -cygquiet=N +setting to perform a GUI install, where you can adjust the proxy setting. + +===== -cygrepo ===== + +The online repository, from which Cygwin packages are downloaded. + +Note: although most repositories end with Cygwin32, they are good for 32 and 64 bit Cygwin. + +Default value: http://ftp.inf.tu-dresden.de/software/windows/Cygwin32 + +>>>>> If you are not in Europe, you might want to change this! <<<<< + + +===== -cygcache ===== + +The local cache folder for Cygwin repositories. + +You can also copy files here from a backup/reference and set -cyglocal. +The setup will then not download/update from the internet but only use the local cache. + +Default value: <folder of MakeCoq_MinGW.bat>\Cygwin_cache + + +===== -cyglocal ===== + +Control if the Cygwin setup uses the latest version from the internet or the version as is in the local folder. + +Possible values: + +Y: Install exactly the Cygwin version from the local repository cache. + Don't update from the internet. + +N: Download the latest Cygwin version from the internet. + Update the local repository cache with the latest version. + +Default value: N + + +===== -cygquiet ===== + +Control if the Cygwin setup runs quitely or interactive. + +Possible values: + +Y: Install Cygwin quitely without user interaction. + +N: Install Cygwin interactively (allows to select additional packages). + +Default value: Y + + +===== -srccache ===== + +The local cache folder for ocaml/coq/... sources. + +Default value: <folder of MakeCoq_MinGW.bat>\source_cache + + +===== -coqver ===== + +The version of Coq to download and compile. + +Possible values: 8.4pl6, 8.5pl2, 8.5pl3, git-v8.6 + Others might work, but are untested. + 8.4 is only tested in mode=absoloute + +Default value: 8.5pl3 + +If git- is prepended, the Coq sources are loaded from git. + +ATTENTION: with default options, the scripts cache source tar balls in two +places, the <destination>/build/tarballs folder and the <scripts>/source_cache +folder. If you modified something in git, you need to delete the cached tar ball +in both places! + +===== -gtksrc ===== + +Control if GTK and its prerequisites are build from sources or if binary MinGW packages from Cygwin are used + +Possible values: + +Y: Build GTK from sources, takes about 90 minutes extra. + This is useful, if you want to debug/fix GTK or library issues. + +N: Use prebuilt MinGW libraries from Cygwin + + +===== -threads ===== + +Control the maximum number of make threads for modules which support parallel make. + +Possible values: 1..N. + Should not be more than 1.5x the number of cores. + Should not be more than available RAM/2GB (e.g. 4 for 8GB) + + +==================== TODO ==================== + +- Installer doesn't remove OCAMLLIB environment variables (it is in the script, but doesn't seem to work) +- CoqIDE doesn't find theme files +- Finish / test mingw_in_Cygwin mode (coqide doesn't start, coqc slow cause of scanning complete share folder) +- Possibly create/login as specific user to bash (not sure if it makes sense - nead to create additional bash login link then) +- maybe move share/doc/menhir somehwere else (reduces coqc startup time) +- Use original installed file list for removing files in uninstaller + +==================== Issues with relocation ==================== + +Coq and OCaml are built in a specific folder and are not really intended for relocation e.g. by an installer. +Some absolute paths in config files are patched in coq_new.nsi. + +Coq is made fairly relocatable by first configuring it with PREFIX=./ and then PREFIX=<installdir>. +OCaml is made relocatable mostly by defining the OCAMLLIB environment variable and by patching some files. +If you have issues with one of the remaining (unpatched) files below, please let me know. + +Text files patched by the installer: + +./ocamllib/ld.conf +./etc/findlib.conf:destdir="D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib" +./etc/findlib.conf:path="D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib" + +Text files containing the install folder path after install: + +./bin/mkcamlp5:LIB=D:/bin/coq64_buildtest_reloc_ocaml20/libocaml/camlp5 +./bin/mkcamlp5.opt:LIB=D:/bin/coq64_buildtest_reloc_ocaml20/libocaml/camlp5 +./libocaml/Makefile.config:PREFIX=D:/bin/coq64_buildtest_reloc_ocaml20 +./libocaml/Makefile.config:LIBDIR=D:/bin/coq64_buildtest_reloc_ocaml20/libocaml +./libocaml/site-lib/findlib/Makefile.config:OCAML_CORE_BIN=/cygdrive/d/bin/coq64_buildtest_reloc_ocaml20/bin +./libocaml/site-lib/findlib/Makefile.config:OCAML_SITELIB=D:/bin/coq64_buildtest_reloc_ocaml20\libocaml\site-lib +./libocaml/site-lib/findlib/Makefile.config:OCAMLFIND_BIN=D:/bin/coq64_buildtest_reloc_ocaml20\bin +./libocaml/site-lib/findlib/Makefile.config:OCAMLFIND_CONF=D:/bin/coq64_buildtest_reloc_ocaml20\etc\findlib.conf +./libocaml/topfind:#directory "D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib/findlib";; +./libocaml/topfind: Topdirs.dir_load Format.err_formatter "D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib/findlib/findlib.cma"; +./libocaml/topfind: Topdirs.dir_load Format.err_formatter "D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib/findlib/findlib_top.cma"; +./libocaml/topfind:(* #load "D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib/findlib/findlib.cma";; *) +./libocaml/topfind:(* #load "D:\\bin\\coq64_buildtest_reloc_ocaml20\\libocaml\\site-lib/findlib/findlib_top.cma";; *) +./man/man1/camlp5.1:These files are installed in the directory D:/bin/coq64_buildtest_reloc_ocaml20/libocaml/camlp5. +./man/man1/camlp5.1:D:/bin/coq64_buildtest_reloc_ocaml20/libocaml/camlp5 + +Binary files containing the build folder path after install: + +$ find . -type f -exec grep "Cygwin_coq64_buildtest_reloc_ocaml20" {} /dev/null \; +Binary file ./bin/coqtop.byte.exe matches +Binary file ./bin/coqtop.exe matches +Binary file ./bin/ocamldoc.exe matches +Binary file ./bin/ocamldoc.opt.exe matches +Binary file ./libocaml/ocamldoc/odoc_info.a matches +Binary file ./libocaml/ocamldoc/odoc_info.cma matches + +Binary files containing the install folder path after install: + +$ find . -type f -exec grep "coq64_buildtest_reloc_ocaml20" {} /dev/null \; +Binary file ./bin/camlp4.exe matches +Binary file ./bin/camlp4boot.exe matches +Binary file ./bin/camlp4o.exe matches +Binary file ./bin/camlp4o.opt.exe matches +Binary file ./bin/camlp4of.exe matches +Binary file ./bin/camlp4of.opt.exe matches +Binary file ./bin/camlp4oof.exe matches +Binary file ./bin/camlp4oof.opt.exe matches +Binary file ./bin/camlp4orf.exe matches +Binary file ./bin/camlp4orf.opt.exe matches +Binary file ./bin/camlp4r.exe matches +Binary file ./bin/camlp4r.opt.exe matches +Binary file ./bin/camlp4rf.exe matches +Binary file ./bin/camlp4rf.opt.exe matches +Binary file ./bin/camlp5.exe matches +Binary file ./bin/camlp5o.exe matches +Binary file ./bin/camlp5o.opt matches +Binary file ./bin/camlp5r.exe matches +Binary file ./bin/camlp5r.opt matches +Binary file ./bin/camlp5sch.exe matches +Binary file ./bin/coqc.exe matches +Binary file ./bin/coqchk.exe matches +Binary file ./bin/coqdep.exe matches +Binary file ./bin/coqdoc.exe matches +Binary file ./bin/coqide.exe matches +Binary file ./bin/coqmktop.exe matches +Binary file ./bin/coqtop.byte.exe matches +Binary file ./bin/coqtop.exe matches +Binary file ./bin/coqworkmgr.exe matches +Binary file ./bin/coq_makefile.exe matches +Binary file ./bin/menhir matches +Binary file ./bin/mkcamlp4.exe matches +Binary file ./bin/ocaml.exe matches +Binary file ./bin/ocamlbuild.byte.exe matches +Binary file ./bin/ocamlbuild.exe matches +Binary file ./bin/ocamlbuild.native.exe matches +Binary file ./bin/ocamlc.exe matches +Binary file ./bin/ocamlc.opt.exe matches +Binary file ./bin/ocamldebug.exe matches +Binary file ./bin/ocamldep.exe matches +Binary file ./bin/ocamldep.opt.exe matches +Binary file ./bin/ocamldoc.exe matches +Binary file ./bin/ocamldoc.opt.exe matches +Binary file ./bin/ocamlfind.exe matches +Binary file ./bin/ocamlmklib.exe matches +Binary file ./bin/ocamlmktop.exe matches +Binary file ./bin/ocamlobjinfo.exe matches +Binary file ./bin/ocamlopt.exe matches +Binary file ./bin/ocamlopt.opt.exe matches +Binary file ./bin/ocamlprof.exe matches +Binary file ./bin/ocamlrun.exe matches +Binary file ./bin/ocpp5.exe matches +Binary file ./lib/config/coq_config.cmo matches +Binary file ./lib/config/coq_config.o matches +Binary file ./lib/grammar/grammar.cma matches +Binary file ./lib/ide/ide_win32_stubs.o matches +Binary file ./lib/lib/clib.a matches +Binary file ./lib/lib/clib.cma matches +Binary file ./lib/libcoqrun.a matches +Binary file ./libocaml/camlp4/camlp4fulllib.a matches +Binary file ./libocaml/camlp4/camlp4fulllib.cma matches +Binary file ./libocaml/camlp4/camlp4lib.a matches +Binary file ./libocaml/camlp4/camlp4lib.cma matches +Binary file ./libocaml/camlp4/camlp4o.cma matches +Binary file ./libocaml/camlp4/camlp4of.cma matches +Binary file ./libocaml/camlp4/camlp4oof.cma matches +Binary file ./libocaml/camlp4/camlp4orf.cma matches +Binary file ./libocaml/camlp4/camlp4r.cma matches +Binary file ./libocaml/camlp4/camlp4rf.cma matches +Binary file ./libocaml/camlp5/odyl.cma matches +Binary file ./libocaml/compiler-libs/ocamlcommon.a matches +Binary file ./libocaml/compiler-libs/ocamlcommon.cma matches +Binary file ./libocaml/dynlink.cma matches +Binary file ./libocaml/expunge.exe matches +Binary file ./libocaml/extract_crc.exe matches +Binary file ./libocaml/libcamlrun.a matches +Binary file ./libocaml/ocamlbuild/ocamlbuildlib.a matches +Binary file ./libocaml/ocamlbuild/ocamlbuildlib.cma matches +Binary file ./libocaml/ocamldoc/odoc_info.a matches +Binary file ./libocaml/ocamldoc/odoc_info.cma matches +Binary file ./libocaml/site-lib/findlib/findlib.a matches +Binary file ./libocaml/site-lib/findlib/findlib.cma matches +Binary file ./libocaml/site-lib/findlib/findlib.cmxs matches diff --git a/dev/build/windows/configure_profile.sh b/dev/build/windows/configure_profile.sh new file mode 100644 index 0000000000..09a9cf35a1 --- /dev/null +++ b/dev/build/windows/configure_profile.sh @@ -0,0 +1,32 @@ +#!/bin/bash + +rcfile=~/.bash_profile +donefile=~/.bash_profile.upated + +if [ ! -f $donefile ] ; then + + echo >> $rcfile + + if [ -n "$1" ]; then + echo export http_proxy="http://$1" >> $rcfile + echo export https_proxy="http://$1" >> $rcfile + echo export ftp_proxy="http://$1" >> $rcfile + fi + + mkdir -p $RESULT_INSTALLDIR_CFMT/bin + + # A tightly controlled path helps to avoid issues + # Note: the order is important: first have the cygwin binaries, then the mingw binaries in the path! + # Note: /bin is mounted at /usr/bin and /lib at /usr/lib and it is common to use /usr/bin in PATH + # See cat /proc/mounts + echo "export PATH=/usr/local/bin:/usr/bin:$RESULT_INSTALLDIR_CFMT/bin:/usr/$TARGET_ARCH/sys-root/mingw/bin:/cygdrive/c/Windows/system32:/cygdrive/c/Windows" >> $rcfile + + # find and xargs complain if the environment is larger than (I think) 8k. + # ORIGINAL_PATH (set by cygwin) can be a few k and exceed the limit + echo unset ORIGINAL_PATH >> $rcfile + + # Other installations of OCaml will mess up things + echo unset OCAMLLIB >> $rcfile + + touch $donefile +fi
\ No newline at end of file diff --git a/dev/build/windows/difftar-folder.sh b/dev/build/windows/difftar-folder.sh new file mode 100644 index 0000000000..65278d5c9c --- /dev/null +++ b/dev/build/windows/difftar-folder.sh @@ -0,0 +1,86 @@ +#!/bin/bash + +###################### COPYRIGHT/COPYLEFT ###################### + +# (C) 2016 Intel Deutschland GmbH +# Author: Michael Soegtrop +# +# Released to the public by Intel under the +# GNU Lesser General Public License Version 2.1 or later +# See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html +# +# With very valuable help on building GTK from +# https://wiki.gnome.org/Projects/GTK+/Win32/MSVCCompilationOfGTKStack +# http://www.gaia-gis.it/spatialite-3.0.0-BETA/mingw64_how_to.html + +###################### Script safety and debugging settings ###################### + +set -o nounset + +# Print usage + +if [ "$#" -lt 1 ] ; then + echo 'Diff a tar (or compressed tar) file with a folder' + echo 'difftar-folder.sh <tarfile> [<folder>] [strip]' + echo default for folder is . + echo default for strip is 0. + echo 'strip must be 0 or 1.' + exit 1 +fi + +# Parse parameters + +tarfile=$1 + +if [ "$#" -ge 2 ] ; then + folder=$2 +else + folder=. +fi + +if [ "$#" -ge 3 ] ; then + strip=$3 +else + strip=0 +fi + +# Get path prefix if --strip is used + +if [ "$strip" -gt 0 ] ; then + prefix=`tar -t -f $tarfile | head -1` +else + prefix= +fi + +# Original folder + +if [ "$strip" -gt 0 ] ; then + orig=${prefix%/}.orig +elif [ "$folder" = "." ] ; then + orig=${tarfile##*/} + orig=./${orig%%.tar*}.orig +elif [ "$folder" = "" ] ; then + orig=${tarfile##*/} + orig=${orig%%.tar*}.orig +else + orig=$folder.orig +fi +echo $orig +mkdir -p "$orig" + + +# Make sure tar uses english output (for Mod time differs) +export LC_ALL=C + +# Search all files with a deviating modification time using tar --diff +tar --diff -a -f "$tarfile" --strip $strip --directory "$folder" | grep "Mod time differs" | while read -r file ; do + # Substitute ': Mod time differs' with nothing + file=${file/: Mod time differs/} + # Check if file exists + if [ -f "$folder/$file" ] ; then + # Extract original file + tar -x -a -f "$tarfile" --strip $strip --directory "$orig" "$prefix$file" + # Compute diff + diff -u "$orig/$file" "$folder/$file" + fi +done
\ No newline at end of file diff --git a/dev/build/windows/makecoq_mingw.sh b/dev/build/windows/makecoq_mingw.sh new file mode 100644 index 0000000000..52b158871b --- /dev/null +++ b/dev/build/windows/makecoq_mingw.sh @@ -0,0 +1,1270 @@ +#!/bin/bash + +###################### COPYRIGHT/COPYLEFT ###################### + +# (C) 2016 Intel Deutschland GmbH +# Author: Michael Soegtrop +# +# Released to the public by Intel under the +# GNU Lesser General Public License Version 2.1 or later +# See https://www.gnu.org/licenses/old-licenses/lgpl-2.1.html +# +# With very valuable help on building GTK from +# https://wiki.gnome.org/Projects/GTK+/Win32/MSVCCompilationOfGTKStack +# http://www.gaia-gis.it/spatialite-3.0.0-BETA/mingw64_how_to.html + +###################### Script safety and debugging settings ###################### + +set -o nounset +set -o errexit +set -x + +# Set this to 1 if all module directories shall be removed before build (no incremental make) +RMDIR_BEFORE_BUILD=1 + +###################### NOTES ##################### + +# - This file goes together with MakeCoq_ForMignGW.bat, which sets up cygwin +# with all required packages and then calls this script. +# +# - This script uses set -o errexit, so if anything fails, the script will stop +# +# - cygwin provided mingw64 packages like mingw64-x86_64-zlib are installed to +# /usr/$TARGET_ARCH/sys-root/mingw, so we use this as install prefix +# +# - if mingw64-x86_64-pkg-config is installed BEFORE building libpng or pixman, +# the .pc files are properly created in /usr/$TARGET_ARCH/sys-root/mingw/lib/pkgconfig +# +# - pango and some others uses pkg-config executable names without path, which doesn't work in cross compile mode +# There are several possible solutions +# 1.) patch build files to get the prefix from pkg-config and use $prefix/bin/ as path +# - doesn't work for pango because automake goes wild +# - mingw tools are not able to handle cygwin path (they need absolute windows paths) +# 2.) export PATH=$PATH:/usr/$TARGET_ARCH/sys-root/mingw/bin +# - a bit dangerous because this exposes much more than required +# - mingw tools are not able to handle cygwin path (they need absolute windows paths) +# 3.) Install required tools via cygwin modules libglib2.0-devel and libgdk_pixbuf2.0-devel +# - Possibly version compatibility issues +# - Possibly mingw/cygwin compatibility issues, e.g. when building font or terminfo databases +# 4.) Build required tools for mingw and cygwin +# - Possibly mingw/cygwin compatibility issues, e.g. when building font or terminfo databases +# +# We use method 3 below +# Method 2 can be tried by putting the cross tools in the path before the cygwin tools (in configure_profile.sh) +# +# - It is tricky to build 64 bit binaries with 32 bit cross tools and vice versa. +# This is because the linker needs to load DLLs from C:\windows\system32, which contains +# both 32 bit and 64 bit DLLs, and which one you get depends by some black magic on if the using +# app is a 32 bit or 64 bit app. So better build 32 bit mingw with 32 bit cygwin and 64 with 64. +# Alternatively the required 32 bit or 64 bit DLLs need to be copied with a 32 bit/64bit cp to some +# folder without such black magic. +# +# - The file selection for the Coq Windows Installer is done with make install (unlike the original script) +# Relocatble builds are first configured with prefix=./ then build and then +# reconfigured with prefix=<installroot> before make install. + + +###################### ARCHITECTURES ##################### + +# The OS on which the build of the tool/lib runs +BUILD=`gcc -dumpmachine` + +# The OS on which the tool runs +# "`find /bin -name "*mingw32-gcc.exe"`" -dumpmachine +HOST=$TARGET_ARCH + +# The OS for which the tool creates code/for which the libs are +TARGET=$TARGET_ARCH + +# Cygwin uses different arch name for 32 bit than mingw/gcc +case $ARCH in + x86_64) CYGWINARCH=x86_64 ;; + i686) CYGWINARCH=x86 ;; + *) false ;; +esac + +###################### PATHS ##################### + +# Name and create some 'global' folders +PATCHES=/build/patches +BUILDLOGS=/build/buildlogs +FLAGFILES=/build/flagfiles +TARBALLS=/build/tarballs +FILELISTS=/build/filelists + +mkdir -p $BUILDLOGS +mkdir -p $FLAGFILES +mkdir -p $TARBALLS +mkdir -p $FILELISTS +cd /build + + +# sysroot prefix for the above /build/host/target combination +PREFIX=$CYGWIN_INSTALLDIR_MFMT/usr/$TARGET_ARCH/sys-root/mingw + +# Install / Prefix folder for COQ +PREFIXCOQ=$RESULT_INSTALLDIR_MFMT + +# Install / Prefix folder for OCaml +if [ "$INSTALLOCAML" == "Y" ]; then + PREFIXOCAML=$PREFIXCOQ +else + PREFIXOCAML=$PREFIX +fi + +mkdir -p $PREFIX/bin +mkdir -p $PREFIXCOQ/bin +mkdir -p $PREFIXOCAML/bin + +###################### Copy Cygwin Setup Info ##################### + +# Copy Cygwin repo ini file and installed files db to tarballs folder. +# Both files together document the exact selection and version of cygwin packages. +# Do this as early as possible to avoid changes by other setups (the repo folder is shared). + +# Escape URL to folder name +CYGWIN_REPO_FOLDER=${CYGWIN_REPOSITORY}/ +CYGWIN_REPO_FOLDER=${CYGWIN_REPO_FOLDER//:/%3a} +CYGWIN_REPO_FOLDER=${CYGWIN_REPO_FOLDER//\//%2f} + +# Copy files +cp $CYGWIN_LOCAL_CACHE_WFMT/$CYGWIN_REPO_FOLDER/$CYGWINARCH/setup.ini $TARBALLS +cp /etc/setup/installed.db $TARBALLS + +###################### LOGGING ##################### + +# The folder which receives log files +mkdir -p buildlogs +LOGS=`pwd`/buildlogs + +# The current log target (first part of the log file name) +LOGTARGET=other + +log1() { + "$@" > $LOGS/$LOGTARGET-$1.log 2> $LOGS/$LOGTARGET-$1.err +} + +log2() { + "$@" > $LOGS/$LOGTARGET-$1-$2.log 2> $LOGS/$LOGTARGET-$1-$2.err +} + +log_1_3() { + "$@" > $LOGS/$LOGTARGET-$1-$3.log 2> $LOGS/$LOGTARGET-$1-$3.err +} + +logn() { + LOGTARGETEX=$1 + shift + "$@" > $LOGS/$LOGTARGET-$LOGTARGETEX.log 2> $LOGS/$LOGTARGET-$LOGTARGETEX.err +} + +###################### UTILITY FUNCTIONS ##################### + +# ------------------------------------------------------------------------------ +# Get a source tar ball, expand and patch it +# - get source archive from $SOURCE_LOCAL_CACHE_CFMT or online using wget +# - create build folder +# - extract source archive +# - patch source file if patch exists +# +# Parameters +# $1 file server name including protocol prefix +# $2 file name (without extension) +# $3 file extension +# $4 number of path levels to strip from tar (usually 1) +# $5 module name (if different from archive) +# $6 expand folder name (if different from module name) +# ------------------------------------------------------------------------------ + +function get_expand_source_tar { + # Handle optional parameters + if [ "$#" -ge 4 ] ; then + strip=$4 + else + strip=1 + fi + + if [ "$#" -ge 5 ] ; then + name=$5 + else + name=$2 + fi + + if [ "$#" -ge 6 ] ; then + folder=$6 + else + folder=$name + fi + + # Set logging target + logtargetold=$LOGTARGET + LOGTARGET=$name + + # Get the source archive either from the source cache or online + if [ ! -f $TARBALLS/$name.$3 ] ; then + if [ -f $SOURCE_LOCAL_CACHE_CFMT/$name.$3 ] ; then + cp $SOURCE_LOCAL_CACHE_CFMT/$name.$3 $TARBALLS + else + wget $1/$2.$3 + if [ ! "$2.$3" == "$name.$3" ] ; then + mv $2.$3 $name.$3 + fi + mv $name.$3 $TARBALLS + # Save the source archive in the source cache + if [ -d $SOURCE_LOCAL_CACHE_CFMT ] ; then + cp $TARBALLS/$name.$3 $SOURCE_LOCAL_CACHE_CFMT + fi + fi + fi + + # Remove build directory (clean build) + if [ $RMDIR_BEFORE_BUILD -eq 1 ] ; then + rm -f -r $folder + fi + + # Create build directory and cd + mkdir -p $folder + cd $folder + + # Extract source archive + if [ "$3" == "zip" ] ; then + log1 unzip $TARBALLS/$name.$3 + if [ "$strip" == "1" ] ; then + # Ok, this is dirty, but it works and it fails if there are name clashes + mv */* . + else + echo "Unzip strip count not supported" + return 1 + fi + else + logn untar tar xvaf $TARBALLS/$name.$3 --strip $strip + fi + + # Patch if patch file exists + if [ -f $PATCHES/$name.patch ] ; then + log1 patch -p1 -i $PATCHES/$name.patch + fi + + # Go back to base folder + cd .. + + LOGTARGET=$logtargetold +} + +# ------------------------------------------------------------------------------ +# Prepare a module build +# - check if build is already done (name.finished file exists) - if so return 1 +# - create name.started +# - get source archive from $SOURCE_LOCAL_CACHE_CFMT or online using wget +# - create build folder +# - cd to build folder and extract source archive +# - create bin_special subfolder and add it to $PATH +# - remember things for build_post +# +# Parameters +# $1 file server name including protocol prefix +# $2 file name (without extension) +# $3 file extension +# $4 [optional] number of path levels to strip from tar (usually 1) +# $5 [optional] module name (if different from archive) +# ------------------------------------------------------------------------------ + +function build_prep { + # Handle optional parameters + if [ "$#" -ge 4 ] ; then + strip=$4 + else + strip=1 + fi + + if [ "$#" -ge 5 ] ; then + name=$5 + else + name=$2 + fi + + # Check if build is already done + if [ ! -f flagfiles/$name.finished ] ; then + BUILD_PACKAGE_NAME=$name + BUILD_OLDPATH=$PATH + BUILD_OLDPWD=`pwd` + LOGTARGET=$name + + touch flagfiles/$name.started + + get_expand_source_tar $1 $2 $3 $strip $name + + cd $name + + # Create a folder and add it to path, where we can put special binaries + # The path is restored in build_post + mkdir bin_special + PATH=`pwd`/bin_special:$PATH + + return 0 + else + return 1 + fi +} + +# ------------------------------------------------------------------------------ +# Finalize a module build +# - create name.finished +# - go back to base folder +# ------------------------------------------------------------------------------ + +function build_post { + if [ ! -f flagfiles/$BUILD_PACKAGE_NAME.finished ]; then + cd $BUILD_OLDPWD + touch flagfiles/$BUILD_PACKAGE_NAME.finished + PATH=$BUILD_OLDPATH + LOGTARGET=other + fi +} + +# ------------------------------------------------------------------------------ +# Build and install a module using the standard configure/make/make install process +# - prepare build (as above) +# - configure +# - make +# - make install +# - finalize build (as above) +# +# parameters +# $1 file server name including protocol prefix +# $2 file name (without extension) +# $3 file extension +# $4 patch function to call between untar and configure (or true if none) +# $5.. extra configure arguments +# ------------------------------------------------------------------------------ + +function build_conf_make_inst { + if build_prep $1 $2 $3 ; then + $4 + logn configure ./configure --build=$BUILD --host=$HOST --target=$TARGET --prefix=$PREFIX "${@:5}" + log1 make $MAKE_OPT + log2 make install + log2 make clean + build_post + fi +} + +# ------------------------------------------------------------------------------ +# Install all files given by a glob pattern to a given folder +# +# parameters +# $1 glob pattern (in '') +# $2 target folder +# ------------------------------------------------------------------------------ + +function install_glob { + # Check if any files matching the pattern exist + if [ "$(echo $1)" != "$1" ] ; then + install -D -t $2 $1 + fi +} + + +# ------------------------------------------------------------------------------ +# Recursively Install all files given by a glob pattern to a given folder +# +# parameters +# $1 source path +# $2 pattern (in '') +# $3 target folder +# ------------------------------------------------------------------------------ + +function install_rec { + ( cd $1 && find -type f -name "$2" -exec install -D -T $1/{} $3/{} \; ) +} + +# ------------------------------------------------------------------------------ +# Write a file list of the target folder +# The file lists are used to create file lists for the windows installer +# +# parameters +# $1 name of file list +# ------------------------------------------------------------------------------ + +function list_files { + if [ ! -e "/build/filelists/$1" ] ; then + ( cd $PREFIXCOQ && find -type f | sort > /build/filelists/$1 ) + fi +} + +# ------------------------------------------------------------------------------ +# Compute the set difference of two file lists +# +# parameters +# $1 name of list A-B (set difference of set A minus set B) +# $2 name of list A +# $3 name of list B +# ------------------------------------------------------------------------------ + +function diff_files { + # See http://www.catonmat.net/blog/set-operations-in-unix-shell/ for file list set operations + comm -23 <(sort "/build/filelists/$2") <(sort "/build/filelists/$3") > "/build/filelists/$1" +} + +# ------------------------------------------------------------------------------ +# Filter a list of files with a regular expression +# +# parameters +# $1 name of output file list +# $2 name of input file list +# $3 name of filter regexp +# ------------------------------------------------------------------------------ + +function filter_files { + egrep "$3" "/build/filelists/$2" > "/build/filelists/$1" +} + +# ------------------------------------------------------------------------------ +# Convert a file list to NSIS installer format +# +# parameters +# $1 name of file list file (output file is the same with extension .nsi) +# ------------------------------------------------------------------------------ + +function files_to_nsis { + # Split the path in the file list into path and filename and create SetOutPath and File instructions + # Note: File /oname cannot be used, because it does not create the paths as SetOutPath does + # Note: I didn't check if the redundant SetOutPath instructions have a bad impact on installer size or install time + cat "/build/filelists/$1" | tr '/' '\\' | sed -r 's/^\.(.*)\\([^\\]+)$/SetOutPath $INSTDIR\\\1\nFile ${COQ_SRC_PATH}\\\1\\\2/' > "/build/filelists/$1.nsh" +} + + +###################### MODULE BUILD FUNCTIONS ##################### + +##### LIBPNG ##### + +function make_libpng { + build_conf_make_inst http://prdownloads.sourceforge.net/libpng libpng-1.6.18 tar.gz true +} + +##### PIXMAN ##### + +function make_pixman { + build_conf_make_inst http://cairographics.org/releases pixman-0.32.8 tar.gz true +} + +##### FREETYPE ##### + +function make_freetype { + build_conf_make_inst http://sourceforge.net/projects/freetype/files/freetype2/2.6.1 freetype-2.6.1 tar.bz2 true +} + +##### EXPAT ##### + +function make_expat { + build_conf_make_inst http://sourceforge.net/projects/expat/files/expat/2.1.0 expat-2.1.0 tar.gz true +} + +##### FONTCONFIG ##### + +function make_fontconfig { + make_freetype + make_expat + # CONFIGURE PARAMETERS + # build/install fails without --disable-docs + build_conf_make_inst http://www.freedesktop.org/software/fontconfig/release fontconfig-2.11.94 tar.gz true --disable-docs +} + +##### ICONV ##### + +function make_libiconv { + build_conf_make_inst http://ftp.gnu.org/pub/gnu/libiconv libiconv-1.14 tar.gz true +} + +##### UNISTRING ##### + +function make_libunistring { + build_conf_make_inst http://ftp.gnu.org/gnu/libunistring libunistring-0.9.5 tar.xz true +} + +##### NCURSES ##### + +function make_ncurses { + # NOTE: ncurses is not required below. This is just kept for documentary purposes in case I need it later. + # + # NOTE: make install fails building the terminfo database because + # : ${TIC_PATH:=unknown} in run_tic.sh + # As a result pkg-config .pc files are not generated + # Also configure of gettext gives two "considers" + # checking where terminfo library functions come from... not found, consider installing GNU ncurses + # checking where termcap library functions come from... not found, consider installing GNU ncurses + # gettext make/make install work anyway + # + # CONFIGURE PARAMETERS + # --enable-term-driver --enable-sp-funcs is rewuired for mingw (see README.MinGW) + # additional changes + # ADD --with-pkg-config + # ADD --enable-pc-files + # ADD --without-manpages + # REM --with-pthread + build_conf_make_inst http://ftp.gnu.org/gnu/ncurses ncurses-5.9 tar.gz true --disable-home-terminfo --enable-reentrant --enable-sp-funcs --enable-term-driver --enable-interop --with-pkg-config --enable-pc-files --without-manpages +} + +##### GETTEXT ##### + +function make_gettext { + # Cygwin packet dependencies: (not 100% sure) libiconv-devel,libunistring-devel,libncurses-devel + # Cygwin packet dependencies for gettext users: (not 100% sure) gettext-devel,libgettextpo-devel + # gettext configure complains that ncurses is also required, but it builds without it + # Ncurses is tricky to install/configure for mingw64, so I dropped ncurses + make_libiconv + make_libunistring + build_conf_make_inst http://ftp.gnu.org/pub/gnu/gettext gettext-0.19 tar.gz true +} + +##### LIBFFI ##### + +function make_libffi { + # NOTE: The official download server is down ftp://sourceware.org/pub/libffi/libffi-3.2.1.tar.gz + build_conf_make_inst http://www.mirrorservice.org/sites/sourceware.org/pub/libffi libffi-3.2.1 tar.gz true +} + +##### LIBEPOXY ##### + +function make_libepoxy { + build_conf_make_inst https://github.com/anholt/libepoxy/releases/download/v1.3.1 libepoxy-1.3.1 tar.bz2 true +} + +##### LIBPCRE ##### + +function make_libpcre { + build_conf_make_inst ftp://ftp.csx.cam.ac.uk/pub/software/programming/pcre pcre-8.39 tar.bz2 true +} + +function make_libpcre2 { + build_conf_make_inst ftp://ftp.csx.cam.ac.uk/pub/software/programming/pcre pcre2-10.22 tar.bz2 true +} + +##### GLIB ##### + +function make_glib { + # Cygwin packet dependencies: mingw64-x86_64-zlib + make_gettext + make_libffi + make_libpcre + # build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/glib/2.46 glib-2.46.0 tar.xz true + build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/glib/2.47 glib-2.47.5 tar.xz true +} + +##### ATK ##### + +function make_atk { + make_gettext + make_glib + build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/atk/2.18 atk-2.18.0 tar.xz true +} + +##### PIXBUF ##### + +function make_gdk-pixbuf { + # Cygwin packet dependencies: mingw64-x86_64-zlib + make_libpng + make_gettext + make_glib + # CONFIGURE PARAMETERS + # --with-included-loaders=yes statically links the image file format handlers + # This avoids "Cannot open pixbuf loader module file '/usr/x86_64-w64-mingw32/sys-root/mingw/lib/gdk-pixbuf-2.0/2.10.0/loaders.cache': No such file or directory" + build_conf_make_inst http://ftp.gnome.org/pub/GNOME/sources/gdk-pixbuf/2.32 gdk-pixbuf-2.32.1 tar.xz true --with-included-loaders=yes +} + +##### CAIRO ##### + +function make_cairo { + # Cygwin packet dependencies: mingw64-x86_64-zlib + make_libpng + make_glib + make_pixman + make_fontconfig + build_conf_make_inst http://cairographics.org/releases cairo-1.14.2 tar.xz true +} + +##### PANGO ##### + +function make_pango { + make_cairo + make_glib + make_fontconfig + build_conf_make_inst http://ftp.gnome.org/pub/GNOME/sources/pango/1.38 pango-1.38.0 tar.xz true +} + +##### GTK2 ##### + +function patch_gtk2 { + rm gtk/gtk.def +} + +function make_gtk2 { + # Cygwin packet dependencies: gtk-update-icon-cache + if [ "$GTK_FROM_SOURCES" == "Y" ]; then + make_glib + make_atk + make_pango + make_gdk-pixbuf + make_cairo + build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/gtk+/2.24 gtk+-2.24.28 tar.xz patch_gtk2 + fi +} + +##### GTK3 ##### + +function make_gtk3 { + make_glib + make_atk + make_pango + make_gdk-pixbuf + make_cairo + make_libepoxy + build_conf_make_inst http://ftp.gnome.org/pub/gnome/sources/gtk+/3.16 gtk+-3.16.7 tar.xz true + + # make all incl. tests and examples runs through fine + # make install fails with issue with + # + # make[5]: Entering directory '/home/soegtrop/GTK/gtk+-3.16.7/demos/gtk-demo' + # test -n "" || ../../gtk/gtk-update-icon-cache --ignore-theme-index --force "/usr/x86_64-w64-mingw32/sys-root/mingw/share/icons/hicolor" + # gtk-update-icon-cache.exe: Failed to open file /usr/x86_64-w64-mingw32/sys-root/mingw/share/icons/hicolor/.icon-theme.cache : No such file or directory + # Makefile:1373: recipe for target 'install-update-icon-cache' failed + # make[5]: *** [install-update-icon-cache] Error 1 + # make[5]: Leaving directory '/home/soegtrop/GTK/gtk+-3.16.7/demos/gtk-demo' +} + +##### LIBXML2 ##### + +function make_libxml2 { + # Cygwin packet dependencies: libtool automake + # Note: latest release version 2.9.2 fails during configuring lzma, so using 2.9.1 + # Note: python binding requires <sys/select.h> which doesn't exist on cygwin + if build_prep https://git.gnome.org/browse/libxml2/snapshot libxml2-2.9.1 tar.xz ; then + # ./autogen.sh --build=$BUILD --host=$HOST --target=$TARGET --prefix=$PREFIX --disable-shared --without-python + # shared library required by gtksourceview + ./autogen.sh --build=$BUILD --host=$HOST --target=$TARGET --prefix=$PREFIX --without-python + log1 make $MAKE_OPT all + log2 make install + log2 make clean + build_post + fi +} + +##### GTK-SOURCEVIEW2 ##### + +function make_gtk_sourceview2 { + # Cygwin packet dependencies: intltool + # gtksourceview-2.11.2 requires GTK2 + # gtksourceview-2.91.9 requires GTK3 + # => We use gtksourceview-2.11.2 which seems to be the newest GTK2 based one + if [ "$GTK_FROM_SOURCES" == "Y" ]; then + make_gtk2 + make_libxml2 + build_conf_make_inst https://download.gnome.org/sources/gtksourceview/2.11 gtksourceview-2.11.2 tar.bz2 true + fi +} + +##### FLEXDLL FLEXLINK ##### + +# Note: there is a circular dependency between flexlink and ocaml (resolved in Ocaml 4.03.) +# For MinGW it is not even possible to first build an Ocaml without flexlink support, +# Because Makefile.nt doesn't support this. So we have to use a binary flexlink. +# One could of cause do a bootstrap run ... + +# Install flexdll objects + +function install_flexdll { + cp flexdll.h /usr/$TARGET_ARCH/sys-root/mingw/include + if [ "$TARGET_ARCH" == "i686-w64-mingw32" ]; then + cp flexdll*_mingw.o /usr/$TARGET_ARCH/bin + cp flexdll*_mingw.o $PREFIXOCAML/bin + elif [ "$TARGET_ARCH" == "x86_64-w64-mingw32" ]; then + cp flexdll*_mingw64.o /usr/$TARGET_ARCH/bin + cp flexdll*_mingw64.o $PREFIXOCAML/bin + else + echo "Unknown target architecture" + return 1 + fi +} + +# Install flexlink + +function install_flexlink { + cp flexlink.exe /usr/$TARGET_ARCH/bin + + cp flexlink.exe $PREFIXOCAML/bin +} + +# Get binary flexdll flexlink for building OCaml +# An alternative is to first build an OCaml without shared library support and build flexlink with it + +function get_flex_dll_link_bin { + if build_prep http://alain.frisch.fr/flexdll flexdll-bin-0.34 zip 1 ; then + install_flexdll + install_flexlink + build_post + fi +} + +# Build flexdll and flexlink from sources after building OCaml + +function make_flex_dll_link { + if build_prep http://alain.frisch.fr/flexdll flexdll-0.34 tar.gz ; then + if [ "$TARGET_ARCH" == "i686-w64-mingw32" ]; then + log1 make $MAKE_OPT build_mingw flexlink.exe + elif [ "$TARGET_ARCH" == "x86_64-w64-mingw32" ]; then + log1 make $MAKE_OPT build_mingw64 flexlink.exe + else + echo "Unknown target architecture" + return 1 + fi + install_flexdll + install_flexlink + log2 make clean + build_post + fi +} + +##### LN replacement ##### + +# Note: this does support symlinks, but symlinks require special user rights on Windows. +# ocamlbuild uses symlinks to link the executables in the build folder to the base folder. +# For this purpose hard links are better. + +function make_ln { + if [ ! -f flagfiles/myln.finished ] ; then + touch flagfiles/myln.started + mkdir -p myln + cd myln + cp $PATCHES/ln.c . + $TARGET_ARCH-gcc -DUNICODE -D_UNICODE -DIGNORE_SYMBOLIC -mconsole -o ln.exe ln.c + install -D ln.exe $PREFIXCOQ/bin/ln.exe + cd .. + touch flagfiles/myln.finished + fi +} + +##### OCAML ##### + +function make_ocaml { + get_flex_dll_link_bin + if build_prep http://caml.inria.fr/pub/distrib/ocaml-4.02 ocaml-4.02.3 tar.gz 1 ; then + # if build_prep http://caml.inria.fr/pub/distrib/ocaml-4.01 ocaml-4.01.0 tar.gz 1 ; then + # See README.win32 + cp config/m-nt.h config/m.h + cp config/s-nt.h config/s.h + if [ "$TARGET_ARCH" == "i686-w64-mingw32" ]; then + cp config/Makefile.mingw config/Makefile + elif [ "$TARGET_ARCH" == "x86_64-w64-mingw32" ]; then + cp config/Makefile.mingw64 config/Makefile + else + echo "Unknown target architecture" + return 1 + fi + + # Prefix is fixed in make file - replace it with the real one + sed -i "s|^PREFIX=.*|PREFIX=$PREFIXOCAML|" config/Makefile + + # We don't want to mess up Coq's dirctory structure so put the OCaml library in a separate folder + # If we refer to the make variable ${PREFIX} below, camlp4 ends up having a wrong path: + # D:\bin\coq64_buildtest_abs_ocaml4\bin>ocamlc -where => D:/bin/coq64_buildtest_abs_ocaml4/libocaml + # D:\bin\coq64_buildtest_abs_ocaml4\bin>camlp4 -where => ${PREFIX}/libocaml\camlp4 + # So we put an explicit path in there + sed -i "s|^LIBDIR=.*|LIBDIR=$PREFIXOCAML/libocaml|" config/Makefile + + # Note: ocaml doesn't support -j 8, so don't pass MAKE_OPT + # I verified that 4.02.3 still doesn't support parallel build + log2 make world -f Makefile.nt + log2 make bootstrap -f Makefile.nt + log2 make opt -f Makefile.nt + log2 make opt.opt -f Makefile.nt + log2 make install -f Makefile.nt + # TODO log2 make clean -f Makefile.nt Temporarily disabled for ocamlbuild development + + # Move license files and other into into special folder + if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then + mkdir -p $PREFIXOCAML/license_readme/ocaml + # 4.01 installs these files, 4.02 doesn't. So delete them and copy them from the sources. + rm -f *.txt + cp LICENSE $PREFIXOCAML/license_readme/ocaml/License.txt + cp INSTALL $PREFIXOCAML/license_readme/ocaml/Install.txt + cp README $PREFIXOCAML/license_readme/ocaml/ReadMe.txt + cp README.win32 $PREFIXOCAML/license_readme/ocaml/ReadMeWin32.txt + cp VERSION $PREFIXOCAML/license_readme/ocaml/Version.txt + cp Changes $PREFIXOCAML/license_readme/ocaml/Changes.txt + fi + + build_post + fi + make_flex_dll_link +} + +##### FINDLIB Ocaml library manager ##### + +function make_findlib { + make_ocaml + if build_prep http://download.camlcity.org/download findlib-1.5.6 tar.gz 1 ; then + ./configure -bindir $PREFIXOCAML\\bin -sitelib $PREFIXOCAML\\libocaml\\site-lib -config $PREFIXOCAML\\etc\\findlib.conf + # Note: findlib doesn't support -j 8, so don't pass MAKE_OPT + log2 make all + log2 make opt + log2 make install + log2 make clean + build_post + fi +} + +##### MENHIR Ocaml Parser Generator ##### + +function make_menhir { + make_ocaml + make_findlib + # if build_prep http://gallium.inria.fr/~fpottier/menhir menhir-20151112 tar.gz 1 ; then + # For Ocaml 4.02 + # if build_prep http://gallium.inria.fr/~fpottier/menhir menhir-20151012 tar.gz 1 ; then + # For Ocaml 4.01 + if build_prep http://gallium.inria.fr/~fpottier/menhir menhir-20140422 tar.gz 1 ; then + # Note: menhir doesn't support -j 8, so don't pass MAKE_OPT + log2 make all PREFIX=$PREFIXOCAML + log2 make install PREFIX=$PREFIXOCAML + mv $PREFIXOCAML/bin/menhir $PREFIXOCAML/bin/menhir.exe + build_post + fi +} + +##### CAMLP4 Ocaml Preprocessor ##### + +function make_camlp4 { + # OCaml up to 4.01 includes camlp4, from 4.02 it isn't included + # Check if command camlp4 exists, if not build camlp4 + if ! command camlp4 ; then + make_ocaml + make_findlib + if build_prep https://github.com/ocaml/camlp4/archive 4.02+6 tar.gz 1 camlp4-4.02+6 ; then + # See https://github.com/ocaml/camlp4/issues/41#issuecomment-112018910 + logn configure ./configure + # Note: camlp4 doesn't support -j 8, so don't pass MAKE_OPT + log2 make all + log2 make install + log2 make clean + build_post + fi + fi +} + +##### CAMLP5 Ocaml Preprocessor ##### + +function make_camlp5 { + make_ocaml + make_findlib + if build_prep http://camlp5.gforge.inria.fr/distrib/src camlp5-6.14 tgz 1 ; then + logn configure ./configure + # Somehow my virus scanner has the boot.new/SAVED directory locked after the move for a second => repeat until success + sed -i 's/mv boot.new boot/until mv boot.new boot; do sleep 1; done/' Makefile + log1 make world.opt $MAKE_OPT + log2 make install + # For some reason gramlib.a is not copied, but it is required by Coq + cp lib/gramlib.a $PREFIXOCAML/libocaml/camlp5/ + log2 make clean + build_post + fi +} + +##### LABLGTK Ocaml GTK binding ##### + +# Note: when rebuilding lablgtk by deleting the .finished file, +# also delete <root>\usr\x86_64-w64-mingw32\sys-root\mingw\lib\site-lib +# Otherwise make install fails + +function make_lablgtk { + make_ocaml + make_findlib + make_camlp4 + if build_prep https://forge.ocamlcore.org/frs/download.php/1479 lablgtk-2.18.3 tar.gz 1 ; then + # configure should be fixed to search for $TARGET_ARCH-pkg-config.exe + cp /bin/$TARGET_ARCH-pkg-config.exe bin_special/pkg-config.exe + logn configure ./configure --build=$BUILD --host=$HOST --target=$TARGET --prefix=$PREFIXOCAML + + # lablgtk shows occasional errors with -j, so don't pass $MAKE_OPT + + # See https://sympa.inria.fr/sympa/arc/caml-list/2015-10/msg00204.html for the make || true + strip + logn make-world-pre make world || true + $TARGET_ARCH-strip.exe --strip-unneeded src/dlllablgtk2.dll + + log2 make world + log2 make install + log2 make clean + build_post + fi +} + +##### Ocaml Stdint ##### + +function make_stdint { + make_ocaml + make_findlib + if build_prep https://github.com/andrenth/ocaml-stdint/archive 0.3.0 tar.gz 1 Stdint-0.3.0; then + # Note: the setup gets the proper install path from ocamlfind, but for whatever reason it wants + # to create an empty folder in some folder which defaults to C:\Program Files. + # The --preifx overrides this. Id didn't see any files created in /tmp/extra. + log_1_3 ocaml setup.ml -configure --prefix /tmp/extra + log_1_3 ocaml setup.ml -build + log_1_3 ocaml setup.ml -install + log_1_3 ocaml setup.ml -clean + build_post + fi +} + +##### COQ ##### + +# Copy one DLLfrom cygwin MINGW packages to Coq install folder + +function copy_coq_dll { + if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then + cp /usr/${ARCH}-w64-mingw32/sys-root/mingw/bin/$1 $PREFIXCOQ/bin/$1 + fi +} + +# Copy required DLLs from cygwin MINGW packages to Coq install folder + +function copy_coq_dlls { + # HOW TO CREATE THE DLL LIST + # With the list empty, after the build/install is finished, open coqide in dependency walker. + # See http://www.dependencywalker.com/ + # Make sure to use the 32 bit / 64 bit version of depends matching the target architecture. + # Select all missing DLLs from the module list, right click "copy filenames" + # Delay loaded DLLs from Windows can be ignored (hour-glass icon at begin of line) + # Do this recursively until there are no further missing DLLs (File close + reopen) + # For running this quickly, just do "cd coq-<ver> ; call copy_coq_dlls ; cd .." at the end of this script. + # Do the same for coqc and ocamlc (usually doesn't result in additional files) + + copy_coq_dll LIBATK-1.0-0.DLL + copy_coq_dll LIBCAIRO-2.DLL + copy_coq_dll LIBEXPAT-1.DLL + copy_coq_dll LIBFFI-6.DLL + copy_coq_dll LIBFONTCONFIG-1.DLL + copy_coq_dll LIBFREETYPE-6.DLL + copy_coq_dll LIBGDK-WIN32-2.0-0.DLL + copy_coq_dll LIBGDK_PIXBUF-2.0-0.DLL + copy_coq_dll LIBGIO-2.0-0.DLL + copy_coq_dll LIBGLIB-2.0-0.DLL + copy_coq_dll LIBGMODULE-2.0-0.DLL + copy_coq_dll LIBGOBJECT-2.0-0.DLL + copy_coq_dll LIBGTK-WIN32-2.0-0.DLL + copy_coq_dll LIBINTL-8.DLL + copy_coq_dll LIBPANGO-1.0-0.DLL + copy_coq_dll LIBPANGOCAIRO-1.0-0.DLL + copy_coq_dll LIBPANGOWIN32-1.0-0.DLL + copy_coq_dll LIBPIXMAN-1-0.DLL + copy_coq_dll LIBPNG16-16.DLL + copy_coq_dll LIBXML2-2.DLL + copy_coq_dll ZLIB1.DLL + + # Depends on if GTK is built from sources + if [ "$GTK_FROM_SOURCES" == "Y" ]; then + copy_coq_dll libiconv-2.dll + copy_coq_dll libpcre-1.dll + else + copy_coq_dll ICONV.DLL + copy_coq_dll LIBBZ2-1.DLL + copy_coq_dll LIBGTKSOURCEVIEW-2.0-0.DLL + copy_coq_dll LIBHARFBUZZ-0.DLL + copy_coq_dll LIBLZMA-5.DLL + copy_coq_dll LIBPANGOFT2-1.0-0.DLL + fi; + + # Architecture dependent files + case $ARCH in + x86_64) copy_coq_dll LIBGCC_S_SEH-1.DLL ;; + i686) copy_coq_dll LIBGCC_S_SJLJ-1.DLL ;; + *) false ;; + esac + + # Win pthread version change + copy_coq_dll LIBWINPTHREAD-1.DLL +} + +function copy_coq_objects { + # copy objects only from folders which exist in the target lib directory + find . -type d | while read FOLDER ; do + if [ -e $PREFIXCOQ/lib/$FOLDER ] ; then + install_glob $FOLDER/'*.cmxa' $PREFIXCOQ/lib/$FOLDER + install_glob $FOLDER/'*.cmi' $PREFIXCOQ/lib/$FOLDER + install_glob $FOLDER/'*.cma' $PREFIXCOQ/lib/$FOLDER + install_glob $FOLDER/'*.cmo' $PREFIXCOQ/lib/$FOLDER + install_glob $FOLDER/'*.a' $PREFIXCOQ/lib/$FOLDER + install_glob $FOLDER/'*.o' $PREFIXCOQ/lib/$FOLDER + fi + done +} + +# Copy required GTK config and suport files + +function copq_coq_gtk { + echo 'gtk-theme-name = "MS-Windows"' > $PREFIX/etc/gtk-2.0/gtkrc + echo 'gtk-fallback-icon-theme = "Tango"' >> $PREFIX/etc/gtk-2.0/gtkrc + + if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then + install_glob $PREFIX/etc/gtk-2.0/'*' $PREFIXCOQ/gtk-2.0 + install_glob $PREFIX/share/gtksourceview-2.0/language-specs/'*' $PREFIXCOQ/share/gtksourceview-2.0/language-specs + install_glob $PREFIX/share/gtksourceview-2.0/styles/'*' $PREFIXCOQ/share/gtksourceview-2.0/styles + install_rec $PREFIX/share/themes/ '*' $PREFIXCOQ/share/themes + + # This below item look like a bug in make install + if [[ ! $COQ_VERSION == 8.4* ]] ; then + mv $PREFIXCOQ/share/coq/*.lang $PREFIXCOQ/share/gtksourceview-2.0/language-specs + mv $PREFIXCOQ/share/coq/*.xml $PREFIXCOQ/share/gtksourceview-2.0/styles + fi + mkdir -p $PREFIXCOQ/ide + mv $PREFIXCOQ/share/coq/*.png $PREFIXCOQ/ide + rmdir $PREFIXCOQ/share/coq + fi +} + +# Copy license and other info files + +function copy_coq_license { + if [ "$INSTALLMODE" == "absolute" ] || [ "$INSTALLMODE" == "relocatable" ]; then + install -D doc/LICENSE $PREFIXCOQ/license_readme/coq/LicenseDoc.txt + install -D LICENSE $PREFIXCOQ/license_readme/coq/License.txt + install -D plugins/micromega/LICENSE.sos $PREFIXCOQ/license_readme/coq/LicenseMicromega.txt + install -D README $PREFIXCOQ/license_readme/coq/ReadMe.txt || true + install -D README.md $PREFIXCOQ/license_readme/coq/ReadMe.md || true + install -D README.doc $PREFIXCOQ/license_readme/coq/ReadMeDoc.txt + install -D CHANGES $PREFIXCOQ/license_readme/coq/Changes.txt + install -D INSTALL $PREFIXCOQ/license_readme/coq/Install.txt + install -D INSTALL.doc $PREFIXCOQ/license_readme/coq/InstallDoc.txt + install -D INSTALL.ide $PREFIXCOQ/license_readme/coq/InstallIde.txt + fi +} + +# Main function for creating Coq + +function make_coq { + make_ocaml + make_lablgtk + make_camlp5 + if + case $COQ_VERSION in + git-*) build_prep https://github.com/coq/coq/archive ${COQ_VERSION##git-} zip 1 coq-${COQ_VERSION} ;; + *) build_prep https://coq.inria.fr/distrib/V$COQ_VERSION/files coq-$COQ_VERSION tar.gz ;; + esac + then + if [ "$INSTALLMODE" == "relocatable" ]; then + # HACK: for relocatable builds, first configure with ./, then build but before install reconfigure with the real target path + logn configure ./configure -debug -with-doc no -prefix ./ -libdir ./lib -mandir ./man + elif [ "$INSTALLMODE" == "absolute" ]; then + logn configure ./configure -debug -with-doc no -prefix $PREFIXCOQ -libdir $PREFIXCOQ/lib -mandir $PREFIXCOQ/man + else + logn configure ./configure -debug -with-doc no -prefix $PREFIXCOQ + fi + + # The windows resource compiler binary name is hard coded + sed -i "s/i686-w64-mingw32-windres/$TARGET_ARCH-windres/" Makefile.build + sed -i "s/i686-w64-mingw32-windres/$TARGET_ARCH-windres/" Makefile.ide || true + + # 8.4x doesn't support parallel make + if [[ $COQ_VERSION == 8.4* ]] ; then + log1 make + else + log1 make $MAKE_OPT + fi + + if [ "$INSTALLMODE" == "relocatable" ]; then + ./configure -debug -with-doc no -prefix $PREFIXCOQ -libdir $PREFIXCOQ/lib -mandir $PREFIXCOQ/man + fi + + log2 make install + log1 copy_coq_dlls + if [ "$INSTALLOCAML" == "Y" ]; then + log1 copy_coq_objects + fi + + copq_coq_gtk + copy_coq_license + + # make clean seems to br broken for 8.5pl2 + # 1.) find | xargs fails on cygwin, can be fixed by sed -i 's|\| xargs rm -f|-exec rm -fv \{\} \+|' Makefile + # 2.) clean of test suites fails with "cannot run complexity tests (no bogomips found)" + # make clean + + build_post + fi +} + +##### GNU Make for MinGW ##### + +function make_mingw_make { + if build_prep http://ftp.gnu.org/gnu/make make-4.2 tar.bz2 ; then + # The config.h.win32 file is fine - don't edit it + # We need to copy the mingw gcc here as "gcc" - then the batch file will use it + cp /usr/bin/${ARCH}-w64-mingw32-gcc-5.4.0.exe ./gcc.exe + # By some magic cygwin bash can run batch files + logn build ./build_w32.bat gcc + # Copy make to Coq folder + cp GccRel/gnumake.exe $PREFIXCOQ/bin/make.exe + build_post + fi +} + +##### GNU binutils for native OCaml ##### + +function make_binutils { + if build_prep http://ftp.gnu.org/gnu/binutils binutils-2.27 tar.gz ; then + logn configure ./configure --build=$BUILD --host=$HOST --target=$TARGET --prefix=$PREFIXCOQ --program-prefix=$TARGET- + log1 make $MAKE_OPT + log2 make install + # log2 make clean + build_post + fi +} + +##### GNU GCC for native OCaml ##### + +function make_gcc { + # Note: the bz2 file is smaller, but decompressing bz2 really takes ages + if build_prep ftp://ftp.fu-berlin.de/unix/languages/gcc/releases/gcc-5.4.0 gcc-5.4.0 tar.gz ; then + # This is equivalent to "contrib/download_prerequisites" but uses caching + # Update versions when updating gcc version + get_expand_source_tar ftp://gcc.gnu.org/pub/gcc/infrastructure mpfr-2.4.2 tar.bz2 1 mpfr-2.4.2 mpfr + get_expand_source_tar ftp://gcc.gnu.org/pub/gcc/infrastructure gmp-4.3.2 tar.bz2 1 gmp-4.3.2 gmp + get_expand_source_tar ftp://gcc.gnu.org/pub/gcc/infrastructure mpc-0.8.1 tar.gz 1 mpc-0.8.1 mpc + get_expand_source_tar ftp://gcc.gnu.org/pub/gcc/infrastructure isl-0.14 tar.bz2 1 isl-0.14 isl + + # For whatever reason gcc needs this (although it never puts anything into it) + # Error: "The directory that should contain system headers does not exist:" + # mkdir -p /mingw/include without --with-sysroot + mkdir -p $PREFIXCOQ/mingw/include + + # See https://gcc.gnu.org/install/configure.html + logn configure ./configure --build=$BUILD --host=$HOST --target=$TARGET \ + --prefix=$PREFIXCOQ --program-prefix=$TARGET- --disable-win32-registry --with-sysroot=$PREFIXCOQ \ + --enable-languages=c --disable-nls \ + --disable-libsanitizer --disable-libssp --disable-libquadmath --disable-libgomp --disable-libvtv --disable-lto + # --disable-decimal-float seems to be required + # --with-sysroot=$PREFIX results in configure error that this is not an absolute path + log1 make $MAKE_OPT + log2 make install + # log2 make clean + build_post + fi +} + +##### Get sources for Cygwin MinGW packages ##### + +function get_cygwin_mingw_sources { + if [ ! -f flagfiles/cygwin_mingw_sources.finished ] ; then + touch flagfiles/cygwin_mingw_sources.started + + # Find all installed files with mingw in the name and download the corresponding source code file from cygwin + # Steps: + # grep /etc/setup/installed.db for mingw => mingw64-x86_64-gcc-g++ mingw64-x86_64-gcc-g++-5.4.0-2.tar.bz2 1 + # remove archive ending and trailing number => mingw64-x86_64-gcc-g++ mingw64-x86_64-gcc-g++-5.4.0-2 + # replace space with / => ${ARCHIVE} = mingw64-x86_64-gcc-g++/mingw64-x86_64-gcc-g++-5.4.0-2 + # escape + signs using ${var//pattern/replace} => ${ARCHIVEESC} = mingw64-x86_64-gcc-g++/mingw64-x86_64-gcc-g\+\+-5.4.0-2 + # grep cygwin setup.ini for installed line + next line (the -A 1 option includes and "after context" of 1 line) + # Note that the folders of the installed binaries and source are different. So we cannot grep just for the source line. + # We could strip off the path and just grep for the file, though. + # => install: x86_64/release/mingw64-x86_64-gcc/mingw64-x86_64-gcc-g++/mingw64-x86_64-gcc-g++-5.4.0-2.tar.xz 10163848 2f8cb7ba3e16ac8ce0455af01de490ded09061b1b06a9a8e367426635b5a33ce230e04005f059d4ea7b52580757da1f6d5bae88eba6b9da76d1bd95e8844b705 + # source: x86_64/release/mingw64-x86_64-gcc/mingw64-x86_64-gcc-5.4.0-2-src.tar.xz 95565368 03f22997b7173b243fff65ea46a39613a2e4e75fc7e6cf0fa73b7bcb86071e15ba6d0ca29d330c047fb556a5e684cad57cd2f5adb6e794249e4b01fe27f92c95 + # Take the 2nd field of the last line => ${SOURCE} = x86_64/release/mingw64-x86_64-gcc/mingw64-x86_64-gcc-5.4.0-2-src.tar.xz + # Remove that path part => ${SOURCEFILE} = mingw64-x86_64-gcc-5.4.0-2-src.tar.xz + + grep "mingw" /etc/setup/installed.db | sed 's/\.tar\.bz2 [0-1]$//' | sed 's/ /\//' | while read ARCHIVE ; do + local ARCHIVEESC=${ARCHIVE//+/\\+} + local SOURCE=`egrep -A 1 "install: ($CYGWINARCH|noarch)/release/[-+_/a-z0-9]*$ARCHIVEESC" $TARBALLS/setup.ini | tail -1 | cut -d " " -f 2` + local SOURCEFILE=${SOURCE##*/} + + # Get the source file (either from the source cache or online) + if [ ! -f $TARBALLS/$SOURCEFILE ] ; then + if [ -f $SOURCE_LOCAL_CACHE_CFMT/$SOURCEFILE ] ; then + cp $SOURCE_LOCAL_CACHE_CFMT/$SOURCEFILE $TARBALLS + else + wget "$CYGWIN_REPOSITORY/$SOURCE" + mv $SOURCEFILE $TARBALLS + # Save the source archive in the source cache + if [ -d $SOURCE_LOCAL_CACHE_CFMT ] ; then + cp $TARBALLS/$SOURCEFILE $SOURCE_LOCAL_CACHE_CFMT + fi + fi + fi + + done + + touch flagfiles/cygwin_mingw_sources.finished + fi +} + +##### Coq Windows Installer ##### + +function make_coq_installer { + make_coq + make_mingw_make + get_cygwin_mingw_sources + + # Prepare the file lists for the installer. We created to file list dumps of the target folder during the build: + # ocaml: ocaml + menhir + camlp5 + findlib + # ocal_coq: as above + coq + + # Create coq file list as ocaml_coq / ocaml + diff_files coq ocaml_coq ocaml + + # Filter out object files + filter_files coq_objects coq '\.(cmxa|cmi|cma|cmo|a|o)$' + + # Filter out plugin object files + filter_files coq_objects_plugins coq_objects '/lib/plugins/.*\.(cmxa|cmi|cma|cmo|a|o)$' + + # Coq objects objects required for plugin development = coq objects except those for pre installed plugins + diff_files coq_plugindev coq_objects coq_objects_plugins + + # Coq files, except objects needed only for plugin development + diff_files coq_base coq coq_plugindev + + # Convert section files to NSIS format + files_to_nsis coq_base + files_to_nsis coq_plugindev + files_to_nsis ocaml + + # Get and extract NSIS Binaries + if build_prep http://downloads.sourceforge.net/project/nsis/NSIS%202/2.51 nsis-2.51 zip ; then + NSIS=`pwd`/makensis.exe + chmod u+x "$NSIS" + # Change to Coq folder + cd ../coq-${COQ_VERSION} + # Copy patched nsi file + cp ../patches/coq_new.nsi dev/nsis + cp ../patches/StrRep.nsh dev/nsis + cp ../patches/ReplaceInFile.nsh dev/nsis + VERSION=`grep ^VERSION= config/Makefile | cut -d = -f 2` + cd dev/nsis + logn nsis-installer "$NSIS" -DVERSION=$VERSION -DARCH=$ARCH -DCOQ_SRC_PATH=$PREFIXCOQ -DCOQ_ICON=..\\..\\ide\\coq.ico coq_new.nsi + + build_post + fi +} + +###################### TOP LEVEL BUILD ##################### + +make_gtk2 +make_gtk_sourceview2 + +make_ocaml +make_findlib +make_lablgtk +make_camlp4 +make_camlp5 +make_menhir +make_stdint +list_files ocaml +make_coq + +if [ "$INSTALLMAKE" == "Y" ] ; then + make_mingw_make +fi + +list_files ocaml_coq + +if [ "$MAKEINSTALLER" == "Y" ] ; then + make_coq_installer +fi + diff --git a/dev/build/windows/patches_coq/ReplaceInFile.nsh b/dev/build/windows/patches_coq/ReplaceInFile.nsh new file mode 100644 index 0000000000..27c7eb2fd9 --- /dev/null +++ b/dev/build/windows/patches_coq/ReplaceInFile.nsh @@ -0,0 +1,67 @@ +; From NSIS Wiki http://nsis.sourceforge.net/ReplaceInFile +; Modifications: +; - Replace only once per line +; - Don't keep original as .old +; - Use StrRep instead of StrReplace (seems to be cleaner) + +Function Func_ReplaceInFile + ClearErrors + + Exch $0 ; REPLACEMENT + Exch + Exch $1 ; SEARCH_TEXT + Exch 2 + Exch $2 ; SOURCE_FILE + + Push $R0 ; SOURCE_FILE file handle + Push $R1 ; temporary file handle + Push $R2 ; unique temporary file name + Push $R3 ; a line to search and replace / save + Push $R4 ; shift puffer + + IfFileExists $2 +1 error ; Check if file exists and open it + FileOpen $R0 $2 "r" + + GetTempFileName $R2 ; Create temporary output file + FileOpen $R1 $R2 "w" + + loop: ; Loop over lines of file + FileRead $R0 $R3 ; Read line + IfErrors finished + Push "$R3" ; Replacine string in line once + Push "$1" + Push "$0" + Call Func_StrRep + Pop $R3 + FileWrite $R1 "$R3" ; Write result + Goto loop + + finished: + FileClose $R1 ; Close files + FileClose $R0 + Delete "$2" ; Delete original file and rename temporary file to target + Rename "$R2" "$2" + ClearErrors + Goto out + + error: + SetErrors + + out: + Pop $R4 + Pop $R3 + Pop $R2 + Pop $R1 + Pop $R0 + Pop $2 + Pop $0 + Pop $1 +FunctionEnd + +!macro ReplaceInFile SOURCE_FILE SEARCH_TEXT REPLACEMENT + Push "${SOURCE_FILE}" + Push "${SEARCH_TEXT}" + Push "${REPLACEMENT}" + Call Func_ReplaceInFile +!macroend + diff --git a/dev/build/windows/patches_coq/StrRep.nsh b/dev/build/windows/patches_coq/StrRep.nsh new file mode 100644 index 0000000000..d94a9f88b4 --- /dev/null +++ b/dev/build/windows/patches_coq/StrRep.nsh @@ -0,0 +1,60 @@ +; From NSIS Wiki http://nsis.sourceforge.net/StrRep +; Slightly modified + +Function Func_StrRep + Exch $R2 ;new + Exch 1 + Exch $R1 ;old + Exch 2 + Exch $R0 ;string + Push $R3 + Push $R4 + Push $R5 + Push $R6 + Push $R7 + Push $R8 + Push $R9 + + StrCpy $R3 0 + StrLen $R4 $R1 + StrLen $R6 $R0 + StrLen $R9 $R2 + loop: + StrCpy $R5 $R0 $R4 $R3 + StrCmp $R5 $R1 found + StrCmp $R3 $R6 done + IntOp $R3 $R3 + 1 ;move offset by 1 to check the next character + Goto loop + found: + StrCpy $R5 $R0 $R3 + IntOp $R8 $R3 + $R4 + StrCpy $R7 $R0 "" $R8 + StrCpy $R0 $R5$R2$R7 + StrLen $R6 $R0 + IntOp $R3 $R3 + $R9 ;move offset by length of the replacement string + Goto loop + done: + + Pop $R9 + Pop $R8 + Pop $R7 + Pop $R6 + Pop $R5 + Pop $R4 + Pop $R3 + Push $R0 + Push $R1 + Pop $R0 + Pop $R1 + Pop $R0 + Pop $R2 + Exch $R1 +FunctionEnd + +!macro StrRep output string old new + Push `${string}` + Push `${old}` + Push `${new}` + Call Func_StrRep + Pop ${output} +!macroend diff --git a/dev/build/windows/patches_coq/camlp4-4.02+6.patch b/dev/build/windows/patches_coq/camlp4-4.02+6.patch new file mode 100644 index 0000000000..0cdb4a929b --- /dev/null +++ b/dev/build/windows/patches_coq/camlp4-4.02+6.patch @@ -0,0 +1,11 @@ +--- camlp4-4.02-6.orig/myocamlbuild.ml 2015-06-17 13:37:36.000000000 +0200 ++++ camlp4-4.02+6/myocamlbuild.ml 2016-10-13 13:57:35.512213600 +0200 +@@ -86,7 +86,7 @@ + let dep = "camlp4"/"boot"/exe in + let cmd = + let ( / ) = Filename.concat in +- "camlp4"/"boot"/exe ++ String.escaped (String.escaped ("camlp4"/"boot"/exe)) + in + (Some dep, cmd) + in diff --git a/dev/build/windows/patches_coq/coq-8.4pl2.patch b/dev/build/windows/patches_coq/coq-8.4pl2.patch new file mode 100644 index 0000000000..45a66d0bfa --- /dev/null +++ b/dev/build/windows/patches_coq/coq-8.4pl2.patch @@ -0,0 +1,11 @@ +--- configure 2014-04-14 22:28:39.174177924 +0200 ++++ configure 2014-04-14 22:29:23.253025166 +0200 +@@ -335,7 +335,7 @@ + MAKEVERSION=`$MAKE -v | head -1 | cut -d" " -f3` + MAKEVERSIONMAJOR=`echo $MAKEVERSION | cut -d. -f1` + MAKEVERSIONMINOR=`echo $MAKEVERSION | cut -d. -f2` +- if [ "$MAKEVERSIONMAJOR" -eq 3 -a "$MAKEVERSIONMINOR" -ge 81 ]; then ++ if [ "$MAKEVERSIONMAJOR" -eq 3 -a "$MAKEVERSIONMINOR" -ge 81 ] || [ "$MAKEVERSIONMAJOR" -ge 4 ] ; then + echo "You have GNU Make $MAKEVERSION. Good!" + else + OK="no"
\ No newline at end of file diff --git a/dev/build/windows/patches_coq/coq-8.4pl6.patch b/dev/build/windows/patches_coq/coq-8.4pl6.patch new file mode 100644 index 0000000000..c3b7f8574e --- /dev/null +++ b/dev/build/windows/patches_coq/coq-8.4pl6.patch @@ -0,0 +1,13 @@ +coq-8.4pl6.orig +--- coq-8.4pl6.orig/configure 2015-04-09 15:59:35.000000000 +0200 ++++ coq-8.4pl6//configure 2016-11-09 13:29:42.235319800 +0100 +@@ -309,9 +309,6 @@ + # executable extension + + case "$ARCH,$CYGWIN" in +- win32,yes) +- EXE=".exe" +- DLLEXT=".so";; + win32,*) + EXE=".exe" + DLLEXT=".dll";; diff --git a/dev/build/windows/patches_coq/coq_new.nsi b/dev/build/windows/patches_coq/coq_new.nsi new file mode 100644 index 0000000000..b88aa066d8 --- /dev/null +++ b/dev/build/windows/patches_coq/coq_new.nsi @@ -0,0 +1,223 @@ +; This script is used to build the Windows install program for Coq. + +; NSIS Modern User Interface +; Written by Joost Verburg +; Modified by Julien Narboux, Pierre Letouzey, Enrico Tassi and Michael Soegtrop + +; The following command line defines are expected: +; VERSION Coq version, e.g. 8.5-pl2 +; ARCH The target architecture, either x86_64 or i686 +; COQ_SRC_PATH path of Coq installation in Windows or MinGW format (either \\ or /, but with drive letter) +; COQ_ICON path of Coq icon file in Windows or MinGW format + +; Enable compression after debugging. +; SetCompress off +SetCompressor lzma + +!define MY_PRODUCT "Coq" ;Define your own software name here +!define OUTFILE "coq-installer-${VERSION}-${ARCH}.exe" + +!include "MUI2.nsh" +!include "FileAssociation.nsh" +!include "StrRep.nsh" +!include "ReplaceInFile.nsh" +!include "winmessages.nsh" + +Var COQ_SRC_PATH_BS ; COQ_SRC_PATH with \ instead of / +Var COQ_SRC_PATH_DBS ; COQ_SRC_PATH with \\ instead of / +Var INSTDIR_DBS ; INSTDIR with \\ instead of \ + +;-------------------------------- +;Configuration + + Name "Coq" + + ;General + OutFile "${OUTFILE}" + + ;Folder selection page + InstallDir "C:\${MY_PRODUCT}" + + ;Remember install folder + InstallDirRegKey HKCU "Software\${MY_PRODUCT}" "" + +;-------------------------------- +;Modern UI Configuration + + !define MUI_ICON "${COQ_ICON}" + + !insertmacro MUI_PAGE_WELCOME + !insertmacro MUI_PAGE_LICENSE "${COQ_SRC_PATH}/license_readme/coq/License.txt" + !insertmacro MUI_PAGE_COMPONENTS + !define MUI_DIRECTORYPAGE_TEXT_TOP "Select where to install Coq. The path MUST NOT include spaces." + !insertmacro MUI_PAGE_DIRECTORY + !insertmacro MUI_PAGE_INSTFILES + !insertmacro MUI_PAGE_FINISH + + !insertmacro MUI_UNPAGE_WELCOME + !insertmacro MUI_UNPAGE_CONFIRM + !insertmacro MUI_UNPAGE_INSTFILES + !insertmacro MUI_UNPAGE_FINISH + +;-------------------------------- +;Languages + + !insertmacro MUI_LANGUAGE "English" + +;-------------------------------- +;Language Strings + + ;Description + LangString DESC_1 ${LANG_ENGLISH} "This package contains Coq and CoqIDE." + LangString DESC_2 ${LANG_ENGLISH} "This package contains an OCaml compiler for Coq native compute and plugin development." + LangString DESC_3 ${LANG_ENGLISH} "This package contains the development files needed in order to build a plugin for Coq." + LangString DESC_4 ${LANG_ENGLISH} "Set the OCAMLLIB environment variable for the current user." + LangString DESC_5 ${LANG_ENGLISH} "Set the OCAMLLIB environment variable for all users." + +;-------------------------------- +; Check for white spaces +Function .onVerifyInstDir + StrLen $0 "$INSTDIR" + StrCpy $1 0 + ${While} $1 < $0 + StrCpy $3 $INSTDIR 1 $1 + StrCmp $3 " " SpacesInPath + IntOp $1 $1 + 1 + ${EndWhile} + Goto done + SpacesInPath: + Abort + done: +FunctionEnd + +;-------------------------------- +;Installer Sections + + +Section "Coq" Sec1 + + SetOutPath "$INSTDIR\" + !include "..\..\..\filelists\coq_base.nsh" + + ${registerExtension} "$INSTDIR\bin\coqide.exe" ".v" "Coq Script File" + + ;Store install folder + WriteRegStr HKCU "Software\${MY_PRODUCT}" "" $INSTDIR + + ;Create uninstaller + WriteUninstaller "$INSTDIR\Uninstall.exe" + WriteRegStr HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ + "DisplayName" "Coq Version ${VERSION}" + WriteRegStr HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ + "UninstallString" '"$INSTDIR\Uninstall.exe"' + WriteRegStr HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ + "DisplayVersion" "${VERSION}" + WriteRegDWORD HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ + "NoModify" "1" + WriteRegDWORD HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ + "NoRepair" "1" + WriteRegStr HKEY_LOCAL_MACHINE "Software\Microsoft\Windows\CurrentVersion\Uninstall\Coq" \ + "URLInfoAbout" "http://coq.inria.fr" + + ; Create start menu entries + ; SetOutPath is required for the path in the .lnk files + SetOutPath "$INSTDIR" + CreateDirectory "$SMPROGRAMS\Coq" + ; The first shortcut set here is treated as main application by Windows 7/8. + ; Use CoqIDE as main application + CreateShortCut "$SMPROGRAMS\Coq\CoqIde.lnk" "$INSTDIR\bin\coqide.exe" + CreateShortCut "$SMPROGRAMS\Coq\Coq.lnk" "$INSTDIR\bin\coqtop.exe" + WriteINIStr "$SMPROGRAMS\Coq\The Coq HomePage.url" "InternetShortcut" "URL" "http://coq.inria.fr" + WriteINIStr "$SMPROGRAMS\Coq\The Coq Standard Library.url" "InternetShortcut" "URL" "http://coq.inria.fr/library" + CreateShortCut "$SMPROGRAMS\Coq\Uninstall.lnk" "$INSTDIR\Uninstall.exe" "" "$INSTDIR\Uninstall.exe" 0 + +SectionEnd + +;OCAML Section "Ocaml for native compute and plugin development" Sec2 +;OCAML SetOutPath "$INSTDIR\" +;OCAML !include "..\..\..\filelists\ocaml.nsh" +;OCAML +;OCAML ; Create a few slash / backslash variants of the source and install path +;OCAML ; Note: NSIS has variables, written as $VAR and defines, written as ${VAR} +;OCAML !insertmacro StrRep $COQ_SRC_PATH_BS ${COQ_SRC_PATH} "/" "\" +;OCAML !insertmacro StrRep $COQ_SRC_PATH_DBS ${COQ_SRC_PATH} "/" "\\" +;OCAML !insertmacro StrRep $INSTDIR_DBS $INSTDIR "\" "\\" +;OCAML +;OCAML ; Replace absolute paths in some OCaml config files +;OCAML ; These are not all, see ReadMe.txt +;OCAML !insertmacro ReplaceInFile "$INSTDIR\libocaml\ld.conf" "/" "\" +;OCAML !insertmacro ReplaceInFile "$INSTDIR\libocaml\ld.conf" "$COQ_SRC_PATH_BS" "$INSTDIR" +;OCAML !insertmacro ReplaceInFile "$INSTDIR\etc\findlib.conf" "$COQ_SRC_PATH_DBS" "$INSTDIR_DBS" +;OCAML SectionEnd + +Section "Coq files for plugin developers" Sec3 + SetOutPath "$INSTDIR\" + !include "..\..\..\filelists\coq_plugindev.nsh" +SectionEnd + +;OCAML Section "OCAMLLIB current user" Sec4 +;OCAML WriteRegStr HKCU "Environment" "OCAMLLIB" "$INSTDIR\libocaml" +;OCAML ; This is required, so that a newly started shell gets the new environment variable +;OCAML ; But it really takes a few seconds +;OCAML DetailPrint "Broadcasting OCAMLLIB environment variable change (current user)" +;OCAML SendMessage ${HWND_BROADCAST} ${WM_WININICHANGE} 0 "STR:Environment" /TIMEOUT=1000 +;OCAML SectionEnd + +;OCAML Section "OCAMLLIB all users" Sec5 +;OCAML WriteRegStr HKLM "SYSTEM\CurrentControlSet\Control\Session Manager\Environment" "OCAMLLIB" "$INSTDIR\libocaml" +;OCAML ; This is required, so that a newly started shell gets the new environment variable +;OCAML ; But it really takes a few seconds +;OCAML DetailPrint "Broadcasting OCAMLLIB environment variable change (all users)" +;OCAML SendMessage ${HWND_BROADCAST} ${WM_WININICHANGE} 0 "STR:Environment" /TIMEOUT=1000 +;OCAML SectionEnd + +;-------------------------------- +;Descriptions + +!insertmacro MUI_FUNCTION_DESCRIPTION_BEGIN + !insertmacro MUI_DESCRIPTION_TEXT ${Sec1} $(DESC_1) + ;OCAML !insertmacro MUI_DESCRIPTION_TEXT ${Sec2} $(DESC_2) + !insertmacro MUI_DESCRIPTION_TEXT ${Sec3} $(DESC_3) + ;OCAML !insertmacro MUI_DESCRIPTION_TEXT ${Sec4} $(DESC_4) + ;OCAML !insertmacro MUI_DESCRIPTION_TEXT ${Sec5} $(DESC_5) +!insertmacro MUI_FUNCTION_DESCRIPTION_END + +;-------------------------------- +;Uninstaller Section + +Section "Uninstall" + ; Files and folders + RMDir /r "$INSTDIR\bin" + RMDir /r "$INSTDIR\dev" + RMDir /r "$INSTDIR\etc" + RMDir /r "$INSTDIR\lib" + RMDir /r "$INSTDIR\libocaml" + RMDir /r "$INSTDIR\share" + RMDir /r "$INSTDIR\ide" + RMDir /r "$INSTDIR\gtk-2.0" + RMDir /r "$INSTDIR\latex" + RMDir /r "$INSTDIR\license_readme" + RMDir /r "$INSTDIR\man" + RMDir /r "$INSTDIR\emacs" + + ; Start Menu + Delete "$SMPROGRAMS\Coq\Coq.lnk" + Delete "$SMPROGRAMS\Coq\CoqIde.lnk" + Delete "$SMPROGRAMS\Coq\Uninstall.lnk" + Delete "$SMPROGRAMS\Coq\The Coq HomePage.url" + Delete "$SMPROGRAMS\Coq\The Coq Standard Library.url" + Delete "$INSTDIR\Uninstall.exe" + + ; Registry keys + DeleteRegKey HKCU "Software\${MY_PRODUCT}" + DeleteRegKey HKLM "SOFTWARE\Coq" + DeleteRegKey HKLM "SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\Coq" + DeleteRegKey HKCU "Environment\OCAMLLIB" + DeleteRegKey HKLM "SYSTEM\CurrentControlSet\Control\Session Manager\Environment\OCAMLLIB" + ${unregisterExtension} ".v" "Coq Script File" + + ; Root folders + RMDir "$INSTDIR" + RMDir "$SMPROGRAMS\Coq" + +SectionEnd diff --git a/dev/build/windows/patches_coq/flexdll-0.34.patch b/dev/build/windows/patches_coq/flexdll-0.34.patch new file mode 100644 index 0000000000..16389baca3 --- /dev/null +++ b/dev/build/windows/patches_coq/flexdll-0.34.patch @@ -0,0 +1,14 @@ +reloc.ml +--- orig.flexdll-0.34/reloc.ml 2015-01-22 17:30:07.000000000 +0100 ++++ flexdll-0.34/reloc.ml 2016-10-12 11:59:16.885829700 +0200 +@@ -117,8 +117,8 @@ + + let new_cmdline () = + let rf = match !toolchain with +- | `MSVC | `MSVC64 | `LIGHTLD -> true +- | `MINGW | `MINGW64 | `GNAT | `CYGWIN | `CYGWIN64 -> false ++ | `MSVC | `MSVC64 | `LIGHTLD | `MINGW | `MINGW64 -> true ++ | `GNAT | `CYGWIN | `CYGWIN64 -> false + in + { + may_use_response_file = rf; diff --git a/dev/build/windows/patches_coq/glib-2.46.0.patch b/dev/build/windows/patches_coq/glib-2.46.0.patch new file mode 100644 index 0000000000..9082460bf0 --- /dev/null +++ b/dev/build/windows/patches_coq/glib-2.46.0.patch @@ -0,0 +1,30 @@ +diff -u -r glib-2.46.0/gio/glocalfile.c glib-2.46.0.patched/gio/glocalfile.c +--- glib-2.46.0/gio/glocalfile.c 2015-08-27 05:32:26.000000000 +0200 ++++ glib-2.46.0.patched/gio/glocalfile.c 2016-01-27 13:08:30.059736400 +0100 +@@ -2682,7 +2682,10 @@ + (!g_path_is_absolute (filename) || len > g_path_skip_root (filename) - filename)) + wfilename[len] = '\0'; + +- retval = _wstat32i64 (wfilename, &buf); ++ // MSoegtrop: _wstat32i64 is the wrong function for GLocalFileStat = struct _stati64 ++ // The correct function is _wstati64, see https://msdn.microsoft.com/en-us/library/14h5k7ff.aspx ++ // Also _wstat32i64 is a VC function, not a windows SDK function, see https://msdn.microsoft.com/en-us/library/aa273365(v=vs.60).aspx ++ retval = _wstati64 (wfilename, &buf); + save_errno = errno; + + g_free (wfilename); +diff -u -r glib-2.46.0/glib/gstdio.c glib-2.46.0.patched/glib/gstdio.c +--- glib-2.46.0/glib/gstdio.c 2015-02-26 13:57:09.000000000 +0100 ++++ glib-2.46.0.patched/glib/gstdio.c 2016-01-27 13:31:12.708987700 +0100 +@@ -493,7 +493,10 @@ + (!g_path_is_absolute (filename) || len > g_path_skip_root (filename) - filename)) + wfilename[len] = '\0'; + +- retval = _wstat (wfilename, buf); ++ // MSoegtrop: _wstat32i64 is the wrong function for GLocalFileStat = struct _stati64 ++ // The correct function is _wstati64, see https://msdn.microsoft.com/en-us/library/14h5k7ff.aspx ++ // Also _wstat32i64 is a VC function, not a windows SDK function, see https://msdn.microsoft.com/en-us/library/aa273365(v=vs.60).aspx ++ retval = _wstati64 (wfilename, buf); + save_errno = errno; + + g_free (wfilename); diff --git a/dev/build/windows/patches_coq/gtksourceview-2.11.2.patch b/dev/build/windows/patches_coq/gtksourceview-2.11.2.patch new file mode 100644 index 0000000000..73a098d12a --- /dev/null +++ b/dev/build/windows/patches_coq/gtksourceview-2.11.2.patch @@ -0,0 +1,213 @@ +diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourceiter.c gtksourceview-2.11.2.patched/gtksourceview/gtksourceiter.c +*** gtksourceview-2.11.2.orig/gtksourceview/gtksourceiter.c 2010-05-30 12:24:14.000000000 +0200 +--- gtksourceview-2.11.2.patched/gtksourceview/gtksourceiter.c 2015-10-27 14:58:54.422888400 +0100 +*************** +*** 80,86 **** + /* If string contains prefix, check that prefix is not followed + * by a unicode mark symbol, e.g. that trailing 'a' in prefix + * is not part of two-char a-with-hat symbol in string. */ +! return type != G_UNICODE_COMBINING_MARK && + type != G_UNICODE_ENCLOSING_MARK && + type != G_UNICODE_NON_SPACING_MARK; + } +--- 80,86 ---- + /* If string contains prefix, check that prefix is not followed + * by a unicode mark symbol, e.g. that trailing 'a' in prefix + * is not part of two-char a-with-hat symbol in string. */ +! return type != G_UNICODE_SPACING_MARK && + type != G_UNICODE_ENCLOSING_MARK && + type != G_UNICODE_NON_SPACING_MARK; + } +diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcelanguagemanager.c gtksourceview-2.11.2.patched/gtksourceview/gtksourcelanguagemanager.c +*** gtksourceview-2.11.2.orig/gtksourceview/gtksourcelanguagemanager.c 2010-05-30 12:24:14.000000000 +0200 +--- gtksourceview-2.11.2.patched/gtksourceview/gtksourcelanguagemanager.c 2015-10-27 14:55:30.294477600 +0100 +*************** +*** 274,280 **** + * containg a list of language files directories. + * The array is owned by @lm and must not be modified. + */ +! G_CONST_RETURN gchar* G_CONST_RETURN * + gtk_source_language_manager_get_search_path (GtkSourceLanguageManager *lm) + { + g_return_val_if_fail (GTK_IS_SOURCE_LANGUAGE_MANAGER (lm), NULL); +--- 274,280 ---- + * containg a list of language files directories. + * The array is owned by @lm and must not be modified. + */ +! const gchar* const * + gtk_source_language_manager_get_search_path (GtkSourceLanguageManager *lm) + { + g_return_val_if_fail (GTK_IS_SOURCE_LANGUAGE_MANAGER (lm), NULL); +*************** +*** 392,398 **** + * available languages or %NULL if no language is available. The array + * is owned by @lm and must not be modified. + */ +! G_CONST_RETURN gchar* G_CONST_RETURN * + gtk_source_language_manager_get_language_ids (GtkSourceLanguageManager *lm) + { + g_return_val_if_fail (GTK_IS_SOURCE_LANGUAGE_MANAGER (lm), NULL); +--- 392,398 ---- + * available languages or %NULL if no language is available. The array + * is owned by @lm and must not be modified. + */ +! const gchar* const * + gtk_source_language_manager_get_language_ids (GtkSourceLanguageManager *lm) + { + g_return_val_if_fail (GTK_IS_SOURCE_LANGUAGE_MANAGER (lm), NULL); +diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcelanguagemanager.h gtksourceview-2.11.2.patched/gtksourceview/gtksourcelanguagemanager.h +*** gtksourceview-2.11.2.orig/gtksourceview/gtksourcelanguagemanager.h 2009-11-15 00:41:33.000000000 +0100 +--- gtksourceview-2.11.2.patched/gtksourceview/gtksourcelanguagemanager.h 2015-10-27 14:55:30.518500000 +0100 +*************** +*** 62,74 **** + + GtkSourceLanguageManager *gtk_source_language_manager_get_default (void); + +! G_CONST_RETURN gchar* G_CONST_RETURN * + gtk_source_language_manager_get_search_path (GtkSourceLanguageManager *lm); + + void gtk_source_language_manager_set_search_path (GtkSourceLanguageManager *lm, + gchar **dirs); + +! G_CONST_RETURN gchar* G_CONST_RETURN * + gtk_source_language_manager_get_language_ids (GtkSourceLanguageManager *lm); + + GtkSourceLanguage *gtk_source_language_manager_get_language (GtkSourceLanguageManager *lm, +--- 62,74 ---- + + GtkSourceLanguageManager *gtk_source_language_manager_get_default (void); + +! const gchar* const * + gtk_source_language_manager_get_search_path (GtkSourceLanguageManager *lm); + + void gtk_source_language_manager_set_search_path (GtkSourceLanguageManager *lm, + gchar **dirs); + +! const gchar* const * + gtk_source_language_manager_get_language_ids (GtkSourceLanguageManager *lm); + + GtkSourceLanguage *gtk_source_language_manager_get_language (GtkSourceLanguageManager *lm, +diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcestylescheme.c gtksourceview-2.11.2.patched/gtksourceview/gtksourcestylescheme.c +*** gtksourceview-2.11.2.orig/gtksourceview/gtksourcestylescheme.c 2010-05-30 12:24:14.000000000 +0200 +--- gtksourceview-2.11.2.patched/gtksourceview/gtksourcestylescheme.c 2015-10-27 14:55:30.545502700 +0100 +*************** +*** 310,316 **** + * + * Since: 2.0 + */ +! G_CONST_RETURN gchar* G_CONST_RETURN * + gtk_source_style_scheme_get_authors (GtkSourceStyleScheme *scheme) + { + g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME (scheme), NULL); +--- 310,316 ---- + * + * Since: 2.0 + */ +! const gchar* const * + gtk_source_style_scheme_get_authors (GtkSourceStyleScheme *scheme) + { + g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME (scheme), NULL); +*************** +*** 318,324 **** + if (scheme->priv->authors == NULL) + return NULL; + +! return (G_CONST_RETURN gchar* G_CONST_RETURN *)scheme->priv->authors->pdata; + } + + /** +--- 318,324 ---- + if (scheme->priv->authors == NULL) + return NULL; + +! return (const gchar* const *)scheme->priv->authors->pdata; + } + + /** +diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcestylescheme.h gtksourceview-2.11.2.patched/gtksourceview/gtksourcestylescheme.h +*** gtksourceview-2.11.2.orig/gtksourceview/gtksourcestylescheme.h 2010-03-29 15:02:56.000000000 +0200 +--- gtksourceview-2.11.2.patched/gtksourceview/gtksourcestylescheme.h 2015-10-27 14:55:30.565504700 +0100 +*************** +*** 61,67 **** + const gchar *gtk_source_style_scheme_get_name (GtkSourceStyleScheme *scheme); + const gchar *gtk_source_style_scheme_get_description(GtkSourceStyleScheme *scheme); + +! G_CONST_RETURN gchar* G_CONST_RETURN * + gtk_source_style_scheme_get_authors (GtkSourceStyleScheme *scheme); + + const gchar *gtk_source_style_scheme_get_filename (GtkSourceStyleScheme *scheme); +--- 61,67 ---- + const gchar *gtk_source_style_scheme_get_name (GtkSourceStyleScheme *scheme); + const gchar *gtk_source_style_scheme_get_description(GtkSourceStyleScheme *scheme); + +! const gchar* const * + gtk_source_style_scheme_get_authors (GtkSourceStyleScheme *scheme); + + const gchar *gtk_source_style_scheme_get_filename (GtkSourceStyleScheme *scheme); +diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcestyleschememanager.c gtksourceview-2.11.2.patched/gtksourceview/gtksourcestyleschememanager.c +*** gtksourceview-2.11.2.orig/gtksourceview/gtksourcestyleschememanager.c 2010-05-30 12:24:14.000000000 +0200 +--- gtksourceview-2.11.2.patched/gtksourceview/gtksourcestyleschememanager.c 2015-10-27 14:55:30.583506500 +0100 +*************** +*** 515,521 **** + * of string containing the search path. + * The array is owned by the @manager and must not be modified. + */ +! G_CONST_RETURN gchar* G_CONST_RETURN * + gtk_source_style_scheme_manager_get_search_path (GtkSourceStyleSchemeManager *manager) + { + g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME_MANAGER (manager), NULL); +--- 515,521 ---- + * of string containing the search path. + * The array is owned by the @manager and must not be modified. + */ +! const gchar* const * + gtk_source_style_scheme_manager_get_search_path (GtkSourceStyleSchemeManager *manager) + { + g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME_MANAGER (manager), NULL); +*************** +*** 554,560 **** + * of string containing the ids of the available style schemes or %NULL if no + * style scheme is available. The array is owned by the @manager and must not be modified. + */ +! G_CONST_RETURN gchar* G_CONST_RETURN * + gtk_source_style_scheme_manager_get_scheme_ids (GtkSourceStyleSchemeManager *manager) + { + g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME_MANAGER (manager), NULL); +--- 554,560 ---- + * of string containing the ids of the available style schemes or %NULL if no + * style scheme is available. The array is owned by the @manager and must not be modified. + */ +! const gchar* const * + gtk_source_style_scheme_manager_get_scheme_ids (GtkSourceStyleSchemeManager *manager) + { + g_return_val_if_fail (GTK_IS_SOURCE_STYLE_SCHEME_MANAGER (manager), NULL); +diff -c -r gtksourceview-2.11.2.orig/gtksourceview/gtksourcestyleschememanager.h gtksourceview-2.11.2.patched/gtksourceview/gtksourcestyleschememanager.h +*** gtksourceview-2.11.2.orig/gtksourceview/gtksourcestyleschememanager.h 2009-11-15 00:41:33.000000000 +0100 +--- gtksourceview-2.11.2.patched/gtksourceview/gtksourcestyleschememanager.h 2015-10-27 14:56:24.498897500 +0100 +*************** +*** 73,84 **** + void gtk_source_style_scheme_manager_prepend_search_path (GtkSourceStyleSchemeManager *manager, + const gchar *path); + +! G_CONST_RETURN gchar* G_CONST_RETURN * + gtk_source_style_scheme_manager_get_search_path (GtkSourceStyleSchemeManager *manager); + + void gtk_source_style_scheme_manager_force_rescan (GtkSourceStyleSchemeManager *manager); + +! G_CONST_RETURN gchar* G_CONST_RETURN * + gtk_source_style_scheme_manager_get_scheme_ids (GtkSourceStyleSchemeManager *manager); + + GtkSourceStyleScheme *gtk_source_style_scheme_manager_get_scheme (GtkSourceStyleSchemeManager *manager, +--- 73,84 ---- + void gtk_source_style_scheme_manager_prepend_search_path (GtkSourceStyleSchemeManager *manager, + const gchar *path); + +! const gchar* const * + gtk_source_style_scheme_manager_get_search_path (GtkSourceStyleSchemeManager *manager); + + void gtk_source_style_scheme_manager_force_rescan (GtkSourceStyleSchemeManager *manager); + +! const gchar* const * + gtk_source_style_scheme_manager_get_scheme_ids (GtkSourceStyleSchemeManager *manager); + + GtkSourceStyleScheme *gtk_source_style_scheme_manager_get_scheme (GtkSourceStyleSchemeManager *manager, diff --git a/dev/build/windows/patches_coq/isl-0.14.patch b/dev/build/windows/patches_coq/isl-0.14.patch new file mode 100644 index 0000000000..f3b8ead1ab --- /dev/null +++ b/dev/build/windows/patches_coq/isl-0.14.patch @@ -0,0 +1,11 @@ +--- orig.isl-0.14/configure 2014-10-26 08:36:32.000000000 +0100 ++++ isl-0.14/configure 2016-10-10 18:16:01.430224500 +0200 +@@ -8134,7 +8134,7 @@ + lt_sysroot=`$CC --print-sysroot 2>/dev/null` + fi + ;; #( +- /*) ++ /*|[A-Z]:\\*|[A-Z]:/*) + lt_sysroot=`echo "$with_sysroot" | sed -e "$sed_quote_subst"` + ;; #( + no|'') diff --git a/dev/build/windows/patches_coq/lablgtk-2.18.3.patch b/dev/build/windows/patches_coq/lablgtk-2.18.3.patch new file mode 100644 index 0000000000..0691c1fc8f --- /dev/null +++ b/dev/build/windows/patches_coq/lablgtk-2.18.3.patch @@ -0,0 +1,87 @@ +diff -u -r lablgtk-2.18.3/configure lablgtk-2.18.3.patched/configure +--- lablgtk-2.18.3/configure 2014-10-29 08:51:05.000000000 +0100 ++++ lablgtk-2.18.3.patched/configure 2015-10-29 08:58:08.543985500 +0100 +@@ -2667,7 +2667,7 @@ + fi + + +-if test "`$OCAMLFIND printconf stdlib`" != "`$CAMLC -where`"; then ++if test "`$OCAMLFIND printconf stdlib | tr '\\' '/'`" != "`$CAMLC -where | tr '\\' '/'`"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Ignoring ocamlfind" >&5 + $as_echo "$as_me: WARNING: Ignoring ocamlfind" >&2;} + OCAMLFIND=no + +diff -u -r lablgtk-2.18.3/src/glib.mli lablgtk-2.18.3.patched/src/glib.mli +--- lablgtk-2.18.3/src/glib.mli 2014-10-29 08:51:06.000000000 +0100 ++++ lablgtk-2.18.3.patched/src/glib.mli 2016-01-25 09:50:59.884715200 +0100 +@@ -75,6 +75,7 @@ + type condition = [ `ERR | `HUP | `IN | `NVAL | `OUT | `PRI] + type id + val channel_of_descr : Unix.file_descr -> channel ++ val channel_of_descr_socket : Unix.file_descr -> channel + val add_watch : + cond:condition list -> callback:(condition list -> bool) -> ?prio:int -> channel -> id + val remove : id -> unit + +diff -u -r lablgtk-2.18.3/src/glib.ml lablgtk-2.18.3.patched/src/glib.ml +--- lablgtk-2.18.3/src/glib.ml 2014-10-29 08:51:06.000000000 +0100 ++++ lablgtk-2.18.3.patched/src/glib.ml 2016-01-25 09:50:59.891715900 +0100 +@@ -72,6 +72,8 @@ + type id + external channel_of_descr : Unix.file_descr -> channel + = "ml_g_io_channel_unix_new" ++ external channel_of_descr_socket : Unix.file_descr -> channel ++ = "ml_g_io_channel_unix_new_socket" + external remove : id -> unit = "ml_g_source_remove" + external add_watch : + cond:condition list -> callback:(condition list -> bool) -> ?prio:int -> channel -> id + +diff -u -r lablgtk-2.18.3/src/ml_glib.c lablgtk-2.18.3.patched/src/ml_glib.c +--- lablgtk-2.18.3/src/ml_glib.c 2014-10-29 08:51:06.000000000 +0100 ++++ lablgtk-2.18.3.patched/src/ml_glib.c 2016-01-25 09:50:59.898716600 +0100 +@@ -25,6 +25,8 @@ + #include <string.h> + #include <locale.h> + #ifdef _WIN32 ++/* to kill a #warning: include winsock2.h before windows.h */ ++#include <winsock2.h> + #include "win32.h" + #include <wtypes.h> + #include <io.h> +@@ -38,6 +40,11 @@ + #include <caml/callback.h> + #include <caml/threads.h> + ++#ifdef _WIN32 ++/* for Socket_val */ ++#include <caml/unixsupport.h> ++#endif ++ + #include "wrappers.h" + #include "ml_glib.h" + #include "glib_tags.h" +@@ -325,14 +332,23 @@ + + #ifndef _WIN32 + ML_1 (g_io_channel_unix_new, Int_val, Val_GIOChannel_noref) ++CAMLprim value ml_g_io_channel_unix_new_socket (value arg1) { ++ return Val_GIOChannel_noref (g_io_channel_unix_new (Int_val (arg1))); ++} + + #else + CAMLprim value ml_g_io_channel_unix_new(value wh) + { + return Val_GIOChannel_noref +- (g_io_channel_unix_new ++ (g_io_channel_win32_new_fd + (_open_osfhandle((long)*(HANDLE*)Data_custom_val(wh), O_BINARY))); + } ++ ++CAMLprim value ml_g_io_channel_unix_new_socket(value wh) ++{ ++ return Val_GIOChannel_noref ++ (g_io_channel_win32_new_socket(Socket_val(wh))); ++} + #endif + + static gboolean ml_g_io_channel_watch(GIOChannel *s, GIOCondition c, diff --git a/dev/build/windows/patches_coq/ln.c b/dev/build/windows/patches_coq/ln.c new file mode 100644 index 0000000000..5e02c72bb7 --- /dev/null +++ b/dev/build/windows/patches_coq/ln.c @@ -0,0 +1,137 @@ +// (C) 2016 Intel Deutschland GmbH +// Author: Michael Soegtrop +// Released to the public under CC0 +// See https://creativecommons.org/publicdomain/zero/1.0/ + +// Windows drop in repacement for Linux ln +// Supports command form "ln TARGET LINK_NAME" +// Supports -s and -f options +// Does not support hard links to folders (but symlinks are ok) + +#include <windows.h> +#include <stdio.h> +#include <tchar.h> + +// Cygwin MinGW doesn't have this Vista++ function in windows.h +#ifdef UNICODE + WINBASEAPI BOOLEAN APIENTRY CreateSymbolicLinkW ( LPCWSTR, LPCWSTR, DWORD ); + #define CreateSymbolicLink CreateSymbolicLinkW + #define CommandLineToArgv CommandLineToArgvW +#else + WINBASEAPI BOOLEAN APIENTRY CreateSymbolicLinkA ( LPCSTR, LPCSTR, DWORD ); + #define CreateSymbolicLink CreateSymbolicLinkA + #define CommandLineToArgv CommandLineToArgvA +#endif +#define SYMBOLIC_LINK_FLAG_DIRECTORY 1 + +int WINAPI WinMain( HINSTANCE hInstance, HINSTANCE hPrevInstance, LPSTR lpCmdLineA, int nShowCmd ) +{ + int iarg; + BOOL symbolic = FALSE; + BOOL force = FALSE; + BOOL folder; + const _TCHAR *target; + const _TCHAR *link; + LPTSTR lpCmdLine; + int argc; + LPTSTR *argv; + + // Parse command line + // This is done explicitly here for two reasons + // 1.) MinGW doesn't seem to support _tmain, wWinMain and the like + // 2.) We want to make sure that CommandLineToArgv is used + lpCmdLine = GetCommandLine(); + argv = CommandLineToArgv( lpCmdLine, &argc ); + + // Get target and link name + if( argc<3 ) + { + _ftprintf( stderr, _T("Expecting at least 2 arguments, got %d\n"), argc-1 ); + return 1; + } + target = argv[argc-2]; + link = argv[argc-1]; + + // Parse options + // The last two arguments are interpreted as file names + // All other arguments must be -s or -f os multi letter options like -sf + for(iarg=1; iarg<argc-2; iarg++ ) + { + const _TCHAR *pos = argv[iarg]; + if( *pos != _T('-') ) + { + _ftprintf( stderr, _T("Command line option expected in argument %d\n"), iarg ); + return 1; + } + pos ++; + + while( *pos ) + { + switch( *pos ) + { + case _T('s') : symbolic = TRUE; break; + case _T('f') : force = TRUE; break; + default : + _ftprintf( stderr, _T("Unknown option '%c'\n"), *pos ); + return 1; + } + pos ++; + } + } + + #ifdef IGNORE_SYMBOLIC + symbolic = FALSE; + #endif + + // Check if link already exists - delete it if force is given or abort + { + if( GetFileAttributes(link) != INVALID_FILE_ATTRIBUTES ) + { + if( force ) + { + if( !DeleteFile( link ) ) + { + _ftprintf( stderr, _T("Error deleting file '%s'\n"), link ); + return 1; + } + } + else + { + _ftprintf( stderr, _T("File '%s' exists!\n"), link ); + return 1; + } + } + } + + // Check if target is a folder + folder = ( (GetFileAttributes(target) & FILE_ATTRIBUTE_DIRECTORY) ) != 0; + + // Create link + if(symbolic) + { + if( !CreateSymbolicLink( link, target, folder ? SYMBOLIC_LINK_FLAG_DIRECTORY : 0 ) ) + { + _ftprintf( stderr, _T("Error creating symbolic link '%s' -> '%s'!\n"), link, target ); + return 1; + } + } + else + { + if( folder ) + { + _ftprintf( stderr, _T("Cannot create hard link to folder") ); + return 1; + } + else + { + if( !CreateHardLink( link, target, NULL ) ) + { + _ftprintf( stderr, _T("Error creating hard link '%s' -> '%s'!\n"), link, target ); + return 1; + } + } + } + + // Everything is fine + return 0; +}
\ No newline at end of file diff --git a/dev/ci/ci-color.sh b/dev/ci/ci-color.sh new file mode 100755 index 0000000000..78ae7f02f9 --- /dev/null +++ b/dev/ci/ci-color.sh @@ -0,0 +1,8 @@ +#!/bin/bash + +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +svn checkout https://scm.gforge.inria.fr/anonscm/svn/color/trunk/color color + +( cd color && make -j ${NJOBS} ) diff --git a/dev/ci/ci-common.sh b/dev/ci/ci-common.sh new file mode 100644 index 0000000000..412da626fd --- /dev/null +++ b/dev/ci/ci-common.sh @@ -0,0 +1,52 @@ +#!/bin/bash + +set -xe + +# Coq's tools need an ending slash :S, we should fix them. +export COQBIN=`pwd`/bin/ +export PATH=`pwd`/bin:$PATH + +ls `pwd`/bin + +# Maybe we should just use Ruby... +mathcomp_CI_BRANCH=master +mathcomp_CI_GITURL=https://github.com/math-comp/math-comp.git + +# git_checkout branch +git_checkout() +{ + local _BRANCH=${1} + local _URL=${2} + local _DEST=${3} + + echo "Checking out ${_DEST}" + git clone --depth 1 -b ${_BRANCH} ${_URL} ${_DEST} + ( cd ${3} && echo "${_DEST}: `git log -1 --format='%s | %H | %cd | %aN'`" ) +} + +checkout_mathcomp() +{ + git_checkout ${mathcomp_CI_BRANCH} ${mathcomp_CI_GITURL} ${1} +} + +# this installs just the ssreflect library of math-comp +install_ssreflect() +{ + echo 'Installing ssreflect' && echo -en 'travis_fold:start:ssr.install\\r' + + checkout_mathcomp math-comp + ( cd math-comp/mathcomp && \ + sed -i.bak '/ssrtest/d' Make && \ + sed -i.bak '/odd_order/d' Make && \ + sed -i.bak '/all\/all.v/d' Make && \ + sed -i.bak '/character/d' Make && \ + sed -i.bak '/real_closed/d' Make && \ + sed -i.bak '/solvable/d' Make && \ + sed -i.bak '/field/d' Make && \ + sed -i.bak '/fingroup/d' Make && \ + sed -i.bak '/algebra/d' Make && \ + make Makefile.coq && make -f Makefile.coq -j ${NJOBS} all && make install ) + + echo -en 'travis_fold:end:ssr.install\\r' + +} diff --git a/dev/ci/ci-compcert.sh b/dev/ci/ci-compcert.sh new file mode 100755 index 0000000000..ec09389f8e --- /dev/null +++ b/dev/ci/ci-compcert.sh @@ -0,0 +1,13 @@ +#!/bin/bash + +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +CompCert_CI_BRANCH=master +CompCert_CI_GITURL=https://github.com/AbsInt/CompCert.git + +opam install -j ${NJOBS} -y menhir +git_checkout ${CompCert_CI_BRANCH} ${CompCert_CI_GITURL} CompCert + +# Patch to avoid the upper version limit +( cd CompCert && sed -i.bak 's/8.6)/8.6|trunk)/' configure && ./configure x86_32-linux && make -j ${NJOBS} ) diff --git a/dev/ci/ci-coquelicot.sh b/dev/ci/ci-coquelicot.sh new file mode 100755 index 0000000000..94bd5e468f --- /dev/null +++ b/dev/ci/ci-coquelicot.sh @@ -0,0 +1,12 @@ +#!/bin/bash + +# $0 is not the safest way, but... +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +install_ssreflect + +# Setup coquelicot +git_checkout master https://scm.gforge.inria.fr/anonscm/git/coquelicot/coquelicot.git coquelicot + +( cd coquelicot && ./autogen.sh && ./configure && ./remake -j${NJOBS} ) diff --git a/dev/ci/ci-cpdt.sh b/dev/ci/ci-cpdt.sh new file mode 100755 index 0000000000..18d7561804 --- /dev/null +++ b/dev/ci/ci-cpdt.sh @@ -0,0 +1,10 @@ +#!/bin/bash + +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +wget http://adam.chlipala.net/cpdt/cpdt.tgz +tar xvfz cpdt.tgz + +( cd cpdt && make clean && make -j ${NJOBS} ) + diff --git a/dev/ci/ci-fiat-crypto.sh b/dev/ci/ci-fiat-crypto.sh new file mode 100755 index 0000000000..c669195ddd --- /dev/null +++ b/dev/ci/ci-fiat-crypto.sh @@ -0,0 +1,9 @@ +#!/bin/bash + +# $0 is not the safest way, but... +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +git_checkout master https://github.com/mit-plv/fiat-crypto.git fiat-crypto + +( cd fiat-crypto && make -j ${NJOBS} ) diff --git a/dev/ci/ci-flocq.sh b/dev/ci/ci-flocq.sh new file mode 100755 index 0000000000..345924e40a --- /dev/null +++ b/dev/ci/ci-flocq.sh @@ -0,0 +1,9 @@ +#!/bin/bash + +# $0 is not the safest way, but... +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +git_checkout master https://scm.gforge.inria.fr/anonscm/git/flocq/flocq.git flocq + +( cd flocq && ./autogen.sh && ./configure && ./remake -j${NJOBS} ) diff --git a/dev/ci/ci-geocoq.sh b/dev/ci/ci-geocoq.sh new file mode 100755 index 0000000000..29667b018a --- /dev/null +++ b/dev/ci/ci-geocoq.sh @@ -0,0 +1,18 @@ +#!/bin/bash + +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +# XXX: replace by generic template +GeoCoq_CI_BRANCH=master +GeoCoq_CI_GITURL=https://github.com/GeoCoq/GeoCoq.git + +git_checkout ${GeoCoq_CI_BRANCH} ${GeoCoq_CI_GITURL} GeoCoq + +( cd GeoCoq && \ + ./configure.sh && \ + sed -i.bak '/Ch16_coordinates_with_functions\.v/d' Make && \ + sed -i.bak '/Elements\/Book_1\.v/d' Make && \ + sed -i.bak '/Elements\/Book_3\.v/d' Make && \ + coq_makefile -f Make -o Makefile && \ + make -j ${NJOBS} ) diff --git a/dev/ci/ci-hott.sh b/dev/ci/ci-hott.sh new file mode 100755 index 0000000000..0c07564c02 --- /dev/null +++ b/dev/ci/ci-hott.sh @@ -0,0 +1,8 @@ +#!/bin/bash + +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +git_checkout mz-8.7 https://github.com/ejgallego/HoTT.git HoTT + +( cd HoTT && ./autogen.sh && ./configure && make -j ${NJOBS} ) diff --git a/dev/ci/ci-iris-coq.sh b/dev/ci/ci-iris-coq.sh new file mode 100755 index 0000000000..c21af976f4 --- /dev/null +++ b/dev/ci/ci-iris-coq.sh @@ -0,0 +1,17 @@ +#!/bin/bash + +# $0 is not the safest way, but... +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +install_ssreflect + +# Setup stdpp +git_checkout master https://gitlab.mpi-sws.org/robbertkrebbers/coq-stdpp.git coq-stdpp + +( cd coq-stdpp && make -j ${NJOBS} && make install ) + +# Setup Iris +git_checkout master https://gitlab.mpi-sws.org/FP/iris-coq.git iris-coq + +( cd iris-coq && make -j ${NJOBS} ) diff --git a/dev/ci/ci-math-classes.sh b/dev/ci/ci-math-classes.sh new file mode 100755 index 0000000000..4450dc0710 --- /dev/null +++ b/dev/ci/ci-math-classes.sh @@ -0,0 +1,12 @@ +#!/bin/bash + +# $0 is not the safest way, but... +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +git_checkout v8.6 https://github.com/math-classes/math-classes.git math-classes +( cd math-classes && make -j ${NJOBS} && make install ) + +git_checkout v8.6 https://github.com/c-corn/corn.git corn +( cd corn && make -j ${NJOBS} ) + diff --git a/dev/ci/ci-math-comp.sh b/dev/ci/ci-math-comp.sh new file mode 100755 index 0000000000..2eb150cb52 --- /dev/null +++ b/dev/ci/ci-math-comp.sh @@ -0,0 +1,13 @@ +#!/bin/bash + +# $0 is not the safest way, but... +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +checkout_mathcomp math-comp + +# odd_order takes too much time for travis. +( cd math-comp/mathcomp && \ + sed -i.bak '/PFsection/d' Make && \ + sed -i.bak '/stripped_odd_order_theorem/d' Make && \ + make Makefile.coq && make -f Makefile.coq -j ${NJOBS} all ) diff --git a/dev/ci/ci-metacoq.sh b/dev/ci/ci-metacoq.sh new file mode 100755 index 0000000000..91a33695b0 --- /dev/null +++ b/dev/ci/ci-metacoq.sh @@ -0,0 +1,16 @@ +#!/bin/bash + +# $0 is not the safest way, but... +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +# MetaCoq + UniCoq + +git_checkout master https://github.com/unicoq/unicoq.git unicoq + +( cd unicoq && coq_makefile -f Make -o Makefile && make -j ${NJOBS} && make install ) + +git_checkout master https://github.com/MetaCoq/MetaCoq.git MetaCoq + +( cd MetaCoq && coq_makefile -f _CoqProject -o Makefile && make -j ${NJOBS} ) + diff --git a/dev/ci/ci-sf.sh b/dev/ci/ci-sf.sh new file mode 100755 index 0000000000..5e41211f1a --- /dev/null +++ b/dev/ci/ci-sf.sh @@ -0,0 +1,11 @@ +#!/bin/bash + +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +wget https://www.cis.upenn.edu/~bcpierce/sf/current/sf.tgz +tar xvfz sf.tgz + +( cd sf && sed -i.bak 's/(K,N)/((K,N))/' LibTactics.v && make clean && make -j ${NJOBS} ) + + diff --git a/dev/ci/ci-tlc.sh b/dev/ci/ci-tlc.sh new file mode 100755 index 0000000000..b946324924 --- /dev/null +++ b/dev/ci/ci-tlc.sh @@ -0,0 +1,8 @@ +#!/bin/bash + +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +git_checkout master https://gforge.inria.fr/git/tlc/tlc.git tlc + +( cd tlc && make -j ${NJOBS} ) diff --git a/dev/ci/ci-unimath.sh b/dev/ci/ci-unimath.sh new file mode 100755 index 0000000000..15e619acbb --- /dev/null +++ b/dev/ci/ci-unimath.sh @@ -0,0 +1,15 @@ +#!/bin/bash + +ci_dir="$(dirname "$0")" +source ${ci_dir}/ci-common.sh + +UniMath_CI_BRANCH=master +UniMath_CI_GITURL=https://github.com/UniMath/UniMath.git + +git_checkout ${UniMath_CI_BRANCH} ${UniMath_CI_GITURL} UniMath + +( cd UniMath && \ + sed -i.bak '/Folds/d' Makefile && \ + sed -i.bak '/HomologicalAlgebra/d' Makefile && \ + make -j ${NJOBS} BUILD_COQ=no ) + @@ -51,6 +51,7 @@ install_printer Top_printers.prsubst install_printer Top_printers.prdelta install_printer Top_printers.ppfconstr install_printer Top_printers.ppgenarginfo +install_printer Top_printers.ppgenargargt install_printer Top_printers.ppist install_printer Top_printers.ppconstrunderbindersidmap install_printer Top_printers.ppunbound_ltac_var_map diff --git a/dev/doc/changes.txt b/dev/doc/changes.txt index fcee79e07e..3de938d774 100644 --- a/dev/doc/changes.txt +++ b/dev/doc/changes.txt @@ -2,6 +2,11 @@ = CHANGES BETWEEN COQ V8.5 AND COQ V8.6 = ========================================= +** Parsing ** + +Pcoq.parsable now takes an extra optional filename argument so as to +bind locations to a file name when relevant. + ** Files ** To avoid clashes with OCaml's compiler libs, the following files were renamed: @@ -9,6 +14,8 @@ kernel/closure.ml{,i} -> kernel/cClosure.ml{,i} lib/errors.ml{,i} -> lib/cErrors.ml{,i} toplevel/cerror.ml{,i} -> toplevel/explainErr.mli{,i} +All IDE-specific files, including the XML protocol have been moved to ide/ + ** Reduction functions ** In closure.ml, we introduced the more precise reduction flags fMATCH, fFIX, @@ -211,6 +218,8 @@ val get_id_for_feedback : unit -> edit_or_state_id * route_id for constructing compound entries still works over this scheme. Note that in the case of (VERNAC) ARGUMENT EXTEND, the name of the argument entry is bound in the parsing rules, so beware of recursive calls. + + For example, to get "wit_constr" you must "open Constrarg" at the top of the file. - Evarutil was split in two parts. The new Evardefine file exposes functions define_evar_* mostly used internally in the unification engine. @@ -237,6 +246,10 @@ define_evar_* mostly used internally in the unification engine. ... let Sigma (xn, sigma, pn) = ... in Sigma (ans, sigma, p1 +> ... +> pn) + + Examples of `Sigma.Unsafe.of_evar_map` include: + + Evarutil.new_evar env (Tacmach.project goal) ty ----> Evarutil.new_evar env (Sigma.Unsafe.of_evar_map (Tacmach.project goal)) ty - The Proofview.Goal.*enter family of functions now takes a polymorphic continuation given as a record as an argument. @@ -249,7 +262,17 @@ define_evar_* mostly used internally in the unification engine. Proofview.Goal.enter { enter = begin fun gl -> ... end } -- `Tacexpr.TacDynamic(Loc.dummy_loc, Pretyping.constr_in c)` --> `Tacinterp.Value.of_constr c` +- `Tacexpr.TacDynamic(Loc.dummy_loc, Pretyping.constr_in c)` ---> `Tacinterp.Value.of_constr c` +- `Vernacexpr.HintsResolveEntry(priority, poly, hnf, path, atom)` ---> `Vernacexpr.HintsResolveEntry(Vernacexpr.({hint_priority = priority; hint_pattern = None}), poly, hnf, path, atom)` +- `Pretyping.Termops.mem_named_context` ---> `Engine.Termops.mem_named_context_val` + (`Global.named_context` ---> `Global.named_context_val`) + (`Context.Named.lookup` ---> `Environ.lookup_named_val`) + +** Search API ** + +The main search functions now take a function iterating over the +results. This allows for clients to use streaming or more economic +printing. ========================================= = CHANGES BETWEEN COQ V8.4 AND COQ V8.5 = diff --git a/dev/doc/notes-on-conversion b/dev/doc/notes-on-conversion index 6274275c9d..a81f170c63 100644 --- a/dev/doc/notes-on-conversion +++ b/dev/doc/notes-on-conversion @@ -21,7 +21,7 @@ Notation OMEGA := (ack 4 4). Definition f (x:nat) := x. -(* Evaluation in tactics can somehow be controled *) +(* Evaluation in tactics can somehow be controlled *) Lemma l1 : OMEGA = OMEGA. reflexivity. (* succeed: identity *) Qed. (* succeed: identity *) diff --git a/dev/make-installer-win32.sh b/dev/make-installer-win32.sh deleted file mode 100755 index 51d428dd1e..0000000000 --- a/dev/make-installer-win32.sh +++ /dev/null @@ -1,22 +0,0 @@ -#!/bin/sh - -set -e - -NSIS="$BASE/NSIS/makensis" -ZIP=_make.zip -URL1=http://sourceforge.net/projects/gnuwin32/files/make/3.81/make-3.81-bin.zip/download -URL2=http://sourceforge.net/projects/gnuwin32/files/make/3.81/make-3.81-dep.zip/download - -[ -e config/Makefile ] || ./configure -debug -prefix ./ -with-doc no -make -j2 -if [ ! -e bin/make.exe ]; then - wget -O $ZIP $URL1 && 7z x $ZIP "bin/*" - wget -O $ZIP $URL2 && 7z x $ZIP "bin/*" - rm -rf $ZIP -fi -VERSION=`grep ^VERSION= config/Makefile | cut -d = -f 2` -cd dev/nsis -"$NSIS" -DVERSION=$VERSION -DGTK_RUNTIME="`cygpath -w $BASE`" -DARCH="win32" coq.nsi -echo Installer: -ls -h $PWD/*exe -cd ../.. diff --git a/dev/make-installer-win64.sh b/dev/make-installer-win64.sh deleted file mode 100755 index 438f4ae5b7..0000000000 --- a/dev/make-installer-win64.sh +++ /dev/null @@ -1,28 +0,0 @@ -#!/bin/sh - -set -e - -NSIS="$BASE/NSIS/makensis" -ZIP=_make.zip -URL1=http://sourceforge.net/projects/gnuwin32/files/make/3.81/make-3.81-bin.zip/download -URL2=http://sourceforge.net/projects/gnuwin32/files/make/3.81/make-3.81-dep.zip/download - -[ -e config/Makefile ] || ./configure -debug -prefix ./ -with-doc no -make -j2 coqide -mkdir -p bin32 -cp bin/* bin32/ -make clean -make archclean -( . ${BASE}_64/environ && ./configure -debug -prefix ./ -with-doc no && make -j2 && make ide/coqidetop.cmxs ) -cp bin32/coqide* bin/ -if [ ! -e bin/make.exe ]; then - wget -O $ZIP $URL1 && 7z x $ZIP "bin/*" - wget -O $ZIP $URL2 && 7z x $ZIP "bin/*" - rm -rf $ZIP -fi -VERSION=`grep ^VERSION= config/Makefile | cut -d = -f 2` -cd dev/nsis -"$NSIS" -DVERSION=$VERSION -DGTK_RUNTIME="`cygpath -w $BASE`" -DARCH="win64" coq.nsi -echo Installer: -ls -h $PWD/*exe -cd ../.. diff --git a/dev/make-sdk-win32.sh b/dev/make-sdk-win32.sh deleted file mode 100755 index 0112324d4d..0000000000 --- a/dev/make-sdk-win32.sh +++ /dev/null @@ -1,370 +0,0 @@ -#!/bin/bash - -# To run this script install cygwin by running setup-x86.exe from cygwin.com -# Install the standard packages plus wget. Then run this script. - -# Sworn by Enrico Tassi <enrico.tassi@inra.fr> -# Modified to support other directories and almost support spaces in paths -# by Jason Gross <jgross@mit.edu> -# License: Expat/MIT http://opensource.org/licenses/MIT - -# This script reads the following environment variables: -# VERBOSE - set to non-empty to have wget/this script be more verbose, for debugging purposes -# BASE - set to non-empty to give a different location for the zip file, e.g., if /cygdrive/c is full or doesn't exist - -set -e -if [ ! -z "$VERBOSE" ] -then - set -x -fi - -# Resources -ocaml=ocaml-4.01.0-i686-mingw64-installer3.exe -glib=base-windows-0.18.1.1.13.356@BUILD_ec06e9.txz -gtk=base-gtk-2.24.18.1.58@BUILD_594ca8.txz -lablgtk=lablgtk-2.18.0.tar.gz -camlp5=camlp5-6.11.tgz -nsis=nsis-2.46-setup.exe - -ocaml_URL='http://yquem.inria.fr/~protzenk/caml-installer/'$ocaml -lablgtk_URL='https://forge.ocamlcore.org/frs/download.php/1261/'$lablgtk -glib_URL='http://dl.arirux.de/5/binaries32/'$glib -gtk_URL='http://dl.arirux.de/5/binaries32/'$gtk -camlp5_URL='http://pauillac.inria.fr/~ddr/camlp5/distrib/src/'$camlp5 -nsis_URL='http://netcologne.dl.sourceforge.net/project/nsis/NSIS%202/2.46/'$nsis - -cygwin=setup-${HOSTTYPE/i6/x}.exe -cygwin_URL='http://cygwin.com/'$cygwin -cygwin_PKGS=p7zip,zip,sed,make,mingw64-i686-gcc-g++,mingw64-i686-gcc-core,mingw64-i686-gcc,patch,rlwrap,libreadline6,diffutils - -has_spaces() { - test -z "$2" -} -# utilities -# http://www.dependencywalker.com/depends22_x86.zip - -# The SDK itself -REVISION=85-1 -# support for working on computers that don't have a C: drive -if [ -z "$BASE" ] -then - TRUE_BASE=/cygdrive/c -else - # get absolute path - TRUE_BASE="$(readlink -f "$BASE")" -fi -BASE="$TRUE_BASE/CoqSDK-$REVISION" - -if [ -z "$VERBOSE" ] -then - WGET_ARGS="-N -q" -else - WGET_ARGS="-N" -fi - -# Windows has a version of FIND in C:/Windows/system32/find, and we don't want to use that -if [ -x /usr/bin/find ] -then - FIND=/usr/bin/find -else - echo "WARNING: /usr/bin/find does not exist. Falling back on:" - which find - FIND=find -fi - -WGET_ARGS="-N -q" - -if [ "$(has_spaces $BASE; echo $?)" -ne 0 ]; then - echo "ERROR: The current base directory ($BASE) has spaces." - echo "ERROR: building lablgtk would fail." - exit 1 -fi - -cyg_install() { - if [ ! -e "$cygwin" ]; then wget $WGET_ARGS "$cygwin_URL"; fi - chmod a+x "$cygwin" - cygstart -w "$cygwin" -q -P $@ -} - -sanity_check() { - echo "Check: wget." - (which wget) || \ - (echo "Please install wget using the cygwin installer and retry.";\ - exit 1) - echo "Check: 7z, gcc. If it fails wait for cygwin to complete and retry" - (which 7z && which i686-w64-mingw32-gcc) || \ - (echo "Some cygwin package is not installed.";\ - echo "Please wait for cygwin to finish and retry.";\ - cyg_install $cygwin_PKGS;\ - exit 1) -} - -install_base() { - echo "Setting up $BASE" - rm -rf "$BASE" - mkdir -p "$BASE" -} - -make_environ() { - echo "Setting up $BASE/environ" - pushd "$BASE" >/dev/null - cat > environ <<- EOF - cyg_install() { - if [ ! -e "$cygwin" ]; then wget $WGET_ARGS "$cygwin_URL"; fi - chmod a+x "$cygwin" - cygstart -w "$cygwin" -q -P \$@ - } - # Sanity checks: is the mingw64-i686-gcc package installed? - (which i686-w64-mingw32-gcc && which make && which sed) || \\ - (echo "Some cygwin package is not installed.";\\ - echo "Please wait for cygwin to finish and retry.";\\ - cyg_install $cygwin_PKGS;\\ - exit 1) || exit 1 - - export BASE="\$( cd "\$( dirname "\${BASH_SOURCE[0]}" )" && pwd )" - export PATH="\$BASE/bin:\$PATH" - export OCAMLLIB="\$(cygpath -m "\$BASE")/lib" - export OCAMLFIND_CONF="\$(cygpath -m "\$BASE")/etc/findlib.conf" - sed s"|@BASE@|\$(cygpath -m "\$BASE")|g" "\$BASE/lib/ld.conf.in" \\ - > "\$BASE/lib/ld.conf" - sed s"|@BASE@|\$(cygpath -m "\$BASE")|g" "\$BASE/lib/topfind.in" \\ - > "\$BASE/lib/topfind" - sed s"|@BASE@|\$(cygpath -m "\$BASE")|g" "\$BASE/etc/findlib.conf.in" \\ - > "\$BASE/etc/findlib.conf" - echo "Good. You can now build Coq and Coqide from cygwin." - EOF - popd >/dev/null -} - -download() { - echo "Downloading some software:" - if [ ! -e "$ocaml" ]; then - echo "- downloading OCaml..." - wget $WGET_ARGS "$ocaml_URL" - fi - chmod a+x "$ocaml" - if [ ! -e "$lablgtk" ]; then - echo "- downloading lablgtk..." - wget $WGET_ARGS --no-check-certificate "$lablgtk_URL" - fi - if [ ! -e "$gtk" ]; then - echo "- downloading gtk..." - wget $WGET_ARGS "$gtk_URL" - fi - if [ ! -e "$glib" ]; then - echo "- downloading glib..." - wget $WGET_ARGS "$glib_URL" - fi - if [ ! -e "$camlp5" ]; then - echo "- downloading camlp5..." - wget $WGET_ARGS "$camlp5_URL" - fi - if [ ! -e "$nsis" ]; then - echo "- downloading nsis..." - wget $WGET_ARGS "$nsis_URL" - fi -} - -cleanup() { - rm -rf tmp build -} - -install_gtk() { - echo "Installing $glib" - tar -xJf "$glib" -C "$BASE" - echo "Installing $gtk" - tar -xJf "$gtk" -C "$BASE" -} - -install_ocaml() { - echo "Installing $ocaml" - mkdir -p tmp - 7z -otmp x "$ocaml" >/dev/null - cp -r tmp/\$_OUTDIR/bin "$BASE/" - cp -r tmp/bin "$BASE/" - cp -r tmp/\$_OUTDIR/lib "$BASE/" - cp -r tmp/lib "$BASE/" - cp -r tmp/\$_OUTDIR/etc "$BASE/" - "$FIND" "$BASE" -name '*.dll' -o -name '*.exe' | tr '\n' '\0' \ - | xargs -0 chmod a+x - mv "$BASE/lib/topfind" "$BASE/lib/topfind.in" - sed -i 's|@SITELIB@|@BASE@/lib/site-lib|g' "$BASE/lib/topfind.in" - cat > "$BASE/lib/ld.conf.in" <<- EOF - @BASE@/lib - @BASE@/lib/stublibs - EOF - cat > "$BASE/etc/findlib.conf.in" <<- EOF - destdir="@BASE@/lib/site-lib" - path="@BASE@/lib/site-lib" - stdlib="@BASE@/lib" - ldconf="@BASE@/lib/ld.conf" - ocamlc="ocamlc.opt" - ocamlopt="ocamlopt.opt" - ocamldep="ocamldep.opt" - ocamldoc="ocamldoc.opt" - EOF - cp "$BASE/lib/topdirs.cmi" "$BASE/lib/compiler-libs/" -} - -build_install_lablgtk() { - echo "Building $lablgtk" - mkdir -p build - tar -xzf "$lablgtk" -C build - cd build/lablgtk-* - patch -p1 <<EOT ---- lablgtk-2.18.0/src/glib.mli 2013-10-01 01:31:50.000000000 -0700 -+++ lablgtk-2.18.0.new/src/glib.mli 2013-12-06 11:57:34.203675200 -0800 -@@ -75,6 +75,7 @@ - type condition = [ \`ERR | \`HUP | \`IN | \`NVAL | \`OUT | \`PRI] - type id - val channel_of_descr : Unix.file_descr -> channel -+ val channel_of_descr_socket : Unix.file_descr -> channel - val add_watch : - cond:condition list -> callback:(condition list -> bool) -> ?prio:int -> channel -> id - val remove : id -> unit ---- lablgtk-2.18.0/src/glib.ml 2013-10-01 01:31:50.000000000 -0700 -+++ lablgtk-2.18.0.new/src/glib.ml 2013-12-06 11:57:53.070804800 -0800 -@@ -72,6 +72,8 @@ - type id - external channel_of_descr : Unix.file_descr -> channel - = "ml_g_io_channel_unix_new" -+ external channel_of_descr_socket : Unix.file_descr -> channel -+ = "ml_g_io_channel_unix_new_socket" - external remove : id -> unit = "ml_g_source_remove" - external add_watch : - cond:condition list -> callback:(condition list -> bool) -> ?prio:int -> channel -> id ---- lablgtk-2.18.0/src/ml_glib.c 2013-10-01 01:31:50.000000000 -0700 -+++ lablgtk-2.18.0.new/src/ml_glib.c 2013-12-10 02:03:33.940371800 -0800 -@@ -25,6 +25,8 @@ - #include <string.h> - #include <locale.h> - #ifdef _WIN32 -+/* to kill a #warning: include winsock2.h before windows.h */ -+#include <winsock2.h> - #include "win32.h" - #include <wtypes.h> - #include <io.h> -@@ -38,6 +40,11 @@ - #include <caml/callback.h> - #include <caml/threads.h> - -+#ifdef _WIN32 -+/* for Socket_val */ -+#include <caml/unixsupport.h> -+#endif -+ - #include "wrappers.h" - #include "ml_glib.h" - #include "glib_tags.h" -@@ -325,14 +332,23 @@ - - #ifndef _WIN32 - ML_1 (g_io_channel_unix_new, Int_val, Val_GIOChannel_noref) -+CAMLprim value ml_g_io_channel_unix_new_socket (value arg1) { -+ return Val_GIOChannel_noref (g_io_channel_unix_new (Int_val (arg1))); -+} - - #else - CAMLprim value ml_g_io_channel_unix_new(value wh) - { - return Val_GIOChannel_noref -- (g_io_channel_unix_new -+ (g_io_channel_win32_new_fd - (_open_osfhandle((long)*(HANDLE*)Data_custom_val(wh), O_BINARY))); - } -+ -+CAMLprim value ml_g_io_channel_unix_new_socket(value wh) -+{ -+ return Val_GIOChannel_noref -+ (g_io_channel_win32_new_socket(Socket_val(wh))); -+} - #endif - - static gboolean ml_g_io_channel_watch(GIOChannel *s, GIOCondition c, -EOT - #sed -i s'/$PKG_CONFIG/"$PKG_CONFIG"/g' configure - #sed -i s'/""$PKG_CONFIG""/"$PKG_CONFIG"/g' configure - ./configure --disable-gtktest --prefix="$(cygpath -m "$BASE")" \ - >log-configure 2>&1 - sed -i 's?\\?/?g' config.make - make >log-make 2>&1 - make opt >>log-make 2>&1 - #echo "Testing $lablgtk" - #cd src - #./lablgtk2 ../examples/calc.ml - #./lablgtk2 -all ../examples/calc.ml - #cd .. - echo "Installing $lablgtk" - make install >>log-make 2>&1 - cd ../.. -} - -build_install_camlp5() { - echo "Building $camlp5" - mkdir -p build - tar -xzf "$camlp5" -C build - cd build/camlp5-* - ./configure >log-configure 2>&1 - sed -i 's/EXT_OBJ=.obj/EXT_OBJ=.o/' config/Makefile - sed -i 's/EXT_LIB=.lib/EXT_LIB=.a/' config/Makefile - make world.opt >log-make 2>&1 - echo "Installing $camlp5" - make install >>log-make 2>&1 - cd ../.. -} - -install_nsis() { - echo "Installing $nsis" - rm -rf tmp - mkdir -p tmp - 7z -otmp x $nsis >/dev/null - mkdir "$BASE/NSIS" - cp -r tmp/\$_OUTDIR/* "$BASE/NSIS" - rm -rf tmp/\$_OUTDIR - rm -rf tmp/\$PLUGINSDIR - cp -r tmp/* "$BASE/NSIS" -} - -zip_sdk() { - echo "Generating CoqSDK-${REVISION}.zip" - here="`pwd`" - cd "$BASE/.." - rm -f "$here/CoqSDK-${REVISION}.zip" - zip -q -r "$here/CoqSDK-${REVISION}.zip" "$(basename "$BASE")" - cd "$here" -} - -diet_sdk() { - rm -rf "$BASE"/+* - rm -rf "$BASE"/bin/camlp4* - rm -rf "$BASE"/lib/camlp4/ - rm -rf "$BASE"/lib/site-lib/camlp4/ -} - -victory(){ - echo "Output file: CoqSDK-${REVISION}.zip "\ - "(`du -sh CoqSDK-${REVISION}.zip | cut -f 1`)" - echo "Usage: unpack and source the environ file at its root" -} - -if [ -z "$1" ]; then - sanity_check - download - cleanup - install_base - install_nsis - install_ocaml - install_gtk - make_environ - . "$BASE/environ" - build_install_lablgtk - build_install_camlp5 - diet_sdk - make_environ - zip_sdk - cleanup - victory -else - # just one step - $1 -fi diff --git a/dev/top_printers.ml b/dev/top_printers.ml index e09477014b..a3d5cf5c12 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -215,7 +215,6 @@ let ppuniverse_subst l = pp (Univ.pr_universe_subst l) let ppuniverse_opt_subst l = pp (Universes.pr_universe_opt_subst l) let ppuniverse_level_subst l = pp (Univ.pr_universe_level_subst l) let ppevar_universe_context l = pp (Evd.pr_evar_universe_context l) -let ppconstraints_map c = pp (Universes.pr_constraints_map c) let ppconstraints c = pp (pr_constraints Level.pr c) let ppuniverseconstraints c = pp (Universes.Constraints.pr c) let ppuniverse_context_future c = @@ -478,6 +477,8 @@ let prgenarginfo arg = let ppgenarginfo arg = pp (prgenarginfo arg) +let ppgenargargt arg = pp (str (Genarg.ArgT.repr arg)) + let ppist ist = let pr id arg = prgenarginfo arg in pp (pridmap pr ist.Geninterp.lfun) diff --git a/doc/common/macros.tex b/doc/common/macros.tex index df5ee405f9..5abdecfc18 100644 --- a/doc/common/macros.tex +++ b/doc/common/macros.tex @@ -72,7 +72,8 @@ %\newcommand{\spec}[1]{\{\,#1\,\}} % Building regular expressions -\newcommand{\zeroone}[1]{\mbox{\sl [}#1\mbox{\sl ]}} +\newcommand{\zeroone}[1]{\mbox{\sl [}{#1}\mbox{\sl ]}} +\newcommand{\zeroonelax}[1]{\mbox{\sl [}#1\mbox{\sl ]}} %\newcommand{\zeroonemany}[1]{$\{$#1$\}$*} %\newcommand{\onemany}[1]{$\{$#1$\}$+} \newcommand{\nelistnosep}[1]{{#1} \mbox{\dots} {#1}} diff --git a/doc/common/styles/html/coqremote/cover.html b/doc/common/styles/html/coqremote/cover.html index 6ec4dc1af0..1c415eca69 100644 --- a/doc/common/styles/html/coqremote/cover.html +++ b/doc/common/styles/html/coqremote/cover.html @@ -61,6 +61,7 @@ <li>V8.3 © INRIA 2010-2011</li> <li>V8.4 © INRIA 2012-2014</li> <li>V8.5 © INRIA 2015-2016</li> + <li>V8.6 © INRIA 2016</li> </ul> <p style="text-indent:0pt">This research was partly supported by IST diff --git a/doc/common/styles/html/simple/cover.html b/doc/common/styles/html/simple/cover.html index 328bd68daf..25fb56320b 100644 --- a/doc/common/styles/html/simple/cover.html +++ b/doc/common/styles/html/simple/cover.html @@ -39,6 +39,7 @@ <li>V8.3 © INRIA 2010-2011</li> <li>V8.4 © INRIA 2012-2014</li> <li>V8.5 © INRIA 2015-2016</li> + <li>V8.6 © INRIA 2016</li> </ul> <p style="text-indent:0pt">This research was partly supported by IST diff --git a/doc/faq/FAQ.tex b/doc/faq/FAQ.tex index 48b61827d1..213fb03137 100644 --- a/doc/faq/FAQ.tex +++ b/doc/faq/FAQ.tex @@ -2587,8 +2587,8 @@ It is the language of commands of Gallina i.e. definitions, lemmas, {\ldots} \Question{What is a dependent type?} -A dependant type is a type which depends on some term. For instance -``vector of size n'' is a dependant type representing all the vectors +A dependent type is a type which depends on some term. For instance +``vector of size n'' is a dependent type representing all the vectors of size $n$. Its type depends on $n$ \Question{What is a proof by reflection?} diff --git a/doc/refman/Classes.tex b/doc/refman/Classes.tex index e8ebb9f995..acfc4bea93 100644 --- a/doc/refman/Classes.tex +++ b/doc/refman/Classes.tex @@ -9,10 +9,6 @@ \aauthor{Matthieu Sozeau} \label{typeclasses} -\begin{flushleft} - \em The status of Type Classes is experimental. -\end{flushleft} - This chapter presents a quick reference of the commands related to type classes. For an actual introduction to type classes, there is a description of the system \cite{sozeau08} and the literature on type @@ -382,6 +378,71 @@ projections as instances. This is almost equivalent to {\tt Hint Resolve Declares variables according to the given binding context, which might use implicit generalization (see \ref{SectionContext}). +\asubsection{\tt typeclasses eauto} +\tacindex{typeclasses eauto} +\label{typeclasseseauto} + +The {\tt typeclasses eauto} tactic uses a different resolution engine +than {\tt eauto} and {\tt auto}. The main differences are the following: +\begin{itemize} +\item Contrary to {\tt eauto} and {\tt auto}, the resolution is done + entirely in the new proof engine (as of Coq v8.6), meaning that + backtracking is available among dependent subgoals, and shelving goals + is supported. {\tt typeclasses eauto} is a multi-goal tactic. + It analyses the dependencies between subgoals to avoid + backtracking on subgoals that are entirely independent. +\item When called with no arguments, {\tt typeclasses eauto} uses the + {\tt typeclass\_instances} database by default (instead of {\tt + core}). + Dependent subgoals are automatically shelved, and shelved + goals can remain after resolution ends (following the behavior of + \Coq{} 8.5). + + \emph{Note: } As of Coq 8.6, {\tt all:once (typeclasses eauto)} + faithfully mimicks what happens during typeclass resolution when it is + called during refinement/type-inference, except that \emph{only} + declared class subgoals are considered at the start of resolution + during type inference, while ``all'' can select non-class subgoals as + well. It might move to {\tt all:typeclasses eauto} in future versions + when the refinement engine will be able to backtrack. +\item When called with specific databases (e.g. {\tt with}), {\tt + typeclasses eauto} allows shelved goals to remain at any point + during search and treat typeclasses goals like any other. +\item The transparency information of databases is used consistently for + all hints declared in them. It is always used when calling the unifier. + When considering the local hypotheses, we use the transparent + state of the first hint database given. Using an empty database + (created with {\tt Create HintDb} for example) with + unfoldable variables and constants as the first argument of + typeclasses eauto hence makes resolution with the local hypotheses use + full conversion during unification. +\end{itemize} + +\begin{Variants} +\item \label{depth} {\tt typeclasses eauto \zeroone{\num}} + \emph{Warning:} The semantics for the limit {\num} is different than + for {\tt auto}. By default, if no limit is given the search is + unbounded. Contrary to {\tt auto}, introduction steps ({\tt intro}) + are counted, which might result in larger limits being necessary + when searching with {\tt typeclasses eauto} than {\tt auto}. + +\item \label{with} {\tt typeclasses eauto with {\ident}$_1$ \ldots {\ident}$_n$}. + This variant runs resolution with the given hint databases. It treats + typeclass subgoals the same as other subgoals (no shelving of + non-typeclass goals in particular). +\end{Variants} + +\asubsection{\tt autoapply {\term} with {\ident}} +\tacindex{autoapply} + +The tactic {\tt autoapply} applies a term using the transparency +information of the hint database {\ident}, and does \emph{no} typeclass +resolution. This can be used in {\tt Hint Extern}'s for typeclass +instances (in hint db {\tt typeclass\_instances}) to +allow backtracking on the typeclass subgoals created by the lemma +application, rather than doing type class resolution locally at the hint +application time. + \subsection{\tt Typeclasses Transparent, Opaque {\ident$_1$ \ldots \ident$_n$}} \comindex{Typeclasses Transparent} \comindex{Typeclasses Opaque} @@ -400,20 +461,123 @@ abbreviate a type, like {\tt relation A := A -> A -> Prop}. This is equivalent to {\tt Hint Transparent,Opaque} {\ident} {\tt: typeclass\_instances}. +\subsection{\tt Set Typeclasses Dependency Order} +\optindex{Typeclasses Dependency Order} + +This option (on by default since 8.6) respects the dependency order between +subgoals, meaning that subgoals which are depended on by other subgoals +come first, while the non-dependent subgoals were put before the +dependent ones previously (Coq v8.5 and below). This can result in quite +different performance behaviors of proof search. + +\subsection{\tt Set Typeclasses Filtered Unification} +\optindex{Typeclasses Filtered Unification} + +This option, available since Coq 8.6 and off by default, switches the +hint application procedure to a filter-then-unify strategy. To apply a +hint, we first check that the goal \emph{matches} syntactically the +inferred or specified pattern of the hint, and only then try to +\emph{unify} the goal with the conclusion of the hint. This can +drastically improve performance by calling unification less often, +matching syntactic patterns being very quick. This also provides more +control on the triggering of instances. For example, forcing a constant +to explicitely appear in the pattern will make it never apply on a goal +where there is a hole in that place. + +\subsection{\tt Set Typeclasses Legacy Resolution} +\optindex{Typeclasses Legacy Resolution} + +This option (off by default) uses the 8.5 implementation of resolution. +Use for compatibility purposes only (porting and debugging). + +\subsection{\tt Set Typeclasses Module Eta} +\optindex{Typeclasses Modulo Eta} + +This option allows eta-conversion for functions and records during +unification of type-classes. This option is now unsupported in 8.6 with +{\tt Typeclasses Filtered Unification} set, but still affects the +default unification strategy, and the one used in {\tt Legacy + Resolution} mode. It is \emph{unset} by default. If {\tt Typeclasses + Filtered Unification} is set, this has no effect and unification will +find solutions up-to eta conversion. Note however that syntactic +pattern-matching is not up-to eta. + +\subsection{\tt Set Typeclasses Limit Intros} +\optindex{Typeclasses Limit Intros} + +This option (on by default in Coq 8.6 and below) controls the ability to +apply hints while avoiding (functional) eta-expansions in the generated +proof term. It does so by allowing hints that conclude in a product to +apply to a goal with a matching product directly, avoiding an +introduction. \emph{Warning:} this can be expensive as it requires +rebuilding hint clauses dynamically, and does not benefit from the +invertibility status of the product introduction rule, resulting in +potentially more expensive proof-search (i.e. more useless +backtracking). + +\subsection{\tt Set Typeclass Resolution After Apply} +\optindex{Typeclasses Resolution After Apply} +\emph{Deprecated since 8.6} + +This option (off by default in Coq 8.6 and 8.5) controls the resolution +of typeclass subgoals generated by the {\tt apply} tactic. + +\subsection{\tt Set Typeclass Resolution For Conversion} +\optindex{Typeclasses Resolution For Conversion} + +This option (on by default) controls the use of typeclass resolution +when a unification problem cannot be solved during +elaboration/type-inference. With this option on, when a unification +fails, typeclass resolution is tried before launching unification once again. + +\subsection{\tt Set Typeclasses Strict Resolution} +\optindex{Typeclasses Strict Resolution} + +Typeclass declarations introduced when this option is set have a +stricter resolution behavior (the option is off by default). When +looking for unifications of a goal with an instance of this class, we +``freeze'' all the existentials appearing in the goals, meaning that +they are considered rigid during unification and cannot be instantiated. + +\subsection{\tt Set Typeclasses Unique Solutions} +\optindex{Typeclasses Unique Solutions} + +When a typeclass resolution is launched we ensure that it has a single +solution or fail. This ensures that the resolution is canonical, but can +make proof search much more expensive. + +\subsection{\tt Set Typeclasses Unique Instances} +\optindex{Typeclasses Unique Instances} + +Typeclass declarations introduced when this option is set have a +more efficient resolution behavior (the option is off by default). When +a solution to the typeclass goal of this class is found, we never +backtrack on it, assuming that it is canonical. + \subsection{\tt Typeclasses eauto := [debug] [dfs | bfs] [\emph{depth}]} \comindex{Typeclasses eauto} \label{TypeclassesEauto} -This command allows customization of the type class resolution tactic, -based on a variant of eauto. The flags semantics are: +This command allows more global customization of the type class +resolution tactic. +The semantics of the options are: \begin{itemize} \item {\tt debug} In debug mode, the trace of successfully applied tactics is printed. \item {\tt dfs, bfs} This sets the search strategy to depth-first search (the default) or breadth-first search. -\item {\emph{depth}} This sets the depth of the search (the default is 100). +\item {\emph{depth}} This sets the depth limit of the search. \end{itemize} +\subsection{\tt Set Typeclasses Debug [Verbosity {\num}]} +\optindex{Typeclasses Debug} +\optindex{Typeclasses Debug Verbosity} + +These options allow to see the resolution steps of typeclasses that are +performed during search. The {\tt Debug} option is synonymous to +{\tt Debug Verbosity 1}, and {\tt Debug Verbosity 2} provides more +information (tried tactics, shelving of goals, etc\ldots). + \subsection{\tt Set Refine Instance Mode} \optindex{Refine Instance Mode} diff --git a/doc/refman/RefMan-com.tex b/doc/refman/RefMan-com.tex index 6f85849888..bef0a1686f 100644 --- a/doc/refman/RefMan-com.tex +++ b/doc/refman/RefMan-com.tex @@ -26,13 +26,13 @@ run by the command {\tt coqtop}. They are two different binary images of \Coq: the byte-code one and the native-code one (if {\ocaml} provides a native-code compiler for your platform, which is supposed in the following). By default, -\verb!coqc! executes the native-code version; this can be overridden -using the \verb!-byte! option. +\verb!coqtop! executes the native-code version; run \verb!coqtop.byte! to +get the byte-code version. The byte-code toplevel is based on an {\ocaml} toplevel (to allow the dynamic link of tactics). You can switch to the {\ocaml} toplevel with the command \verb!Drop.!, and come back to the -\Coq~toplevel with the command \verb!Toplevel.loop();;!. +\Coq~toplevel with the command \verb!Coqloop.loop();;!. \section{Batch compilation ({\tt coqc})} The {\tt coqc} command takes a name {\em file} as argument. Then it @@ -199,6 +199,12 @@ The following command-line options are recognized by the commands {\tt available for {\tt coqc} only; it is the counterpart of {\tt -compile-verbose}. + \item[{\tt -w} (all|none|w$_1$,\ldots,w$_n$)]\ % + + Configure the display of warnings. This option expects {\tt all}, {\tt none} + or a comma-separated list of warning names or categories (see + Section~\ref{SetWarnings}). + %Mostly unused in the code %\item[{\tt -debug}]\ % % diff --git a/doc/refman/RefMan-ext.tex b/doc/refman/RefMan-ext.tex index 51e881bff4..b475a5233c 100644 --- a/doc/refman/RefMan-ext.tex +++ b/doc/refman/RefMan-ext.tex @@ -1315,10 +1315,10 @@ command: \begin{quote} \tt Arguments {\qualid} \nelist{\possiblybracketedident}{} \end{quote} -where the list of {\possiblybracketedident} is the list of all arguments of -{\qualid} where the ones to be declared implicit are surrounded by -square brackets and the ones to be declared as maximally inserted implicits -are surrounded by curly braces. +where the list of {\possiblybracketedident} is a prefix of the list of arguments +of {\qualid} where the ones to be declared implicit are surrounded by square +brackets and the ones to be declared as maximally inserted implicits are +surrounded by curly braces. After the above declaration is issued, implicit arguments can just (and have to) be skipped in any expression involving an application of @@ -1591,7 +1591,7 @@ Implicit arguments names can be redefined using the following syntax: {\tt Arguments {\qualid} \nelist{\name}{} : rename} \end{quote} -Without the {\tt rename} flag, {\tt Arguments} can be used to assert +With the {\tt assert} flag, {\tt Arguments} can be used to assert that a given object has the expected number of arguments and that these arguments are named as expected. @@ -1600,7 +1600,7 @@ these arguments are named as expected. Arguments p [s t] _ [u] _: rename. Check (p r1 (u:=c)). Check (p (s:=a) (t:=b) r1 (u:=c) r2). -Fail Arguments p [s t] _ [w] _. +Fail Arguments p [s t] _ [w] _ : assert. \end{coq_example} diff --git a/doc/refman/RefMan-gal.tex b/doc/refman/RefMan-gal.tex index 99eee44e03..3814e4403a 100644 --- a/doc/refman/RefMan-gal.tex +++ b/doc/refman/RefMan-gal.tex @@ -713,9 +713,9 @@ definition have a special syntax: ``{\tt let fix}~$f$~{\ldots}~{\tt {\tt Inductive} \nelist{\inductivebody}{with} {\tt .} \\ & $|$ & {\tt CoInductive} \nelist{\inductivebody}{with} {\tt .} \\ & & \\ -{\inductivebody} & ::= & - {\ident} \zeroone{\binders} {\tt :} {\term} {\tt :=} \\ - && ~~\zeroone{\zeroone{\tt |} \nelist{$\!${\ident}$\!$ \zeroone{\binders} {\typecstrwithoutblank}}{|}} \\ +{\inductivebody} & ::= & + {\ident} \zeroone{\binders} {\typecstr} {\tt :=} \\ + && ~~\zeroone{\zeroone{\tt |} \nelist{$\!${\ident}$\!$ \zeroone{\binders} {\typecstr}}{|}} \\ & & \\ %% TODO: where ... %% Fixpoints {\fixpoint} & ::= & {\tt Fixpoint} \nelist{\fixpointbody}{with} {\tt .} \\ diff --git a/doc/refman/RefMan-ltac.tex b/doc/refman/RefMan-ltac.tex index 587f4e5cb3..9378529cbe 100644 --- a/doc/refman/RefMan-ltac.tex +++ b/doc/refman/RefMan-ltac.tex @@ -1289,7 +1289,7 @@ Prints a profile for all tactics that start with {\qstring}. Append a period (.) \begin{quote} {\tt Reset Ltac Profile}. \end{quote} -Resets the profile, that is, deletes all accumulated information +Resets the profile, that is, deletes all accumulated information. Note that backtracking across a {\tt Reset Ltac Profile} will not restore the information. \begin{coq_eval} Reset Initial. diff --git a/doc/refman/RefMan-oth.tex b/doc/refman/RefMan-oth.tex index 919e7b5cdc..56ce753cd6 100644 --- a/doc/refman/RefMan-oth.tex +++ b/doc/refman/RefMan-oth.tex @@ -914,6 +914,19 @@ This command turns off the normal displaying. \subsection[\tt Unset Silent.]{\tt Unset Silent.\optindex{Silent}} This command turns the normal display on. +\subsection[\tt Set Warnings ``(\nterm{w}$_1$,\ldots,% + \nterm{w}$_n$)''.]{{\tt Set Warnings ``(\nterm{w}$_1$,\ldots,% + \nterm{w}$_n$)''}.\optindex{Warnings}} +\label{SetWarnings} +This command configures the display of warnings. It is experimental, and +expects, between quotes, a comma-separated list of warning names or +categories. Adding~\texttt{-} in front of a warning or category disables it, +adding~\texttt{+} makes it an error. It is possible to use the special +categories \texttt{all} and \texttt{default}, the latter containing the warnings +enabled by default. The flags are interpreted from left to right, so in case of +an overlap, the flags on the right have higher priority, meaning that +\texttt{A,-A} is equivalent to \texttt{-A}. + \subsection[\tt Set Search Output Name Only.]{\tt Set Search Output Name Only.\optindex{Search Output Name Only} \label{Search-Output-Name-Only} \index{Search Output Name Only mode}} diff --git a/doc/refman/RefMan-pre.tex b/doc/refman/RefMan-pre.tex index cb2ab5dc2f..f36969e821 100644 --- a/doc/refman/RefMan-pre.tex +++ b/doc/refman/RefMan-pre.tex @@ -1087,6 +1087,139 @@ Paris, January 2015, revised December 2015,\\ Hugo Herbelin, Matthieu Sozeau and the {\Coq} development team\\ \end{flushright} +\section*{Credits: version 8.6} + +{\Coq} version 8.6 contains the result of refinements, stabilization of +8.5's features and cleanups of the internals of the system. Over the +year of (now time-based) development, about 450 bugs were resolved and +over 100 contributions integrated. The main user visible changes are: +\begin{itemize} +\item A new, faster state-of-the-art universe constraint checker, by + Jacques-Henri Jourdan. +\item In CoqIDE and other asynchronous interfaces, more fine-grained + asynchronous processing and error reporting by Enrico Tassi, making {\Coq} + capable of recovering from errors and continue processing the document. +\item More access to the proof engine features from Ltac: goal + management primitives, range selectors and a {\tt typeclasses + eauto} engine handling multiple goals and multiple successes, by + Cyprien Mangin, Matthieu Sozeau and Arnaud Spiwack. +\item Tactic behavior uniformization and specification, generalization + of intro-patterns by Hugo Herbelin and others. +\item A brand new warning system allowing to control warnings, turn them + into errors or ignore them selectively by Maxime Dénès, Guillaume + Melquiond, Pierre-Marie Pédrot and others. +\item Irrefutable patterns in abstractions, by Daniel de Rauglaudre. +\item The {\tt ssreflect} subterm selection algorithm by Georges Gonthier and + Enrico Tassi is now accessible to tactic writers through the {\tt ssrmatching} + plugin. +\item Integration of {\tt LtacProf}, a profiler for {\tt Ltac} by Jason + Gross, Paul Steckler, Enrico Tassi and Tobias Tebbi. +\end{itemize} + +{\Coq} 8.6 also comes with a bunch of smaller-scale changes and +improvements regarding the different components of the system. We shall +only list a few of them. + +The {\tt iota} reduction flag is now a shorthand for {\tt match}, {\tt + fix} and {\tt cofix} flags controlling the corresponding reduction +rules (by Hugo Herbelin and Maxime Dénès). + +Maxime Dénès maintained the native compilation machinery. + +Pierre-Marie Pédrot separated the Ltac code from general purpose +tactics, and generalized and rationalized the handling of generic +arguments, allowing to create new versions of Ltac more easily in the +future. + +In patterns and terms, {\tt @}, abbreviations and notations are now +interpreted the same way, by Hugo Herbelin. + +Name handling for universes has been improved by Pierre-Marie Pédrot and +Matthieu Sozeau. The minimization algorithm has been improved by +Matthieu Sozeau. + +The unifier has been improved by Hugo Herbelin and Matthieu Sozeau, +fixing some incompatibilities introduced in Coq 8.5. Unification +constraints can now be left floating around and be seen by the user +thanks to a new option. The {\tt Keyed Unification} mode has been +improved by Matthieu Sozeau. + +The typeclass resolution engine and associated proof-search tactic have +been reimplemented on top of the proof-engine monad, providing better +integration in tactics, and new options have been introduced to control +it, by Matthieu Sozeau with help from Théo Zimmermann. + +The efficiency of the whole system has been significantly improved +thanks to contributions from Pierre-Marie Pédrot, Maxime Dénès and +Matthieu Sozeau and performance issue tracking by Jason Gross and Paul +Steckler. + +Standard library improvements by Jason Gross, Sébastien Hinderer, Pierre +Letouzey and others. + +Emilio Jesús Gallego Arias contributed many cleanups and refactorings of +the pretty-printing and user interface communication components. + +Frédéric Besson maintained the micromega tactic. + +The OPAM repository for {\Coq} packages has been maintained by Guillaume +Claret, Guillaume Melquiond, Matthieu Sozeau, Enrico Tassi and others. A +list of packages is now available at \url{https://coq.inria.fr/opam/www/}. + +Packaging tools and software development kits were prepared by Michael +Soegtrop with the help of Maxime Dénès and Enrico Tassi for Windows, and +Maxime Dénès and Matthieu Sozeau for MacOS X. Packages are now regularly +built on the continuous integration server. {\Coq} now comes with a {\tt + META} file usable with {\tt ocamlfind}, contributed by Emilio Jesús +Gallego Arias, Gregory Malecha, and Matthieu Sozeau. + +Matej KoÅ¡Ãk maintained and greatly improved the continuous integration +setup and the testing of {\Coq} contributions. He also contributed many +API improvement and code cleanups throughout the system. + +The contributors for this version are Bruno Barras, C.J. Bell, Yves +Bertot, Frédéric Besson, Pierre Boutillier, Tej Chajed, Guillaume +Claret, Xavier Clerc, Pierre Corbineau, Pierre Courtieu, Maxime Dénès, +Ricky Elrod, Emilio Jesús Gallego Arias, Jason Gross, Hugo Herbelin, +Sébastien Hinderer, Jacques-Henri Jourdan, Matej Kosik, Xavier Leroy, +Pierre Letouzey, Gregory Malecha, Cyprien Mangin, Erik Martin-Dorel, +Guillaume Melquiond, Clément Pit--Claudel, Pierre-Marie Pédrot, Daniel +de Rauglaudre, Lionel Rieg, Gabriel Scherer, Thomas Sibut-Pinote, +Matthieu Sozeau, Arnaud Spiwack, Paul Steckler, Enrico Tassi, Laurent +Théry, Nickolai Zeldovich and Théo Zimmermann. The development process +was coordinated by Hugo Herbelin and Matthieu Sozeau with the help of +Maxime Dénès, who was also in charge of the release process. + +Many power users helped to improve the design of the new features via +the bug tracker, the pull request system, the {\Coq} development mailing +list or the coq-club mailing list. Special thanks to the users who +contributed patches and intensive brain-storming and code reviews, +starting with Cyril Cohen, Jason Gross, Robbert Krebbers, Jonathan +Leivent, Xavier Leroy, Gregory Malecha, Clément Pit--Claudel, Gabriel +Scherer and Beta Ziliani. It would however be impossible to mention +exhaustively the names of everybody who to some extent influenced the +development. + +Version 8.6 is the first release of {\Coq} developed on a time-based +development cycle. Its development spanned 10 months from the release of +{\Coq} 8.5 and was based on a public roadmap. To date, it contains more +external contributions than any previous {\Coq} system. Code reviews +were systematically done before integration of new features, with an +important focus given to compatibility and performance issues, resulting +in a hopefully more robust release than {\Coq} 8.5. + +Coq Enhancement Proposals (CEPs for short) were introduced by Enrico +Tassi to provide more visibility and a discussion period on new +features, they are publicly available \url{https://github.com/coq/ceps}. + +Started during this period, an effort is led by Yves Bertot and Maxime +Dénès to put together a {\Coq} consortium. + +\begin{flushright} +Paris, November 2016,\\ +Matthieu Sozeau and the {\Coq} development team\\ +\end{flushright} + %new Makefile diff --git a/doc/refman/RefMan-syn.tex b/doc/refman/RefMan-syn.tex index 92107b750b..21c39de967 100644 --- a/doc/refman/RefMan-syn.tex +++ b/doc/refman/RefMan-syn.tex @@ -649,7 +649,7 @@ A recursive pattern for binders can be used in position of a recursive pattern for terms. Here is an example: \begin{coq_example*} -Notation ``'FUNAPP' x .. y , f'' := +Notation "'FUNAPP' x .. y , f" := (fun x => .. (fun y => (.. (f x) ..) y ) ..) (at level 200, x binder, y binder, right associativity). \end{coq_example*} @@ -811,13 +811,13 @@ constant have to be interpreted in a given scope. The command is \begin{quote} {\tt Arguments} {\qualid} \nelist{\name {\tt \%}\scope}{} \end{quote} -where the list is the list of the arguments of {\qualid} eventually -annotated with their {\scope}. Grouping round parentheses can -be used to decorate multiple arguments with the same scope. -{\scope} can be either a scope name or its delimiting key. For example -the following command puts the first two arguments of {\tt plus\_fct} -in the scope delimited by the key {\tt F} ({\tt Rfun\_scope}) and the -last argument in the scope delimited by the key {\tt R} ({\tt R\_scope}). +where the list is a prefix of the list of the arguments of {\qualid} eventually +annotated with their {\scope}. Grouping round parentheses can be used to +decorate multiple arguments with the same scope. {\scope} can be either a scope +name or its delimiting key. For example the following command puts the first two +arguments of {\tt plus\_fct} in the scope delimited by the key {\tt F} ({\tt + Rfun\_scope}) and the last argument in the scope delimited by the key {\tt R} +({\tt R\_scope}). \begin{coq_example*} Arguments plus_fct (f1 f2)%F x%R. diff --git a/doc/refman/RefMan-tac.tex b/doc/refman/RefMan-tac.tex index c5fd40bf15..3f12411863 100644 --- a/doc/refman/RefMan-tac.tex +++ b/doc/refman/RefMan-tac.tex @@ -114,7 +114,7 @@ following syntax: \begin{tabular}{lcl} {\occclause} & ::= & {\tt in} {\occgoalset} \\ {\occgoalset} & ::= & - \zeroone{{\ident$_1$} \zeroone{\atoccurrences} {\tt ,} \\ + \zeroonelax{{\ident$_1$} \zeroone{\atoccurrences} {\tt ,} \\ & & {\dots} {\tt ,}\\ & & {\ident$_m$} \zeroone{\atoccurrences}}\\ & & \zeroone{{\tt |-} \zeroone{{\tt *} \zeroone{\atoccurrences}}}\\ @@ -263,6 +263,16 @@ Defined. This tactic behaves like {\tt refine}, but it does not shelve any subgoal. It does not perform any beta-reduction either. +\item {\tt notypeclasses refine \term}\tacindex{notypeclasses refine} + + This tactic behaves like {\tt refine} except it performs typechecking + without resolution of typeclasses. + +\item {\tt simple notypeclasses refine \term}\tacindex{simple + notypeclasses refine} + + This tactic behaves like {\tt simple refine} except it performs typechecking + without resolution of typeclasses. \end{Variants} \subsection{\tt apply \term} @@ -292,7 +302,7 @@ Section~\ref{pattern} to transform the goal so that it gets the form {\tt (fun $x$ => $Q$)~$u_1$~\ldots~$u_n$}. \begin{ErrMsgs} -\item \errindex{Impossible to unify \dots\ with \dots} +\item \errindex{Unable to unify \dots\ with \dots} The {\tt apply} tactic failed to match the conclusion of {\term} and the current goal. @@ -1278,7 +1288,7 @@ in the list of subgoals remaining to prove. In particular, \texttt{pose proof {\term} as {\ident}} behaves as \texttt{assert ({\ident} := {\term})} and \texttt{pose proof {\term} - as {\intropattern}\tacindex{pose proof}} is the same as applying + as {\intropattern}} is the same as applying the {\intropattern} to {\term}. \item \texttt{enough ({\ident} :\ {\form})}\tacindex{enough} @@ -2289,6 +2299,12 @@ giving \texttt{injection {\term} as} (with an empty list of names). To obtain this behavior, the option {\tt Set Structural Injection} must be activated. This option is off by default. +By default, \texttt{injection} only creates new equalities between +terms whose type is in sort \texttt{Type} or \texttt{Set}, thus +implementing a special behavior for objects that are proofs +of a statement in \texttt{Prop}. This behavior can be turned off +by setting the option \texttt{Set Keep Proof Equalities}. +\optindex{Keep Proof Equalities} \subsection{\tt inversion \ident} \tacindex{inversion} @@ -2308,6 +2324,14 @@ latter is first introduced in the local context using stock the lemmas whenever the same instance needs to be inverted several times. See Section~\ref{Derive-Inversion}. +\Rem Part of the behavior of the \texttt{inversion} tactic is to generate +equalities between expressions that appeared in the hypothesis that is +being processed. By default, no equalities are generated if they relate +two proofs (i.e. equalities between terms whose type is in +sort \texttt{Prop}). This behavior can be turned off by using the option +\texttt{Set Keep Proof Equalities.} +\optindex{Keep Proof Equalities} + \begin{Variants} \item \texttt{inversion \num} @@ -3475,12 +3499,11 @@ hints of the database named {\tt core}. Uses the hint databases $\ident_1$ \dots\ $\ident_n$ in addition to the database {\tt core}. See Section~\ref{Hints-databases} for the list of pre-defined databases and the way to create or extend a - database. This option can be combined with the previous one. + database. \item {\tt auto with *} - Uses all existing hint databases, minus the special database - {\tt v62}. See Section~\ref{Hints-databases} + Uses all existing hint databases. See Section~\ref{Hints-databases} \item \texttt{auto using} \nterm{lemma}$_1$ {\tt ,} {\ldots} {\tt ,} \nterm{lemma}$_n$ @@ -3489,9 +3512,17 @@ hints of the database named {\tt core}. $lemma_i$ is an inductive type, it is the collection of its constructors which is added as hints. -\item \texttt{auto using} \nterm{lemma}$_1$ {\tt ,} {\ldots} {\tt ,} \nterm{lemma}$_n$ with \ident$_1$ {\ldots} \ident$_n$ +\item {\tt info\_auto} - This combines the effects of the {\tt using} and {\tt with} options. + Behaves like {\tt auto} but shows the tactics it uses to solve the goal. + This variant is very useful for getting a better understanding of automation, + or to know what lemmas/assumptions were used. + +\item {\tt \zeroone{info\_}auto \zeroone{\num}} \zeroone{{\tt using} \nterm{lemma}$_1$ + {\tt ,} {\ldots} {\tt ,} \nterm{lemma}$_n$} \zeroone{{\tt with} + \ident$_1$ {\ldots} \ident$_n$} + + This is the most general form, combining the various options. \item {\tt trivial}\tacindex{trivial} @@ -3503,6 +3534,14 @@ hints of the database named {\tt core}. \item \texttt{trivial with *} +\item \texttt{trivial using} \nterm{lemma}$_1$ {\tt ,} {\ldots} {\tt ,} \nterm{lemma}$_n$ + +\item {\tt info\_trivial} + +\item {\tt \zeroone{info\_}trivial} \zeroone{{\tt using} \nterm{lemma}$_1$ + {\tt ,} {\ldots} {\tt ,} \nterm{lemma}$_n$} \zeroone{{\tt with} + \ident$_1$ {\ldots} \ident$_n$} + \end{Variants} \Rem {\tt auto} either solves completely the goal or else leaves it @@ -3516,8 +3555,8 @@ intact. \texttt{auto} and \texttt{trivial} never fail. This tactic generalizes {\tt auto}. While {\tt auto} does not try resolution hints which would leave existential variables in the goal, -{\tt eauto} does try them (informally speaking, it uses {\tt eapply} -where {\tt auto} uses {\tt apply}). +{\tt eauto} does try them (informally speaking, it uses +{\tt simple eapply} where {\tt auto} uses {\tt simple apply}). As a consequence, {\tt eauto} can solve such a goal: \begin{coq_eval} @@ -3532,8 +3571,17 @@ eauto. Abort. \end{coq_eval} -Note that {\tt ex\_intro} should be declared as an -hint. +Note that {\tt ex\_intro} should be declared as a hint. + +\begin{Variants} + +\item {\tt \zeroone{info\_}eauto \zeroone{\num}} \zeroone{{\tt using} \nterm{lemma}$_1$ + {\tt ,} {\ldots} {\tt ,} \nterm{lemma}$_n$} \zeroone{{\tt with} + \ident$_1$ {\ldots} \ident$_n$} + + The various options for eauto are the same as for auto. + +\end{Variants} \SeeAlso Section~\ref{Hints-databases} @@ -3679,19 +3727,22 @@ command to add a hint to some databases \ident$_1$, \dots, \ident$_n$ is The {\hintdef} is one of the following expressions: \begin{itemize} -\item {\tt Resolve \term} +\item {\tt Resolve \term {\zeroone{{\tt |} \zeroone{\num} \zeroone{\pattern}}}} \comindex{Hint Resolve} This command adds {\tt simple apply {\term}} to the hint list with the head symbol of the type of \term. The cost of that hint is - the number of subgoals generated by {\tt simple apply {\term}}. + the number of subgoals generated by {\tt simple apply {\term}} or \num + if specified. The associated pattern is inferred from the conclusion + of the type of \term or the given \pattern if specified. %{\tt auto} actually uses a slightly modified variant of {\tt simple apply} with use_metas_eagerly_in_conv_on_closed_terms set to false - % Is it really needed? - %% In case the inferred type of \term\ does not start with a product - %% the tactic added in the hint list is {\tt exact {\term}}. In case - %% this type can however be reduced to a type starting with a product, - %% the tactic {\tt apply {\term}} is also stored in the hints list. + In case the inferred type of \term\ does not start with a product + the tactic added in the hint list is {\tt exact {\term}}. +% Actually, a slightly restricted version is used (no conversion on the head symbol) + In case + this type can however be reduced to a type starting with a product, + the tactic {\tt simple apply {\term}} is also stored in the hints list. If the inferred type of \term\ contains a dependent quantification on a variable which occurs only in the premisses of the type and not @@ -3721,6 +3772,17 @@ The {\hintdef} is one of the following expressions: Adds each \texttt{Resolve} {\term$_i$}. + \item {\tt Resolve -> \term} + + Adds the left-to-right implication of an equivalence as a hint + (informally the hint will be used as {\tt apply <- \term}, + although as mentionned before, the tactic actually used is + a restricted version of apply). + + \item {\tt Resolve <- \term} + + Adds the right-to-left implication of an equivalence as a hint. + \end{Variants} \item \texttt{Immediate {\term}} @@ -3856,7 +3918,7 @@ Abort. \comindex{Hint Cut} \textit{Warning:} these hints currently only apply to typeclass proof search and - the \texttt{typeclasses eauto} tactic. + the \texttt{typeclasses eauto} tactic (\ref{typeclasseseauto}). This command can be used to cut the proof-search tree according to a regular expression matching paths to be cut. The grammar for regular @@ -3948,8 +4010,8 @@ Several hint databases are defined in the \Coq\ standard library. The actual content of a database is the collection of the hints declared to belong to this database in each of the various modules currently loaded. Especially, requiring new modules potentially extend a -database. At {\Coq} startup, only the {\tt core} and {\tt v62} -databases are non empty and can be used. +database. At {\Coq} startup, only the {\tt core} database is non empty +and can be used. \begin{description} @@ -3984,18 +4046,8 @@ databases are non empty and can be used. from the \texttt{Classes} directory. \end{description} -There is also a special database called {\tt v62}. It collects all -hints that were declared in the versions of {\Coq} prior to version -6.2.4 when the databases {\tt core}, {\tt arith}, and so on were -introduced. The purpose of the database {\tt v62} is to ensure -compatibility with further versions of {\Coq} for developments done in -versions prior to 6.2.4 ({\tt auto} being replaced by {\tt auto with v62}). -The database {\tt v62} is intended not to be extended (!). It is not -included in the hint databases list used in the {\tt auto with *} tactic. - -Furthermore, you are advised not to put your own hints in the -{\tt core} database, but use one or several databases specific to your -development. +You are advised not to put your own hints in the {\tt core} database, +but use one or several databases specific to your development. \subsection{\tt Remove Hints \term$_1$ \mbox{\dots} \term$_n$ :~ \ident$_1$ \mbox{\dots} \ident$_m$} @@ -4356,22 +4408,23 @@ vernacular command and printed using {\nobreak {\tt Print Firstorder Tries to solve the goal with {\tac} when no logical rule may apply. - \item {\tt firstorder with \ident$_1$ \dots\ \ident$_n$ } - \tacindex{firstorder with} - - Adds lemmas \ident$_1$ \dots\ \ident$_n$ to the proof-search - environment. - \item {\tt firstorder using {\qualid}$_1$ , \dots\ , {\qualid}$_n$ } \tacindex{firstorder using} - Adds lemmas in {\tt auto} hints bases {\qualid}$_1$ \dots\ {\qualid}$_n$ - to the proof-search environment. If {\qualid}$_i$ refers to an inductive - type, it is the collection of its constructors which is added as hints. + Adds lemmas {\qualid}$_1$ \dots\ {\qualid}$_n$ to the proof-search + environment. If {\qualid}$_i$ refers to an inductive type, it is + the collection of its constructors which are added to the + proof-search environment. + + \item {\tt firstorder with \ident$_1$ \dots\ \ident$_n$ } + \tacindex{firstorder with} + + Adds lemmas from {\tt auto} hint bases \ident$_1$ \dots\ \ident$_n$ + to the proof-search environment. -\item \texttt{firstorder using {\qualid}$_1$ , \dots\ , {\qualid}$_n$ with \ident$_1$ \dots\ \ident$_n$} +\item \texttt{firstorder {\tac} using {\qualid}$_1$ , \dots\ , {\qualid}$_n$ with \ident$_1$ \dots\ \ident$_n$} - This combines the effects of the {\tt using} and {\tt with} options. + This combines the effects of the different variants of \texttt{firstorder}. \end{Variants} @@ -4568,7 +4621,7 @@ It is equivalent to {\tt apply refl\_equal}. \begin{ErrMsgs} \item \errindex{The conclusion is not a substitutive equation} -\item \errindex{Impossible to unify \dots\ with \dots} +\item \errindex{Unable to unify \dots\ with \dots} \end{ErrMsgs} \subsection{\tt symmetry} diff --git a/doc/tutorial/Tutorial.tex b/doc/tutorial/Tutorial.tex index 973a0b75e0..0d537256bb 100644 --- a/doc/tutorial/Tutorial.tex +++ b/doc/tutorial/Tutorial.tex @@ -3,6 +3,7 @@ \usepackage[utf8]{inputenc} \usepackage{textcomp} \usepackage{pslatex} +\usepackage{hyperref} \input{../common/version.tex} \input{../common/macros.tex} @@ -17,7 +18,7 @@ \chapter*{Getting started} -\Coq\ is a Proof Assistant for a Logical Framework known as the Calculus +\Coq{} is a Proof Assistant for a Logical Framework known as the Calculus of Inductive Constructions. It allows the interactive construction of formal proofs, and also the manipulation of functional programs consistently with their specifications. It runs as a computer program @@ -29,7 +30,7 @@ possibilities of \Coq, but rather to present in the most elementary manner a tutorial on the basic specification language, called Gallina, in which formal axiomatisations may be developed, and on the main proof tools. For more advanced information, the reader could refer to -the \Coq{} Reference Manual or the \textit{Coq'Art}, a new book by Y. +the \Coq{} Reference Manual or the \textit{Coq'Art}, a book by Y. Bertot and P. Castéran on practical uses of the \Coq{} system. Coq can be used from a standard teletype-like shell window but @@ -39,9 +40,9 @@ and Pcoq.}. Instructions on installation procedures, as well as more comprehensive documentation, may be found in the standard distribution of \Coq, -which may be obtained from \Coq{} web site \texttt{http://coq.inria.fr}. +which may be obtained from \Coq{} web site \url{https://coq.inria.fr/}. -In the following, we assume that \Coq~ is called from a standard +In the following, we assume that \Coq{} is called from a standard teletype-like shell window. All examples preceded by the prompting sequence \verb:Coq < : represent user input, terminated by a period. @@ -51,10 +52,10 @@ users screen. When used from a graphical user interface such as CoqIde, the prompt is not displayed: user input is given in one window and \Coq's answers are displayed in a different window. -The sequence of such examples is a valid \Coq~ +The sequence of such examples is a valid \Coq{} session, unless otherwise specified. This version of the tutorial has been prepared on a PC workstation running Linux. The standard -invocation of \Coq\ delivers a message such as: +invocation of \Coq{} delivers a message such as: \begin{small} \begin{flushleft} @@ -67,17 +68,17 @@ Coq < \end{flushleft} \end{small} -The first line gives a banner stating the precise version of \Coq~ +The first line gives a banner stating the precise version of \Coq{} used. You should always return this banner when you report an anomaly to our bug-tracking system -\verb|http://logical.futurs.inria.fr/coq-bugs| +\url{https://coq.inria.fr/bugs/}. \chapter{Basic Predicate Calculus} \section{An overview of the specification language Gallina} A formal development in Gallina consists in a sequence of {\sl declarations} -and {\sl definitions}. You may also send \Coq~ {\sl commands} which are +and {\sl definitions}. You may also send \Coq{} {\sl commands} which are not really part of the formal development, but correspond to information requests, or service routine invocations. For instance, the command: \begin{verbatim} @@ -106,7 +107,7 @@ of the system, called respectively \verb:Prop:, \verb:Set:, and Every valid expression $e$ in Gallina is associated with a specification, itself a valid expression, called its {\sl type} $\tau(E)$. We write $e:\tau(E)$ for the judgment that $e$ is of type $E$. -You may request \Coq~ to return to you the type of a valid expression by using +You may request \Coq{} to return to you the type of a valid expression by using the command \verb:Check:: \begin{coq_eval} @@ -130,7 +131,7 @@ Check nat. The specification \verb:Set: is an abstract type, one of the basic sorts of the Gallina language, whereas the notions $nat$ and $O$ are notions which are defined in the arithmetic prelude, -automatically loaded when running the \Coq\ system. +automatically loaded when running the \Coq{} system. We start by introducing a so-called section name. The role of sections is to structure the modelisation by limiting the scope of parameters, @@ -206,7 +207,7 @@ We may optionally indicate the required type: Definition two : nat := S one. \end{coq_example} -Actually \Coq~ allows several possible syntaxes: +Actually \Coq{} allows several possible syntaxes: \begin{coq_example} Definition three := S two : nat. \end{coq_example} @@ -249,7 +250,7 @@ explicitly the type of the quantified variable. We check: Check (forall m:nat, gt m 0). \end{coq_example} We may revert to the clean state of -our initial session using the \Coq~ \verb:Reset: command: +our initial session using the \Coq{} \verb:Reset: command: \begin{coq_example} Reset Initial. \end{coq_example} @@ -340,7 +341,7 @@ assumption. \end{coq_example} The proof is now finished. We may either discard it, by using the -command \verb:Abort: which returns to the standard \Coq~ toplevel loop +command \verb:Abort: which returns to the standard \Coq{} toplevel loop without further ado, or else save it as a lemma in the current context, under name say \verb:trivial_lemma:: \begin{coq_example} @@ -414,7 +415,7 @@ backtrack one step, and more generally \verb:Undo n: to backtrack n steps. We end this section by showing a useful command, \verb:Inspect n.:, -which inspects the global \Coq~ environment, showing the last \verb:n: declared +which inspects the global \Coq{} environment, showing the last \verb:n: declared notions: \begin{coq_example} Inspect 3. @@ -429,7 +430,7 @@ their value (or proof-term) is omitted. \subsection{Conjunction} We have seen how \verb:intro: and \verb:apply: tactics could be combined -in order to prove implicational statements. More generally, \Coq~ favors a style +in order to prove implicational statements. More generally, \Coq{} favors a style of reasoning, called {\sl Natural Deduction}, which decomposes reasoning into so called {\sl introduction rules}, which tell how to prove a goal whose main operator is a given propositional connective, and {\sl elimination rules}, @@ -528,7 +529,7 @@ such a simple tautology. The reason is that we want to keep \subsection{Tauto} A complete tactic for propositional -tautologies is indeed available in \Coq~ as the \verb:tauto: tactic. +tautologies is indeed available in \Coq{} as the \verb:tauto: tactic. \begin{coq_example} Restart. tauto. @@ -555,7 +556,7 @@ The two instantiations are effected automatically by the tactic \verb:apply: when pattern-matching a goal. The specialist will of course recognize our proof term as a $\lambda$-term, used as notation for the natural deduction proof term through the Curry-Howard isomorphism. The -naive user of \Coq~ may safely ignore these formal details. +naive user of \Coq{} may safely ignore these formal details. Let us exercise the \verb:tauto: tactic on a more complex example: \begin{coq_example} @@ -579,7 +580,7 @@ argument fails. This may come as a surprise to someone familiar with classical reasoning. Peirce's lemma is true in Boolean logic, i.e. it evaluates to \verb:true: for every truth-assignment to \verb:A: and \verb:B:. Indeed the double negation -of Peirce's law may be proved in \Coq~ using \verb:tauto:: +of Peirce's law may be proved in \Coq{} using \verb:tauto:: \begin{coq_example} Abort. Lemma NNPeirce : ~ ~ (((A -> B) -> A) -> A). @@ -588,7 +589,7 @@ Qed. \end{coq_example} In classical logic, the double negation of a proposition is equivalent to this -proposition, but in the constructive logic of \Coq~ this is not so. If you +proposition, but in the constructive logic of \Coq{} this is not so. If you want to use classical logic in \Coq, you have to import explicitly the \verb:Classical: module, which will declare the axiom \verb:classic: of excluded middle, and classical tautologies such as de Morgan's laws. @@ -652,7 +653,7 @@ function and predicate symbols. \subsection{Sections and signatures} Usually one works in some domain of discourse, over which range the individual -variables and function symbols. In \Coq~ we speak in a language with a rich +variables and function symbols. In \Coq{} we speak in a language with a rich variety of types, so me may mix several domains of discourse, in our multi-sorted language. For the moment, we just do a few exercises, over a domain of discourse \verb:D: axiomatised as a \verb:Set:, and we consider two @@ -660,7 +661,7 @@ predicate symbols \verb:P: and \verb:R: over \verb:D:, of arities respectively 1 and 2. Such abstract entities may be entered in the context as global variables. But we must be careful about the pollution of our global environment by such declarations. For instance, we have already -polluted our \Coq~ session by declaring the variables +polluted our \Coq{} session by declaring the variables \verb:n:, \verb:Pos_n:, \verb:A:, \verb:B:, and \verb:C:. \begin{coq_example} @@ -714,7 +715,7 @@ Check ex. \end{coq_example} and the notation \verb+(exists x:D, P x)+ is just concrete syntax for the expression \verb+(ex D (fun x:D => P x))+. -Existential quantification is handled in \Coq~ in a similar +Existential quantification is handled in \Coq{} in a similar fashion to the connectives \verb:/\: and \verb:\/: : it is introduced by the proof combinator \verb:ex_intro:, which is invoked by the specific tactic \verb:Exists:, and its elimination provides a witness \verb+a:D+ to @@ -951,7 +952,7 @@ Abort. \subsection{Equality} -The basic equality provided in \Coq~ is Leibniz equality, noted infix like +The basic equality provided in \Coq{} is Leibniz equality, noted infix like \verb+x=y+, when \verb:x: and \verb:y: are two expressions of type the same Set. The replacement of \verb:x: by \verb:y: in any term is effected by a variety of tactics, such as \verb:rewrite: @@ -1208,7 +1209,7 @@ About prim_rec. Oops! Instead of the expected type \verb+nat->(nat->nat->nat)->nat->nat+ we get an apparently more complicated expression. Indeed the type of \verb:prim_rec: is equivalent by rule $\beta$ to its expected type; this may -be checked in \Coq~ by command \verb:Eval Cbv Beta:, which $\beta$-reduces +be checked in \Coq{} by command \verb:Eval Cbv Beta:, which $\beta$-reduces an expression to its {\sl normal form}: \begin{coq_example} Eval cbv beta in @@ -1228,7 +1229,7 @@ That is, we specify that \verb+(addition n m)+ computes by cases on \verb:n: according to its main constructor; when \verb:n = O:, we get \verb:m:; when \verb:n = S p:, we get \verb:(S rec):, where \verb:rec: is the result of the recursive computation \verb+(addition p m)+. Let us verify it by -asking \Coq~to compute for us say $2+3$: +asking \Coq{} to compute for us say $2+3$: \begin{coq_example} Eval compute in (addition (S (S O)) (S (S (S O)))). \end{coq_example} @@ -1275,7 +1276,7 @@ as subgoals the corresponding instantiations of the base case \verb:(P O): , and of the inductive step \verb+forall y:nat, P y -> P (S y)+. In each case we get an instance of function \verb:plus: in which its second argument starts with a constructor, and is thus amenable to simplification -by primitive recursion. The \Coq~tactic \verb:simpl: can be used for +by primitive recursion. The \Coq{} tactic \verb:simpl: can be used for this purpose: \begin{coq_example} simpl. @@ -1488,7 +1489,7 @@ Set Printing Width 60. \section{Opening library modules} -When you start \Coq~ without further requirements in the command line, +When you start \Coq{} without further requirements in the command line, you get a bare system with few libraries loaded. As we saw, a standard prelude module provides the standard logic connectives, and a few arithmetic notions. If you want to load and open other modules from @@ -1503,9 +1504,9 @@ Such a command looks for a (compiled) module file \verb:Arith.vo: in the libraries registered by \Coq. Libraries inherit the structure of the file system of the operating system and are registered with the command \verb:Add LoadPath:. Physical directories are mapped to -logical directories. Especially the standard library of \Coq~ is +logical directories. Especially the standard library of \Coq{} is pre-registered as a library of name \verb=Coq=. Modules have absolute -unique names denoting their place in \Coq~ libraries. An absolute +unique names denoting their place in \Coq{} libraries. An absolute name is a sequence of single identifiers separated by dots. E.g. the module \verb=Arith= has full name \verb=Coq.Arith.Arith= and because it resides in eponym subdirectory \verb=Arith= of the standard diff --git a/engine/evarutil.ml b/engine/evarutil.ml index e45e7dc496..df170c8ddc 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -678,6 +678,28 @@ let gather_dependent_evars evm l = (* /spiwack *) +(** [advance sigma g] returns [Some g'] if [g'] is undefined and is + the current avatar of [g] (for instance [g] was changed by [clear] + into [g']). It returns [None] if [g] has been (partially) + solved. *) +(* spiwack: [advance] is probably performance critical, and the good + behaviour of its definition may depend sensitively to the actual + definition of [Evd.find]. Currently, [Evd.find] starts looking for + a value in the heap of undefined variable, which is small. Hence in + the most common case, where [advance] is applied to an unsolved + goal ([advance] is used to figure if a side effect has modified the + goal) it terminates quickly. *) +let rec advance sigma evk = + let evi = Evd.find sigma evk in + match evi.evar_body with + | Evar_empty -> Some evk + | Evar_defined v -> + if Option.default false (Store.get evi.evar_extra cleared) then + let (evk,_) = Term.destEvar v in + advance sigma evk + else + None + (** The following functions return the set of undefined evars contained in the object, the defined evars being traversed. This is roughly a combination of the previous functions and diff --git a/engine/evarutil.mli b/engine/evarutil.mli index c0c81442d5..7fdc7aac78 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -110,6 +110,12 @@ val is_ground_env : evar_map -> env -> bool its (partial) definition. *) val gather_dependent_evars : evar_map -> evar list -> (Evar.Set.t option) Evar.Map.t +(** [advance sigma g] returns [Some g'] if [g'] is undefined and is + the current avatar of [g] (for instance [g] was changed by [clear] + into [g']). It returns [None] if [g] has been (partially) + solved. *) +val advance : evar_map -> evar -> evar option + (** The following functions return the set of undefined evars contained in the object, the defined evars being traversed. This is roughly a combination of the previous functions and diff --git a/engine/evd.ml b/engine/evd.ml index 6ba8a51120..c2f848291b 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -641,6 +641,7 @@ let set_universe_context evd uctx' = { evd with universes = uctx' } let add_conv_pb ?(tail=false) pb d = + (** MS: we have duplicates here, why? *) if tail then {d with conv_pbs = d.conv_pbs @ [pb]} else {d with conv_pbs = pb::d.conv_pbs} @@ -679,13 +680,16 @@ let restrict evk filter ?candidates evd = { evar_info with evar_filter = filter; evar_candidates = candidates; evar_extra = Store.empty } in + let last_mods = match evd.conv_pbs with + | [] -> evd.last_mods + | _ -> Evar.Set.add evk evd.last_mods in let evar_names = EvNames.reassign_name_defined evk evk' evd.evar_names in let ctxt = Filter.filter_list filter (evar_context evar_info) in let id_inst = Array.map_of_list (mkVar % get_id) ctxt in let body = mkEvar(evk',id_inst) in let (defn_evars, undf_evars) = define_aux evd.defn_evars evd.undf_evars evk body in { evd with undf_evars = EvMap.add evk' evar_info' undf_evars; - defn_evars; evar_names }, evk' + defn_evars; last_mods; evar_names }, evk' let downcast evk ccl evd = let evar_info = EvMap.find evk evd.undf_evars in @@ -853,6 +857,13 @@ let is_eq_sort s1 s2 = if Univ.Universe.equal u1 u2 then None else Some (u1, u2) +(* Precondition: l is not defined in the substitution *) +let universe_rigidity evd l = + let uctx = evd.universes in + if Univ.LSet.mem l (Univ.ContextSet.levels (UState.context_set uctx)) then + UnivFlexible (Univ.LSet.mem l (UState.algebraics uctx)) + else UnivRigid + let normalize_universe evd = let vars = ref (UState.subst evd.universes) in let normalize = Universes.normalize_universe_opt_subst vars in @@ -1411,6 +1422,16 @@ let print_env_short env = let pr_evar_constraints pbs = let pr_evconstr (pbty, env, t1, t2) = + let env = + (** We currently allow evar instances to refer to anonymous de + Bruijn indices, so we protect the error printing code in this + case by giving names to every de Bruijn variable in the + rel_context of the conversion problem. MS: we should rather + stop depending on anonymous variables, they can be used to + indicate independency. Also, this depends on a strategy for + naming/renaming. *) + Namegen.make_all_name_different env + in print_env_short env ++ spc () ++ str "|-" ++ spc () ++ print_constr_env env t1 ++ spc () ++ str (match pbty with diff --git a/engine/evd.mli b/engine/evd.mli index b47b389d1b..86887f3dcc 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -467,7 +467,17 @@ val retract_coercible_metas : evar_map -> metabinding list * evar_map (********************************************************* Sort/universe variables *) -(** Rigid or flexible universe variables *) +(** Rigid or flexible universe variables. + + [UnivRigid] variables are user-provided or come from an explicit + [Type] in the source, we do not minimize them or unify them eagerly. + + [UnivFlexible alg] variables are fresh universe variables of + polymorphic constants or generated during refinement, sometimes in + algebraic position (i.e. not appearing in the term at the moment of + creation). They are the candidates for minimization (if alg, to an + algebraic universe) and unified eagerly in the first-order + unification heurstic. *) type rigid = UState.rigid = | UnivRigid @@ -514,7 +524,8 @@ val new_univ_variable : ?loc:Loc.t -> ?name:string -> rigid -> evar_map -> evar_ val new_sort_variable : ?loc:Loc.t -> ?name:string -> rigid -> evar_map -> evar_map * sorts val add_global_univ : evar_map -> Univ.Level.t -> evar_map - + +val universe_rigidity : evar_map -> Univ.Level.t -> rigid val make_flexible_variable : evar_map -> bool -> Univ.universe_level -> evar_map val is_sort_variable : evar_map -> sorts -> Univ.universe_level option (** [is_sort_variable evm s] returns [Some u] or [None] if [s] is diff --git a/engine/ftactic.ml b/engine/ftactic.ml index 588709873e..aeaaea7e48 100644 --- a/engine/ftactic.ml +++ b/engine/ftactic.ml @@ -29,13 +29,28 @@ let bind (type a) (type b) (m : a t) (f : a -> b t) : b t = m >>= function | Uniform x -> (** We dispatch the uniform result on each goal under focus, as we know that the [m] argument was actually dependent. *) - Proofview.Goal.goals >>= fun l -> - let ans = List.map (fun _ -> x) l in + Proofview.Goal.goals >>= fun goals -> + let ans = List.map (fun g -> (g,x)) goals in Proofview.tclUNIT ans - | Depends l -> Proofview.tclUNIT l + | Depends l -> + Proofview.Goal.goals >>= fun goals -> + Proofview.tclUNIT (List.combine goals l) + in + (* After the tactic has run, some goals which were previously + produced may have been solved by side effects. The values + attached to such goals must be discarded, otherwise the list of + result would not have the same length as the list of focused + goals, which is an invariant of the [Ftactic] module. It is the + reason why a goal is attached to each result above. *) + let filter (g,x) = + g >>= fun g -> + Proofview.Goal.unsolved g >>= function + | true -> Proofview.tclUNIT (Some x) + | false -> Proofview.tclUNIT None in Proofview.tclDISPATCHL (List.map f l) >>= fun l -> - Proofview.tclUNIT (Depends (List.concat l)) + Proofview.Monad.List.map_filter filter (List.concat l) >>= fun filtered -> + Proofview.tclUNIT (Depends filtered) let goals = Proofview.Goal.goals >>= fun l -> Proofview.tclUNIT (Depends l) let set_sigma r = diff --git a/engine/proofview.ml b/engine/proofview.ml index a2838a2de1..c01879765b 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -152,33 +152,9 @@ let focus i j sp = let (new_comb, context) = focus_sublist i j sp.comb in ( { sp with comb = new_comb } , context ) - -(** [advance sigma g] returns [Some g'] if [g'] is undefined and is - the current avatar of [g] (for instance [g] was changed by [clear] - into [g']). It returns [None] if [g] has been (partially) - solved. *) -(* spiwack: [advance] is probably performance critical, and the good - behaviour of its definition may depend sensitively to the actual - definition of [Evd.find]. Currently, [Evd.find] starts looking for - a value in the heap of undefined variable, which is small. Hence in - the most common case, where [advance] is applied to an unsolved - goal ([advance] is used to figure if a side effect has modified the - goal) it terminates quickly. *) -let rec advance sigma g = - let open Evd in - let evi = Evd.find sigma g in - match evi.evar_body with - | Evar_empty -> Some g - | Evar_defined v -> - if Option.default false (Store.get evi.evar_extra Evarutil.cleared) then - let (e,_) = Term.destEvar v in - advance sigma e - else - None - (** [undefined defs l] is the list of goals in [l] which are still unsolved (after advancing cleared goals). *) -let undefined defs l = CList.map_filter (advance defs) l +let undefined defs l = CList.map_filter (Evarutil.advance defs) l (** Unfocuses a proofview with respect to a context. *) let unfocus c sp = @@ -465,7 +441,7 @@ let iter_goal i = Comb.get >>= fun initial -> Proof.List.fold_left begin fun (subgoals as cur) goal -> Solution.get >>= fun step -> - match advance step goal with + match Evarutil.advance step goal with | None -> return cur | Some goal -> Comb.set [goal] >> @@ -489,7 +465,7 @@ let fold_left2_goal i s l = in Proof.List.fold_left2 err begin fun ((r,subgoals) as cur) goal a -> Solution.get >>= fun step -> - match advance step goal with + match Evarutil.advance step goal with | None -> return cur | Some goal -> Comb.set [goal] >> @@ -533,7 +509,7 @@ let tclDISPATCHGEN0 join tacs = let open Proof in Pv.get >>= function | { comb=[goal] ; solution } -> - begin match advance solution goal with + begin match Evarutil.advance solution goal with | None -> tclUNIT (join []) | Some _ -> Proof.map (fun res -> join [res]) tac end @@ -685,6 +661,21 @@ let unshelve l p = let l = undefined p.solution l in { p with comb = p.comb@l } +let mark_in_evm ~goal evd content = + let info = Evd.find evd content in + let info = + if goal then + { info with Evd.evar_source = match info.Evd.evar_source with + | _, (Evar_kinds.VarInstance _ | Evar_kinds.GoalEvar) as x -> x + | loc,_ -> loc,Evar_kinds.GoalEvar } + else info + in + let info = match Evd.Store.get info.Evd.evar_extra typeclass_resolvable with + | None -> { info with Evd.evar_extra = Evd.Store.set info.Evd.evar_extra typeclass_resolvable () } + | Some () -> info + in + Evd.add evd content info + let with_shelf tac = let open Proof in Pv.get >>= fun pv -> @@ -697,8 +688,11 @@ let with_shelf tac = let fgoals = Evd.future_goals solution in let pgoal = Evd.principal_future_goal solution in let sigma = Evd.restore_future_goals sigma fgoals pgoal in - Pv.set { npv with shelf; solution = sigma } >> - tclUNIT (CList.rev_append gls' gls, ans) + (* Ensure we mark and return only unsolved goals *) + let gls' = undefined sigma (CList.rev_append gls' gls) in + let sigma = CList.fold_left (mark_in_evm ~goal:false) sigma gls' in + let npv = { npv with shelf; solution = sigma } in + Pv.set npv >> tclUNIT (gls', ans) (** [goodmod p m] computes the representative of [p] modulo [m] in the interval [[0,m-1]].*) @@ -929,6 +923,8 @@ module Unsafe = struct { step with comb = step.comb @ gls } end + let tclSETENV = Env.set + let tclGETGOALS = Comb.get let tclSETGOALS = Comb.set @@ -943,19 +939,12 @@ module Unsafe = struct { p with solution = Evd.reset_future_goals p.solution } let mark_as_goal evd content = - let info = Evd.find evd content in - let info = - { info with Evd.evar_source = match info.Evd.evar_source with - | _, (Evar_kinds.VarInstance _ | Evar_kinds.GoalEvar) as x -> x - | loc,_ -> loc,Evar_kinds.GoalEvar } - in - let info = match Evd.Store.get info.Evd.evar_extra typeclass_resolvable with - | None -> { info with Evd.evar_extra = Evd.Store.set info.Evd.evar_extra typeclass_resolvable () } - | Some () -> info - in - Evd.add evd content info + mark_in_evm ~goal:true evd content + + let advance = Evarutil.advance - let advance = advance + let mark_as_unresolvable p gl = + { p with solution = mark_in_evm ~goal:false p.solution gl } let typeclass_resolvable = typeclass_resolvable @@ -1117,7 +1106,7 @@ module Goal = struct Pv.get >>= fun step -> let sigma = step.solution in let map goal = - match advance sigma goal with + match Evarutil.advance sigma goal with | None -> None (** ppedrot: Is this check really necessary? *) | Some goal -> let gl = @@ -1129,6 +1118,10 @@ module Goal = struct in tclUNIT (CList.map_filter map step.comb) + let unsolved { self=self } = + tclEVARMAP >>= fun sigma -> + tclUNIT (not (Option.is_empty (Evarutil.advance sigma self))) + (* compatibility *) let goal { self=self } = self @@ -1164,10 +1157,6 @@ let tclLIFT = Proof.lift let tclCHECKINTERRUPT = tclLIFT (NonLogical.make Control.check_for_interrupt) - - - - (*** Compatibility layer with <= 8.2 tactics ***) module V82 = struct type tac = Evar.t Evd.sigma -> Evar.t list Evd.sigma diff --git a/engine/proofview.mli b/engine/proofview.mli index bc68f11ff0..90be2f90ab 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -326,8 +326,9 @@ val unshelve : Goal.goal list -> proofview -> proofview (** [depends_on g1 g2 sigma] checks if g1 occurs in the type/ctx of g2 *) val depends_on : Evd.evar_map -> Goal.goal -> Goal.goal -> bool -(** [with_shelf tac] executes [tac] and returns its result together with the set - of goals shelved by [tac]. The current shelf is unchanged. *) +(** [with_shelf tac] executes [tac] and returns its result together with + the set of goals shelved by [tac]. The current shelf is unchanged + and the returned list contains only unsolved goals. *) val with_shelf : 'a tactic -> (Goal.goal list * 'a) tactic (** If [n] is positive, [cycle n] puts the [n] first goal last. If [n] @@ -372,7 +373,6 @@ val mark_as_unsafe : unit tactic with given up goals cannot be closed. *) val give_up : unit tactic - (** {7 Control primitives} *) (** [tclPROGRESS t] checks the state of the proof after [t]. It it is @@ -409,6 +409,9 @@ module Unsafe : sig (** Like {!tclEVARS} but also checks whether goals have been solved. *) val tclEVARSADVANCE : Evd.evar_map -> unit tactic + (** Set the global environment of the tactic *) + val tclSETENV : Environ.env -> unit tactic + (** [tclNEWGOALS gls] adds the goals [gls] to the ones currently being proved, appending them to the list of focused goals. If a goal is already solved, it is not added. *) @@ -431,6 +434,9 @@ module Unsafe : sig and makes it unresolvable for type classes. *) val mark_as_goal : Evd.evar_map -> Evar.t -> Evd.evar_map + (** Make an evar unresolvable for type classes. *) + val mark_as_unresolvable : proofview -> Evar.t -> proofview + (** [advance sigma g] returns [Some g'] if [g'] is undefined and is the current avatar of [g] (for instance [g] was changed by [clear] into [g']). It returns [None] if [g] has been (partially) @@ -518,6 +524,10 @@ module Goal : sig FIXME: encapsulate the level in an existential type. *) val goals : ([ `LZ ], 'r) t tactic list tactic + (** [unsolved g] is [true] if [g] is still unsolved in the current + proof state. *) + val unsolved : ('a, 'r) t -> bool tactic + (** Compatibility: avoid if possible *) val goal : ([ `NF ], 'r) t -> Evar.t diff --git a/engine/termops.ml b/engine/termops.ml index a047bf53c7..697b9a5f15 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -599,6 +599,10 @@ let collect_vars c = | _ -> fold_constr aux vars c in aux Id.Set.empty c +let vars_of_global_reference env gr = + let c, _ = Universes.unsafe_constr_of_global gr in + vars_of_global (Global.env ()) c + (* Tests whether [m] is a subterm of [t]: [m] is appropriately lifted through abstractions of [t] *) @@ -975,11 +979,8 @@ let smash_rel_context sign = let fold_named_context_both_sides f l ~init = List.fold_right_and_left f l init -let rec mem_named_context id ctxt = - match ctxt with - | decl :: _ when Id.equal id (NamedDecl.get_id decl) -> true - | _ :: sign -> mem_named_context id sign - | [] -> false +let mem_named_context_val id ctxt = + try ignore(Environ.lookup_named_val id ctxt); true with Not_found -> false let compact_named_context_reverse sign = let compact l decl = diff --git a/engine/termops.mli b/engine/termops.mli index 5d85088f8d..fd8edafbcf 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -121,6 +121,7 @@ val dependent_in_decl : constr -> Context.Named.Declaration.t -> bool val count_occurrences : constr -> constr -> int val collect_metas : constr -> int list val collect_vars : constr -> Id.Set.t (** for visible vars only *) +val vars_of_global_reference : env -> Globnames.global_reference -> Id.Set.t val occur_term : constr -> constr -> bool (** Synonymous of dependent Substitution of metavariables *) @@ -237,7 +238,7 @@ val map_rel_context_with_binders : val fold_named_context_both_sides : ('a -> Context.Named.Declaration.t -> Context.Named.Declaration.t list -> 'a) -> Context.Named.t -> init:'a -> 'a -val mem_named_context : Id.t -> Context.Named.t -> bool +val mem_named_context_val : Id.t -> named_context_val -> bool val compact_named_context : Context.Named.t -> Context.NamedList.t val compact_named_context_reverse : Context.Named.t -> Context.NamedList.t diff --git a/grammar/tacextend.mlp b/grammar/tacextend.mlp index a1b3f4f255..683a7e2f71 100644 --- a/grammar/tacextend.mlp +++ b/grammar/tacextend.mlp @@ -48,7 +48,7 @@ let make_fun_clauses loc s l = let map c = GramCompat.make_fun loc [make_clause c] in mlexpr_of_list map l -let get_argt e = <:expr< match $e$ with [ Genarg.ExtraArg tag -> tag | _ -> assert False ] >> +let get_argt e = <:expr< (fun e -> match e with [ Genarg.ExtraArg tag -> tag | _ -> assert False ]) $e$ >> let rec mlexpr_of_symbol = function | Ulist1 s -> <:expr< Extend.Ulist1 $mlexpr_of_symbol s$ >> diff --git a/ide/.merlin b/ide/.merlin index 3f3d9d275d..953b5dce4c 100644 --- a/ide/.merlin +++ b/ide/.merlin @@ -1,4 +1,4 @@ -PKG lablgtk2.sourceview2 +PKG unix laglgtk2 lablgtk2.sourceview2 S utils B utils diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index bb8723dfe6..c0c4131ac5 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -100,7 +100,7 @@ let coqide_cmd_checks (loc,ast) = if is_debug ast then user_error "Debug mode not available within CoqIDE"; if is_known_option ast then - Feedback.msg_warning (strbrk"This will not work. Use CoqIDE display menu instead"); + Feedback.msg_warning (strbrk"This will not work. Use CoqIDE view menu instead"); if Vernac.is_navigation_vernac ast || is_undo ast then Feedback.msg_warning (strbrk "Rather use CoqIDE navigation instead"); if is_query ast then @@ -392,7 +392,8 @@ let init = Stm.add false ~ontop:(Stm.get_current_state ()) 0 (Printf.sprintf "Add LoadPath \"%s\". " dir) else Stm.get_current_state (), `NewTip in - Stm.set_compilation_hints file; + if Filename.check_suffix file ".v" then + Stm.set_compilation_hints file; Stm.finish (); initial_id end diff --git a/ide/interface.mli b/ide/interface.mli index 2a9b8b241f..123cac6c22 100644 --- a/ide/interface.mli +++ b/ide/interface.mli @@ -139,7 +139,7 @@ type add_rty = state_id * ((unit, state_id) union * string) [Inr (start,(stop,tip))] if [id] is in a zone that can be focused. In that case the zone is delimited by [start] and [stop] while [tip] is the new document [tip]. Edits made by subsequent [add] are always - performend on top of [id]. *) + performed on top of [id]. *) type edit_at_sty = state_id type edit_at_rty = (unit, state_id * (state_id * state_id)) union @@ -153,7 +153,7 @@ type query_rty = string type goals_sty = unit type goals_rty = goals option -(** Retrieve the list of unintantiated evars in the current proof. [None] if no +(** Retrieve the list of uninstantiated evars in the current proof. [None] if no proof is in progress. *) type evars_sty = unit type evars_rty = evar list option diff --git a/ide/preferences.ml b/ide/preferences.ml index 64327d74f5..f0fd45d77f 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -468,7 +468,7 @@ let create_tag name default = let iter table = let tag = GText.tag ~name () in table#add tag#as_tag; - pref#connect#changed (fun _ -> set_tag tag); + ignore (pref#connect#changed (fun _ -> set_tag tag)); set_tag tag; in List.iter iter [Tags.Script.table; Tags.Proof.table; Tags.Message.table]; @@ -918,7 +918,7 @@ let configure ?(apply=(fun () -> ())) () = in let doc_url = let predefined = [ - "file://"^(List.fold_left Filename.concat (Coq_config.docdir) ["html";"refman";""]); + "file://"^(List.fold_left Filename.concat (Coq_config.docdir) ["refman";"html"]); Coq_config.wwwrefman; use_default_doc_url ] in @@ -931,7 +931,7 @@ let configure ?(apply=(fun () -> ())) () = doc_url#get in let library_url = let predefined = [ - "file://"^(List.fold_left Filename.concat (Coq_config.docdir) ["html";"stdlib";""]); + "file://"^(List.fold_left Filename.concat (Coq_config.docdir) ["stdlib";"html"]); Coq_config.wwwstdlib ] in combo diff --git a/ide/texmacspp.ml b/ide/texmacspp.ml index 53a29008ad..680da7f54b 100644 --- a/ide/texmacspp.ml +++ b/ide/texmacspp.ml @@ -189,7 +189,8 @@ match sm with end | SetEntryType (s, _) -> ["entrytype", s] | SetOnlyPrinting -> ["onlyprinting", ""] - | SetOnlyParsing v -> ["compat", Flags.pr_version v] + | SetOnlyParsing -> ["onlyparsing", ""] + | SetCompatVersion v -> ["compat", Flags.pr_version v] | SetFormat (system, (loc, s)) -> let start, stop = unlock loc in ["format-"^system, s; "begin", start; "end", stop] @@ -708,6 +709,7 @@ let rec tmpp v loc = | VernacSetStrategy _ as x -> xmlTODO loc x | VernacUnsetOption _ as x -> xmlTODO loc x | VernacSetOption _ as x -> xmlTODO loc x + | VernacSetAppendOption _ as x -> xmlTODO loc x | VernacAddOption _ as x -> xmlTODO loc x | VernacRemoveOption _ as x -> xmlTODO loc x | VernacMemOption _ as x -> xmlTODO loc x diff --git a/ide/utils/configwin_keys.ml b/ide/utils/configwin_keys.ml index 9f44e5c6be..e9b19da621 100644 --- a/ide/utils/configwin_keys.ml +++ b/ide/utils/configwin_keys.ml @@ -154,7 +154,7 @@ let xk_KP_9 = 0xFFB9 (* - * Auxilliary Functions; note the duplicate definitions for left and right + * Auxiliary Functions; note the duplicate definitions for left and right * function keys; Sun keyboards and a few other manufactures have such * function key groups on the left and/or right sides of the keyboard. * We've not found a keyboard with more than 35 function keys total. diff --git a/interp/constrextern.ml b/interp/constrextern.ml index e71daef999..dd8a48b85e 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -149,17 +149,8 @@ let extern_evar loc n l = CEvar (loc,n,l) For instance, in the debugger the tables of global references may be inaccurate *) -let safe_shortest_qualid_of_global vars r = - try shortest_qualid_of_global vars r - with Not_found -> - match r with - | VarRef v -> make_qualid DirPath.empty v - | ConstRef c -> make_qualid DirPath.empty Names.(Label.to_id (con_label c)) - | IndRef (i,_) | ConstructRef ((i,_),_) -> - make_qualid DirPath.empty Names.(Label.to_id (mind_label i)) - let default_extern_reference loc vars r = - Qualid (loc,safe_shortest_qualid_of_global vars r) + Qualid (loc,shortest_qualid_of_global vars r) let my_extern_reference = ref default_extern_reference @@ -481,7 +472,7 @@ let explicitize loc inctx impl (cf,f) args = (!print_implicits && !print_implicits_explicit_args) || (is_needed_for_correct_partial_application tail imp) || (!print_implicits_defensive && - (not (is_inferable_implicit inctx n imp) || !Flags.beautify_file) && + (not (is_inferable_implicit inctx n imp) || !Flags.beautify) && is_significant_implicit (Lazy.force a)) in if visible then diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 4502aa7ace..c916fcd886 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -1061,6 +1061,15 @@ let find_pattern_variable = function | Ident (loc,id) -> id | Qualid (loc,_) as x -> raise (InternalizationError(loc,NotAConstructor x)) +let check_duplicate loc fields = + let eq (ref1, _) (ref2, _) = eq_reference ref1 ref2 in + let dups = List.duplicates eq fields in + match dups with + | [] -> () + | (r, _) :: _ -> + user_err_loc (loc, "", str "This record defines several times the field " ++ + pr_reference r ++ str ".") + (** [sort_fields ~complete loc fields completer] expects a list [fields] of field assignments [f = e1; g = e2; ...], where [f, g] are fields of a record and [e1] are "values" (either terms, when @@ -1094,6 +1103,7 @@ let sort_fields ~complete loc fields completer = try Qualid (loc, shortest_qualid_of_global Id.Set.empty global_record_id) with Not_found -> anomaly (str "Environment corruption for records") in + let () = check_duplicate loc fields in let (end_index, (* one past the last field index *) first_field_index, (* index of the first field of the record *) proj_list) (* list of projections *) @@ -1400,7 +1410,40 @@ let rec intern_pat genv aliases pat = check_or_pat_variables loc ids (List.tl idsl); (ids,List.flatten pl') +(* [check_no_patcast p] raises an error if [p] contains a cast. This code is a + bit ad-hoc, and is due to current restrictions on casts in patterns. We + support them only in local binders and only at top level. In fact, they are + currently eliminated by the parser. The only reason why they are in the + [cases_pattern_expr] type is that the parser needs to factor the "(c : t)" + notation with user defined notations (such as the pair). In the long term, we + will try to support such casts everywhere, and use them to print the domains + of lambdas in the encoding of match in constr. We put this check here and not + in the parser because it would require to duplicate the levels of the + [pattern] rule. *) +let rec check_no_patcast = function + | CPatCast (loc,_,_) -> + CErrors.user_err_loc (loc, "check_no_patcast", + Pp.strbrk "Casts are not supported here.") + | CPatDelimiters(_,_,p) + | CPatAlias(_,p,_) -> check_no_patcast p + | CPatCstr(_,_,opl,pl) -> + Option.iter (List.iter check_no_patcast) opl; + List.iter check_no_patcast pl + | CPatOr(_,pl) -> + List.iter check_no_patcast pl + | CPatNotation(_,_,subst,pl) -> + check_no_patcast_subst subst; + List.iter check_no_patcast pl + | CPatRecord(_,prl) -> + List.iter (fun (_,p) -> check_no_patcast p) prl + | CPatAtom _ | CPatPrim _ -> () + +and check_no_patcast_subst (pl,pll) = + List.iter check_no_patcast pl; + List.iter (List.iter check_no_patcast) pll + let intern_cases_pattern genv scopes aliases pat = + check_no_patcast pat; intern_pat genv aliases (drop_notations_pattern (function ConstructRef _ -> () | _ -> raise Not_found) scopes pat) @@ -1409,6 +1452,7 @@ let _ = fun scopes p -> intern_cases_pattern (Global.env ()) scopes empty_alias p let intern_ind_pattern genv scopes pat = + check_no_patcast pat; let no_not = try drop_notations_pattern (function (IndRef _ | ConstructRef _) -> () | _ -> raise Not_found) scopes pat @@ -1558,7 +1602,8 @@ let internalize globalenv env allow_patvar (_, ntnvars as lvar) c = let idl_tmp = Array.map (fun ((loc,id),bl,ty,_) -> let (env',rbl) = List.fold_left intern_local_binder (env,[]) bl in - let rbl = List.map (function BDRawDef a -> a | BDPattern _ -> assert false) rbl in + let rbl = List.map (function BDRawDef a -> a | BDPattern _ -> + Loc.raise loc (Stream.Error "pattern with quote not allowed after cofix")) rbl in (List.rev rbl, intern_type env' ty,env')) dl in let idl = Array.map2 (fun (_,_,_,bd) (b,c,env') -> @@ -2003,14 +2048,14 @@ let interp_notation_constr ?(impls=empty_internalization_env) nenv a = tmp_scope = None; scopes = []; impls = impls} false (empty_ltac_sign, vl) a in (* Translate and check that [c] has all its free variables bound in [vars] *) - let a = notation_constr_of_glob_constr nenv c in + let a, reversible = notation_constr_of_glob_constr nenv c in (* Splits variables into those that are binding, bound, or both *) (* binding and bound *) let out_scope = function None -> None,[] | Some (a,l) -> a,l in let vars = Id.Map.map (fun (isonlybinding, sc, typ) -> (!isonlybinding, out_scope !sc, typ)) vl in (* Returns [a] and the ordered list of variables with their scopes *) - vars, a + vars, a, reversible (* Interpret binders and contexts *) diff --git a/interp/constrintern.mli b/interp/constrintern.mli index eea76aa310..61e7c6f5cb 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -186,7 +186,7 @@ val global_reference_in_absolute_module : DirPath.t -> Id.t -> constr val interp_notation_constr : ?impls:internalization_env -> notation_interp_env -> constr_expr -> (bool * subscopes * notation_var_internalization_type) Id.Map.t * - notation_constr + notation_constr * reversibility_flag (** Globalization options *) val parsing_explicit : bool ref diff --git a/interp/notation.ml b/interp/notation.ml index d301ed21db..389a1c9dff 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -1009,6 +1009,9 @@ let find_notation_parsing_rules ntn = try pi3 (String.Map.find ntn !notation_rules) with Not_found -> anomaly (str "No parsing rule found for " ++ str ntn) +let get_defined_notations () = + String.Set.elements @@ String.Map.domain !notation_rules + let add_notation_extra_printing_rule ntn k v = try notation_rules := diff --git a/interp/notation.mli b/interp/notation.mli index b47e1975e3..2e92a00a8c 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -203,6 +203,9 @@ val find_notation_extra_printing_rules : notation -> extra_unparsing_rules val find_notation_parsing_rules : notation -> notation_grammar val add_notation_extra_printing_rule : notation -> string -> string -> unit +(** Returns notations with defined parsing/printing rules *) +val get_defined_notations : unit -> notation list + (** Rem: printing rules for primitive token are canonical *) val with_notation_protection : ('a -> 'b) -> 'a -> 'b diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index cc81a00919..0c5393cf41 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -248,6 +248,10 @@ let check_is_hole id = function GHole _ -> () | t -> let pair_equal eq1 eq2 (a,b) (a',b') = eq1 a a' && eq2 b b' +type recursive_pattern_kind = +| RecursiveTerms of bool (* associativity *) +| RecursiveBinders of glob_constr * glob_constr + let compare_recursive_parts found f f' (iterator,subc) = let diff = ref None in let terminator = ref None in @@ -269,18 +273,16 @@ let compare_recursive_parts found f f' (iterator,subc) = let x,y = if lassoc then y,x else x,y in begin match !diff with | None -> - let () = diff := Some (x, y, Some lassoc) in + let () = diff := Some (x, y, RecursiveTerms lassoc) in true | Some _ -> false end | GLambda (_,Name x,_,t_x,c), GLambda (_,Name y,_,t_y,term) | GProd (_,Name x,_,t_x,c), GProd (_,Name y,_,t_y,term) -> (* We found a binding position where it differs *) - check_is_hole x t_x; - check_is_hole y t_y; begin match !diff with | None -> - let () = diff := Some (x, y, None) in + let () = diff := Some (x, y, RecursiveBinders (t_x,t_y)) in aux c term | Some _ -> false end @@ -294,7 +296,7 @@ let compare_recursive_parts found f f' (iterator,subc) = (* Here, we would need a loc made of several parts ... *) user_err_loc (subtract_loc loc1 loc2,"", str "Both ends of the recursive pattern are the same.") - | Some (x,y,Some lassoc) -> + | Some (x,y,RecursiveTerms lassoc) -> let newfound,x,y,lassoc = if List.mem_f (pair_equal Id.equal Id.equal) (x,y) (pi2 !found) || List.mem_f (pair_equal Id.equal Id.equal) (x,y) (pi3 !found) @@ -312,17 +314,20 @@ let compare_recursive_parts found f f' (iterator,subc) = (* found have been collected by compare_constr *) found := newfound; NList (x,y,iterator,f (Option.get !terminator),lassoc) - | Some (x,y,None) -> + | Some (x,y,RecursiveBinders (t_x,t_y)) -> let newfound = (pi1 !found, pi2 !found, (x,y) :: pi3 !found) in let iterator = f' (subst_glob_vars [x,GVar(Loc.ghost,y)] iterator) in (* found have been collected by compare_constr *) found := newfound; + check_is_hole x t_x; + check_is_hole y t_y; NBinderList (x,y,iterator,f (Option.get !terminator)) else raise Not_found let notation_constr_and_vars_of_glob_constr a = let found = ref ([],[],[]) in + let has_ltac = ref false in let rec aux c = let keepfound = !found in (* n^2 complexity but small and done only once per notation *) @@ -368,7 +373,9 @@ let notation_constr_and_vars_of_glob_constr a = NRec (fk,idl,dll,Array.map aux tl,Array.map aux bl) | GCast (_,c,k) -> NCast (aux c,Miscops.map_cast_type aux k) | GSort (_,s) -> NSort s - | GHole (_,w,naming,arg) -> NHole (w, naming, arg) + | GHole (_,w,naming,arg) -> + if arg != None then has_ltac := true; + NHole (w, naming, arg) | GRef (_,r,_) -> NRef r | GEvar _ | GPatVar _ -> error "Existential variables not allowed in notations." @@ -376,9 +383,10 @@ let notation_constr_and_vars_of_glob_constr a = in let t = aux a in (* Side effect *) - t, !found + t, !found, !has_ltac -let check_variables nenv (found,foundrec,foundrecbinding) = +let check_variables_and_reversibility nenv (found,foundrec,foundrecbinding) = + let injective = ref true in let recvars = nenv.ninterp_rec_vars in let fold _ y accu = Id.Set.add y accu in let useless_vars = Id.Map.fold fold recvars Id.Set.empty in @@ -401,7 +409,7 @@ let check_variables nenv (found,foundrec,foundrecbinding) = error (Id.to_string x ^ " should not be bound in a recursive pattern of the right-hand side.") - else nenv.ninterp_only_parse <- true + else injective := false in let check_pair s x y where = if not (List.mem_f (pair_equal Id.equal Id.equal) (x,y) where) then @@ -421,12 +429,13 @@ let check_variables nenv (found,foundrec,foundrecbinding) = with Not_found -> check_bound x end | NtnInternTypeIdent -> check_bound x in - Id.Map.iter check_type vars + Id.Map.iter check_type vars; + !injective let notation_constr_of_glob_constr nenv a = - let a, found = notation_constr_and_vars_of_glob_constr a in - let () = check_variables nenv found in - a + let a, found, has_ltac = notation_constr_and_vars_of_glob_constr a in + let injective = check_variables_and_reversibility nenv found in + a, not has_ltac && injective (**********************************************************************) (* Substitution of kernel names, avoiding a list of bound identifiers *) @@ -436,7 +445,6 @@ let notation_constr_of_constr avoiding t = let nenv = { ninterp_var_type = Id.Map.empty; ninterp_rec_vars = Id.Map.empty; - ninterp_only_parse = false; } in notation_constr_of_glob_constr nenv t @@ -454,7 +462,7 @@ let rec subst_notation_constr subst bound raw = | NRef ref -> let ref',t = subst_global subst ref in if ref' == ref then raw else - notation_constr_of_constr bound t + fst (notation_constr_of_constr bound t) | NVar _ -> raw diff --git a/interp/notation_ops.mli b/interp/notation_ops.mli index 4ebd3ddd80..c8fcbf7410 100644 --- a/interp/notation_ops.mli +++ b/interp/notation_ops.mli @@ -29,7 +29,7 @@ val ldots_var : Id.t bound by the notation; also interpret recursive patterns *) val notation_constr_of_glob_constr : notation_interp_env -> - glob_constr -> notation_constr + glob_constr -> notation_constr * reversibility_flag (** Re-interpret a notation as a [glob_constr], taking care of binders *) diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml index d2dcbd92aa..2523063e64 100644 --- a/interp/syntax_def.ml +++ b/interp/syntax_def.ml @@ -84,11 +84,6 @@ let declare_syntactic_definition local id onlyparse pat = let pr_syndef kn = pr_qualid (shortest_qualid_of_syndef Id.Set.empty kn) -let verbose_compat_notations = ref true - -let is_verbose_compat () = - !verbose_compat_notations - let pr_compat_warning (kn, def, v) = let pp_def = match def with | [], NRef r -> spc () ++ str "is" ++ spc () ++ pr_global_env Id.Set.empty r @@ -98,11 +93,11 @@ let pr_compat_warning (kn, def, v) = pr_syndef kn ++ pp_def ++ since let warn_compatibility_notation = - CWarnings.create ~name:"compatibility-notation" - ~category:"deprecated" pr_compat_warning + CWarnings.(create ~name:"compatibility-notation" + ~category:"deprecated" ~default:Disabled pr_compat_warning) let verbose_compat kn def = function - | Some v when is_verbose_compat () && Flags.version_strictly_greater v -> + | Some v when Flags.version_strictly_greater v -> warn_compatibility_notation (kn, def, v) | _ -> () @@ -113,12 +108,3 @@ let search_syntactic_definition kn = def open Goptions - -let set_verbose_compat_notations = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "verbose compatibility notations"; - optkey = ["Verbose";"Compat";"Notations"]; - optread = (fun () -> !verbose_compat_notations); - optwrite = ((:=) verbose_compat_notations) } diff --git a/interp/syntax_def.mli b/interp/syntax_def.mli index aa2c9c3c1b..55e2848e69 100644 --- a/interp/syntax_def.mli +++ b/interp/syntax_def.mli @@ -17,6 +17,3 @@ val declare_syntactic_definition : bool -> Id.t -> Flags.compat_version option -> syndef_interpretation -> unit val search_syntactic_definition : kernel_name -> syndef_interpretation - -(** Option concerning verbose display of compatibility notations *) -val set_verbose_compat_notations : bool -> unit diff --git a/interp/topconstr.ml b/interp/topconstr.ml index 2b860173a6..a397ca82eb 100644 --- a/interp/topconstr.ml +++ b/interp/topconstr.ml @@ -22,8 +22,7 @@ open Constrexpr_ops let asymmetric_patterns = ref (false) let _ = Goptions.declare_bool_option { Goptions.optsync = true; Goptions.optdepr = false; - Goptions.optname = - "Constructors in patterns require all their arguments but no parameters instead of explicit parameters and arguments"; + Goptions.optname = "no parameters in constructors"; Goptions.optkey = ["Asymmetric";"Patterns"]; Goptions.optread = (fun () -> !asymmetric_patterns); Goptions.optwrite = (fun a -> asymmetric_patterns:=a); @@ -61,6 +60,9 @@ let rec cases_pattern_fold_names f a = function | CPatPrim _ | CPatAtom _ -> a | CPatCast _ -> assert false +let ids_of_pattern = + cases_pattern_fold_names Id.Set.add Id.Set.empty + let ids_of_pattern_list = List.fold_left (Loc.located_fold_left @@ -93,8 +95,9 @@ let rec fold_local_binders g f n acc b = function f n (fold_local_binders g f n' acc b l) t | LocalRawDef ((_,na),t)::l -> f n (fold_local_binders g f (name_fold g na n) acc b l) t - | LocalPattern _::l -> - assert false + | LocalPattern (_,pat,t)::l -> + let acc = fold_local_binders g f (cases_pattern_fold_names g n pat) acc b l in + Option.fold_left (f n) acc t | [] -> f n acc b @@ -173,7 +176,8 @@ let split_at_annot bl na = (List.rev ans, LocalRawAssum (r, k, t) :: rest) end | LocalRawDef _ as x :: rest -> aux (x :: acc) rest - | LocalPattern _ :: rest -> assert false + | LocalPattern (loc,_,_) :: rest -> + Loc.raise loc (Stream.Error "pattern with quote not allowed after fix") | [] -> user_err_loc(loc,"", str "No parameter named " ++ Nameops.pr_id id ++ str".") @@ -196,8 +200,9 @@ let map_local_binders f g e bl = (map_binder g e nal, LocalRawAssum(nal,k,f e ty)::bl) | LocalRawDef((loc,na),ty) -> (name_fold g na e, LocalRawDef((loc,na),f e ty)::bl) - | LocalPattern _ -> - assert false in + | LocalPattern (loc,pat,t) -> + let ids = ids_of_pattern pat in + (Id.Set.fold g ids e, LocalPattern (loc,pat,Option.map (f e) t)::bl) in let (e,rbl) = List.fold_left h (e,[]) bl in (e, List.rev rbl) diff --git a/intf/notation_term.mli b/intf/notation_term.mli index 883b017727..1ab9980a5c 100644 --- a/intf/notation_term.mli +++ b/intf/notation_term.mli @@ -73,10 +73,11 @@ type interpretation = (Id.t * (subscopes * notation_var_instance_type)) list * notation_constr +type reversibility_flag = bool + type notation_interp_env = { ninterp_var_type : notation_var_internalization_type Id.Map.t; ninterp_rec_vars : Id.t Id.Map.t; - mutable ninterp_only_parse : bool; } type grammar_constr_prod_item = diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index ed44704df4..92e4dd618e 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -123,8 +123,14 @@ type hint_mode = | ModeNoHeadEvar (* No evar at the head *) | ModeOutput (* Anything *) +type 'a hint_info_gen = + { hint_priority : int option; + hint_pattern : 'a option } + +type hint_info_expr = constr_pattern_expr hint_info_gen + type hints_expr = - | HintsResolve of (int option * bool * reference_or_constr) list + | HintsResolve of (hint_info_expr * bool * reference_or_constr) list | HintsImmediate of reference_or_constr list | HintsUnfold of reference list | HintsTransparency of reference list * bool @@ -211,8 +217,9 @@ type syntax_modifier = | SetLevel of int | SetAssoc of Extend.gram_assoc | SetEntryType of string * Extend.simple_constr_prod_entry_key - | SetOnlyParsing of Flags.compat_version + | SetOnlyParsing | SetOnlyPrinting + | SetCompatVersion of Flags.compat_version | SetFormat of string * string located type proof_end = @@ -346,7 +353,7 @@ type vernac_expr = | VernacScheme of (lident option * scheme) list | VernacCombinedScheme of lident * lident list | VernacUniverse of lident list - | VernacConstraint of (lident * Univ.constraint_type * lident) list + | VernacConstraint of (glob_level * Univ.constraint_type * glob_level) list (* Gallina extensions *) | VernacBeginSection of lident @@ -367,12 +374,12 @@ type vernac_expr = local_binder list * (* super *) typeclass_constraint * (* instance name, class name, params *) (bool * constr_expr) option * (* props *) - int option (* Priority *) + hint_info_expr | VernacContext of local_binder list | VernacDeclareInstances of - reference list * int option (* instance names, priority *) + (reference * hint_info_expr) list (* instances names, priorities and patterns *) | VernacDeclareClass of reference (* inductive or definition name *) @@ -415,10 +422,12 @@ type vernac_expr = | VernacDeclareImplicits of reference or_by_notation * (explicitation * bool * bool) list list | VernacArguments of reference or_by_notation * - ((Name.t * bool * (Loc.t * string) option * bool * bool) list) list * - int * [ `ReductionDontExposeCase | `ReductionNeverUnfold | `Rename | - `ExtraScopes | `Assert | `ClearImplicits | `ClearScopes | - `DefaultImplicits ] list + vernac_argument_status list (* Main arguments status list *) * + (Name.t * vernac_implicit_status) list list (* Extra implicit status lists *) * + int option (* Number of args to trigger reduction *) * + [ `ReductionDontExposeCase | `ReductionNeverUnfold | `Rename | + `ExtraScopes | `Assert | `ClearImplicits | `ClearScopes | + `DefaultImplicits ] list | VernacArgumentsScope of reference or_by_notation * scope_name option list | VernacReserve of simple_binder list @@ -428,6 +437,7 @@ type vernac_expr = (Conv_oracle.level * reference or_by_notation list) list | VernacUnsetOption of Goptions.option_name | VernacSetOption of Goptions.option_name * option_value + | VernacSetAppendOption of Goptions.option_name * string | VernacAddOption of Goptions.option_name * option_ref_value list | VernacRemoveOption of Goptions.option_name * option_ref_value list | VernacMemOption of Goptions.option_name * option_ref_value list @@ -477,6 +487,15 @@ and tacdef_body = | TacticDefinition of Id.t Loc.located * raw_tactic_expr (* indicates that user employed ':=' in Ltac body *) | TacticRedefinition of reference * raw_tactic_expr (* indicates that user employed '::=' in Ltac body *) +and vernac_implicit_status = Implicit | MaximallyImplicit | NotImplicit + +and vernac_argument_status = { + name : Name.t; + recarg_like : bool; + notation_scope : (Loc.t * string) option; + implicit_status : vernac_implicit_status; +} + (* A vernac classifier has to tell if a command: vernac_when: has to be executed now (alters the parser) or later vernac_type: if it is starts, ends, continues a proof or diff --git a/kernel/byterun/coq_fix_code.c b/kernel/byterun/coq_fix_code.c index 29e33d349b..d5feafbf91 100644 --- a/kernel/byterun/coq_fix_code.c +++ b/kernel/byterun/coq_fix_code.c @@ -57,7 +57,7 @@ void init_arity () { arity[MAKEBLOCK1]=arity[MAKEBLOCK2]=arity[MAKEBLOCK3]=arity[MAKEBLOCK4]= arity[MAKEACCU]=arity[CONSTINT]=arity[PUSHCONSTINT]=arity[GRABREC]= arity[PUSHFIELDS]=arity[GETFIELD]=arity[SETFIELD]= - arity[BRANCH]=arity[ISCONST]= 1; + arity[BRANCH]=arity[ISCONST]=arity[ENSURESTACKCAPACITY]=1; /* instruction with two operands */ arity[APPTERM]=arity[MAKEBLOCK]=arity[CLOSURE]= arity[ARECONST]=arity[PROJ]=2; @@ -79,7 +79,7 @@ void * coq_stat_alloc (asize_t sz) value coq_makeaccu (value i) { code_t q; - code_t res = coq_stat_alloc(8); + code_t res = coq_stat_alloc(2 * sizeof(opcode_t)); q = res; *q++ = VALINSTR(MAKEACCU); *q = (opcode_t)Int_val(i); @@ -91,13 +91,13 @@ value coq_pushpop (value i) { int n; n = Int_val(i); if (n == 0) { - res = coq_stat_alloc(4); + res = coq_stat_alloc(sizeof(opcode_t)); *res = VALINSTR(STOP); return (value)res; } else { code_t q; - res = coq_stat_alloc(12); + res = coq_stat_alloc(3 * sizeof(opcode_t)); q = res; *q++ = VALINSTR(POP); *q++ = (opcode_t)n; diff --git a/kernel/byterun/coq_instruct.h b/kernel/byterun/coq_instruct.h index 8c5ab0ecbd..d92e85fdf8 100644 --- a/kernel/byterun/coq_instruct.h +++ b/kernel/byterun/coq_instruct.h @@ -14,6 +14,8 @@ /* Nota: this list of instructions is parsed to produce derived files */ /* coq_jumptbl.h and copcodes.ml. Instructions should be uppercase */ /* and alone on lines starting by two spaces. */ +/* If adding an instruction, DON'T FORGET TO UPDATE coq_fix_code.c */ +/* with the arity of the instruction and maybe coq_tcode_of_code. */ enum instructions { ACC0, ACC1, ACC2, ACC3, ACC4, ACC5, ACC6, ACC7, ACC, @@ -37,6 +39,7 @@ enum instructions { GETFIELD0, GETFIELD1, GETFIELD, SETFIELD0, SETFIELD1, SETFIELD, PROJ, + ENSURESTACKCAPACITY, CONST0, CONST1, CONST2, CONST3, CONSTINT, PUSHCONST0, PUSHCONST1, PUSHCONST2, PUSHCONST3, PUSHCONSTINT, ACCUMULATE, diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index df5fdce755..af89712d5e 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -23,9 +23,9 @@ #include "coq_values.h" /* spiwack: I append here a few macros for value/number manipulation */ -#define uint32_of_value(val) (((uint32_t)val >> 1)) -#define value_of_uint32(i) ((value)(((uint32_t)(i) << 1) | 1)) -#define UI64_of_uint32(lo) ((uint64_t)(lo)) +#define uint32_of_value(val) (((uint32_t)(val)) >> 1) +#define value_of_uint32(i) ((value)((((uint32_t)(i)) << 1) | 1)) +#define UI64_of_uint32(lo) ((uint64_t)((uint32_t)(lo))) #define UI64_of_value(val) (UI64_of_uint32(uint32_of_value(val))) /* /spiwack */ @@ -76,6 +76,14 @@ sp is a local copy of the global variable extern_sp. */ # define print_lint(i) #endif +#define CHECK_STACK(num_args) { \ +if (sp - num_args < coq_stack_threshold) { \ + coq_sp = sp; \ + realloc_coq_stack(num_args + Coq_stack_threshold / sizeof(value)); \ + sp = coq_sp; \ + } \ +} + /* GC interface */ #define Setup_for_gc { sp -= 2; sp[0] = accu; sp[1] = coq_env; coq_sp = sp; } #define Restore_after_gc { accu = sp[0]; coq_env = sp[1]; sp += 2; } @@ -198,6 +206,9 @@ value coq_interprete sp = coq_sp; pc = coq_pc; accu = coq_accu; + + CHECK_STACK(0); + #ifdef THREADED_CODE goto *(void *)(coq_jumptbl_base + *pc++); /* Jump to the first instruction */ #else @@ -354,7 +365,7 @@ value coq_interprete coq_extra_args = *pc - 1; pc = Code_val(accu); coq_env = accu; - goto check_stacks; + goto check_stack; } Instruct(APPLY1) { value arg1 = sp[0]; @@ -371,7 +382,7 @@ value coq_interprete pc = Code_val(accu); coq_env = accu; coq_extra_args = 0; - goto check_stacks; + goto check_stack; } Instruct(APPLY2) { value arg1 = sp[0]; @@ -386,7 +397,7 @@ value coq_interprete pc = Code_val(accu); coq_env = accu; coq_extra_args = 1; - goto check_stacks; + goto check_stack; } Instruct(APPLY3) { value arg1 = sp[0]; @@ -403,17 +414,13 @@ value coq_interprete pc = Code_val(accu); coq_env = accu; coq_extra_args = 2; - goto check_stacks; + goto check_stack; } /* Stack checks */ - check_stacks: - print_instr("check_stacks"); - if (sp < coq_stack_threshold) { - coq_sp = sp; - realloc_coq_stack(Coq_stack_threshold); - sp = coq_sp; - } + check_stack: + print_instr("check_stack"); + CHECK_STACK(0); /* We also check for signals */ if (caml_signals_are_pending) { /* If there's a Ctrl-C, we reset the vm */ @@ -422,6 +429,16 @@ value coq_interprete } Next; + Instruct(ENSURESTACKCAPACITY) { + print_instr("ENSURESTACKCAPACITY"); + int size = *pc++; + /* CHECK_STACK may trigger here a useless allocation because of the + threshold, but check_stack: often does it anyway, so we prefer to + factorize the code. */ + CHECK_STACK(size); + Next; + } + Instruct(APPTERM) { int nargs = *pc++; int slotsize = *pc; @@ -436,7 +453,7 @@ value coq_interprete pc = Code_val(accu); coq_env = accu; coq_extra_args += nargs - 1; - goto check_stacks; + goto check_stack; } Instruct(APPTERM1) { value arg1 = sp[0]; @@ -445,7 +462,7 @@ value coq_interprete sp[0] = arg1; pc = Code_val(accu); coq_env = accu; - goto check_stacks; + goto check_stack; } Instruct(APPTERM2) { value arg1 = sp[0]; @@ -458,7 +475,7 @@ value coq_interprete print_lint(accu); coq_env = accu; coq_extra_args += 1; - goto check_stacks; + goto check_stack; } Instruct(APPTERM3) { value arg1 = sp[0]; @@ -472,7 +489,7 @@ value coq_interprete pc = Code_val(accu); coq_env = accu; coq_extra_args += 2; - goto check_stacks; + goto check_stack; } Instruct(RETURN) { @@ -503,6 +520,7 @@ value coq_interprete int num_args = Wosize_val(coq_env) - 2; int i; print_instr("RESTART"); + CHECK_STACK(num_args); sp -= num_args; for (i = 0; i < num_args; i++) sp[i] = Field(coq_env, i + 2); coq_env = Field(coq_env, 1); @@ -539,6 +557,7 @@ value coq_interprete pc++;/* On saute le Restart */ } else { if (coq_extra_args < rec_pos) { + /* Partial application */ mlsize_t num_args, i; num_args = 1 + coq_extra_args; /* arg1 + extra args */ Alloc_small(accu, num_args + 2, Closure_tag); @@ -553,10 +572,10 @@ value coq_interprete } else { /* The recursif argument is an accumulator */ mlsize_t num_args, i; - /* Construction of partially applied PF */ + /* Construction of fixpoint applied to its [rec_pos-1] first arguments */ Alloc_small(accu, rec_pos + 2, Closure_tag); - Field(accu, 1) = coq_env; - for (i = 0; i < rec_pos; i++) Field(accu, i + 2) = sp[i]; + Field(accu, 1) = coq_env; // We store the fixpoint in the first field + for (i = 0; i < rec_pos; i++) Field(accu, i + 2) = sp[i]; // Storing args Code_val(accu) = pc; sp += rec_pos; *--sp = accu; @@ -862,29 +881,7 @@ value coq_interprete sp++; Next; } - - /* *sp = accu; - * Netoyage des cofix * - size = Wosize_val(accu); - for (i = 2; i < size; i++) { - accu = Field(*sp, i); - if (IS_EVALUATED_COFIX(accu)) { - size_aux = Wosize_val(accu); - *--sp = accu; - Alloc_small(accu, size_aux, Accu_tag); - for(j = 0; j < size_aux; j++) Field(accu, j) = Field(*sp, j); - *sp = accu; - Alloc_small(accu, 1, ATOM_COFIX_TAG); - Field(accu, 0) = Field(Field(*sp, 1), 0); - caml_modify(&Field(*sp, 1), accu); - accu = *sp; sp++; - caml_modify(&Field(*sp, i), accu); - } - } - sp++; - Next; - } */ - + Instruct(SETFIELD){ print_instr("SETFIELD"); caml_modify(&Field(accu, *pc),*sp); @@ -894,25 +891,58 @@ value coq_interprete Instruct(PROJ){ + do_proj: print_instr("PROJ"); if (Is_accu (accu)) { - value block; - /* Skip over the index of projected field */ - pc++; - /* Create atom */ - Alloc_small(block, 2, ATOM_PROJ_TAG); - Field(block, 0) = Field(coq_global_data, *pc); - Field(block, 1) = accu; - accu = block; - /* Create accumulator */ - Alloc_small(block, 2, Accu_tag); - Code_val(block) = accumulate; - Field(block, 1) = accu; - accu = block; + *--sp = accu; // Save matched block on stack + accu = Field(accu, 1); // Save atom to accu register + switch (Tag_val(accu)) { + case ATOM_COFIX_TAG: // We are forcing a cofix + { + mlsize_t i, nargs; + sp -= 2; + // Push the current instruction as the return address + sp[0] = (value)(pc - 1); + sp[1] = coq_env; + coq_env = Field(accu, 0); // Pointer to suspension + accu = sp[2]; // Save accumulator to accu register + sp[2] = Val_long(coq_extra_args); // Push number of args for return + nargs = Wosize_val(accu) - 2; // Number of args = size of accumulator - 1 (accumulator code) - 1 (atom) + // Push arguments to stack + CHECK_STACK(nargs + 1); + sp -= nargs; + for (i = 0; i < nargs; ++i) sp[i] = Field(accu, i + 2); + *--sp = accu; // Last argument is the pointer to the suspension + coq_extra_args = nargs; + pc = Code_val(coq_env); // Trigger evaluation + goto check_stack; + } + case ATOM_COFIXEVALUATED_TAG: + { + accu = Field(accu, 1); + ++sp; + goto do_proj; + } + default: + { + value block; + /* Skip over the index of projected field */ + ++pc; + /* Create atom */ + Alloc_small(accu, 2, ATOM_PROJ_TAG); + Field(accu, 0) = Field(coq_global_data, *pc++); + Field(accu, 1) = *sp++; + /* Create accumulator */ + Alloc_small(block, 2, Accu_tag); + Code_val(block) = accumulate; + Field(block, 1) = accu; + accu = block; + } + } } else { - accu = Field(accu, *pc++); + accu = Field(accu, *pc); + pc += 2; } - pc++; Next; } @@ -978,28 +1008,31 @@ value coq_interprete } Instruct(MAKESWITCHBLOCK) { print_instr("MAKESWITCHBLOCK"); - *--sp = accu; - accu = Field(accu,1); + *--sp = accu; // Save matched block on stack + accu = Field(accu,1); // Save atom to accu register switch (Tag_val(accu)) { - case ATOM_COFIX_TAG: + case ATOM_COFIX_TAG: // We are forcing a cofix { mlsize_t i, nargs; print_instr("COFIX_TAG"); sp-=2; pc++; + // Push the return address sp[0] = (value) (pc + *pc); sp[1] = coq_env; - coq_env = Field(accu,0); - accu = sp[2]; - sp[2] = Val_long(coq_extra_args); - nargs = Wosize_val(accu) - 2; + coq_env = Field(accu,0); // Pointer to suspension + accu = sp[2]; // Save accumulator to accu register + sp[2] = Val_long(coq_extra_args); // Push number of args for return + nargs = Wosize_val(accu) - 2; // Number of args = size of accumulator - 1 (accumulator code) - 1 (atom) + // Push arguments to stack + CHECK_STACK(nargs+1); sp -= nargs; - for (i = 0; i < nargs; i++) sp[i] = Field(accu, i + 2); - *--sp = accu; + for (i = 0; i < nargs; i++) sp[i] = Field(accu, i + 2); + *--sp = accu; // Last argument is the pointer to the suspension print_lint(nargs); coq_extra_args = nargs; - pc = Code_val(coq_env); - goto check_stacks; + pc = Code_val(coq_env); // Trigger evaluation + goto check_stack; } case ATOM_COFIXEVALUATED_TAG: { @@ -1024,7 +1057,7 @@ value coq_interprete annot = *pc++; sz = *pc++; *--sp=Field(coq_global_data, annot); - /* On sauve la pile */ + /* We save the stack */ if (sz == 0) accu = Atom(0); else { Alloc_small(accu, sz, Default_tag); @@ -1035,17 +1068,17 @@ value coq_interprete } } *--sp = accu; - /* On cree le zipper switch */ + /* We create the switch zipper */ Alloc_small(accu, 5, Default_tag); Field(accu, 0) = (value)typlbl; Field(accu, 1) = (value)swlbl; Field(accu, 2) = sp[1]; Field(accu, 3) = sp[0]; Field(accu, 4) = coq_env; sp++;sp[0] = accu; - /* On cree l'atome */ + /* We create the atom */ Alloc_small(accu, 2, ATOM_SWITCH_TAG); Field(accu, 0) = sp[1]; Field(accu, 1) = sp[0]; sp++;sp[0] = accu; - /* On cree l'accumulateur */ + /* We create the accumulator */ Alloc_small(accu, 2, Accu_tag); Code_val(accu) = accumulate; Field(accu,1) = *sp++; @@ -1206,7 +1239,7 @@ value coq_interprete Alloc_small(accu, 2, 1); /* ( _ , arity, tag ) */ /*unsigned shift*/ Field(accu, 0) = (value)((p >> 31)|1) ; /*higher part*/ - Field(accu, 1) = (value)((int32_t)p|1); /*lower part*/ + Field(accu, 1) = (value)((uint32_t)p|1); /*lower part*/ } Next; } @@ -1457,26 +1490,32 @@ value coq_push_val(value v) { value coq_push_arguments(value args) { int nargs,i; + value * sp = coq_sp; nargs = Wosize_val(args) - 2; + CHECK_STACK(nargs); coq_sp -= nargs; print_instr("push_args");print_int(nargs); for(i = 0; i < nargs; i++) coq_sp[i] = Field(args, i+2); return Val_unit; } -value coq_push_vstack(value stk) { +value coq_push_vstack(value stk, value max_stack_size) { int len,i; + value * sp = coq_sp; len = Wosize_val(stk); + CHECK_STACK(len); coq_sp -= len; print_instr("push_vstack");print_int(len); for(i = 0; i < len; i++) coq_sp[i] = Field(stk,i); + sp = coq_sp; + CHECK_STACK(uint32_of_value(max_stack_size)); return Val_unit; } value coq_interprete_ml(value tcode, value a, value e, value ea) { print_instr("coq_interprete"); return coq_interprete((code_t)tcode, a, e, Long_val(ea)); - print_instr("end coq_interprete"); + print_instr("end coq_interprete"); } value coq_eval_tcode (value tcode, value e) { diff --git a/kernel/byterun/coq_memory.c b/kernel/byterun/coq_memory.c index c9bcdc32ff..45cfae509d 100644 --- a/kernel/byterun/coq_memory.c +++ b/kernel/byterun/coq_memory.c @@ -130,6 +130,7 @@ value init_coq_vm(value unit) /* ML */ return Val_unit;; } +/* [required_space] is a size in words */ void realloc_coq_stack(asize_t required_space) { asize_t size; diff --git a/kernel/cClosure.ml b/kernel/cClosure.ml index d475f097ce..fe9ec5794c 100644 --- a/kernel/cClosure.ml +++ b/kernel/cClosure.ml @@ -270,11 +270,9 @@ let info_env info = info.i_cache.i_env open Context.Named.Declaration -let rec assoc_defined id = function -| [] -> raise Not_found -| LocalAssum _ :: ctxt -> assoc_defined id ctxt -| LocalDef (id', c, _) :: ctxt -> - if Id.equal id id' then c else assoc_defined id ctxt +let assoc_defined id env = match Environ.lookup_named id env with +| LocalDef (_, c, _) -> c +| _ -> raise Not_found let ref_value_cache ({i_cache = cache} as infos) ref = try @@ -291,7 +289,7 @@ let ref_value_cache ({i_cache = cache} as infos) ref = | None -> raise Not_found | Some t -> lift n t end - | VarKey id -> assoc_defined id (named_context cache.i_env) + | VarKey id -> assoc_defined id cache.i_env | ConstKey cst -> constant_value_in cache.i_env cst in let v = cache.i_repr infos body in diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml index 8d4de523a1..810c346990 100644 --- a/kernel/cbytecodes.ml +++ b/kernel/cbytecodes.ml @@ -43,7 +43,7 @@ type structured_constant = type reloc_table = (tag * int) array type annot_switch = - {ci : case_info; rtbl : reloc_table; tailcall : bool} + {ci : case_info; rtbl : reloc_table; tailcall : bool; max_stack_size : int} module Label = struct @@ -87,6 +87,7 @@ type instruction = | Ksequence of bytecodes * bytecodes | Kproj of int * Constant.t (* index of the projected argument, name of projection *) + | Kensurestackcapacity of int (* spiwack: instructions concerning integers *) | Kbranch of Label.t (* jump to label *) | Kaddint31 (* adds the int31 in the accu @@ -264,6 +265,8 @@ let rec pp_instr i = | Kproj(n,p) -> str "proj " ++ int n ++ str " " ++ Constant.print p + | Kensurestackcapacity size -> str "growstack " ++ int size + | Kaddint31 -> str "addint31" | Kaddcint31 -> str "addcint31" | Kaddcarrycint31 -> str "addcarrycint31" diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli index 5f1f09d00c..b8de7619cf 100644 --- a/kernel/cbytecodes.mli +++ b/kernel/cbytecodes.mli @@ -39,7 +39,7 @@ val pp_struct_const : structured_constant -> Pp.std_ppcmds type reloc_table = (tag * int) array type annot_switch = - {ci : case_info; rtbl : reloc_table; tailcall : bool} + {ci : case_info; rtbl : reloc_table; tailcall : bool; max_stack_size : int} module Label : sig @@ -84,6 +84,7 @@ type instruction = | Ksequence of bytecodes * bytecodes | Kproj of int * Constant.t (** index of the projected argument, name of projection *) + | Kensurestackcapacity of int (** spiwack: instructions concerning integers *) | Kbranch of Label.t (** jump to label, is it needed ? *) diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index 008955d804..b1fc0c85de 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -91,6 +91,11 @@ open Pre_env (* In Cfxe_t accumulators, we need to store [fcofixi] for testing *) (* conversion of cofixpoints (which is intentional). *) +module Config = struct + let stack_threshold = 256 (* see byterun/coq_memory.h *) + let stack_safety_margin = 15 +end + type argument = ArgConstr of Constr.t | ArgUniv of Univ.Level.t let empty_fv = { size= 0; fv_rev = []; fv_fwd = FvMap.empty } @@ -112,6 +117,26 @@ let empty_comp_env ?(univs=0) ()= in_env = ref empty_fv } +(* Maximal stack size reached during the current function body. Used to + reallocate the stack if we lack space. *) +let max_stack_size = ref 0 + +let set_max_stack_size stack_size = + if stack_size > !max_stack_size then + max_stack_size := stack_size + +let ensure_stack_capacity f x = + let old = !max_stack_size in + max_stack_size := 0; + let code = f x in + let used_safe = + !max_stack_size + Config.stack_safety_margin + in + max_stack_size := old; + if used_safe > Config.stack_threshold then + Kensurestackcapacity used_safe :: code + else code + (*i Creation functions for comp_env *) let rec add_param n sz l = @@ -370,14 +395,28 @@ let const_bn tag args = else Const_bn(last_variant_tag, Array.append [|Const_b0 (tag - last_variant_tag) |] args) - -let code_makeblock arity tag cont = +(* +If [tag] hits the OCaml limitation for non constant constructors, we switch to +another representation for the remaining constructors: +[last_variant_tag|tag - last_variant_tag|args] + +We subtract last_variant_tag for efficiency of match interpretation. + *) + +let nest_block tag arity cont = + Kconst (Const_b0 (tag - last_variant_tag)) :: + Kmakeblock(arity+1, last_variant_tag) :: cont + +let code_makeblock ~stack_size ~arity ~tag cont = if tag < last_variant_tag then Kmakeblock(arity, tag) :: cont - else - Kpush :: Kconst (Const_b0 (tag - last_variant_tag)) :: - Kmakeblock(arity+1, last_variant_tag) :: cont + else begin + set_max_stack_size (stack_size + 1); + Kpush :: nest_block tag arity cont + end +(* [code_construct] compiles an abstracted constructor dropping parameters and + updates [fun_code] *) (* Inv : nparam + arity > 0 *) let code_construct tag nparams arity cont = let f_cont = @@ -386,11 +425,11 @@ let code_construct tag nparams arity cont = [Kconst (Const_b0 tag); Kreturn 0] else if tag < last_variant_tag then [Kacc 0; Kpop 1; Kmakeblock(arity, tag); Kreturn 0] - else - [Kconst (Const_b0 (tag - last_variant_tag)); - Kmakeblock(arity+1, last_variant_tag); Kreturn 0]) + else + nest_block tag arity [Kreturn 0]) in let lbl = Label.create() in + (* No need to grow the stack here, as the function does not push stuff. *) fun_code := [Ksequence (add_grab (nparams+arity) lbl f_cont,!fun_code)]; Kclosure(lbl,0) :: cont @@ -506,6 +545,7 @@ let comp_args comp_expr reloc args sz cont = done; !c +(* Precondition: args not empty *) let comp_app comp_fun comp_arg reloc f args sz cont = let nargs = Array.length args in match is_tailcall cont with @@ -535,11 +575,12 @@ let compile_fv_elem reloc fv sz cont = let rec compile_fv reloc l sz cont = match l with | [] -> cont - | [fvn] -> compile_fv_elem reloc fvn sz cont + | [fvn] -> set_max_stack_size (sz + 1); compile_fv_elem reloc fvn sz cont | fvn :: tl -> compile_fv_elem reloc fvn sz (Kpush :: compile_fv reloc tl (sz + 1) cont) + (* Compiling constants *) let rec get_alias env kn = @@ -554,6 +595,7 @@ let rec get_alias env kn = (* sz is the size of the local stack *) let rec compile_constr reloc c sz cont = + set_max_stack_size sz; match kind_of_term c with | Meta _ -> invalid_arg "Cbytegen.compile_constr : Meta" | Evar _ -> invalid_arg "Cbytegen.compile_constr : Evar" @@ -602,6 +644,7 @@ let rec compile_constr reloc c sz cont = compile_str_cst reloc (Bstrconst (Const_sorts (Type uglob))) sz cont else let compile_get_univ reloc idx sz cont = + set_max_stack_size sz; compile_fv_elem reloc (FVuniv_var idx) sz cont in comp_app compile_str_cst compile_get_univ reloc @@ -621,7 +664,8 @@ let rec compile_constr reloc c sz cont = let r_fun = comp_env_fun arity in let lbl_fun = Label.create() in let cont_fun = - compile_constr r_fun body arity [Kreturn arity] in + ensure_stack_capacity (compile_constr r_fun body arity) [Kreturn arity] + in fun_code := [Ksequence(add_grab arity lbl_fun cont_fun,!fun_code)]; let fv = fv r_fun in compile_fv reloc fv.fv_rev sz (Kclosure(lbl_fun,fv.size) :: cont) @@ -641,9 +685,10 @@ let rec compile_constr reloc c sz cont = (* Compilation des types *) let env_type = comp_env_fix_type rfv in for i = 0 to ndef - 1 do - let lbl,fcode = - label_code - (compile_constr env_type type_bodies.(i) 0 [Kstop]) in + let fcode = + ensure_stack_capacity (compile_constr env_type type_bodies.(i) 0) [Kstop] + in + let lbl,fcode = label_code fcode in lbl_types.(i) <- lbl; fun_code := [Ksequence(fcode,!fun_code)] done; @@ -653,7 +698,8 @@ let rec compile_constr reloc c sz cont = let arity = List.length params in let env_body = comp_env_fix ndef i arity rfv in let cont1 = - compile_constr env_body body arity [Kreturn arity] in + ensure_stack_capacity (compile_constr env_body body arity) [Kreturn arity] + in let lbl = Label.create () in lbl_bodies.(i) <- lbl; let fcode = add_grabrec rec_args.(i) arity lbl cont1 in @@ -671,9 +717,10 @@ let rec compile_constr reloc c sz cont = let rfv = ref empty_fv in let env_type = comp_env_cofix_type ndef rfv in for i = 0 to ndef - 1 do - let lbl,fcode = - label_code - (compile_constr env_type type_bodies.(i) 0 [Kstop]) in + let fcode = + ensure_stack_capacity (compile_constr env_type type_bodies.(i) 0) [Kstop] + in + let lbl,fcode = label_code fcode in lbl_types.(i) <- lbl; fun_code := [Ksequence(fcode,!fun_code)] done; @@ -683,14 +730,17 @@ let rec compile_constr reloc c sz cont = let arity = List.length params in let env_body = comp_env_cofix ndef arity rfv in let lbl = Label.create () in - let cont1 = - compile_constr env_body body (arity+1) (cont_cofix arity) in - let cont2 = - add_grab (arity+1) lbl cont1 in + let comp arity = + (* 4 stack slots are needed to update the cofix when forced *) + set_max_stack_size (arity + 4); + compile_constr env_body body (arity+1) (cont_cofix arity) + in + let cont = ensure_stack_capacity comp arity in lbl_bodies.(i) <- lbl; - fun_code := [Ksequence(cont2,!fun_code)]; + fun_code := [Ksequence(add_grab (arity+1) lbl cont,!fun_code)]; done; let fv = !rfv in + set_max_stack_size (sz + fv.size + ndef + 2); compile_fv reloc fv.fv_rev sz (Kclosurecofix(fv.size, init, lbl_types, lbl_bodies) :: cont) @@ -708,9 +758,11 @@ let rec compile_constr reloc c sz cont = let lbl_eblocks = Array.make neblock Label.no in let branch1,cont = make_branch cont in (* Compiling return type *) - let lbl_typ,fcode = - label_code (compile_constr reloc t sz [Kpop sz; Kstop]) - in fun_code := [Ksequence(fcode,!fun_code)]; + let fcode = + ensure_stack_capacity (compile_constr reloc t sz) [Kpop sz; Kstop] + in + let lbl_typ,fcode = label_code fcode in + fun_code := [Ksequence(fcode,!fun_code)]; (* Compiling branches *) let lbl_sw = Label.create () in let sz_b,branch,is_tailcall = @@ -720,14 +772,9 @@ let rec compile_constr reloc c sz cont = sz, branch1, true | _ -> sz+3, Kjump, false in - let annot = {ci = ci; rtbl = tbl; tailcall = is_tailcall} in - (* Compiling branch for accumulators *) - let lbl_accu, code_accu = - label_code(Kmakeswitchblock(lbl_typ,lbl_sw,annot,sz) :: branch::cont) - in - lbl_blocks.(0) <- lbl_accu; - let c = ref code_accu in - (* perform the extra match if needed (to many block constructors) *) + + let c = ref cont in + (* Perform the extra match if needed (too many block constructors) *) if neblock <> 0 then begin let lbl_b, code_b = label_code ( @@ -757,14 +804,34 @@ let rec compile_constr reloc c sz cont = compile_constr reloc branchs.(i) (sz_b+arity) (Kappterm(arity,sz_appterm) :: !c) in let code_b = - if tag < last_variant_tag then Kpushfields arity :: code_b - else Kacc 0::Kpop 1::Kpushfields(arity+1)::Kpop 1::code_b in + if tag < last_variant_tag then begin + set_max_stack_size (sz_b + arity); + Kpushfields arity :: code_b + end + else begin + set_max_stack_size (sz_b + arity + 1); + Kacc 0::Kpop 1::Kpushfields(arity+1)::Kpop 1::code_b + end + in let lbl_b,code_b = label_code code_b in if tag < last_variant_tag then lbl_blocks.(tag) <- lbl_b else lbl_eblocks.(tag - last_variant_tag) <- lbl_b; c := code_b done; - c := Klabel lbl_sw :: Kswitch(lbl_consts,lbl_blocks) :: !c; + + let annot = + {ci = ci; rtbl = tbl; tailcall = is_tailcall; + max_stack_size = !max_stack_size - sz} + in + + (* Compiling branch for accumulators *) + let lbl_accu, code_accu = + set_max_stack_size (sz+3); + label_code(Kmakeswitchblock(lbl_typ,lbl_sw,annot,sz) :: branch :: !c) + in + lbl_blocks.(0) <- lbl_accu; + + c := Klabel lbl_sw :: Kswitch(lbl_consts,lbl_blocks) :: code_accu; let code_sw = match branch1 with (* spiwack : branch1 can't be a lbl anymore it's a Branch instead @@ -781,12 +848,14 @@ let rec compile_constr reloc c sz cont = code_sw) and compile_str_cst reloc sc sz cont = + set_max_stack_size sz; match sc with | Bconstr c -> compile_constr reloc c sz cont | Bstrconst sc -> Kconst sc :: cont | Bmakeblock(tag,args) -> - let nargs = Array.length args in - comp_args compile_str_cst reloc args sz (code_makeblock nargs tag cont) + let arity = Array.length args in + let cont = code_makeblock ~stack_size:(sz+arity-1) ~arity ~tag cont in + comp_args compile_str_cst reloc args sz cont | Bconstruct_app(tag,nparams,arity,args) -> if Int.equal (Array.length args) 0 then code_construct tag nparams arity cont @@ -800,6 +869,7 @@ and compile_str_cst reloc sc sz cont = (* spiwack : compilation of constants with their arguments. Makes a special treatment with 31-bit integer addition *) and compile_get_global reloc (kn,u) sz cont = + set_max_stack_size sz; let kn = get_alias !global_env kn in if Univ.Instance.is_empty u then Kgetglobal kn :: cont @@ -808,11 +878,13 @@ and compile_get_global reloc (kn,u) sz cont = compile_universe reloc () (Univ.Instance.to_array u) sz cont and compile_universe reloc uni sz cont = + set_max_stack_size sz; match Univ.Level.var_index uni with | None -> Kconst (Const_univ_level uni) :: cont | Some idx -> pos_universe_var idx reloc sz :: cont and compile_const reloc kn u args sz cont = + set_max_stack_size sz; let nargs = Array.length args in (* spiwack: checks if there is a specific way to compile the constant if there is not, Not_found is raised, and the function @@ -874,7 +946,7 @@ let compile fail_on_error ?universes:(universes=0) env c = let reloc, init_code = if Int.equal universes 0 then let reloc = empty_comp_env () in - reloc, compile_constr reloc c 0 cont + reloc, ensure_stack_capacity (compile_constr reloc c 0) cont else (* We are going to generate a lambda, but merge the universe closure * with the function closure if it exists. @@ -891,11 +963,16 @@ let compile fail_on_error ?universes:(universes=0) env c = let r_fun = comp_env_fun ~univs:universes arity in let lbl_fun = Label.create () in let cont_fun = - compile_constr r_fun body full_arity [Kreturn full_arity] + ensure_stack_capacity (compile_constr r_fun body full_arity) + [Kreturn full_arity] in fun_code := [Ksequence(add_grab full_arity lbl_fun cont_fun,!fun_code)]; let fv = fv r_fun in - reloc, compile_fv reloc fv.fv_rev 0 (Kclosure(lbl_fun,fv.size) :: cont) + let init_code = + ensure_stack_capacity (compile_fv reloc fv.fv_rev 0) + (Kclosure(lbl_fun,fv.size) :: cont) + in + reloc, init_code in let fv = List.rev (!(reloc.in_env).fv_rev) in (if !Flags.dump_bytecode then diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index d779a81ff6..ad7a41a347 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -234,6 +234,7 @@ let emit_instr = function else (out opSETFIELD;out_int n) | Ksequence _ -> invalid_arg "Cemitcodes.emit_instr" | Kproj (n,p) -> out opPROJ; out_int n; slot_for_const (Const_proj p) + | Kensurestackcapacity size -> out opENSURESTACKCAPACITY; out_int size (* spiwack *) | Kbranch lbl -> out opBRANCH; out_label lbl | Kaddint31 -> out opADDINT31 diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml index e195618b6b..c27cb04870 100644 --- a/kernel/csymtable.ml +++ b/kernel/csymtable.ml @@ -191,7 +191,7 @@ and slot_for_fv env fv = | None -> let open Context.Named in let open Declaration in - env.env_named_context |> lookup id |> get_value |> fill_fv_cache nv id val_of_named idfun + env |> Pre_env.lookup_named id |> get_value |> fill_fv_cache nv id val_of_named idfun | Some (v, _) -> v end | FVrel i -> diff --git a/kernel/entries.mli b/kernel/entries.mli index df2c4653f7..ea7c266bcd 100644 --- a/kernel/entries.mli +++ b/kernel/entries.mli @@ -98,7 +98,12 @@ type module_entry = | MExpr of module_params_entry * module_struct_entry * module_struct_entry option -type seff_env = [ `Nothing | `Opaque of Constr.t * Univ.universe_context_set ] + +type seff_env = + [ `Nothing + (* The proof term and its universes. + Same as the constant_body's but not in an ephemeron *) + | `Opaque of Constr.t * Univ.universe_context_set ] type side_eff = | SEsubproof of constant * Declarations.constant_body * seff_env diff --git a/kernel/environ.ml b/kernel/environ.ml index 7351a87d44..16ddfac64b 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -56,14 +56,14 @@ let type_in_type env = not (typing_flags env).check_universes let deactivated_guard env = not (typing_flags env).check_guarded let universes env = env.env_stratification.env_universes -let named_context env = env.env_named_context -let named_context_val env = env.env_named_context,env.env_named_vals +let named_context env = env.env_named_context.env_named_ctx +let named_context_val env = env.env_named_context let rel_context env = env.env_rel_context let opaque_tables env = env.indirect_pterms let set_opaque_tables env indirect_pterms = { env with indirect_pterms } let empty_context env = - match env.env_rel_context, env.env_named_context with + match env.env_rel_context, env.env_named_context.env_named_ctx with | [], [] -> true | _ -> false @@ -99,14 +99,12 @@ let fold_rel_context f env ~init = (* Named context *) -let named_context_of_val = fst -let named_vals_of_val = snd +let named_context_of_val c = c.env_named_ctx (* [map_named_val f ctxt] apply [f] to the body and the type of each declarations. *** /!\ *** [f t] should be convertible with t *) -let map_named_val f = - on_fst (Context.Named.map f) +let map_named_val = map_named_val let empty_named_context = Context.Named.empty @@ -118,8 +116,8 @@ let val_of_named_context ctxt = List.fold_right push_named_context_val ctxt empty_named_context_val -let lookup_named id env = Context.Named.lookup id env.env_named_context -let lookup_named_val id (ctxt,_) = Context.Named.lookup id ctxt +let lookup_named = lookup_named +let lookup_named_val id ctxt = fst (Id.Map.find id ctxt.env_named_map) let eq_named_context_val c1 c2 = c1 == c2 || Context.Named.equal (named_context_of_val c1) (named_context_of_val c2) @@ -139,10 +137,9 @@ let evaluable_named id env = | Some _ -> true | _ -> false -let reset_with_named_context (ctxt,ctxtv) env = +let reset_with_named_context ctxt env = { env with env_named_context = ctxt; - env_named_vals = ctxtv; env_rel_context = Context.Rel.empty; env_rel_val = []; env_nb_rel = 0 } @@ -157,11 +154,11 @@ let pop_rel_context n env = let fold_named_context f env ~init = let rec fold_right env = - match env.env_named_context with - | [] -> init - | d::ctxt -> + match match_named_context_val env.env_named_context with + | None -> init + | Some (d, v, rem) -> let env = - reset_with_named_context (ctxt,List.tl env.env_named_vals) env in + reset_with_named_context rem env in f env d (fold_right env) in fold_right env @@ -493,66 +490,35 @@ let compile_constant_body = Cbytegen.compile_constant_body false exception Hyp_not_found -let apply_to_hyp (ctxt,vals) id f = - let rec aux rtail ctxt vals = - match ctxt, vals with - | d::ctxt, v::vals -> - if Id.equal (get_id d) id then - (f ctxt d rtail)::ctxt, v::vals - else - let ctxt',vals' = aux (d::rtail) ctxt vals in - d::ctxt', v::vals' - | [],[] -> raise Hyp_not_found - | _, _ -> assert false - in aux [] ctxt vals - -let apply_to_hyp_and_dependent_on (ctxt,vals) id f g = - let rec aux ctxt vals = - match ctxt,vals with - | d::ctxt, v::vals -> +let apply_to_hyp ctxt id f = + let rec aux rtail ctxt = + match match_named_context_val ctxt with + | Some (d, v, ctxt) -> if Id.equal (get_id d) id then - let sign = ctxt,vals in - push_named_context_val (f d sign) sign + push_named_context_val_val (f ctxt.env_named_ctx d rtail) v ctxt else - let (ctxt,vals as sign) = aux ctxt vals in - push_named_context_val (g d sign) sign - | [],[] -> raise Hyp_not_found - | _,_ -> assert false - in aux ctxt vals - -let insert_after_hyp (ctxt,vals) id d check = - let rec aux ctxt vals = - match ctxt, vals with - | decl::ctxt', v::vals' -> - if Id.equal (get_id decl) id then begin - check ctxt; - push_named_context_val d (ctxt,vals) - end else - let ctxt,vals = aux ctxt vals in - d::ctxt, v::vals - | [],[] -> raise Hyp_not_found - | _, _ -> assert false - in aux ctxt vals - + let ctxt' = aux (d::rtail) ctxt in + push_named_context_val_val d v ctxt' + | None -> raise Hyp_not_found + in aux [] ctxt (* To be used in Logic.clear_hyps *) -let remove_hyps ids check_context check_value (ctxt, vals) = - let rec remove_hyps ctxt vals = match ctxt, vals with - | [], [] -> ([], []), false - | d :: rctxt, (nid, v) :: rvals -> - let (ans, seen) = remove_hyps rctxt rvals in +let remove_hyps ids check_context check_value ctxt = + let rec remove_hyps ctxt = match match_named_context_val ctxt with + | None -> empty_named_context_val, false + | Some (d, v, rctxt) -> + let (ans, seen) = remove_hyps rctxt in if Id.Set.mem (get_id d) ids then (ans, true) - else if not seen then (ctxt, vals), false + else if not seen then ctxt, false else - let (rctxt', rvals') = ans in + let rctxt' = ans in let d' = check_context d in let v' = check_value v in - if d == d' && v == v' && rctxt == rctxt' && rvals == rvals' then - (ctxt, vals), true - else (d' :: rctxt', (nid, v') :: rvals'), true - | _ -> assert false + if d == d' && v == v' && rctxt == rctxt' then + ctxt, true + else push_named_context_val_val d' v' rctxt', true in - fst (remove_hyps ctxt vals) + fst (remove_hyps ctxt) (*spiwack: the following functions assemble the pieces of the retroknowledge note that the "consistent" register function is available in the module diff --git a/kernel/environ.mli b/kernel/environ.mli index b5e5764354..6ac00088b3 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -78,7 +78,6 @@ val fold_rel_context : (** {5 Context of variables (section variables and goal assumptions) } *) val named_context_of_val : named_context_val -> Context.Named.t -val named_vals_of_val : named_context_val -> Pre_env.named_vals val val_of_named_context : Context.Named.t -> named_context_val val empty_named_context_val : named_context_val @@ -265,18 +264,6 @@ val apply_to_hyp : named_context_val -> variable -> (Context.Named.t -> Context.Named.Declaration.t -> Context.Named.t -> Context.Named.Declaration.t) -> named_context_val -(** [apply_to_hyp_and_dependent_on sign id f g] split [sign] into - [tail::(id,_,_)::head] and - return [(g tail)::(f (id,_,_))::head]. *) -val apply_to_hyp_and_dependent_on : named_context_val -> variable -> - (Context.Named.Declaration.t -> named_context_val -> Context.Named.Declaration.t) -> - (Context.Named.Declaration.t -> named_context_val -> Context.Named.Declaration.t) -> - named_context_val - -val insert_after_hyp : named_context_val -> variable -> - Context.Named.Declaration.t -> - (Context.Named.t -> unit) -> named_context_val - val remove_hyps : Id.Set.t -> (Context.Named.Declaration.t -> Context.Named.Declaration.t) -> (Pre_env.lazy_val -> Pre_env.lazy_val) -> named_context_val -> named_context_val diff --git a/kernel/make-opcodes b/kernel/make-opcodes index c8f573c682..e1371b3d0c 100644 --- a/kernel/make-opcodes +++ b/kernel/make-opcodes @@ -1,2 +1,3 @@ $1=="enum" {n=0; next; } - {for (i = 1; i <= NF; i++) {printf("let op%s = %d\n", $i, n++);}} + {printf("(* THIS FILE IS GENERATED. DON'T EDIT. *)\n\n"); + for (i = 1; i <= NF; i++) {printf("let op%s = %d\n", $i, n++);}} diff --git a/kernel/names.ml b/kernel/names.ml index 9267a64d61..1eb9a31751 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -34,9 +34,15 @@ struct let hash = String.hash + let warn_invalid_identifier = + CWarnings.create ~name:"invalid-identifier" ~category:"parsing" + ~default:CWarnings.Disabled + (fun s -> str s) + let check_soft ?(warn = true) x = let iter (fatal, x) = - if fatal then CErrors.error x else if warn then Feedback.msg_warning (str x) + if fatal then CErrors.error x else + if warn then warn_invalid_identifier x in Option.iter iter (Unicode.ident_refutation x) diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index ad5b04f3d1..eaddace4b7 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -1861,7 +1861,7 @@ and compile_rel env sigma univ auxdefs n = and compile_named env sigma univ auxdefs id = let open Context.Named.Declaration in - match Context.Named.lookup id env.env_named_context with + match lookup_named id env with | LocalDef (_,t,_) -> let code = lambda_of_constr env sigma t in let auxdefs,code = compile_with_fv env sigma univ auxdefs None code in diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml index 5afefeebde..f211583e06 100644 --- a/kernel/pre_env.ml +++ b/kernel/pre_env.ml @@ -61,12 +61,14 @@ let force_lazy_val vk = match !vk with let dummy_lazy_val () = ref VKnone let build_lazy_val vk key = vk := VKvalue (CEphemeron.create key) -type named_vals = (Id.t * lazy_val) list +type named_context_val = { + env_named_ctx : Context.Named.t; + env_named_map : (Context.Named.Declaration.t * lazy_val) Id.Map.t; +} type env = { env_globals : globals; - env_named_context : Context.Named.t; - env_named_vals : named_vals; + env_named_context : named_context_val; env_rel_context : Context.Rel.t; env_rel_val : lazy_val list; env_nb_rel : int; @@ -77,9 +79,10 @@ type env = { indirect_pterms : Opaqueproof.opaquetab; } -type named_context_val = Context.Named.t * named_vals - -let empty_named_context_val = [],[] +let empty_named_context_val = { + env_named_ctx = []; + env_named_map = Id.Map.empty; +} let empty_env = { env_globals = { @@ -87,8 +90,7 @@ let empty_env = { env_inductives = Mindmap_env.empty; env_modules = MPmap.empty; env_modtypes = MPmap.empty}; - env_named_context = Context.Named.empty; - env_named_vals = []; + env_named_context = empty_named_context_val; env_rel_context = Context.Rel.empty; env_rel_val = []; env_nb_rel = 0; @@ -125,17 +127,43 @@ let env_of_rel n env = (* Named context *) -let push_named_context_val d (ctxt,vals) = - let rval = ref VKnone in - Context.Named.add d ctxt, (get_id d,rval)::vals +let push_named_context_val_val d rval ctxt = +(* assert (not (Id.Map.mem (get_id d) ctxt.env_named_map)); *) + { + env_named_ctx = Context.Named.add d ctxt.env_named_ctx; + env_named_map = Id.Map.add (get_id d) (d, rval) ctxt.env_named_map; + } + +let push_named_context_val d ctxt = + push_named_context_val_val d (ref VKnone) ctxt + +let match_named_context_val c = match c.env_named_ctx with +| [] -> None +| decl :: ctx -> + let (_, v) = Id.Map.find (get_id decl) c.env_named_map in + let map = Id.Map.remove (get_id decl) c.env_named_map in + let cval = { env_named_ctx = ctx; env_named_map = map } in + Some (decl, v, cval) + +let map_named_val f ctxt = + let open Context.Named.Declaration in + let fold accu d = + let d' = map_constr f d in + let accu = + if d == d' then accu + else Id.Map.modify (get_id d) (fun _ (_, v) -> (d', v)) accu + in + (accu, d') + in + let map, ctx = List.fold_map fold ctxt.env_named_map ctxt.env_named_ctx in + if map == ctxt.env_named_map then ctxt + else { env_named_ctx = ctx; env_named_map = map } let push_named d env = (* if not (env.env_rel_context = []) then raise (ASSERT env.env_rel_context); assert (env.env_rel_context = []); *) - let rval = ref VKnone in { env_globals = env.env_globals; - env_named_context = Context.Named.add d env.env_named_context; - env_named_vals = (get_id d, rval) :: env.env_named_vals; + env_named_context = push_named_context_val d env.env_named_context; env_rel_context = env.env_rel_context; env_rel_val = env.env_rel_val; env_nb_rel = env.env_nb_rel; @@ -146,8 +174,11 @@ let push_named d env = indirect_pterms = env.indirect_pterms; } +let lookup_named id env = + fst (Id.Map.find id env.env_named_context.env_named_map) + let lookup_named_val id env = - snd(List.find (fun (id',_) -> Id.equal id id') env.env_named_vals) + snd(Id.Map.find id env.env_named_context.env_named_map) (* Warning all the names should be different *) let env_of_named id env = env diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli index e551d22c81..866790367d 100644 --- a/kernel/pre_env.mli +++ b/kernel/pre_env.mli @@ -40,12 +40,14 @@ val force_lazy_val : lazy_val -> (values * Id.Set.t) option val dummy_lazy_val : unit -> lazy_val val build_lazy_val : lazy_val -> (values * Id.Set.t) -> unit -type named_vals = (Id.t * lazy_val) list +type named_context_val = private { + env_named_ctx : Context.Named.t; + env_named_map : (Context.Named.Declaration.t * lazy_val) Id.Map.t; +} type env = { env_globals : globals; - env_named_context : Context.Named.t; - env_named_vals : named_vals; + env_named_context : named_context_val; env_rel_context : Context.Rel.t; env_rel_val : lazy_val list; env_nb_rel : int; @@ -56,8 +58,6 @@ type env = { indirect_pterms : Opaqueproof.opaquetab; } -type named_context_val = Context.Named.t * named_vals - val empty_named_context_val : named_context_val val empty_env : env @@ -73,7 +73,15 @@ val env_of_rel : int -> env -> env val push_named_context_val : Context.Named.Declaration.t -> named_context_val -> named_context_val +val push_named_context_val_val : + Context.Named.Declaration.t -> lazy_val -> named_context_val -> named_context_val +val match_named_context_val : + named_context_val -> (Context.Named.Declaration.t * lazy_val * named_context_val) option +val map_named_val : + (constr -> constr) -> named_context_val -> named_context_val + val push_named : Context.Named.Declaration.t -> env -> env +val lookup_named : Id.t -> env -> Context.Named.Declaration.t val lookup_named_val : Id.t -> env -> lazy_val val env_of_named : Id.t -> env -> env diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 6c664f7918..1ae89347ad 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -316,7 +316,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = (try let cuniv = conv_table_key infos fl1 fl2 cuniv in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv - with NotConvertible -> + with NotConvertible | Univ.UniverseInconsistency _ -> (* else the oracle tells which constant is to be expanded *) let oracle = CClosure.oracle_of_infos infos in let (app1,app2) = diff --git a/kernel/reduction.mli b/kernel/reduction.mli index 9812c45f7b..8a2b2469d6 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -36,7 +36,7 @@ type 'a extended_conversion_function = type conv_pb = CONV | CUMUL type 'a universe_compare = - { (* Might raise NotConvertible *) + { (* Might raise NotConvertible or UnivInconsistency *) compare : env -> conv_pb -> sorts -> sorts -> 'a -> 'a; compare_instances: flex:bool -> Univ.Instance.t -> Univ.Instance.t -> 'a -> 'a; @@ -56,9 +56,12 @@ constructors. *) val convert_instances : flex:bool -> Univ.Instance.t -> Univ.Instance.t -> 'a * 'a universe_compare -> 'a * 'a universe_compare +(** These two never raise UnivInconsistency, inferred_universes + just gathers the constraints. *) val checked_universes : UGraph.t universe_compare val inferred_universes : (UGraph.t * Univ.Constraint.t) universe_compare +(** These two functions can only raise NotConvertible *) val conv : constr extended_conversion_function val conv_leq : types extended_conversion_function @@ -70,6 +73,9 @@ val infer_conv : ?l2r:bool -> ?evars:(existential->constr option) -> val infer_conv_leq : ?l2r:bool -> ?evars:(existential->constr option) -> ?ts:Names.transparent_state -> types infer_conversion_function +(** Depending on the universe state functions, this might raise + [UniverseInconsistency] in addition to [NotConvertible] (for better error + messages). *) val generic_conv : conv_pb -> l2r:bool -> (existential->constr option) -> Names.transparent_state -> (constr,'a) generic_conversion_function diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index 09f7bd75cd..bc1cb63d82 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -213,8 +213,8 @@ type private_constant_role = Term_typing.side_effect_role = | Schema of inductive * string let empty_private_constants = [] -let add_private x xs = x :: xs -let concat_private xs ys = xs @ ys +let add_private x xs = if List.mem_f Term_typing.equal_eff x xs then xs else x :: xs +let concat_private xs ys = List.fold_right add_private xs ys let mk_pure_proof = Term_typing.mk_pure_proof let inline_private_constants_in_constr = Term_typing.inline_side_effects let inline_private_constants_in_definition_entry = Term_typing.inline_entry_side_effects @@ -794,7 +794,10 @@ type compiled_library = { type native_library = Nativecode.global list let get_library_native_symbols senv dir = - DPMap.find dir senv.native_symbols + try DPMap.find dir senv.native_symbols + with Not_found -> CErrors.errorlabstrm "get_library_native_symbols" + Pp.((str "Linker error in the native compiler. Are you using Require inside a nested Module declaration?") ++ fnl () ++ + (str "This use case is not supported, but disabling the native compiler may help.")) (** FIXME: MS: remove?*) let current_modpath senv = senv.modpath diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index fcd95576c0..89b5fc40e3 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -30,6 +30,7 @@ val inline_entry_side_effects : yet type checked proof. *) val uniq_seff : side_effects -> side_effects +val equal_eff : side_effect -> side_effect -> bool val translate_constant : structure_body -> env -> constant -> side_effects constant_entry -> diff --git a/kernel/uGraph.ml b/kernel/uGraph.ml index e2712615be..4884d0deb1 100644 --- a/kernel/uGraph.ml +++ b/kernel/uGraph.ml @@ -638,19 +638,6 @@ let check_smaller g strict u v = type 'a check_function = universes -> 'a -> 'a -> bool -let check_equal_expr g x y = - x == y || (let (u, n) = x and (v, m) = y in - Int.equal n m && check_equal g u v) - -let check_eq_univs g l1 l2 = - let f x1 x2 = check_equal_expr g x1 x2 in - let exists x1 l = Universe.exists (fun x2 -> f x1 x2) l in - Universe.for_all (fun x1 -> exists x1 l2) l1 - && Universe.for_all (fun x2 -> exists x2 l1) l2 - -let check_eq g u v = - Universe.equal u v || check_eq_univs g u v - let check_smaller_expr g (u,n) (v,m) = let diff = n - m in match diff with @@ -669,7 +656,13 @@ let real_check_leq g u v = let check_leq g u v = Universe.equal u v || is_type0m_univ u || - check_eq_univs g u v || real_check_leq g u v + real_check_leq g u v + +let check_eq_univs g l1 l2 = + real_check_leq g l1 l2 && real_check_leq g l2 l1 + +let check_eq g u v = + Universe.equal u v || check_eq_univs g u v (* enforce_univ_eq g u v will force u=v if possible, will fail otherwise *) diff --git a/kernel/univ.ml b/kernel/univ.ml index 9224ec48d7..09f884ecd0 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -468,15 +468,32 @@ struct else if Level.is_prop u then hcons (Level.set,n+k) else hcons (u,n+k) - + + type super_result = + SuperSame of bool + (* The level expressions are in cumulativity relation. boolean + indicates if left is smaller than right? *) + | SuperDiff of int + (* The level expressions are unrelated, the comparison result + is canonical *) + + (** [super u v] compares two level expressions, + returning [SuperSame] if they refer to the same level at potentially different + increments or [SuperDiff] if they are different. The booleans indicate if the + left expression is "smaller" than the right one in both cases. *) let super (u,n as x) (v,n' as y) = let cmp = Level.compare u v in - if Int.equal cmp 0 then - if n < n' then Inl true - else Inl false - else if is_prop x then Inl true - else if is_prop y then Inl false - else Inr cmp + if Int.equal cmp 0 then SuperSame (n < n') + else + match x, y with + | (l,0), (l',0) -> + let open RawLevel in + (match Level.data l, Level.data l' with + | Prop, Prop -> SuperSame false + | Prop, _ -> SuperSame true + | _, Prop -> SuperSame false + | _, _ -> SuperDiff cmp) + | _, _ -> SuperDiff cmp let to_string (v, n) = if Int.equal n 0 then Level.to_string v @@ -598,24 +615,26 @@ struct | Nil, _ -> l2 | _, Nil -> l1 | Cons (h1, _, t1), Cons (h2, _, t2) -> - (match Expr.super h1 h2 with - | Inl true (* h1 < h2 *) -> merge_univs t1 l2 - | Inl false -> merge_univs l1 t2 - | Inr c -> - if c <= 0 (* h1 < h2 is name order *) - then cons h1 (merge_univs t1 l2) - else cons h2 (merge_univs l1 t2)) + let open Expr in + (match super h1 h2 with + | SuperSame true (* h1 < h2 *) -> merge_univs t1 l2 + | SuperSame false -> merge_univs l1 t2 + | SuperDiff c -> + if c <= 0 (* h1 < h2 is name order *) + then cons h1 (merge_univs t1 l2) + else cons h2 (merge_univs l1 t2)) let sort u = let rec aux a l = match l with | Cons (b, _, l') -> - (match Expr.super a b with - | Inl false -> aux a l' - | Inl true -> l - | Inr c -> - if c <= 0 then cons a l - else cons b (aux a l')) + let open Expr in + (match super a b with + | SuperSame false -> aux a l' + | SuperSame true -> l + | SuperDiff c -> + if c <= 0 then cons a l + else cons b (aux a l')) | Nil -> cons a l in fold (fun a acc -> aux a acc) u nil diff --git a/kernel/vconv.ml b/kernel/vconv.ml index 894f5296a8..74d956bef0 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -77,6 +77,7 @@ and conv_whd env pb k whd1 whd2 cu = | Vatom_stk(a1,stk1), Vatom_stk(a2,stk2) -> conv_atom env pb k a1 stk1 a2 stk2 cu | Vfun _, _ | _, Vfun _ -> + (* on the fly eta expansion *) conv_val env CONV (k+1) (apply_whd k whd1) (apply_whd k whd2) cu | Vsort _, _ | Vprod _, _ | Vfix _, _ | Vcofix _, _ | Vconstr_const _, _ diff --git a/kernel/vm.ml b/kernel/vm.ml index eb992ef892..53483a2220 100644 --- a/kernel/vm.ml +++ b/kernel/vm.ml @@ -170,7 +170,7 @@ type whd = external push_ra : tcode -> unit = "coq_push_ra" external push_val : values -> unit = "coq_push_val" external push_arguments : arguments -> unit = "coq_push_arguments" -external push_vstack : vstack -> unit = "coq_push_vstack" +external push_vstack : vstack -> int -> unit = "coq_push_vstack" (* interpreteur *) @@ -206,7 +206,9 @@ let apply_varray vf varray = else begin push_ra stop; - push_vstack varray; + (* The fun code of [vf] will make sure we have enough stack, so we put 0 + here. *) + push_vstack varray 0; interprete (fun_code vf) vf (Obj.magic vf) (n - 1) end @@ -560,7 +562,9 @@ let check_switch sw1 sw2 = sw1.sw_annot.rtbl = sw2.sw_annot.rtbl let case_info sw = sw.sw_annot.ci let type_of_switch sw = - push_vstack sw.sw_stk; + (* The fun code of types will make sure we have enough stack, so we put 0 + here. *) + push_vstack sw.sw_stk 0; interprete sw.sw_type_code crazy_val sw.sw_env 0 let branch_arg k (tag,arity) = @@ -580,9 +584,10 @@ let branch_arg k (tag,arity) = let apply_switch sw arg = let tc = sw.sw_annot.tailcall in if tc then - (push_ra stop;push_vstack sw.sw_stk) + (push_ra stop;push_vstack sw.sw_stk sw.sw_annot.max_stack_size) else - (push_vstack sw.sw_stk; push_ra (popstop_code (Array.length sw.sw_stk))); + (push_vstack sw.sw_stk sw.sw_annot.max_stack_size; + push_ra (popstop_code (Array.length sw.sw_stk))); interprete sw.sw_code arg sw.sw_env 0 let branch_of_switch k sw = diff --git a/lib/cErrors.ml b/lib/cErrors.ml index 1459141d1e..5c56192fc5 100644 --- a/lib/cErrors.ml +++ b/lib/cErrors.ml @@ -16,6 +16,16 @@ let push = Backtrace.add_backtrace exception Anomaly of string option * std_ppcmds (* System errors *) +(* XXX: To move to common tagging functions in Pp, blocked on tag + * system cleanup as we cannot define generic error tags now. + * + * Anyways, tagging should not happen here, but in the specific + * listener to the msg_* stuff. + *) +let tag_err_str s = tag Ppstyle.(Tag.inj error_tag tag) (str s) ++ spc () +let err_str = tag_err_str "Error:" +let ann_str = tag_err_str "Anomaly:" + let _ = let pr = function | Anomaly (s, pp) -> Some ("\"Anomaly: " ^ string_of_ppcmds pp ^ "\"") @@ -93,7 +103,9 @@ let print_backtrace e = match Backtrace.get_backtrace e with let print_anomaly askreport e = if askreport then - hov 0 (str "Anomaly: " ++ raw_anomaly e ++ spc () ++ str "Please report.") + hov 0 (ann_str ++ raw_anomaly e ++ spc () ++ + strbrk "Please report at " ++ str Coq_config.wwwbugtracker ++ + str ".") else hov 0 (raw_anomaly e) @@ -113,7 +125,7 @@ let iprint_no_report (e, info) = let _ = register_handler begin function | UserError(s, pps) -> - hov 0 (str "Error: " ++ where (Some s) ++ pps) + hov 0 (err_str ++ where (Some s) ++ pps) | _ -> raise Unhandled end diff --git a/lib/cWarnings.ml b/lib/cWarnings.ml index 720f54606c..cc2463e224 100644 --- a/lib/cWarnings.ml +++ b/lib/cWarnings.ml @@ -21,7 +21,7 @@ let warnings : (string, t) Hashtbl.t = Hashtbl.create 97 let categories : (string, string list) Hashtbl.t = Hashtbl.create 97 let current_loc = ref Loc.ghost -let flags = ref "default" +let flags = ref "" let set_current_loc = (:=) current_loc @@ -35,6 +35,10 @@ let add_warning_in_category ~name ~category = in Hashtbl.replace categories category (name::ws) +let refine_loc = function + | None when not (Loc.is_ghost !current_loc) -> Some !current_loc + | loc -> loc + let create ~name ~category ?(default=Enabled) pp = Hashtbl.add warnings name { default; category; status = default }; add_warning_in_category ~name ~category; @@ -44,15 +48,17 @@ let create ~name ~category ?(default=Enabled) pp = match w.status with | Disabled -> () | AsError -> - let loc = Option.default !current_loc loc in - CErrors.user_err_loc (loc,"_",pp x) + begin match refine_loc loc with + | Some loc -> CErrors.user_err_loc (loc,"_",pp x) + | None -> CErrors.errorlabstrm "_" (pp x) + end | Enabled -> let msg = pp x ++ spc () ++ str "[" ++ str name ++ str "," ++ str category ++ str "]" in - let loc = Option.default !current_loc loc in - Feedback.msg_warning ~loc msg + let loc = refine_loc loc in + Feedback.msg_warning ?loc msg let warn_unknown_warning = create ~name:"unknown-warning" ~category:"toplevel" @@ -62,7 +68,7 @@ let set_warning_status ~name status = try let w = Hashtbl.find warnings name in Hashtbl.replace warnings name { w with status = status } - with Not_found -> warn_unknown_warning name + with Not_found -> () let reset_default_warnings () = Hashtbl.iter (fun name w -> @@ -74,6 +80,13 @@ let set_all_warnings_status status = Hashtbl.replace warnings name { w with status }) warnings +let set_category_status ~name status = + let names = Hashtbl.find categories name in + List.iter (fun name -> set_warning_status name status) names + +let is_all_keyword name = CString.equal name "all" +let is_none_keyword s = CString.equal s "none" + let parse_flag s = if String.length s > 1 then match String.get s 0 with @@ -82,39 +95,94 @@ let parse_flag s = | _ -> (Enabled, s) else CErrors.error "Invalid warnings flag" -let rec do_all_keyword = function - | [] -> [] - | (status, name as item) :: items -> - if CString.equal name "all" then - (set_all_warnings_status status; do_all_keyword items) - else item :: do_all_keyword items - -let rec do_categories = function - | [] -> [] - | (status, name as item) :: items -> - try - let names = Hashtbl.find categories name in - List.iter (fun name -> set_warning_status name status) names; - do_categories items - with Not_found -> item :: do_categories items +let string_of_flag (status,name) = + match status with + | AsError -> "+" ^ name + | Disabled -> "-" ^ name + | Enabled -> name + +let string_of_flags flags = + String.concat "," (List.map string_of_flag flags) + +let set_status ~name status = + if is_all_keyword name then + set_all_warnings_status status + else + try + set_category_status ~name status + with Not_found -> + try + set_warning_status ~name status + with Not_found -> () + +let split_flags s = + let reg = Str.regexp "[ ,]+" in Str.split reg s + +let check_warning ~silent (_status,name) = + is_all_keyword name || + Hashtbl.mem categories name || + Hashtbl.mem warnings name || + (if not silent then warn_unknown_warning name; false) + +(** [cut_before_all_rev] removes all flags subsumed by a later occurrence of the + "all" flag, and reverses the list. *) +let rec cut_before_all_rev acc = function + | [] -> acc + | (_status,name as w) :: warnings -> + cut_before_all_rev (w :: if is_all_keyword name then [] else acc) warnings + +let cut_before_all_rev warnings = cut_before_all_rev [] warnings + +(** [uniquize_flags_rev] removes flags that are subsumed by later occurrences of + themselves or their categories, and reverses the list. *) +let uniquize_flags_rev flags = + let rec aux acc visited = function + | (_,name as flag)::flags -> + if CString.Set.mem name visited then aux acc visited flags else + let visited = + try + let warnings = Hashtbl.find categories name in + List.fold_left (fun v w -> CString.Set.add w v) visited warnings + with Not_found -> + visited + in + aux (flag::acc) (CString.Set.add name visited) flags + | [] -> acc + in aux [] CString.Set.empty flags + +(** [normalize_flags] removes unknown or redundant warnings. If [silent] is + true, it emits a warning when an unknown warning is met. *) +let normalize_flags ~silent warnings = + let warnings = List.filter (check_warning ~silent) warnings in + let warnings = cut_before_all_rev warnings in + uniquize_flags_rev warnings + +let flags_of_string s = List.map parse_flag (split_flags s) + +let normalize_flags_string s = + if is_none_keyword s then s + else + let flags = flags_of_string s in + let flags = normalize_flags ~silent:false flags in + string_of_flags flags let rec parse_warnings items = - List.iter (fun (status, name) -> set_warning_status ~name status) items + CList.iter (fun (status, name) -> set_status ~name status) items (* For compatibility, we accept "none" *) -let parse_flags s = - if CString.equal s "none" then begin +let parse_flags s = + if is_none_keyword s then begin Flags.make_warn false; - set_all_warnings_status Disabled + set_all_warnings_status Disabled; + "none" end else begin Flags.make_warn true; - let reg = Str.regexp "[ ,]+" in - let items = List.map parse_flag (Str.split reg s) in - let items = do_all_keyword items in - let items = do_categories items in - parse_warnings items + let flags = flags_of_string s in + let flags = normalize_flags ~silent:true flags in + parse_warnings flags; + string_of_flags flags end let set_flags s = - flags := s; reset_default_warnings (); parse_flags s + reset_default_warnings (); let s = parse_flags s in flags := s diff --git a/lib/cWarnings.mli b/lib/cWarnings.mli index 3515542840..3f6cee31b7 100644 --- a/lib/cWarnings.mli +++ b/lib/cWarnings.mli @@ -6,29 +6,16 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -type status = - Disabled | Enabled | AsError - -(* -type 'a repr = { - print : 'a -> Pp.std_ppcmds; - kind : string; - enabled : bool; -} - *) +type status = Disabled | Enabled | AsError val set_current_loc : Loc.t -> unit val create : name:string -> category:string -> ?default:status -> ('a -> Pp.std_ppcmds) -> ?loc:Loc.t -> 'a -> unit -(* -val emit : 'a t -> 'a -> unit - -type any = Any : string * string * 'a repr -> any - -val dump : unit -> any list - *) - val get_flags : unit -> string val set_flags : string -> unit + +(** Cleans up a user provided warnings status string, e.g. removing unknown + warnings (in which case a warning is emitted) or subsumed warnings . *) +val normalize_flags_string : string -> string diff --git a/lib/feedback.ml b/lib/feedback.ml index dd1ca2af36..44b3ee35d7 100644 --- a/lib/feedback.ml +++ b/lib/feedback.ml @@ -52,8 +52,7 @@ open Pp_control type logger = ?loc:Loc.t -> level -> std_ppcmds -> unit -let msgnl_with fmt strm = msg_with fmt (strm ++ fnl ()) -let msgnl strm = msgnl_with !std_ft strm +let msgnl_with ?pp_tag fmt strm = msg_with ?pp_tag fmt (strm ++ fnl ()) (* XXX: This is really painful! *) module Emacs = struct @@ -75,45 +74,100 @@ end open Emacs -let dbg_str = str "Debug:" ++ spc () +let dbg_str = tag Ppstyle.(Tag.inj debug_tag tag) (str "Debug:") ++ spc () let info_str = mt () -let warn_str = str "Warning:" ++ spc () -let err_str = str "Error:" ++ spc () +let warn_str = tag Ppstyle.(Tag.inj warning_tag tag) (str "Warning:") ++ spc () +let err_str = tag Ppstyle.(Tag.inj error_tag tag) (str "Error:" ) ++ spc () let make_body quoter info ?loc s = let loc = Option.cata Pp.pr_loc (Pp.mt ()) loc in quoter (hov 0 (loc ++ info ++ s)) (* Generic logger *) -let gen_logger dbg err ?loc level msg = match level with - | Debug -> msgnl (make_body dbg dbg_str ?loc msg) - | Info -> msgnl (make_body dbg info_str ?loc msg) - (* XXX: What to do with loc here? *) - | Notice -> msgnl msg +let gen_logger dbg err ?pp_tag ?loc level msg = match level with + | Debug -> msgnl_with ?pp_tag !std_ft (make_body dbg dbg_str ?loc msg) + | Info -> msgnl_with ?pp_tag !std_ft (make_body dbg info_str ?loc msg) + | Notice -> msgnl_with ?pp_tag !std_ft msg | Warning -> Flags.if_warn (fun () -> - msgnl_with !err_ft (make_body err warn_str ?loc msg)) () - | Error -> msgnl_with !err_ft (make_body err err_str ?loc msg) + msgnl_with ?pp_tag !err_ft (make_body err warn_str ?loc msg)) () + | Error -> msgnl_with ?pp_tag !err_ft (make_body err err_str ?loc msg) -(** Standard loggers *) -let std_logger = gen_logger (fun x -> x) (fun x -> x) +(* We provide a generic clear_log_backend callback for backends + wanting to do clenaup after the print. +*) +let std_logger_tag = ref None +let std_logger_cleanup = ref (fun () -> ()) -(* Color logger *) -let color_terminal_logger ?loc level strm = - let msg = Ppstyle.color_msg in - match level with - | Debug -> msg ?loc ~header:("Debug", Ppstyle.debug_tag) !std_ft strm - | Info -> msg ?loc !std_ft strm - | Notice -> msg ?loc !std_ft strm - | Warning -> Flags.if_warn (fun () -> - msg ?loc ~header:("Warning", Ppstyle.warning_tag) !err_ft strm) () - | Error -> msg ?loc ~header:("Error", Ppstyle.error_tag) !err_ft strm +let std_logger ?loc level msg = + gen_logger (fun x -> x) (fun x -> x) ?pp_tag:!std_logger_tag ?loc level msg; + !std_logger_cleanup () (* Rules for emacs: - Debug/info: emacs_quote_info - Warning/Error: emacs_quote_err - Notice: unquoted + + Note the inconsistency. *) -let emacs_logger = gen_logger emacs_quote_info emacs_quote_err +let emacs_logger = gen_logger emacs_quote_info emacs_quote_err ?pp_tag:None + +(** Color logging. Moved from pp_style, it may need some more refactoring *) + +(** Not thread-safe. We should put a lock somewhere if we print from + different threads. Do we? *) +let make_style_stack () = + (** Default tag is to reset everything *) + let empty = Terminal.make () in + let default_tag = Terminal.({ + fg_color = Some `DEFAULT; + bg_color = Some `DEFAULT; + bold = Some false; + italic = Some false; + underline = Some false; + negative = Some false; + }) + in + let style_stack = ref [] in + let peek () = match !style_stack with + | [] -> default_tag (** Anomalous case, but for robustness *) + | st :: _ -> st + in + let push tag = + let style = match Ppstyle.get_style tag with + | None -> empty + | Some st -> st + in + (** Use the merging of the latest tag and the one being currently pushed. + This may be useful if for instance the latest tag changes the background and + the current one the foreground, so that the two effects are additioned. *) + let style = Terminal.merge (peek ()) style in + style_stack := style :: !style_stack; + Terminal.eval style + in + let pop _ = match !style_stack with + | [] -> (** Something went wrong, we fallback *) + Terminal.eval default_tag + | _ :: rem -> style_stack := rem; + Terminal.eval (peek ()) + in + let clear () = style_stack := [] in + push, pop, clear + +let init_color_output () = + let open Pp_control in + let push_tag, pop_tag, clear_tag = make_style_stack () in + std_logger_cleanup := clear_tag; + std_logger_tag := Some Ppstyle.pp_tag; + let tag_handler = { + Format.mark_open_tag = push_tag; + Format.mark_close_tag = pop_tag; + Format.print_open_tag = ignore; + Format.print_close_tag = ignore; + } in + Format.pp_set_mark_tags !std_ft true; + Format.pp_set_mark_tags !err_ft true; + Format.pp_set_formatter_tag_functions !std_ft tag_handler; + Format.pp_set_formatter_tag_functions !err_ft tag_handler let logger = ref std_logger let set_logger l = logger := l diff --git a/lib/feedback.mli b/lib/feedback.mli index 48b1c19a67..5160bd5bc1 100644 --- a/lib/feedback.mli +++ b/lib/feedback.mli @@ -72,11 +72,8 @@ val set_logger : logger -> unit (** [std_logger] standard logger to [stdout/stderr] *) val std_logger : logger -val color_terminal_logger : logger -(* This logger will apply the proper {!Pp_style} tags, and in - particular use the formatters {!Pp_control.std_ft} and - {!Pp_control.err_ft} to display those messages. Be careful this is - not compatible with the Emacs mode! *) +(** [init_color_output ()] Enable color in the std_logger *) +val init_color_output : unit -> unit (** [feedback_logger] will produce feedback messages instead IO events *) val feedback_logger : logger diff --git a/lib/flags.ml b/lib/flags.ml index d29064c97f..0e2f7e5a62 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -70,7 +70,7 @@ let priority_of_string = function | "high" -> High | _ -> raise (Invalid_argument "priority_of_string") type tac_error_filter = [ `None | `Only of string list | `All ] -let async_proofs_tac_error_resilience = ref (`Only [ "par" ; "curly" ]) +let async_proofs_tac_error_resilience = ref (`Only [ "curly" ]) let async_proofs_cmd_error_resilience = ref true let async_proofs_is_worker () = @@ -112,17 +112,22 @@ type compat_version = V8_2 | V8_3 | V8_4 | V8_5 | Current let compat_version = ref Current -let version_strictly_greater v = match !compat_version, v with -| V8_2, (V8_2 | V8_3 | V8_4 | V8_5 | Current) -> false -| V8_3, (V8_3 | V8_4 | V8_5 | Current) -> false -| V8_4, (V8_4 | V8_5 | Current) -> false -| V8_5, (V8_5 | Current) -> false -| Current, Current -> false -| V8_3, V8_2 -> true -| V8_4, (V8_2 | V8_3) -> true -| V8_5, (V8_2 | V8_3 | V8_4) -> true -| Current, (V8_2 | V8_3 | V8_4 | V8_5) -> true - +let version_compare v1 v2 = match v1, v2 with +| V8_2, V8_2 -> 0 +| V8_2, (V8_3 | V8_4 | V8_5 | Current) -> -1 +| V8_3, V8_2 -> 1 +| V8_3, V8_3 -> 0 +| V8_3, (V8_4 | V8_5 | Current) -> -1 +| V8_4, (V8_2 | V8_3) -> 1 +| V8_4, V8_4 -> 0 +| V8_4, (V8_5 | Current) -> -1 +| V8_5, (V8_2 | V8_3 | V8_4) -> 1 +| V8_5, V8_5 -> 0 +| V8_5, Current -> -1 +| Current, Current -> 0 +| Current, (V8_2 | V8_3 | V8_4 | V8_5) -> 1 + +let version_strictly_greater v = version_compare !compat_version v > 0 let version_less_or_equal v = not (version_strictly_greater v) let pr_version = function @@ -134,8 +139,6 @@ let pr_version = function (* Translate *) let beautify = ref false -let make_beautify f = beautify := f -let do_beautify () = !beautify let beautify_file = ref false (* Silent / Verbose *) @@ -226,7 +229,7 @@ let print_mod_uid = ref false let tactic_context_compat = ref false let profile_ltac = ref false -let profile_ltac_cutoff = ref 0.0 +let profile_ltac_cutoff = ref 2.0 let dump_bytecode = ref false let set_dump_bytecode = (:=) dump_bytecode diff --git a/lib/flags.mli b/lib/flags.mli index 839c252cbb..897602641c 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -64,13 +64,12 @@ val univ_print : bool ref type compat_version = V8_2 | V8_3 | V8_4 | V8_5 | Current val compat_version : compat_version ref +val version_compare : compat_version -> compat_version -> int val version_strictly_greater : compat_version -> bool val version_less_or_equal : compat_version -> bool val pr_version : compat_version -> string val beautify : bool ref -val make_beautify : bool -> unit -val do_beautify : unit -> bool val beautify_file : bool ref val make_silent : bool -> unit diff --git a/lib/minisys.ml b/lib/minisys.ml index 25e4d79c4e..f15021c655 100644 --- a/lib/minisys.ml +++ b/lib/minisys.ml @@ -46,14 +46,6 @@ let ok_dirname f = let exists_dir dir = try Sys.is_directory dir with Sys_error _ -> false -let check_unix_dir warn dir = - if (Sys.os_type = "Win32" || Sys.os_type = "Cygwin") && - (String.length dir > 2 && dir.[1] = ':' || - String.contains dir '\\' || - String.contains dir ';') - then warn ("assuming " ^ dir ^ - " to be a Unix path even if looking like a Win32 path.") - let apply_subdir f path name = (* we avoid all files and subdirs starting by '.' (e.g. .svn) *) (* as well as skipped files like CVS, ... *) diff --git a/lib/monad.ml b/lib/monad.ml index a1714a41b3..2e55e9698c 100644 --- a/lib/monad.ml +++ b/lib/monad.ml @@ -64,6 +64,9 @@ module type ListS = sig its second argument in a tail position. *) val iter : ('a -> unit t) -> 'a list -> unit t + (** Like the regular {!CList.map_filter}. The monadic effects are threaded left*) + val map_filter : ('a -> 'b option t) -> 'a list -> 'b list t + (** {6 Two-list iterators} *) @@ -138,6 +141,14 @@ module Make (M:Def) : S with type +'a t = 'a M.t = struct | a::b::l -> f a >> f b >> iter f l + let rec map_filter f = function + | [] -> return [] + | a::l -> + f a >>= function + | None -> map_filter f l + | Some b -> + map_filter f l >>= fun filtered -> + return (b::filtered) let rec fold_left2 r f x l1 l2 = match l1,l2 with diff --git a/lib/monad.mli b/lib/monad.mli index c8655efa04..f7de71f53a 100644 --- a/lib/monad.mli +++ b/lib/monad.mli @@ -66,6 +66,9 @@ module type ListS = sig its second argument in a tail position. *) val iter : ('a -> unit t) -> 'a list -> unit t + (** Like the regular {!CList.map_filter}. The monadic effects are threaded left*) + val map_filter : ('a -> 'b option t) -> 'a list -> 'b list t + (** {6 Two-list iterators} *) @@ -77,17 +77,6 @@ open Pp_control \end{description} *) -let comments = ref [] - -let rec split_com comacc acc pos = function - [] -> comments := List.rev acc; comacc - | ((b,e),c as com)::coms -> - (* Take all comments that terminates before pos, or begin exactly - at pos (used to print comments attached after an expression) *) - if e<=pos || pos=b then split_com (c::comacc) acc pos coms - else split_com comacc (com::acc) pos coms - - type block_type = | Pp_hbox of int | Pp_vbox of int @@ -111,7 +100,7 @@ type 'a ppcmd_token = | Ppcmd_open_box of block_type | Ppcmd_close_box | Ppcmd_close_tbox - | Ppcmd_comment of int + | Ppcmd_comment of string list | Ppcmd_open_tag of Tag.t | Ppcmd_close_tag @@ -177,7 +166,7 @@ let tab () = Glue.atom(Ppcmd_set_tab) let fnl () = Glue.atom(Ppcmd_force_newline) let pifb () = Glue.atom(Ppcmd_print_if_broken) let ws n = Glue.atom(Ppcmd_white_space n) -let comment n = Glue.atom(Ppcmd_comment n) +let comment l = Glue.atom(Ppcmd_comment l) (* derived commands *) let mt () = Glue.empty @@ -254,32 +243,15 @@ let qstring s = str "\"" ++ str (escape_string s) ++ str "\"" let qs = qstring let quote s = h 0 (str "\"" ++ s ++ str "\"") -(* This flag tells if the last printed comment ends with a newline, to - avoid empty lines *) -let com_eol = ref false - -let com_brk ft = com_eol := false -let com_if ft f = - if !com_eol then (com_eol := false; Format.pp_force_newline ft ()) - else Lazy.force f - let rec pr_com ft s = let (s1,os) = try let n = String.index s '\n' in String.sub s 0 n, Some (String.sub s (n+1) (String.length s - n - 1)) with Not_found -> s,None in - com_if ft (Lazy.from_val()); -(* let s1 = - if String.length s1 <> 0 && s1.[0] = ' ' then - (Format.pp_print_space ft (); String.sub s1 1 (String.length s1 - 1)) - else s1 in*) Format.pp_print_as ft (utf8_length s1) s1; match os with - Some s2 -> - if Int.equal (String.length s2) 0 then (com_eol := true) - else - (Format.pp_force_newline ft (); pr_com ft s2) + Some s2 -> Format.pp_force_newline ft (); pr_com ft s2 | None -> () type tag_handler = Tag.t -> Format.tag @@ -298,34 +270,24 @@ let pp_dirs ?pp_tag ft = begin match tok with | Str_def s -> let n = utf8_length s in - com_if ft (Lazy.from_val()); Format.pp_print_as ft n s + Format.pp_print_as ft n s | Str_len (s, n) -> - com_if ft (Lazy.from_val()); Format.pp_print_as ft n s + Format.pp_print_as ft n s end | Ppcmd_box(bty,ss) -> (* Prevent evaluation of the stream! *) - com_if ft (Lazy.from_val()); pp_open_box bty ; if not (Format.over_max_boxes ()) then Glue.iter pp_cmd ss; Format.pp_close_box ft () - | Ppcmd_open_box bty -> com_if ft (Lazy.from_val()); pp_open_box bty + | Ppcmd_open_box bty -> pp_open_box bty | Ppcmd_close_box -> Format.pp_close_box ft () | Ppcmd_close_tbox -> Format.pp_close_tbox ft () - | Ppcmd_white_space n -> - com_if ft (Lazy.from_fun (fun()->Format.pp_print_break ft n 0)) - | Ppcmd_print_break(m,n) -> - com_if ft (Lazy.from_fun(fun()->Format.pp_print_break ft m n)) + | Ppcmd_white_space n -> Format.pp_print_break ft n 0 + | Ppcmd_print_break(m,n) -> Format.pp_print_break ft m n | Ppcmd_set_tab -> Format.pp_set_tab ft () - | Ppcmd_print_tbreak(m,n) -> - com_if ft (Lazy.from_fun(fun()->Format.pp_print_tbreak ft m n)) - | Ppcmd_force_newline -> - com_brk ft; Format.pp_force_newline ft () - | Ppcmd_print_if_broken -> - com_if ft (Lazy.from_fun(fun()->Format.pp_print_if_newline ft ())) - | Ppcmd_comment i -> - let coms = split_com [] [] i !comments in -(* Format.pp_open_hvbox ft 0;*) - List.iter (pr_com ft) coms(*; - Format.pp_close_box ft ()*) + | Ppcmd_print_tbreak(m,n) -> Format.pp_print_tbreak ft m n + | Ppcmd_force_newline -> Format.pp_force_newline ft () + | Ppcmd_print_if_broken -> Format.pp_print_if_newline ft () + | Ppcmd_comment coms -> List.iter (pr_com ft) coms | Ppcmd_open_tag tag -> begin match pp_tag with | None -> () @@ -339,13 +301,12 @@ let pp_dirs ?pp_tag ft = in let pp_dir = function | Ppdir_ppcmds cmdstream -> Glue.iter pp_cmd cmdstream - | Ppdir_print_newline -> - com_brk ft; Format.pp_print_newline ft () + | Ppdir_print_newline -> Format.pp_print_newline ft () | Ppdir_print_flush -> Format.pp_print_flush ft () in fun (dirstream : _ ppdirs) -> try - Glue.iter pp_dir dirstream; com_brk ft + Glue.iter pp_dir dirstream with reraise -> let reraise = Backtrace.add_backtrace reraise in let () = Format.pp_print_flush ft () in @@ -356,8 +317,8 @@ let pp_with ?pp_tag ft strm = pp_dirs ?pp_tag ft (Glue.atom (Ppdir_ppcmds strm)) (* pretty printing functions WITH FLUSH *) -let msg_with ft strm = - pp_dirs ft (Glue.atom(Ppdir_ppcmds strm) ++ Glue.atom(Ppdir_print_flush)) +let msg_with ?pp_tag ft strm = + pp_dirs ?pp_tag ft (Glue.atom(Ppdir_ppcmds strm) ++ Glue.atom(Ppdir_print_flush)) (* If mixing some output and a goal display, please use msg_warning, so that interfaces (proofgeneral for example) can easily dispatch @@ -365,7 +326,7 @@ let msg_with ft strm = (** Output to a string formatter *) let string_of_ppcmds c = - Format.fprintf Format.str_formatter "@[%a@]" msg_with c; + Format.fprintf Format.str_formatter "@[%a@]" (msg_with ?pp_tag:None) c; Format.flush_str_formatter () (* Copy paste from Util *) diff --git a/lib/pp.mli b/lib/pp.mli index 3bd560812e..8342a983de 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -23,8 +23,7 @@ val ws : int -> std_ppcmds val mt : unit -> std_ppcmds val ismt : std_ppcmds -> bool -val comment : int -> std_ppcmds -val comments : ((int * int) * string) list ref +val comment : string list -> std_ppcmds (** {6 Manipulation commands} *) @@ -173,8 +172,8 @@ val pr_loc : Loc.t -> std_ppcmds (** FIXME: These ignore the logging settings and call [Format] directly *) type tag_handler = Tag.t -> Format.tag -(** [msg_with fmt pp] Print [pp] to [fmt] and flush [fmt] *) -val msg_with : Format.formatter -> std_ppcmds -> unit +(** [msg_with ?pp_tag fmt pp] Print [pp] to [fmt] and flush [fmt] *) +val msg_with : ?pp_tag:tag_handler -> Format.formatter -> std_ppcmds -> unit -(** [msg_with fmt pp] Print [pp] to [fmt] and don't flush [fmt] *) +(** [msg_with ?pp_tag fmt pp] Print [pp] to [fmt] and don't flush [fmt] *) val pp_with : ?pp_tag:tag_handler -> Format.formatter -> std_ppcmds -> unit diff --git a/lib/ppstyle.ml b/lib/ppstyle.ml index ecfaa822c7..aa47c51671 100644 --- a/lib/ppstyle.ml +++ b/lib/ppstyle.ml @@ -56,41 +56,6 @@ let default = Terminal.({ let empty = Terminal.make () -let make_style_stack style_tags = - (** Not thread-safe. We should put a lock somewhere if we print from - different threads. Do we? *) - let style_stack = ref [] in - let peek () = match !style_stack with - | [] -> default (** Anomalous case, but for robustness *) - | st :: _ -> st - in - let push tag = - let style = - try - begin match String.Map.find tag style_tags with - | None -> empty - | Some st -> st - end - with Not_found -> empty - in - (** Use the merging of the latest tag and the one being currently pushed. - This may be useful if for instance the latest tag changes the background and - the current one the foreground, so that the two effects are additioned. *) - let style = Terminal.merge (peek ()) style in - let () = style_stack := style :: !style_stack in - Terminal.eval style - in - let pop _ = match !style_stack with - | [] -> - (** Something went wrong, we fallback *) - Terminal.eval default - | _ :: rem -> - let () = style_stack := rem in - Terminal.eval (peek ()) - in - let clear () = style_stack := [] in - push, pop, clear - let error_tag = let style = Terminal.make ~bold:true ~fg_color:`WHITE ~bg_color:`RED () in make ~style ["message"; "error"] @@ -106,37 +71,3 @@ let debug_tag = let pp_tag t = match Pp.Tag.prj t tag with | None -> "" | Some key -> key - -let clear_tag_fn = ref (fun () -> ()) - -let init_color_output () = - let push_tag, pop_tag, clear_tag = make_style_stack !tags in - clear_tag_fn := clear_tag; - let tag_handler = { - Format.mark_open_tag = push_tag; - Format.mark_close_tag = pop_tag; - Format.print_open_tag = ignore; - Format.print_close_tag = ignore; - } in - let open Pp_control in - Format.pp_set_mark_tags !std_ft true; - Format.pp_set_mark_tags !err_ft true; - Format.pp_set_formatter_tag_functions !std_ft tag_handler; - Format.pp_set_formatter_tag_functions !err_ft tag_handler - -let color_msg ?loc ?header ft strm = - let pptag = tag in - let open Pp in - let ploc = Option.cata Pp.pr_loc (Pp.mt ()) loc in - let strm = match header with - | None -> hov 0 (ploc ++ strm) - | Some (h, t) -> - let tag = Pp.Tag.inj t pptag in - let h = Pp.tag tag (str h ++ str ":") in - hov 0 (ploc ++ h ++ spc () ++ strm) - in - pp_with ~pp_tag ft strm; - Format.pp_print_newline ft (); - Format.pp_print_flush ft (); - (** In case something went wrong, we reset the stack *) - !clear_tag_fn () diff --git a/lib/ppstyle.mli b/lib/ppstyle.mli index b07fcd5d4c..d9fd757656 100644 --- a/lib/ppstyle.mli +++ b/lib/ppstyle.mli @@ -44,14 +44,7 @@ val parse_config : string -> unit val dump : unit -> (t * Terminal.style option) list (** Recover the list of known tags together with their current style. *) -(** {5 Setting color output} *) - -val init_color_output : unit -> unit - -val color_msg : ?loc:Loc.t -> ?header:string * Format.tag -> - Format.formatter -> Pp.std_ppcmds -> unit -(** {!color_msg ?header fmt pp} will format according to the tags - defined in this file *) +(** {5 Color output} *) val pp_tag : Pp.tag_handler (** Returns the name of a style tag that is understandable by the formatters diff --git a/lib/profile.ml b/lib/profile.ml index 0910db3fe2..d620fe69c4 100644 --- a/lib/profile.ml +++ b/lib/profile.ml @@ -146,9 +146,9 @@ let merge_profile filename (curr_table, curr_outside, curr_total as new_data) = number of allocated bytes may exceed the maximum integer capacity (2^31 on 32-bits architectures); therefore, allocation is measured by small steps, total allocations are computed by adding elementary - measures and carries are controled from step to step *) + measures and carries are controlled from step to step *) -(* Unix measure of time is approximative and shoitt delays are often +(* Unix measure of time is approximate and short delays are often unperceivable; therefore, total times are measured in one (big) step to avoid rounding errors and to get the best possible approximation. @@ -358,7 +358,7 @@ let declare_profile name = prof_table := (name,e)::!prof_table; e -(* Default initialisation, may be overriden *) +(* Default initialization, may be overridden *) let _ = init_profile () (******************************) diff --git a/lib/richpp.ml b/lib/richpp.ml index a98273edb2..d1c6d158e4 100644 --- a/lib/richpp.ml +++ b/lib/richpp.ml @@ -55,7 +55,7 @@ let rich_pp annotate ppcmds = string_of_int index in - let pp_buffer = Buffer.create 13 in + let pp_buffer = Buffer.create 180 in let push_pcdata () = (** Push the optional PCData on the above node *) @@ -113,6 +113,13 @@ let rich_pp annotate ppcmds = pp_set_formatter_tag_functions ft tag_functions; pp_set_mark_tags ft true; + (* Set formatter width. This is currently a hack and duplicate code + with Pp_control. Hopefully it will be fixed better in Coq 8.7 *) + let w = pp_get_margin str_formatter () in + let m = max (64 * w / 100) (w-30) in + pp_set_margin ft w; + pp_set_max_indent ft m; + (** The whole output must be a valid document. To that end, we nest the document inside <pp> tags. *) pp_open_tag ft "pp"; diff --git a/lib/stateid.ml b/lib/stateid.ml index 500581a39e..ae25735c5f 100644 --- a/lib/stateid.ml +++ b/lib/stateid.ml @@ -22,7 +22,7 @@ let to_int id = id let newer_than id1 id2 = id1 > id2 let state_id_info : (t * t) Exninfo.t = Exninfo.make () -let add exn ?(valid = initial) id = +let add exn ~valid id = Exninfo.add exn state_id_info (valid, id) let get exn = Exninfo.get exn state_id_info diff --git a/lib/stateid.mli b/lib/stateid.mli index cd8fddf0ce..1d87a343b3 100644 --- a/lib/stateid.mli +++ b/lib/stateid.mli @@ -26,9 +26,8 @@ val newer_than : t -> t -> bool (* Attaches to an exception the concerned state id, plus an optional * state id that is a valid state id before the error. - * Backtracking to the valid id is safe. - * The initial_state_id is assumed to be safe. *) -val add : Exninfo.info -> ?valid:t -> t -> Exninfo.info + * Backtracking to the valid id is safe. *) +val add : Exninfo.info -> valid:t -> t -> Exninfo.info val get : Exninfo.info -> (t * t) option type ('a,'b) request = { diff --git a/lib/system.ml b/lib/system.ml index af9aa5c074..1817aed1fc 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -33,7 +33,6 @@ let all_subdirs ~unix_path:root = | _ -> () in process_directory f path in - check_unix_dir (fun s -> Feedback.msg_warning (str s)) root; if exists_dir root then traverse root [] else warn_cannot_open_dir root; List.rev !l @@ -310,6 +309,7 @@ let with_time time f x = raise e let process_id () = - if Flags.async_proofs_is_worker () then !Flags.async_proofs_worker_id - else Printf.sprintf "master:%d" (Thread.id (Thread.self ())) - + Printf.sprintf "%d:%s:%d" (Unix.getpid ()) + (if Flags.async_proofs_is_worker () then !Flags.async_proofs_worker_id + else "master") + (Thread.id (Thread.self ())) diff --git a/lib/system.mli b/lib/system.mli index 4dbb3695d2..214369095c 100644 --- a/lib/system.mli +++ b/lib/system.mli @@ -20,11 +20,6 @@ val (//) : unix_path -> string -> unix_path val exists_dir : unix_path -> bool -(** [check_unix_dir warn path] calls [warn] with an appropriate - message if [path] looks does not look like a Unix path on Windows *) - -val check_unix_dir : (string -> unit) -> unix_path -> unit - (** [exclude_search_in_dirname path] excludes [path] when processing directories *) diff --git a/lib/unicode.ml b/lib/unicode.ml index dc852d9819..ced5e258c2 100644 --- a/lib/unicode.ml +++ b/lib/unicode.ml @@ -8,9 +8,7 @@ (** Unicode utilities *) -type status = Letter | IdentPart | Symbol - -exception Unsupported +type status = Letter | IdentPart | Symbol | Unknown (* The following table stores classes of Unicode characters that are used by the lexer. There are 3 different classes so 2 bits are @@ -29,6 +27,7 @@ let mask i = function | Letter -> 1 lsl ((i land 7) lsl 1) (* 01 *) | IdentPart -> 2 lsl ((i land 7) lsl 1) (* 10 *) | Symbol -> 3 lsl ((i land 7) lsl 1) (* 11 *) + | Unknown -> 0 lsl ((i land 7) lsl 1) (* 00 *) (* Helper to reset 2 bits in a word. *) let reset_mask i = @@ -55,7 +54,7 @@ let lookup x = if v = 1 then Letter else if v = 2 then IdentPart else if v = 3 then Symbol - else raise Unsupported + else Unknown (* [classify] discriminates between 3 different kinds of symbols based on the standard unicode classification (extracted from @@ -215,7 +214,6 @@ let ident_refutation s = |x -> x with | End_of_input -> Some (true,"The empty string is not an identifier.") - | Unsupported -> Some (true,s^": unsupported character in utf8 sequence.") | Invalid_argument _ -> Some (true,s^": invalid utf8 sequence.") let lowercase_unicode = diff --git a/lib/unicode.mli b/lib/unicode.mli index 1f8bd44eee..2609e1968f 100644 --- a/lib/unicode.mli +++ b/lib/unicode.mli @@ -8,22 +8,16 @@ (** Unicode utilities *) -type status = Letter | IdentPart | Symbol +type status = Letter | IdentPart | Symbol | Unknown -(** This exception is raised when UTF-8 the input string contains unsupported UTF-8 characters. *) -exception Unsupported - -(** Classify a unicode char into 3 classes. - @raise Unsupported if the input string contains unsupported UTF-8 characters. *) +(** Classify a unicode char into 3 classes or unknown. *) val classify : int -> status (** Return [None] if a given string can be used as a (Coq) identifier. - Return [Some (b,s)] otherwise, where [s] is an explanation and [b] is severity. - @raise Unsupported if the input string contains unsupported UTF-8 characters. *) + Return [Some (b,s)] otherwise, where [s] is an explanation and [b] is severity. *) val ident_refutation : string -> (bool * string) option (** First char of a string, converted to lowercase - @raise Unsupported if the input string contains unsupported UTF-8 characters. @raise Assert_failure if the input string is empty. *) val lowercase_first_char : string -> string diff --git a/library/declare.ml b/library/declare.ml index 3d063225f4..c9992fff3b 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -434,6 +434,23 @@ let assumption_message id = (** Global universe names, in a different summary *) +type universe_context_decl = polymorphic * Univ.universe_context_set + +let cache_universe_context (p, ctx) = + Global.push_context_set p ctx; + if p then Lib.add_section_context ctx + +let input_universe_context : universe_context_decl -> Libobject.obj = + declare_object + { (default_object "Global universe context state") with + cache_function = (fun (na, pi) -> cache_universe_context pi); + load_function = (fun _ (_, pi) -> cache_universe_context pi); + discharge_function = (fun (_, (p, _ as x)) -> if p then None else Some x); + classify_function = (fun a -> Keep a) } + +let declare_universe_context poly ctx = + Lib.add_anonymous_leaf (input_universe_context (poly, ctx)) + (* Discharged or not *) type universe_decl = polymorphic * (Id.t * Univ.universe_level) list @@ -446,9 +463,8 @@ let cache_universes (p, l) = Univ.ContextSet.add_universe lev ctx)) (glob, Univ.ContextSet.empty) l in - Global.push_context_set p ctx; - if p then Lib.add_section_context ctx; - Universes.set_global_universe_names glob' + cache_universe_context (p, ctx); + Universes.set_global_universe_names glob' let input_universes : universe_decl -> Libobject.obj = declare_object @@ -475,8 +491,10 @@ let do_universe poly l = type constraint_decl = polymorphic * Univ.constraints let cache_constraints (na, (p, c)) = - Global.add_constraints c; - if p then Lib.add_section_context (Univ.ContextSet.add_constraints c Univ.ContextSet.empty) + let ctx = + Univ.ContextSet.add_constraints c + Univ.ContextSet.empty (* No declared universes here, just constraints *) + in cache_universe_context (p,ctx) let discharge_constraints (_, (p, c as a)) = if p then None else Some a @@ -491,12 +509,20 @@ let input_constraints : constraint_decl -> Libobject.obj = classify_function = (fun a -> Keep a) } let do_constraint poly l = - let u_of_id = - let names, _ = Universes.global_universe_names () in - fun (loc, id) -> - try Idmap.find id names - with Not_found -> - user_err_loc (loc, "Constraint", str "Undeclared universe " ++ pr_id id) + let open Misctypes in + let u_of_id x = + match x with + | GProp -> Loc.dummy_loc, (false, Univ.Level.prop) + | GSet -> Loc.dummy_loc, (false, Univ.Level.set) + | GType None -> + user_err_loc (Loc.dummy_loc, "Constraint", + str "Cannot declare constraints on anonymous universes") + | GType (Some (loc, id)) -> + let id = Id.of_string id in + let names, _ = Universes.global_universe_names () in + try loc, Idmap.find id names + with Not_found -> + user_err_loc (loc, "Constraint", str "Undeclared universe " ++ pr_id id) in let in_section = Lib.sections_are_opened () in let () = @@ -514,8 +540,8 @@ let do_constraint poly l = ++ str "Polymorphic Constraint instead") 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 (fst l) p (fst r) p'; + let ploc, (p, lu) = u_of_id l and rloc, (p', ru) = u_of_id r in + check_poly ploc p rloc p'; Univ.Constraint.add (lu, d, ru) acc) Univ.Constraint.empty l in diff --git a/library/declare.mli b/library/declare.mli index 7824506da0..f70d594d7e 100644 --- a/library/declare.mli +++ b/library/declare.mli @@ -87,7 +87,11 @@ val exists_name : Id.t -> bool -(** Global universe names and constraints *) +(** Global universe contexts, names and constraints *) + +val declare_universe_context : polymorphic -> Univ.universe_context_set -> unit val do_universe : polymorphic -> Id.t Loc.located list -> unit -val do_constraint : polymorphic -> (Id.t Loc.located * Univ.constraint_type * Id.t Loc.located) list -> unit +val do_constraint : polymorphic -> + (Misctypes.glob_level * Univ.constraint_type * Misctypes.glob_level) list -> + unit diff --git a/library/goptions.ml b/library/goptions.ml index 1cf25987b1..9dc0f40588 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -208,6 +208,10 @@ type 'a option_sig = { optread : unit -> 'a; optwrite : 'a -> unit } +type option_locality = OptLocal | OptDefault | OptGlobal + +type option_mod = OptSet | OptAppend + module OptionOrd = struct type t = option_name @@ -238,49 +242,52 @@ let warn_deprecated_option = (fun key -> str "Option" ++ spc () ++ str (nickname key) ++ strbrk " is deprecated") -let declare_option cast uncast +let get_locality = function + | Some true -> OptLocal + | Some false -> OptGlobal + | None -> OptDefault + +let declare_option cast uncast append ?(preprocess = fun x -> x) { optsync=sync; optdepr=depr; optname=name; optkey=key; optread=read; optwrite=write } = check_key key; let default = read() in - (* spiwack: I use two spaces in the nicknames of "local" and "global" objects. - That way I shouldn't collide with [nickname key] for any [key]. As [key]-s are - lists of strings *without* spaces. *) - let (write,lwrite,gwrite) = if sync then - let ldecl_obj = (* "Local": doesn't survive section or modules. *) - declare_object {(default_object ("L "^nickname key)) with - cache_function = (fun (_,v) -> write v); - classify_function = (fun _ -> Dispose)} - in - let decl_obj = (* default locality: survives sections but not modules. *) - declare_object {(default_object (nickname key)) with - cache_function = (fun (_,v) -> write v); - classify_function = (fun _ -> Dispose); - discharge_function = (fun (_,v) -> Some v)} - in - let gdecl_obj = (* "Global": survives section and modules. *) - declare_object {(default_object ("G "^nickname key)) with - cache_function = (fun (_,v) -> write v); - classify_function = (fun v -> Substitute v); - subst_function = (fun (_,v) -> v); - discharge_function = (fun (_,v) -> Some v); - load_function = (fun _ (_,v) -> write v)} - in - let _ = Summary.declare_summary (nickname key) - { Summary.freeze_function = (fun _ -> read ()); - Summary.unfreeze_function = write; - Summary.init_function = (fun () -> write default) } - in - begin fun v -> add_anonymous_leaf (decl_obj v) end , - begin fun v -> add_anonymous_leaf (ldecl_obj v) end , - begin fun v -> add_anonymous_leaf (gdecl_obj v) end - else write,write,write + let change = + if sync then + let _ = Summary.declare_summary (nickname key) + { Summary.freeze_function = (fun _ -> read ()); + Summary.unfreeze_function = write; + Summary.init_function = (fun () -> write default) } in + let cache_options (_,(l,m,v)) = + match m with + | OptSet -> write v + | OptAppend -> write (append (read ()) v) in + let load_options i o = cache_options o in + let subst_options (subst,obj) = obj in + let discharge_options (_,(l,_,_ as o)) = + match l with OptLocal -> None | _ -> Some o in + let classify_options (l,_,_ as o) = + match l with OptGlobal -> Substitute o | _ -> Dispose in + let options : option_locality * option_mod * _ -> obj = + declare_object + { (default_object (nickname key)) with + load_function = load_options; + cache_function = cache_options; + subst_function = subst_options; + discharge_function = discharge_options; + classify_function = classify_options } in + (fun l m v -> let v = preprocess v in Lib.add_anonymous_leaf (options (l, m, v))) + else + (fun _ m v -> + let v = preprocess v in + match m with + | OptSet -> write v + | OptAppend -> write (append (read ()) v)) in let warn () = if depr then warn_deprecated_option key in let cread () = cast (read ()) in - let cwrite v = warn (); write (uncast v) in - let clwrite v = warn (); lwrite (uncast v) in - let cgwrite v = warn (); gwrite (uncast v) in - value_tab := OptionMap.add key (name, depr, (sync,cread,cwrite,clwrite,cgwrite)) !value_tab; + let cwrite l v = warn (); change l OptSet (uncast v) in + let cappend l v = warn (); change l OptAppend (uncast v) in + value_tab := OptionMap.add key (name, depr, (sync,cread,cwrite,cappend)) !value_tab; write type 'a write_function = 'a -> unit @@ -289,18 +296,22 @@ let declare_int_option = declare_option (fun v -> IntValue v) (function IntValue v -> v | _ -> anomaly (Pp.str "async_option")) + (fun _ _ -> anomaly (Pp.str "async_option")) let declare_bool_option = declare_option (fun v -> BoolValue v) (function BoolValue v -> v | _ -> anomaly (Pp.str "async_option")) + (fun _ _ -> anomaly (Pp.str "async_option")) let declare_string_option = declare_option (fun v -> StringValue v) (function StringValue v -> v | _ -> anomaly (Pp.str "async_option")) + (fun x y -> x^","^y) let declare_stringopt_option = declare_option (fun v -> StringOptValue v) (function StringOptValue v -> v | _ -> anomaly (Pp.str "async_option")) + (fun _ _ -> anomaly (Pp.str "async_option")) (* 3- User accessible commands *) @@ -315,13 +326,8 @@ let set_option_value locality check_and_cast key v = let opt = try Some (get_option key) with Not_found -> None in match opt with | None -> warn_unknown_option key - | Some (name, depr, (_,read,write,lwrite,gwrite)) -> - let write = match locality with - | None -> write - | Some true -> lwrite - | Some false -> gwrite - in - write (check_and_cast v (read ())) + | Some (name, depr, (_,read,write,append)) -> + write (get_locality locality) (check_and_cast v (read ())) let bad_type_error () = error "Bad type of value for this option." @@ -357,6 +363,13 @@ let set_string_option_value_gen locality = let unset_option_value_gen locality key = set_option_value locality check_unset_value key () +let set_string_option_append_value_gen locality key v = + let opt = try Some (get_option key) with Not_found -> None in + match opt with + | None -> warn_unknown_option key + | Some (name, depr, (_,read,write,append)) -> + append (get_locality locality) (check_string_value v (read ())) + let set_int_option_value = set_int_option_value_gen None let set_bool_option_value = set_bool_option_value_gen None let set_string_option_value = set_string_option_value_gen None @@ -369,13 +382,13 @@ let msg_option_value (name,v) = | BoolValue false -> str "off" | IntValue (Some n) -> int n | IntValue None -> str "undefined" - | StringValue s -> str s + | StringValue s -> str "\"" ++ str s ++ str "\"" | StringOptValue None -> str"undefined" - | StringOptValue (Some s) -> str s + | StringOptValue (Some s) -> str "\"" ++ str s ++ str "\"" (* | IdentValue r -> pr_global_env Id.Set.empty r *) let print_option_value key = - let (name, depr, (_,read,_,_,_)) = get_option key in + let (name, depr, (_,read,_,_)) = get_option key in let s = read () in match s with | BoolValue b -> @@ -385,7 +398,7 @@ let print_option_value key = let get_tables () = let tables = !value_tab in - let fold key (name, depr, (sync,read,_,_,_)) accu = + let fold key (name, depr, (sync,read,_,_)) accu = let state = { opt_sync = sync; opt_name = name; @@ -404,13 +417,13 @@ let print_tables () = in str "Synchronous options:" ++ fnl () ++ OptionMap.fold - (fun key (name, depr, (sync,read,_,_,_)) p -> + (fun key (name, depr, (sync,read,_,_)) p -> if sync then p ++ print_option key name (read ()) depr else p) !value_tab (mt ()) ++ str "Asynchronous options:" ++ fnl () ++ OptionMap.fold - (fun key (name, depr, (sync,read,_,_,_)) p -> + (fun key (name, depr, (sync,read,_,_)) p -> if sync then p else p ++ print_option key name (read ()) depr) !value_tab (mt ()) ++ diff --git a/library/goptions.mli b/library/goptions.mli index 26864503b1..3b3651f393 100644 --- a/library/goptions.mli +++ b/library/goptions.mli @@ -122,13 +122,19 @@ type 'a option_sig = { (** When an option is declared synchronous ([optsync] is [true]), the output is a synchronous write function. Otherwise it is [optwrite] *) +(** The [preprocess] function is triggered before setting the option. It can be + used to emit a warning on certain values, and clean-up the final value. *) type 'a write_function = 'a -> unit -val declare_int_option : int option option_sig -> int option write_function -val declare_bool_option : bool option_sig -> bool write_function -val declare_string_option: string option_sig -> string write_function -val declare_stringopt_option: string option option_sig -> string option write_function +val declare_int_option : ?preprocess:(int option -> int option) -> + int option option_sig -> int option write_function +val declare_bool_option : ?preprocess:(bool -> bool) -> + bool option_sig -> bool write_function +val declare_string_option: ?preprocess:(string -> string) -> + string option_sig -> string write_function +val declare_stringopt_option: ?preprocess:(string option -> string option) -> + string option option_sig -> string option write_function (** {6 Special functions supposed to be used only in vernacentries.ml } *) @@ -154,6 +160,7 @@ val get_ref_table : val set_int_option_value_gen : bool option -> option_name -> int option -> unit val set_bool_option_value_gen : bool option -> option_name -> bool -> unit val set_string_option_value_gen : bool option -> option_name -> string -> unit +val set_string_option_append_value_gen : bool option -> option_name -> string -> unit val unset_option_value_gen : bool option -> option_name -> unit val set_int_option_value : option_name -> int option -> unit diff --git a/library/impargs.ml b/library/impargs.ml index bce7a15cbe..828d652c83 100644 --- a/library/impargs.ml +++ b/library/impargs.ml @@ -491,13 +491,15 @@ let implicits_of_global ref = let l = Refmap.find ref !implicits_table in try let rename_l = Arguments_renaming.arguments_names ref in - let rename imp name = match imp, name with - | Some (_, x,y), Name id -> Some (id, x,y) - | _ -> imp in - List.map2 (fun (t, il) rl -> t, List.map2 rename il rl) l rename_l + let rec rename implicits names = match implicits, names with + | [], _ -> [] + | _, [] -> implicits + | Some (_, x,y) :: implicits, Name id :: names -> + Some (id, x,y) :: rename implicits names + | imp :: implicits, _ :: names -> imp :: rename implicits names + in + List.map (fun (t, il) -> t, rename il rename_l) l with Not_found -> l - | Invalid_argument _ -> - anomaly (Pp.str "renamings list and implicits list have different lenghts") with Not_found -> [DefaultImpArgs,[]] let cache_implicits_decl (ref,imps) = @@ -657,7 +659,7 @@ let check_inclusion l = let rec aux = function | n1::(n2::_ as nl) -> if n1 <= n2 then - error "Sequences of implicit arguments must be of different lengths"; + error "Sequences of implicit arguments must be of different lengths."; aux nl | _ -> () in aux (List.map (fun (imps,_) -> List.length imps) l) diff --git a/library/lib.ml b/library/lib.ml index 7218950da3..f680ecee3c 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -231,11 +231,16 @@ let add_leaves id objs = List.iter add_obj objs; oname -let add_anonymous_leaf obj = +let add_anonymous_leaf ?(cache_first = true) obj = let id = anonymous_id () in let oname = make_oname id in - cache_object (oname,obj); - add_entry oname (Leaf obj) + if cache_first then begin + cache_object (oname,obj); + add_entry oname (Leaf obj) + end else begin + add_entry oname (Leaf obj); + cache_object (oname,obj) + end let add_frozen_state () = add_anonymous_entry diff --git a/library/lib.mli b/library/lib.mli index 0a70152efb..a8e110c67a 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -54,7 +54,7 @@ val segment_of_objects : current list of operations (most recent ones coming first). *) val add_leaf : Names.Id.t -> Libobject.obj -> Libnames.object_name -val add_anonymous_leaf : Libobject.obj -> unit +val add_anonymous_leaf : ?cache_first:bool -> Libobject.obj -> unit val pull_to_head : Libnames.object_name -> unit (** this operation adds all objects with the same name and calls [load_object] diff --git a/library/universes.ml b/library/universes.ml index db95607f18..112b20a4c4 100644 --- a/library/universes.ml +++ b/library/universes.ml @@ -702,12 +702,45 @@ let pr_universe_body = function let pr_universe_opt_subst = Univ.LMap.pr pr_universe_body -exception Found of Level.t +let compare_constraint_type d d' = + match d, d' with + | Eq, Eq -> 0 + | Eq, _ -> -1 + | _, Eq -> 1 + | Le, Le -> 0 + | Le, _ -> -1 + | _, Le -> 1 + | Lt, Lt -> 0 + +type lowermap = constraint_type LMap.t + +let lower_union = + let merge k a b = + match a, b with + | Some _, None -> a + | None, Some _ -> b + | None, None -> None + | Some l, Some r -> + if compare_constraint_type l r >= 0 then a + else b + in LMap.merge merge + +let lower_add l c m = + try let c' = LMap.find l m in + if compare_constraint_type c c' > 0 then + LMap.add l c m + else m + with Not_found -> LMap.add l c m + +let lower_of_list l = + List.fold_left (fun acc (d,l) -> LMap.add l d acc) LMap.empty l + +exception Found of Level.t * lowermap let find_inst insts v = - try LMap.iter (fun k (enf,alg,v') -> - if not alg && enf && Universe.equal v' v then raise (Found k)) + try LMap.iter (fun k (enf,alg,v',lower) -> + if not alg && enf && Universe.equal v' v then raise (Found (k, lower))) insts; raise Not_found - with Found l -> l + with Found (f,l) -> (f,l) let compute_lbound left = (** The universe variable was not fixed yet. @@ -726,27 +759,33 @@ let compute_lbound left = else None)) None left -let instantiate_with_lbound u lbound alg enforce (ctx, us, algs, insts, cstrs) = +let instantiate_with_lbound u lbound lower alg enforce (ctx, us, algs, insts, cstrs) = if enforce then let inst = Universe.make u in let cstrs' = enforce_leq lbound inst cstrs in (ctx, us, LSet.remove u algs, - LMap.add u (enforce,alg,lbound) insts, cstrs'), (enforce, alg, inst) + LMap.add u (enforce,alg,lbound,lower) insts, cstrs'), + (enforce, alg, inst, lower) else (* Actually instantiate *) (Univ.LSet.remove u ctx, Univ.LMap.add u (Some lbound) us, algs, - LMap.add u (enforce,alg,lbound) insts, cstrs), (enforce, alg, lbound) + LMap.add u (enforce,alg,lbound,lower) insts, cstrs), + (enforce, alg, lbound, lower) type constraints_map = (Univ.constraint_type * Univ.LMap.key) list Univ.LMap.t let pr_constraints_map cmap = LMap.fold (fun l cstrs acc -> Level.pr l ++ str " => " ++ - prlist_with_sep spc (fun (d,r) -> pr_constraint_type d ++ Level.pr r) cstrs ++ fnl () - ++ acc) + prlist_with_sep spc (fun (d,r) -> pr_constraint_type d ++ Level.pr r) cstrs ++ + fnl () ++ acc) cmap (mt ()) let remove_alg l (ctx, us, algs, insts, cstrs) = (ctx, us, LSet.remove l algs, insts, cstrs) + +let remove_lower u lower = + let levels = Universe.levels u in + LSet.fold (fun l acc -> LMap.remove l acc) levels lower let minimize_univ_variables ctx us algs left right cstrs = let left, lbounds = @@ -756,22 +795,50 @@ let minimize_univ_variables ctx us algs left right cstrs = let lbounds' = match compute_lbound (List.map (fun (d,l) -> d, Universe.make l) lower) with | None -> lbounds - | Some lbound -> LMap.add r (true, false, lbound) lbounds + | Some lbound -> LMap.add r (true, false, lbound, lower_of_list lower) + lbounds in (Univ.LMap.remove r left, lbounds')) left (left, Univ.LMap.empty) in let rec instance (ctx', us, algs, insts, cstrs as acc) u = - let acc, left = - try let l = LMap.find u left in - List.fold_left - (fun (acc, left') (d, l) -> - let acc', (enf,alg,l') = aux acc l in - let l' = - if enf then Universe.make l - else l' - in acc', (d, l') :: left') - (acc, []) l - with Not_found -> acc, [] + let acc, left, lower = + try + let l = LMap.find u left in + let acc, left, newlow, lower = + List.fold_left + (fun (acc, left', newlow, lower') (d, l) -> + let acc', (enf,alg,l',lower) = aux acc l in + let l' = + if enf then Universe.make l + else l' + in acc', (d, l') :: left', + lower_add l d newlow, lower_union lower lower') + (acc, [], LMap.empty, LMap.empty) l + in + let not_lower (d,l) = + (* We're checking if (d,l) is already implied by the lower + constraints on some level u. If it represents l < u (d is Lt + or d is Le and i > 0, the i < 0 case is impossible due to + invariants of Univ), and the lower constraints only have l <= + u then it is not implied. *) + Univ.Universe.exists + (fun (l,i) -> + let d = + if i == 0 then d + else match d with + | Le -> Lt + | d -> d + in + try let d' = LMap.find l lower in + (* If d is stronger than the already implied lower + * constraints we must keep it. *) + compare_constraint_type d d' > 0 + with Not_found -> + (** No constraint existing on l *) true) l + in + let left = List.uniquize (List.filter not_lower left) in + (acc, left, LMap.union newlow lower) + with Not_found -> acc, [], LMap.empty and right = try Some (LMap.find u right) with Not_found -> None @@ -779,31 +846,33 @@ let minimize_univ_variables ctx us algs left right cstrs = let instantiate_lbound lbound = let alg = LSet.mem u algs in if alg then - (* u is algebraic: we instantiate it with it's lower bound, if any, + (* u is algebraic: we instantiate it with its lower bound, if any, or enforce the constraints if it is bounded from the top. *) - instantiate_with_lbound u lbound true false acc + let lower = remove_lower lbound lower in + instantiate_with_lbound u lbound lower true false acc else (* u is non algebraic *) match Universe.level lbound with | Some l -> (* The lowerbound is directly a level *) (* u is not algebraic but has no upper bounds, we instantiate it with its lower bound if it is a different level, otherwise we keep it. *) + let lower = LMap.remove l lower in if not (Level.equal l u) then (* Should check that u does not have upper constraints that are not already in right *) let acc' = remove_alg l acc in - instantiate_with_lbound u lbound false false acc' - else acc, (true, false, lbound) - | None -> - try - (* if right <> None then raise Not_found; *) - (* Another universe represents the same lower bound, - we can share them with no harm. *) - let can = find_inst insts lbound in - instantiate_with_lbound u (Universe.make can) false false acc + instantiate_with_lbound u lbound lower false false acc' + else acc, (true, false, lbound, lower) + | None -> + try + (* Another universe represents the same lower bound, + we can share them with no harm. *) + let can, lower = find_inst insts lbound in + let lower = LMap.remove can lower in + instantiate_with_lbound u (Universe.make can) lower false false acc with Not_found -> (* We set u as the canonical universe representing lbound *) - instantiate_with_lbound u lbound false true acc + instantiate_with_lbound u lbound lower false true acc in let acc' acc = match right with @@ -812,7 +881,7 @@ let minimize_univ_variables ctx us algs left right cstrs = let dangling = List.filter (fun (d, r) -> not (LMap.mem r us)) cstrs in if List.is_empty dangling then acc else - let ((ctx', us, algs, insts, cstrs), (enf,_,inst as b)) = acc in + let ((ctx', us, algs, insts, cstrs), (enf,_,inst,lower as b)) = acc in let cstrs' = List.fold_left (fun cstrs (d, r) -> if d == Univ.Le then enforce_leq inst (Universe.make r) cstrs @@ -824,15 +893,15 @@ let minimize_univ_variables ctx us algs left right cstrs = in (ctx', us, algs, insts, cstrs'), b in - if not (LSet.mem u ctx) then acc' (acc, (true, false, Universe.make u)) + if not (LSet.mem u ctx) then acc' (acc, (true, false, Universe.make u, lower)) else let lbound = compute_lbound left in match lbound with | None -> (* Nothing to do *) - acc' (acc, (true, false, Universe.make u)) + acc' (acc, (true, false, Universe.make u, lower)) | Some lbound -> try acc' (instantiate_lbound lbound) - with Failure _ -> acc' (acc, (true, false, Universe.make u)) + with Failure _ -> acc' (acc, (true, false, Universe.make u, lower)) and aux (ctx', us, algs, seen, cstrs as acc) u = try acc, LMap.find u seen with Not_found -> instance acc u diff --git a/library/universes.mli b/library/universes.mli index a5740ec49f..d3a271b8d0 100644 --- a/library/universes.mli +++ b/library/universes.mli @@ -232,40 +232,6 @@ val refresh_constraints : UGraph.t -> universe_context_set -> universe_context_s val pr_universe_opt_subst : universe_opt_subst -> Pp.std_ppcmds -(* For tracing *) - -type constraints_map = (Univ.constraint_type * Univ.LMap.key) list Univ.LMap.t - -val pr_constraints_map : constraints_map -> Pp.std_ppcmds - -val choose_canonical : universe_set -> (Level.t -> bool) (* flexibles *) -> universe_set -> universe_set -> - universe_level * (universe_set * universe_set * universe_set) - -val compute_lbound : (constraint_type * Univ.universe) list -> universe option - -val instantiate_with_lbound : - Univ.LMap.key -> - Univ.universe -> - bool -> - bool -> - Univ.LSet.t * Univ.universe option Univ.LMap.t * - Univ.LSet.t * - (bool * bool * Univ.universe) Univ.LMap.t * Univ.constraints -> - (Univ.LSet.t * Univ.universe option Univ.LMap.t * - Univ.LSet.t * - (bool * bool * Univ.universe) Univ.LMap.t * Univ.constraints) * - (bool * bool * Univ.universe) - -val minimize_univ_variables : - Univ.LSet.t -> - Univ.universe option Univ.LMap.t -> - Univ.LSet.t -> - constraints_map -> constraints_map -> - Univ.constraints -> - Univ.LSet.t * Univ.universe option Univ.LMap.t * - Univ.LSet.t * - (bool * bool * Univ.universe) Univ.LMap.t * Univ.constraints - (** {6 Support for old-style sort-polymorphism } *) val solve_constraints_system : universe option array -> universe array -> universe array -> diff --git a/ltac/coretactics.ml4 b/ltac/coretactics.ml4 index de4d589eee..6186667584 100644 --- a/ltac/coretactics.ml4 +++ b/ltac/coretactics.ml4 @@ -151,7 +151,10 @@ END TACTIC EXTEND symmetry [ "symmetry" ] -> [ Tactics.intros_symmetry {onhyps=Some[];concl_occs=AllOccurrences} ] -| [ "symmetry" clause_dft_concl(cl) ] -> [ Tactics.intros_symmetry cl ] +END + +TACTIC EXTEND symmetry_in +| [ "symmetry" "in" in_clause(cl) ] -> [ Tactics.intros_symmetry cl ] END (** Split *) diff --git a/ltac/extraargs.ml4 b/ltac/extraargs.ml4 index c6d72e03e2..0db1cd7bae 100644 --- a/ltac/extraargs.ml4 +++ b/ltac/extraargs.ml4 @@ -260,6 +260,20 @@ END let pr_by_arg_tac prtac opt_c = pr_by_arg_tac () () prtac opt_c +let pr_in_clause _ _ _ cl = Pptactic.pr_in_clause Ppconstr.pr_lident cl +let pr_in_top_clause _ _ _ cl = Pptactic.pr_in_clause Id.print cl +let in_clause' = Pcoq.Tactic.in_clause + +ARGUMENT EXTEND in_clause + TYPED AS clause_dft_concl + PRINTED BY pr_in_top_clause + RAW_TYPED AS clause_dft_concl + RAW_PRINTED BY pr_in_clause + GLOB_TYPED AS clause_dft_concl + GLOB_PRINTED BY pr_in_clause +| [ in_clause'(cl) ] -> [ cl ] +END + (* spiwack: the print functions are incomplete, but I don't know what they are used for *) let pr_r_nat_field natf = diff --git a/ltac/extraargs.mli b/ltac/extraargs.mli index 0cf77935c2..b12187e18a 100644 --- a/ltac/extraargs.mli +++ b/ltac/extraargs.mli @@ -71,3 +71,8 @@ val pr_by_arg_tac : val retroknowledge_field : Retroknowledge.field Pcoq.Gram.entry val wit_retroknowledge_field : (Retroknowledge.field, unit, unit) Genarg.genarg_type + +val wit_in_clause : + (Id.t Loc.located Locus.clause_expr, + Id.t Loc.located Locus.clause_expr, + Id.t Locus.clause_expr) Genarg.genarg_type diff --git a/ltac/extratactics.ml4 b/ltac/extratactics.ml4 index e50b0520bc..d88bcd7eb1 100644 --- a/ltac/extratactics.ml4 +++ b/ltac/extratactics.ml4 @@ -38,7 +38,7 @@ DECLARE PLUGIN "extratactics" let with_delayed_uconstr ist c tac = let flags = { Pretyping.use_typeclasses = false; - use_unif_heuristics = true; + solve_unification_constraints = true; use_hook = Some Pfedit.solve_by_implicit_tactic; fail_evar = false; expand_evars = true @@ -263,7 +263,10 @@ let add_rewrite_hint bases ort t lcsr = let ctx = let ctx = UState.context_set ctx in if poly then ctx - else (Global.push_context_set false ctx; Univ.ContextSet.empty) + else (** This is a global universe context that shouldn't be + refreshed at every use of the hint, declare it globally. *) + (Declare.declare_universe_context false ctx; + Univ.ContextSet.empty) in Constrexpr_ops.constr_loc ce, (c, ctx), ort, Option.map (in_gen (rawwit wit_ltac)) t in let eqs = List.map f lcsr in @@ -313,7 +316,8 @@ let project_hint pri l2r r = in let ctx = Evd.universe_context_set sigma in let c = Declare.declare_definition ~internal:Declare.InternalTacticRequest id (c,ctx) in - (pri,false,true,Hints.PathAny, Hints.IsGlobRef (Globnames.ConstRef c)) + let info = {Vernacexpr.hint_priority = pri; hint_pattern = None} in + (info,false,true,Hints.PathAny, Hints.IsGlobRef (Globnames.ConstRef c)) let add_hints_iff l2r lc n bl = Hints.add_hints true bl @@ -339,20 +343,21 @@ END let constr_flags = { Pretyping.use_typeclasses = true; - Pretyping.use_unif_heuristics = true; + Pretyping.solve_unification_constraints = true; Pretyping.use_hook = Some Pfedit.solve_by_implicit_tactic; Pretyping.fail_evar = false; Pretyping.expand_evars = true } -let refine_tac ist simple c = +let refine_tac ist simple with_classes c = Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in - let flags = constr_flags in + let flags = + { constr_flags with Pretyping.use_typeclasses = with_classes } in let expected_type = Pretyping.OfType concl in let c = Pretyping.type_uconstr ~flags ~expected_type ist c in let update = { run = fun sigma -> c.delayed env sigma } in - let refine = Refine.refine ~unsafe:false update in + let refine = Refine.refine ~unsafe:true update in if simple then refine else refine <*> Tactics.New.reduce_after_refine <*> @@ -360,11 +365,28 @@ let refine_tac ist simple c = end } TACTIC EXTEND refine -| [ "refine" uconstr(c) ] -> [ refine_tac ist false c ] +| [ "refine" uconstr(c) ] -> + [ refine_tac ist false true c ] END TACTIC EXTEND simple_refine -| [ "simple" "refine" uconstr(c) ] -> [ refine_tac ist true c ] +| [ "simple" "refine" uconstr(c) ] -> + [ refine_tac ist true true c ] +END + +TACTIC EXTEND notcs_refine +| [ "notypeclasses" "refine" uconstr(c) ] -> + [ refine_tac ist false false c ] +END + +TACTIC EXTEND notcs_simple_refine +| [ "simple" "notypeclasses" "refine" uconstr(c) ] -> + [ refine_tac ist true false c ] +END + +(* Solve unification constraints using heuristics or fail if any remain *) +TACTIC EXTEND solve_constraints +[ "solve_constraints" ] -> [ Refine.solve_constraints ] END (**********************************************************************) diff --git a/ltac/g_auto.ml4 b/ltac/g_auto.ml4 index 8bc2ffd654..6a8fa8d698 100644 --- a/ltac/g_auto.ml4 +++ b/ltac/g_auto.ml4 @@ -43,18 +43,24 @@ END let eval_uconstrs ist cs = let flags = { Pretyping.use_typeclasses = false; - use_unif_heuristics = true; + solve_unification_constraints = true; use_hook = Some Pfedit.solve_by_implicit_tactic; fail_evar = false; expand_evars = true } in List.map (fun c -> Pretyping.type_uconstr ~flags ist c) cs -let pr_auto_using _ _ _ = Pptactic.pr_auto_using (fun _ -> mt ()) +let pr_auto_using_raw _ _ _ = Pptactic.pr_auto_using Ppconstr.pr_constr_expr +let pr_auto_using_glob _ _ _ = Pptactic.pr_auto_using (fun (c,_) -> Printer.pr_glob_constr c) +let pr_auto_using _ _ _ = Pptactic.pr_auto_using Printer.pr_closed_glob ARGUMENT EXTEND auto_using TYPED AS uconstr_list PRINTED BY pr_auto_using + RAW_TYPED AS uconstr_list + RAW_PRINTED BY pr_auto_using_raw + GLOB_TYPED AS uconstr_list + GLOB_PRINTED BY pr_auto_using_glob | [ "using" ne_uconstr_list_sep(l, ",") ] -> [ l ] | [ ] -> [ [] ] END @@ -171,18 +177,32 @@ TACTIC EXTEND convert_concl_no_check | ["convert_concl_no_check" constr(x) ] -> [ Tactics.convert_concl_no_check x Term.DEFAULTcast ] END -let pr_hints_path_atom _ _ _ = Hints.pp_hints_path_atom +let pr_pre_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Libnames.pr_reference +let pr_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Printer.pr_global +let glob_hints_path_atom ist = Hints.glob_hints_path_atom ARGUMENT EXTEND hints_path_atom PRINTED BY pr_hints_path_atom -| [ ne_global_list(g) ] -> [ Hints.PathHints (List.map Nametab.global g) ] + + GLOBALIZED BY glob_hints_path_atom + + RAW_PRINTED BY pr_pre_hints_path_atom + GLOB_PRINTED BY pr_hints_path_atom +| [ ne_global_list(g) ] -> [ Hints.PathHints g ] | [ "_" ] -> [ Hints.PathAny ] END let pr_hints_path prc prx pry c = Hints.pp_hints_path c - +let pr_pre_hints_path prc prx pry c = Hints.pp_hints_path_gen Libnames.pr_reference c +let glob_hints_path ist = Hints.glob_hints_path + ARGUMENT EXTEND hints_path - PRINTED BY pr_hints_path +PRINTED BY pr_hints_path + +GLOBALIZED BY glob_hints_path +RAW_PRINTED BY pr_pre_hints_path +GLOB_PRINTED BY pr_hints_path + | [ "(" hints_path(p) ")" ] -> [ p ] | [ hints_path(p) "*" ] -> [ Hints.PathStar p ] | [ "emp" ] -> [ Hints.PathEmpty ] @@ -192,8 +212,6 @@ ARGUMENT EXTEND hints_path | [ hints_path(p) hints_path(q) ] -> [ Hints.PathSeq (p, q) ] END -let pr_hintbases _prc _prlc _prt = Pptactic.pr_hintbases - ARGUMENT EXTEND opthints TYPED AS preident_list_opt PRINTED BY pr_hintbases @@ -203,7 +221,7 @@ END VERNAC COMMAND EXTEND HintCut CLASSIFIED AS SIDEFF | [ "Hint" "Cut" "[" hints_path(p) "]" opthints(dbnames) ] -> [ - let entry = Hints.HintsCutEntry p in + let entry = Hints.HintsCutEntry (Hints.glob_hints_path p) in Hints.add_hints (Locality.make_section_locality (Locality.LocalityFixme.consume ())) (match dbnames with None -> ["core"] | Some l -> l) entry ] END diff --git a/ltac/g_class.ml4 b/ltac/g_class.ml4 index 18df596eb8..7e26b5d189 100644 --- a/ltac/g_class.ml4 +++ b/ltac/g_class.ml4 @@ -44,19 +44,33 @@ ARGUMENT EXTEND debug TYPED AS bool PRINTED BY pr_debug | [ ] -> [ false ] END +let pr_search_strategy _prc _prlc _prt = function + | Some Dfs -> Pp.str "dfs" + | Some Bfs -> Pp.str "bfs" + | None -> Pp.mt () + +ARGUMENT EXTEND eauto_search_strategy PRINTED BY pr_search_strategy +| [ "(bfs)" ] -> [ Some Bfs ] +| [ "(dfs)" ] -> [ Some Dfs ] +| [ ] -> [ None ] +END + (* true = All transparent, false = Opaque if possible *) VERNAC COMMAND EXTEND Typeclasses_Settings CLASSIFIED AS SIDEFF - | [ "Typeclasses" "eauto" ":=" debug(d) int_opt(depth) ] -> [ + | [ "Typeclasses" "eauto" ":=" debug(d) eauto_search_strategy(s) int_opt(depth) ] -> [ set_typeclasses_debug d; + Option.iter set_typeclasses_strategy s; set_typeclasses_depth depth ] END (** Compatibility: typeclasses eauto has 8.5 and 8.6 modes *) TACTIC EXTEND typeclasses_eauto + | [ "typeclasses" "eauto" "bfs" int_or_var_opt(d) "with" ne_preident_list(l) ] -> + [ typeclasses_eauto ~strategy:Bfs ~depth:d l ] | [ "typeclasses" "eauto" int_or_var_opt(d) "with" ne_preident_list(l) ] -> - [ typeclasses_eauto d l ] + [ typeclasses_eauto ~depth:d l ] | [ "typeclasses" "eauto" int_or_var_opt(d) ] -> [ typeclasses_eauto ~only_classes:true ~depth:d [Hints.typeclasses_db] ] END diff --git a/ltac/g_rewrite.ml4 b/ltac/g_rewrite.ml4 index 82b79c883d..28078efd64 100644 --- a/ltac/g_rewrite.ml4 +++ b/ltac/g_rewrite.ml4 @@ -63,8 +63,17 @@ let glob_strategy ist s = map_strategy (Tacintern.intern_constr ist) (fun c -> c let subst_strategy s str = str let pr_strategy _ _ _ (s : strategy) = Pp.str "<strategy>" -let pr_raw_strategy _ _ _ (s : raw_strategy) = Pp.str "<strategy>" -let pr_glob_strategy _ _ _ (s : glob_strategy) = Pp.str "<strategy>" +let pr_raw_strategy prc prlc _ (s : raw_strategy) = + let prr = Pptactic.pr_red_expr (prc, prlc, Pptactic.pr_or_by_notation Libnames.pr_reference, prc) in + Rewrite.pr_strategy prc prr s +let pr_glob_strategy prc prlc _ (s : glob_strategy) = + let prr = Pptactic.pr_red_expr + (Ppconstr.pr_constr_expr, + Ppconstr.pr_lconstr_expr, + Pptactic.pr_or_by_notation Libnames.pr_reference, + Ppconstr.pr_constr_expr) + in + Rewrite.pr_strategy prc prr s ARGUMENT EXTEND rewstrategy PRINTED BY pr_strategy diff --git a/ltac/profile_ltac.ml b/ltac/profile_ltac.ml index a91ff98fb9..2514ededb0 100644 --- a/ltac/profile_ltac.ml +++ b/ltac/profile_ltac.ml @@ -128,7 +128,7 @@ let to_ltacprof_results xml = | _ -> CErrors.anomaly Pp.(str "Malformed ltacprof XML") let feedback_results results = - Feedback.(feedback + Feedback.(feedback (Custom (Loc.dummy_loc, "ltacprof_results", of_ltacprof_results results))) (* ************** pretty printing ************************************* *) @@ -218,7 +218,7 @@ let to_string ~filter ?(cutoff=0.0) node = !global in warn_encountered_multi_success_backtracking (); - let filter s n = filter s && n >= cutoff in + let filter s n = filter s && (all_total <= 0.0 || n /. all_total >= cutoff /. 100.0) in let msg = h 0 (str "total time: " ++ padl 11 (format_sec (all_total))) ++ fnl () ++ diff --git a/ltac/rewrite.ml b/ltac/rewrite.ml index 69f45e1aeb..44efdd383f 100644 --- a/ltac/rewrite.ml +++ b/ltac/rewrite.ml @@ -1700,6 +1700,40 @@ let rec map_strategy (f : 'a -> 'a2) (g : 'b -> 'b2) : ('a,'b) strategy_ast -> ( | StratEval r -> StratEval (g r) | StratFold c -> StratFold (f c) +let pr_ustrategy = function +| Subterms -> str "subterms" +| Subterm -> str "subterm" +| Innermost -> str "innermost" +| Outermost -> str "outermost" +| Bottomup -> str "bottomup" +| Topdown -> str "topdown" +| Progress -> str "progress" +| Try -> str "try" +| Any -> str "any" +| Repeat -> str "repeat" + +let paren p = str "(" ++ p ++ str ")" + +let rec pr_strategy prc prr = function +| StratId -> str "id" +| StratFail -> str "fail" +| StratRefl -> str "refl" +| StratUnary (s, str) -> + pr_ustrategy s ++ spc () ++ paren (pr_strategy prc prr str) +| StratBinary (Choice, str1, str2) -> + str "choice" ++ spc () ++ paren (pr_strategy prc prr str1) ++ spc () ++ + paren (pr_strategy prc prr str2) +| StratBinary (Compose, str1, str2) -> + pr_strategy prc prr str1 ++ str ";" ++ spc () ++ pr_strategy prc prr str2 +| StratConstr (c, true) -> prc c +| StratConstr (c, false) -> str "<-" ++ spc () ++ prc c +| StratTerms cl -> str "terms" ++ spc () ++ pr_sequence prc cl +| StratHints (old, id) -> + let cmd = if old then "old_hints" else "hints" in + str cmd ++ spc () ++ str id +| StratEval r -> str "eval" ++ spc () ++ prr r +| StratFold c -> str "fold" ++ spc () ++ prc c + let rec strategy_of_ast = function | StratId -> Strategies.id | StratFail -> Strategies.fail @@ -1754,7 +1788,7 @@ let declare_instance a aeq n s = declare_an_instance n s [a;aeq] let anew_instance global binders instance fields = new_instance (Flags.is_universe_polymorphism ()) binders instance (Some (true, CRecord (Loc.ghost,fields))) - ~global ~generalize:false ~refine:false None + ~global ~generalize:false ~refine:false Hints.empty_hint_info let declare_instance_refl global binders a aeq n lemma = let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive" @@ -1935,7 +1969,7 @@ let add_morphism_infer glob m n = Decl_kinds.IsAssumption Decl_kinds.Logical) in add_instance (Typeclasses.new_instance - (Lazy.force PropGlobal.proper_class) None glob + (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info glob poly (ConstRef cst)); declare_projection n instance_id (ConstRef cst) else @@ -1946,7 +1980,7 @@ let add_morphism_infer glob m n = let hook _ = function | Globnames.ConstRef cst -> add_instance (Typeclasses.new_instance - (Lazy.force PropGlobal.proper_class) None + (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info glob poly (ConstRef cst)); declare_projection n instance_id (ConstRef cst) | _ -> assert false @@ -1970,7 +2004,7 @@ let add_morphism glob binders m s n = let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in ignore(new_instance ~global:glob poly binders instance (Some (true, CRecord (Loc.ghost,[]))) - ~generalize:false ~tac ~hook:(declare_projection n instance_id) None) + ~generalize:false ~tac ~hook:(declare_projection n instance_id) Hints.empty_hint_info) (** Bind to "rewrite" too *) diff --git a/ltac/rewrite.mli b/ltac/rewrite.mli index f448c85430..35c4483513 100644 --- a/ltac/rewrite.mli +++ b/ltac/rewrite.mli @@ -62,6 +62,9 @@ val strategy_of_ast : (glob_constr_and_expr, raw_red_expr) strategy_ast -> strat val map_strategy : ('a -> 'b) -> ('c -> 'd) -> ('a, 'c) strategy_ast -> ('b, 'd) strategy_ast +val pr_strategy : ('a -> Pp.std_ppcmds) -> ('b -> Pp.std_ppcmds) -> + ('a, 'b) strategy_ast -> Pp.std_ppcmds + (** Entry point for user-level "rewrite_strat" *) val cl_rewrite_clause_strat : strategy -> Id.t option -> unit Proofview.tactic diff --git a/ltac/tacinterp.ml b/ltac/tacinterp.ml index 08e67a0c2f..aa45f1ccf5 100644 --- a/ltac/tacinterp.ml +++ b/ltac/tacinterp.ml @@ -646,7 +646,7 @@ let interp_gen kind ist allow_patvar flags env sigma (c,ce) = let constr_flags = { use_typeclasses = true; - use_unif_heuristics = true; + solve_unification_constraints = true; use_hook = Some solve_by_implicit_tactic; fail_evar = true; expand_evars = true } @@ -661,21 +661,21 @@ let interp_type = interp_constr_gen IsType let open_constr_use_classes_flags = { use_typeclasses = true; - use_unif_heuristics = true; + solve_unification_constraints = true; use_hook = Some solve_by_implicit_tactic; fail_evar = false; expand_evars = true } let open_constr_no_classes_flags = { use_typeclasses = false; - use_unif_heuristics = true; + solve_unification_constraints = true; use_hook = Some solve_by_implicit_tactic; fail_evar = false; expand_evars = true } let pure_open_constr_flags = { use_typeclasses = false; - use_unif_heuristics = true; + solve_unification_constraints = true; use_hook = None; fail_evar = false; expand_evars = false } @@ -875,6 +875,9 @@ let rec message_of_value v = Ftactic.return (pr_closed_glob_env (pf_env gl) (project gl) c) end } + else if has_type v (topwit wit_var) then + let id = out_gen (topwit wit_var) v in + Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (pr_id id) end } else match Value.to_list v with | Some l -> Ftactic.List.map message_of_value l >>= fun l -> @@ -954,7 +957,7 @@ let interp_or_and_intro_pattern_option ist env sigma = function (match coerce_to_intro_pattern env (Id.Map.find id ist.lfun) with | IntroAction (IntroOrAndPattern l) -> sigma, Some (loc,l) | _ -> - raise (CannotCoerceTo "a disjunctive/conjunctive introduction pattern")) + user_err_loc (loc,"", str "Cannot coerce to a disjunctive/conjunctive pattern.")) | Some (ArgArg (loc,l)) -> let sigma,l = interp_or_and_intro_pattern ist env sigma l in sigma, Some (loc,l) diff --git a/ltac/tactic_debug.ml b/ltac/tactic_debug.ml index e1c9fed637..5cbddc7f64 100644 --- a/ltac/tactic_debug.ml +++ b/ltac/tactic_debug.ml @@ -385,6 +385,8 @@ let skip_extensions trace = | [] -> [] in List.rev (aux (List.rev trace)) +let finer_loc loc1 loc2 = Loc.merge loc1 loc2 = loc2 + let extract_ltac_trace trace eloc = let trace = skip_extensions trace in let (loc,c),tail = List.sep_last trace in @@ -392,11 +394,10 @@ let extract_ltac_trace trace eloc = (* We entered a user-defined tactic, we display the trace with location of the call *) let msg = hov 0 (explain_ltac_call_trace c tail eloc ++ fnl()) in - Some msg, loc + Some msg, if finer_loc eloc loc then eloc else loc else (* We entered a primitive tactic, we don't display trace but report on the finest location *) - let finer_loc loc1 loc2 = Loc.merge loc1 loc2 = loc2 in let best_loc = (* trace is with innermost call coming first *) let rec aux best_loc = function diff --git a/parsing/cLexer.ml4 b/parsing/cLexer.ml4 index bec891f7f1..aec6a32644 100644 --- a/parsing/cLexer.ml4 +++ b/parsing/cLexer.ml4 @@ -69,6 +69,15 @@ let ttree_remove ttree str = in remove ttree 0 +let ttree_elements ttree = + let rec elts tt accu = + let accu = match tt.node with + | None -> accu + | Some s -> CString.Set.add s accu + in + CharMap.fold (fun _ tt accu -> elts tt accu) tt.branch accu + in + elts ttree CString.Set.empty (* Errors occurring while lexing (explained as "Lexer error: ...") *) @@ -96,19 +105,11 @@ module Error = struct Printf.sprintf "Unsupported Unicode character (0x%x)" x) (* Require to fix the Camlp4 signature *) - let print ppf x = Pp.pp_with ppf (Pp.str (to_string x)) + let print ppf x = Pp.pp_with ~pp_tag:Ppstyle.pp_tag ppf (Pp.str (to_string x)) end open Error -let current_file = ref "" - -let get_current_file () = - !current_file - -let set_current_file ~fname = - current_file := fname - let err loc str = Loc.raise (Compat.to_coqloc loc) (Error.E str) let bad_token str = raise (Error.E (Bad_token str)) @@ -120,11 +121,6 @@ type token_kind = | AsciiChar | EmptyStream -let error_unsupported_unicode_character loc n unicode cs = - let bp = Stream.count cs in - let loc = set_loc_pos loc bp (bp+n) in - err loc (UnsupportedUnicode unicode) - let error_utf8 loc cs = let bp = Stream.count cs in Stream.junk cs; (* consume the char to avoid read it and fail again *) @@ -174,14 +170,12 @@ let lookup_utf8_tail loc c cs = (Char.code c3 land 0x3F) lsl 6 + (Char.code c4 land 0x3F) | _ -> error_utf8 loc cs in - try Unicode.classify unicode, n - with Unicode.Unsupported -> - njunk n cs; error_unsupported_unicode_character loc n unicode cs + Utf8Token (Unicode.classify unicode, n) let lookup_utf8 loc cs = match Stream.peek cs with | Some ('\x00'..'\x7F') -> AsciiChar - | Some ('\x80'..'\xFF' as c) -> Utf8Token (lookup_utf8_tail loc c cs) + | Some ('\x80'..'\xFF' as c) -> lookup_utf8_tail loc c cs | None -> EmptyStream let unlocated f x = f x @@ -199,17 +193,6 @@ let check_keyword str = in loop_symb (Stream.of_string str) -let warn_unparsable_keyword = - CWarnings.create ~name:"unparsable-keyword" ~category:"parsing" - (fun (s,unicode) -> - strbrk (Printf.sprintf "Token '%s' contains unicode character 0x%x \ - which will not be parsable." s unicode)) - -let check_keyword_to_add s = - try check_keyword s - with Error.E (UnsupportedUnicode unicode) -> - warn_unparsable_keyword (s,unicode) - let check_ident str = let rec loop_id intail = parser | [< ' ('a'..'z' | 'A'..'Z' | '_'); s >] -> @@ -240,13 +223,15 @@ let is_keyword s = let add_keyword str = if not (is_keyword str) then begin - check_keyword_to_add str; + check_keyword str; token_tree := ttree_add !token_tree str end let remove_keyword str = token_tree := ttree_remove !token_tree str +let keywords () = ttree_elements !token_tree + (* Freeze and unfreeze the state of the lexer *) type frozen_t = ttree @@ -270,6 +255,12 @@ let get_buff len = String.sub !buff 0 len (* The classical lexer: idents, numbers, quoted strings, comments *) +let warn_unrecognized_unicode = + CWarnings.create ~name:"unrecognized-unicode" ~category:"parsing" + (fun (u,id) -> + strbrk (Printf.sprintf "Not considering unicode character \"%s\" of unknown \ + lexical status as part of identifier \"%s\"." u id)) + let rec ident_tail loc len = parser | [< ' ('a'..'z' | 'A'..'Z' | '0'..'9' | ''' | '_' as c); s >] -> ident_tail loc (store len c) s @@ -277,6 +268,10 @@ let rec ident_tail loc len = parser match lookup_utf8 loc s with | Utf8Token ((Unicode.IdentPart | Unicode.Letter), n) -> ident_tail loc (nstore n len s) s + | Utf8Token (Unicode.Unknown, n) -> + let id = get_buff len in + let u = String.concat "" (List.map (String.make 1) (Stream.npeek n s)) in + warn_unrecognized_unicode ~loc:!@loc (u,id); len | _ -> len let rec number len = parser @@ -334,40 +329,59 @@ let rec string loc ~comm_level bp len = parser (* Hook for exporting comment into xml theory files *) let (f_xml_output_comment, xml_output_comment) = Hook.make ~default:ignore () +(* To associate locations to a file name *) +let current_file = ref None + (* Utilities for comments in beautify *) let comment_begin = ref None let comm_loc bp = match !comment_begin with | None -> comment_begin := Some bp | _ -> () -let current = Buffer.create 8192 -let between_com = ref true +let comments = ref [] +let current_comment = Buffer.create 8192 +let between_commands = ref true -type com_state = int option * string * bool -let restore_com_state (o,s,b) = +let rec split_comments comacc acc pos = function + [] -> comments := List.rev acc; comacc + | ((b,e),c as com)::coms -> + (* Take all comments that terminates before pos, or begin exactly + at pos (used to print comments attached after an expression) *) + if e<=pos || pos=b then split_comments (c::comacc) acc pos coms + else split_comments comacc (com::acc) pos coms + +let extract_comments pos = split_comments [] [] pos !comments + +(* The state of the lexer visible from outside *) +type lexer_state = int option * string * bool * ((int * int) * string) list * string option + +let init_lexer_state f = (None,"",true,[],f) +let set_lexer_state (o,s,b,c,f) = comment_begin := o; - Buffer.clear current; Buffer.add_string current s; - between_com := b -let dflt_com = (None,"",true) -let com_state () = - let s = (!comment_begin, Buffer.contents current, !between_com) in - restore_com_state dflt_com; s + Buffer.clear current_comment; Buffer.add_string current_comment s; + between_commands := b; + comments := c; + current_file := f +let release_lexer_state () = + (!comment_begin, Buffer.contents current_comment, !between_commands, !comments, !current_file) +let drop_lexer_state () = + set_lexer_state (init_lexer_state None) -let real_push_char c = Buffer.add_char current c +let real_push_char c = Buffer.add_char current_comment c (* Add a char if it is between two commands, if it is a newline or if the last char is not a space itself. *) let push_char c = if - !between_com || List.mem c ['\n';'\r'] || + !between_commands || List.mem c ['\n';'\r'] || (List.mem c [' ';'\t']&& - (Int.equal (Buffer.length current) 0 || - not (let s = Buffer.contents current in + (Int.equal (Buffer.length current_comment) 0 || + not (let s = Buffer.contents current_comment in List.mem s.[String.length s - 1] [' ';'\t';'\n';'\r']))) then real_push_char c -let push_string s = Buffer.add_string current s +let push_string s = Buffer.add_string current_comment s let null_comment s = let rec null i = @@ -375,12 +389,12 @@ let null_comment s = null (String.length s - 1) let comment_stop ep = - let current_s = Buffer.contents current in - if !Flags.xml_export && Buffer.length current > 0 && - (!between_com || not(null_comment current_s)) then + let current_s = Buffer.contents current_comment in + if !Flags.xml_export && Buffer.length current_comment > 0 && + (!between_commands || not(null_comment current_s)) then Hook.get f_xml_output_comment current_s; - (if Flags.do_beautify() && Buffer.length current > 0 && - (!between_com || not(null_comment current_s)) then + (if !Flags.beautify && Buffer.length current_comment > 0 && + (!between_commands || not(null_comment current_s)) then let bp = match !comment_begin with Some bp -> bp | None -> @@ -389,28 +403,10 @@ let comment_stop ep = ++ str current_s ++str"' ending at " ++ int ep); ep-1 in - Pp.comments := ((bp,ep),current_s) :: !Pp.comments); - Buffer.clear current; + comments := ((bp,ep),current_s) :: !comments); + Buffer.clear current_comment; comment_begin := None; - between_com := false - -(* Does not unescape!!! *) -let rec comm_string loc bp = parser - | [< ''"' >] ep -> push_string "\""; loc - | [< ''\\'; loc = - (parser [< ' ('"' | '\\' as c) >] -> - let () = match c with - | '"' -> real_push_char c - | _ -> () - in - real_push_char c; loc - | [< >] -> real_push_char '\\'; loc); s >] - -> comm_string loc bp s - | [< _ = Stream.empty >] ep -> - let loc = set_loc_pos loc bp ep in - err loc Unterminated_string - | [< ''\n' as c; s >] ep -> real_push_char c; comm_string (bump_loc_line loc ep) bp s - | [< 'c; s >] -> real_push_char c; comm_string loc bp s + between_commands := false let rec comment loc bp = parser bp2 | [< ''('; @@ -423,12 +419,8 @@ let rec comment loc bp = parser bp2 | [< '')' >] -> push_string "*)"; loc | [< s >] -> real_push_char '*'; comment loc bp s >] -> loc | [< ''"'; s >] -> - let loc = - (* In beautify mode, the lexing differs between strings in comments and - regular strings (e.g. escaping). It seems wrong. *) - if Flags.do_beautify() then (push_string"\""; comm_string loc bp2 s) - else fst (string loc ~comm_level:(Some 0) bp2 0 s) - in + let loc, len = string loc ~comm_level:(Some 0) bp2 0 s in + push_string "\""; push_string (get_buff len); push_string "\""; comment loc bp s | [< _ = Stream.empty >] ep -> let loc = set_loc_pos loc bp ep in @@ -499,20 +491,19 @@ let process_chars loc bp c cs = let loc = set_loc_pos loc bp ep' in err loc Undefined_token -let token_of_special c s = match c with - | '.' -> FIELD s - | _ -> assert false - -(* Parse what follows a dot / a dollar *) +(* Parse what follows a dot *) -let parse_after_special loc c bp = +let parse_after_dot loc c bp = parser - | [< ' ('a'..'z' | 'A'..'Z' | '_' as d); len = ident_tail loc (store 0 d) >] -> - token_of_special c (get_buff len) + | [< ' ('a'..'z' | 'A'..'Z' | '_' as d); len = ident_tail loc (store 0 d); s >] -> + let field = get_buff len in + (try find_keyword loc ("."^field) s with Not_found -> FIELD field) | [< s >] -> match lookup_utf8 loc s with | Utf8Token (Unicode.Letter, n) -> - token_of_special c (get_buff (ident_tail loc (nstore n 0 s) s)) + let len = ident_tail loc (nstore n 0 s) s in + let field = get_buff len in + (try find_keyword loc ("."^field) s with Not_found -> FIELD field) | AsciiChar | Utf8Token _ | EmptyStream -> fst (process_chars loc bp c s) (* Parse what follows a question mark *) @@ -540,7 +531,7 @@ let rec next_token loc = parser bp comm_loc bp; push_char c; next_token (bump_loc_line loc ep) s | [< '' ' | '\t' | '\r' as c; s >] -> comm_loc bp; push_char c; next_token loc s - | [< ''.' as c; t = parse_after_special loc c bp; s >] ep -> + | [< ''.' as c; t = parse_after_dot loc c bp; s >] ep -> comment_stop bp; (* We enforce that "." should either be part of a larger keyword, for instance ".(", or followed by a blank or eof. *) @@ -548,19 +539,19 @@ let rec next_token loc = parser bp | KEYWORD ("." | "...") -> if not (blank_or_eof s) then err (set_loc_pos loc bp (ep+1)) Undefined_token; - between_com := true; + between_commands := true; | _ -> () in (t, set_loc_pos loc bp ep) | [< ' ('-'|'+'|'*' as c); s >] -> - let t,new_between_com = - if !between_com then process_sequence loc bp c s, true + let t,new_between_commands = + if !between_commands then process_sequence loc bp c s, true else process_chars loc bp c s,false in - comment_stop bp; between_com := new_between_com; t + comment_stop bp; between_commands := new_between_commands; t | [< ''?'; s >] ep -> let t = parse_after_qmark loc bp s in - comment_stop bp; (t, set_loc_pos loc ep bp) + comment_stop bp; (t, set_loc_pos loc bp ep) | [< ' ('a'..'z' | 'A'..'Z' | '_' as c); len = ident_tail loc (store 0 c); s >] ep -> let id = get_buff len in @@ -580,6 +571,12 @@ let rec next_token loc = parser bp let loc = comment loc bp s in next_token loc s | [< t = process_chars loc bp c >] -> comment_stop bp; t >] -> t + | [< ' ('{' | '}' as c); s >] ep -> + let t,new_between_commands = + if !between_commands then (KEYWORD (String.make 1 c), set_loc_pos loc bp ep), true + else process_chars loc bp c s, false + in + comment_stop bp; between_commands := new_between_commands; t | [< s >] -> match lookup_utf8 loc s with | Utf8Token (Unicode.Letter, n) -> @@ -588,11 +585,9 @@ let rec next_token loc = parser bp let ep = Stream.count s in comment_stop bp; (try find_keyword loc id s with Not_found -> IDENT id), set_loc_pos loc bp ep - | AsciiChar | Utf8Token ((Unicode.Symbol | Unicode.IdentPart), _) -> + | AsciiChar | Utf8Token ((Unicode.Symbol | Unicode.IdentPart | Unicode.Unknown), _) -> let t = process_chars loc bp (Stream.next s) s in - let new_between_com = match t with - (KEYWORD ("{"|"}"),_) -> !between_com | _ -> false in - comment_stop bp; between_com := new_between_com; t + comment_stop bp; t | EmptyStream -> comment_stop bp; (EOI, set_loc_pos loc bp (bp+1)) @@ -614,12 +609,6 @@ let loct_func loct i = let loct_add loct i loc = Hashtbl.add loct i loc -let current_location_table = ref (loct_create ()) - -type location_table = (int, Compat.CompatLoc.t) Hashtbl.t -let location_table () = !current_location_table -let restore_location_table t = current_location_table := t - (** {6 The lexer of Coq} *) (** Note: removing a token. @@ -657,7 +646,6 @@ let func cs = cur_loc := Compat.after loc; loct_add loct i loc; Some tok) in - current_location_table := loct; (ts, loct_func loct) let lexer = { @@ -694,7 +682,6 @@ end let mk () = let loct = loct_create () in let cur_loc = ref (Compat.make_loc !current_file 1 0 0 0) in - current_location_table := loct; let rec self init_loc (* FIXME *) = parser i [< (tok, loc) = next_token !cur_loc; s >] -> diff --git a/parsing/cLexer.mli b/parsing/cLexer.mli index 3b4891d9ac..e0fdf8cb55 100644 --- a/parsing/cLexer.mli +++ b/parsing/cLexer.mli @@ -9,22 +9,7 @@ val add_keyword : string -> unit val remove_keyword : string -> unit val is_keyword : string -> bool - -(* val location_function : int -> Loc.t *) - -(** for coqdoc *) -type location_table -val location_table : unit -> location_table -val restore_location_table : location_table -> unit - - -(** [get_current_file fname] returns the filename used in locations emitted by - the lexer *) -val get_current_file : unit -> string - -(** [set_current_file fname] sets the filename used in locations emitted by the - lexer *) -val set_current_file : fname:string -> unit +val keywords : unit -> CString.Set.t val check_ident : string -> unit val is_ident : string -> bool @@ -34,12 +19,12 @@ type frozen_t val freeze : unit -> frozen_t val unfreeze : frozen_t -> unit -type com_state -val com_state: unit -> com_state -val restore_com_state: com_state -> unit - val xml_output_comment : (string -> unit) Hook.t +(* Retrieve the comments lexed at a given location of the stream + currently being processeed *) +val extract_comments : int -> string list + val terminal : string -> Tok.t (** The lexer of Coq: *) diff --git a/parsing/compat.ml4 b/parsing/compat.ml4 index 18bc8d664f..befa0d01ba 100644 --- a/parsing/compat.ml4 +++ b/parsing/compat.ml4 @@ -10,6 +10,10 @@ (** Locations *) +let file_loc_of_file = function +| None -> "" +| Some f -> f + IFDEF CAMLP5 THEN module CompatLoc = struct @@ -29,7 +33,7 @@ let to_coqloc loc = Loc.line_nb_last = Ploc.line_nb_last loc; Loc.bol_pos_last = Ploc.bol_pos_last loc; } -let make_loc fname line_nb bol_pos bp ep = Ploc.make_loc fname line_nb bol_pos (bp, ep) "" +let make_loc fname line_nb bol_pos bp ep = Ploc.make_loc (file_loc_of_file fname) line_nb bol_pos (bp, ep) "" (* Update a loc without allocating an intermediate pair *) let set_loc_pos loc bp ep = @@ -80,7 +84,7 @@ let to_coqloc loc = Loc.bol_pos_last = CompatLoc.stop_bol loc; } let make_loc fname line_nb bol_pos start stop = - CompatLoc.of_tuple (fname, line_nb, bol_pos, start, line_nb, bol_pos, stop, false) + CompatLoc.of_tuple (file_loc_of_file fname, line_nb, bol_pos, start, line_nb, bol_pos, stop, false) open CompatLoc @@ -97,7 +101,7 @@ let bump_loc_line_last loc bol_pos = stop_line loc + 1, bol_pos, stop_off loc, is_ghost loc) let set_loc_file loc fname = - of_tuple (fname, start_line loc, start_bol loc, start_off loc, + of_tuple (file_loc_of_file fname, start_line loc, start_bol loc, start_off loc, stop_line loc, stop_bol loc, stop_off loc, is_ghost loc) let after loc = @@ -138,12 +142,23 @@ module type LexerSig = sig exception E of t val to_string : t -> string end + type lexer_state + val init_lexer_state : string option -> lexer_state + val set_lexer_state : lexer_state -> unit + val release_lexer_state : unit -> lexer_state + val drop_lexer_state : unit -> unit end ELSE -module type LexerSig = - Camlp4.Sig.Lexer with module Loc = CompatLoc and type Token.t = Tok.t +module type LexerSig = sig + include Camlp4.Sig.Lexer with module Loc = CompatLoc and type Token.t = Tok.t + type lexer_state + val init_lexer_state : string option -> lexer_state + val set_lexer_state : lexer_state -> unit + val release_lexer_state : unit -> lexer_state + val drop_lexer_state : unit -> unit +end END @@ -162,10 +177,13 @@ module type GrammarSig = sig string option * Gramext.g_assoc option * production_rule list type extend_statment = Gramext.position option * single_extend_statment list + type coq_parsable + val parsable : ?file:string -> char Stream.t -> coq_parsable val action : 'a -> action val entry_create : string -> 'a entry - val entry_parse : 'a entry -> parsable -> 'a + val entry_parse : 'a entry -> coq_parsable -> 'a val entry_print : Format.formatter -> 'a entry -> unit + val with_parsable : coq_parsable -> ('a -> 'b) -> 'a -> 'b val srules' : production_rule list -> symbol val parse_tokens_after_filter : 'a entry -> Tok.t Stream.t -> 'a end @@ -181,14 +199,35 @@ module GrammarMake (L:LexerSig) : GrammarSig = struct string option * Gramext.g_assoc option * production_rule list type extend_statment = Gramext.position option * single_extend_statment list + type coq_parsable = parsable * L.lexer_state ref + let parsable ?file c = + let state = ref (L.init_lexer_state file) in + L.set_lexer_state !state; + let a = parsable c in + state := L.release_lexer_state (); + (a,state) let action = Gramext.action let entry_create = Entry.create - let entry_parse e p = - try Entry.parse e p + let entry_parse e (p,state) = + L.set_lexer_state !state; + try + let c = Entry.parse e p in + state := L.release_lexer_state (); + c with Exc_located (loc,e) -> + L.drop_lexer_state (); let loc' = Loc.get_loc (Exninfo.info e) in let loc = match loc' with None -> to_coqloc loc | Some loc -> loc in Loc.raise loc e + let with_parsable (p,state) f x = + L.set_lexer_state !state; + try + let a = f x in + state := L.release_lexer_state (); + a + with e -> + L.drop_lexer_state (); + raise e let entry_print ft x = Entry.print ft x let srules' = Gramext.srules @@ -202,12 +241,13 @@ module type GrammarSig = sig with module Loc = CompatLoc and type Token.t = Tok.t type 'a entry = 'a Entry.t type action = Action.t - type parsable - val parsable : char Stream.t -> parsable + type coq_parsable + val parsable : ?file:string -> char Stream.t -> coq_parsable val action : 'a -> action val entry_create : string -> 'a entry - val entry_parse : 'a entry -> parsable -> 'a + val entry_parse : 'a entry -> coq_parsable -> 'a val entry_print : Format.formatter -> 'a entry -> unit + val with_parsable : coq_parsable -> ('a -> 'b) -> 'a -> 'b val srules' : production_rule list -> symbol end @@ -217,13 +257,28 @@ module GrammarMake (L:LexerSig) : GrammarSig = struct include Camlp4.Struct.Grammar.Static.Make (L) type 'a entry = 'a Entry.t type action = Action.t - type parsable = char Stream.t - let parsable s = s + type coq_parsable = char Stream.t * L.lexer_state ref + let parsable ?file s = let state = ref (L.init_lexer_state file) in (s, state) let action = Action.mk let entry_create = Entry.mk - let entry_parse e s = - try parse e (*FIXME*)CompatLoc.ghost s - with Exc_located (loc,e) -> raise_coq_loc loc e + let entry_parse e (s,state) = + L.set_lexer_state !state; + try + let c = parse e (*FIXME*)CompatLoc.ghost s in + state := L.release_lexer_state (); + c + with Exc_located (loc,e) -> + L.drop_lexer_state (); + raise_coq_loc loc e;; + let with_parsable (p,state) f x = + L.set_lexer_state !state; + try + let a = f x in + state := L.release_lexer_state (); + a + with e -> + L.drop_lexer_state (); + Pervasives.raise e;; let entry_print ft x = Entry.print ft x let srules' = srules (entry_create "dummy") end diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 74994c5e3d..7f3a3d10ca 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -127,7 +127,7 @@ let name_colon = let aliasvar = function CPatAlias (loc, _, id) -> Some (loc,Name id) | _ -> None GEXTEND Gram - GLOBAL: binder_constr lconstr constr operconstr sort global + GLOBAL: binder_constr lconstr constr operconstr universe_level sort global constr_pattern lconstr_pattern Constr.ident closed_binder open_binders binder binders binders_fixannot record_declaration typeclass_constraint pattern appl_arg; @@ -298,10 +298,10 @@ GEXTEND Gram | -> [] ] ] ; instance: - [ [ "@{"; l = LIST1 level; "}" -> Some l + [ [ "@{"; l = LIST1 universe_level; "}" -> Some l | -> None ] ] ; - level: + universe_level: [ [ "Set" -> GSet | "Prop" -> GProp | "Type" -> GType None diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4 index 1e3c4b880b..70c5d5d88b 100644 --- a/parsing/g_proofs.ml4 +++ b/parsing/g_proofs.ml4 @@ -103,10 +103,9 @@ GEXTEND Gram (* Declare "Resolve" explicitly so as to be able to later extend with "Resolve ->" and "Resolve <-" *) | IDENT "Hint"; IDENT "Resolve"; lc = LIST1 reference_or_constr; - pri = OPT [ "|"; i = natural -> i ]; - dbnames = opt_hintbases -> + info = hint_info; dbnames = opt_hintbases -> VernacHints (false,dbnames, - HintsResolve (List.map (fun x -> (pri, true, x)) lc)) + HintsResolve (List.map (fun x -> (info, true, x)) lc)) ] ]; obsolete_locality: [ [ IDENT "Local" -> true | -> false ] ] @@ -116,9 +115,8 @@ GEXTEND Gram | c = constr -> HintsConstr c ] ] ; hint: - [ [ IDENT "Resolve"; lc = LIST1 reference_or_constr; - pri = OPT [ "|"; i = natural -> i ] -> - HintsResolve (List.map (fun x -> (pri, true, x)) lc) + [ [ IDENT "Resolve"; lc = LIST1 reference_or_constr; info = hint_info -> + HintsResolve (List.map (fun x -> (info, true, x)) lc) | IDENT "Immediate"; lc = LIST1 reference_or_constr -> HintsImmediate lc | IDENT "Transparent"; lc = LIST1 global -> HintsTransparency (lc, true) | IDENT "Opaque"; lc = LIST1 global -> HintsTransparency (lc, false) diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 199ef9fcee..3152afb28d 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -220,7 +220,7 @@ let warn_deprecated_eqn_syntax = GEXTEND Gram GLOBAL: simple_tactic constr_with_bindings quantified_hypothesis bindings red_expr int_or_var open_constr uconstr - simple_intropattern clause_dft_concl hypident destruction_arg; + simple_intropattern in_clause clause_dft_concl hypident destruction_arg; int_or_var: [ [ n = integer -> ArgArg n diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index c09693b364..e61be53a99 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -226,8 +226,8 @@ GEXTEND Gram [ [ i = identref; l = OPT [ "@{" ; l = LIST0 identref; "}" -> l ] -> (i,l) ] ] ; univ_constraint: - [ [ l = identref; ord = [ "<" -> Univ.Lt | "=" -> Univ.Eq | "<=" -> Univ.Le ]; - r = identref -> (l, ord, r) ] ] + [ [ l = universe_level; ord = [ "<" -> Univ.Lt | "=" -> Univ.Eq | "<=" -> Univ.Le ]; + r = universe_level -> (l, ord, r) ] ] ; finite_token: [ [ "Inductive" -> (Inductive_kw,Finite) @@ -580,9 +580,15 @@ let warn_deprecated_implicit_arguments = CWarnings.create ~name:"deprecated-implicit-arguments" ~category:"deprecated" (fun () -> strbrk "Implicit Arguments is deprecated; use Arguments instead") +let warn_deprecated_arguments_syntax = + CWarnings.create ~name:"deprecated-arguments-syntax" ~category:"deprecated" + (fun () -> strbrk "The \"/\" and \"!\" modifiers have an effect only " + ++ strbrk "in the first arguments list. The syntax allowing" + ++ strbrk " them to appear in other lists is deprecated.") + (* Extensions: implicits, coercions, etc. *) GEXTEND Gram - GLOBAL: gallina_ext instance_name; + GLOBAL: gallina_ext instance_name hint_info; gallina_ext: [ [ (* Transparent and Opaque *) @@ -635,62 +641,51 @@ GEXTEND Gram | IDENT "Instance"; namesup = instance_name; ":"; expl = [ "!" -> Decl_kinds.Implicit | -> Decl_kinds.Explicit ] ; t = operconstr LEVEL "200"; - pri = OPT [ "|"; i = natural -> i ] ; + info = hint_info ; props = [ ":="; "{"; r = record_declaration; "}" -> Some (true,r) | ":="; c = lconstr -> Some (false,c) | -> None ] -> - VernacInstance (false,snd namesup,(fst namesup,expl,t),props,pri) + VernacInstance (false,snd namesup,(fst namesup,expl,t),props,info) | IDENT "Existing"; IDENT "Instance"; id = global; - pri = OPT [ "|"; i = natural -> i ] -> - VernacDeclareInstances ([id], pri) + info = hint_info -> + VernacDeclareInstances [id, info] + | IDENT "Existing"; IDENT "Instances"; ids = LIST1 global; - pri = OPT [ "|"; i = natural -> i ] -> - VernacDeclareInstances (ids, pri) + pri = OPT [ "|"; i = natural -> i ] -> + let info = { hint_priority = pri; hint_pattern = None } in + let insts = List.map (fun i -> (i, info)) ids in + VernacDeclareInstances insts | IDENT "Existing"; IDENT "Class"; is = global -> VernacDeclareClass is (* Arguments *) | IDENT "Arguments"; qid = smart_global; - impl = LIST1 [ l = LIST0 - [ item = argument_spec -> - let id, r, s = item in [`Id (id,r,s,false,false)] - | "/" -> [`Slash] - | "("; items = LIST1 argument_spec; ")"; sc = OPT scope -> - let f x = match sc, x with - | None, x -> x | x, None -> Option.map (fun y -> !@loc, y) x - | Some _, Some _ -> error "scope declared twice" in - List.map (fun (id,r,s) -> `Id(id,r,f s,false,false)) items - | "["; items = LIST1 argument_spec; "]"; sc = OPT scope -> - let f x = match sc, x with - | None, x -> x | x, None -> Option.map (fun y -> !@loc, y) x - | Some _, Some _ -> error "scope declared twice" in - List.map (fun (id,r,s) -> `Id(id,r,f s,true,false)) items - | "{"; items = LIST1 argument_spec; "}"; sc = OPT scope -> - let f x = match sc, x with - | None, x -> x | x, None -> Option.map (fun y -> !@loc, y) x - | Some _, Some _ -> error "scope declared twice" in - List.map (fun (id,r,s) -> `Id(id,r,f s,true,true)) items - ] -> l ] SEP ","; + args = LIST0 argument_spec_block; + more_implicits = OPT + [ ","; impl = LIST1 + [ impl = LIST0 more_implicits_block -> + let warn_deprecated = List.exists fst impl in + if warn_deprecated then warn_deprecated_arguments_syntax ~loc:!@loc (); + List.flatten (List.map snd impl)] + SEP "," -> impl + ]; mods = OPT [ ":"; l = LIST1 arguments_modifier SEP "," -> l ] -> let mods = match mods with None -> [] | Some l -> List.flatten l in - let impl = List.map List.flatten impl in - let rec aux n (narg, impl) = function - | `Id x :: tl -> aux (n+1) (narg, impl@[x]) tl - | `Slash :: tl -> aux (n+1) (n, impl) tl - | [] -> narg, impl in - let nargs, impl = List.split (List.map (aux 0 (-1, [])) impl) in - let nargs, rest = List.hd nargs, List.tl nargs in - if List.exists (fun arg -> not (Int.equal arg nargs)) rest then - error "All arguments lists must have the same length"; - let err_incompat x y = - error ("Options \""^x^"\" and \""^y^"\" are incompatible") in - if nargs > 0 && List.mem `ReductionNeverUnfold mods then - err_incompat "simpl never" "/"; - if List.mem `ReductionNeverUnfold mods && - List.mem `ReductionDontExposeCase mods then - err_incompat "simpl never" "simpl nomatch"; - VernacArguments (qid, impl, nargs, mods) - + let slash_position = ref None in + let rec parse_args i = function + | [] -> [] + | `Id x :: args -> x :: parse_args (i+1) args + | `Slash :: args -> + if Option.is_empty !slash_position then + (slash_position := Some i; parse_args i args) + else + error "The \"/\" modifier can occur only once" + in + let args = parse_args 0 (List.flatten args) in + let more_implicits = Option.default [] more_implicits in + VernacArguments (qid, args, more_implicits, !slash_position, mods) + + (* moved there so that camlp5 factors it with the previous rule *) | IDENT "Arguments"; IDENT "Scope"; qid = smart_global; "["; scl = LIST0 [ "_" -> None | sc = IDENT -> Some sc ]; "]" -> @@ -747,6 +742,55 @@ GEXTEND Gram snd id, not (Option.is_empty b), Option.map (fun x -> !@loc, x) s ] ]; + (* List of arguments implicit status, scope, modifiers *) + argument_spec_block: [ + [ item = argument_spec -> + let name, recarg_like, notation_scope = item in + [`Id { name=name; recarg_like=recarg_like; + notation_scope=notation_scope; + implicit_status = NotImplicit}] + | "/" -> [`Slash] + | "("; items = LIST1 argument_spec; ")"; sc = OPT scope -> + let f x = match sc, x with + | None, x -> x | x, None -> Option.map (fun y -> !@loc, y) x + | Some _, Some _ -> error "scope declared twice" in + List.map (fun (name,recarg_like,notation_scope) -> + `Id { name=name; recarg_like=recarg_like; + notation_scope=f notation_scope; + implicit_status = NotImplicit}) items + | "["; items = LIST1 argument_spec; "]"; sc = OPT scope -> + let f x = match sc, x with + | None, x -> x | x, None -> Option.map (fun y -> !@loc, y) x + | Some _, Some _ -> error "scope declared twice" in + List.map (fun (name,recarg_like,notation_scope) -> + `Id { name=name; recarg_like=recarg_like; + notation_scope=f notation_scope; + implicit_status = Implicit}) items + | "{"; items = LIST1 argument_spec; "}"; sc = OPT scope -> + let f x = match sc, x with + | None, x -> x | x, None -> Option.map (fun y -> !@loc, y) x + | Some _, Some _ -> error "scope declared twice" in + List.map (fun (name,recarg_like,notation_scope) -> + `Id { name=name; recarg_like=recarg_like; + notation_scope=f notation_scope; + implicit_status = MaximallyImplicit}) items + ] + ]; + name_or_bang: [ + [ b = OPT "!"; id = name -> + not (Option.is_empty b), id + ] + ]; + (* Same as [argument_spec_block], but with only implicit status and names *) + more_implicits_block: [ + [ (bang,name) = name_or_bang -> (bang, [(snd name, Vernacexpr.NotImplicit)]) + | "/" -> (true (* Should warn about deprecated syntax *), []) + | "["; items = LIST1 name_or_bang; "]" -> + (List.exists fst items, List.map (fun (_,(_,name)) -> (name, Vernacexpr.Implicit)) items) + | "{"; items = LIST1 name_or_bang; "}" -> + (List.exists fst items, List.map (fun (_,(_,name)) -> (name, Vernacexpr.MaximallyImplicit)) items) + ] + ]; strategy_level: [ [ IDENT "expand" -> Conv_oracle.Expand | IDENT "opaque" -> Conv_oracle.Opaque @@ -760,6 +804,11 @@ GEXTEND Gram (Option.default [] sup) | -> ((!@loc, Anonymous), None), [] ] ] ; + hint_info: + [ [ "|"; i = OPT natural; pat = OPT constr_pattern -> + { hint_priority = i; hint_pattern = pat } + | -> { hint_priority = None; hint_pattern = None } ] ] + ; reserv_list: [ [ bl = LIST1 reserv_tuple -> bl | b = simple_reserv -> [b] ] ] ; @@ -781,8 +830,8 @@ GEXTEND Gram (* Hack! Should be in grammar_ext, but camlp4 factorize badly *) | IDENT "Declare"; IDENT "Instance"; namesup = instance_name; ":"; expl = [ "!" -> Decl_kinds.Implicit | -> Decl_kinds.Explicit ] ; t = operconstr LEVEL "200"; - pri = OPT [ "|"; i = natural -> i ] -> - VernacInstance (true, snd namesup, (fst namesup, expl, t), None, pri) + info = hint_info -> + VernacInstance (true, snd namesup, (fst namesup, expl, t), None, info) (* System directory *) | IDENT "Pwd" -> VernacChdir None @@ -838,7 +887,20 @@ GEXTEND Gram (* For acting on parameter tables *) | "Set"; table = option_table; v = option_value -> - VernacSetOption (table,v) + begin match v with + | StringValue s -> + (* We make a special case for warnings because appending is their + natural semantics *) + if CString.List.equal table ["Warnings"] then + VernacSetAppendOption (table, s) + else + let (last, prefix) = List.sep_last table in + if String.equal last "Append" && not (List.is_empty prefix) then + VernacSetAppendOption (prefix, s) + else + VernacSetOption (table, v) + | _ -> VernacSetOption (table, v) + end | "Set"; table = option_table -> VernacSetOption (table,BoolValue true) | IDENT "Unset"; table = option_table -> @@ -1103,10 +1165,9 @@ GEXTEND Gram | IDENT "right"; IDENT "associativity" -> SetAssoc RightA | IDENT "no"; IDENT "associativity" -> SetAssoc NonA | IDENT "only"; IDENT "printing" -> SetOnlyPrinting - | IDENT "only"; IDENT "parsing" -> - SetOnlyParsing Flags.Current + | IDENT "only"; IDENT "parsing" -> SetOnlyParsing | IDENT "compat"; s = STRING -> - SetOnlyParsing (Coqinit.get_compat_version s) + SetCompatVersion (Coqinit.get_compat_version s) | IDENT "format"; s1 = [s = STRING -> (!@loc,s)]; s2 = OPT [s = STRING -> (!@loc,s)] -> begin match s1, s2 with diff --git a/parsing/pcoq.ml b/parsing/pcoq.ml index 714e25f85e..7dc02190ea 100644 --- a/parsing/pcoq.ml +++ b/parsing/pcoq.ml @@ -304,6 +304,7 @@ module Constr = let binder_constr = gec_constr "binder_constr" let ident = make_gen_entry uconstr "ident" let global = make_gen_entry uconstr "global" + let universe_level = make_gen_entry uconstr "universe_level" let sort = make_gen_entry uconstr "sort" let pattern = Gram.entry_create "constr:pattern" let constr_pattern = gec_constr "constr_pattern" @@ -349,6 +350,7 @@ module Tactic = let red_expr = make_gen_entry utactic "red_expr" let simple_intropattern = make_gen_entry utactic "simple_intropattern" + let in_clause = make_gen_entry utactic "in_clause" let clause_dft_concl = make_gen_entry utactic "clause" @@ -377,6 +379,7 @@ module Vernac_ = let vernac = gec_vernac "Vernac.vernac" let vernac_eoi = eoi_entry vernac let rec_definition = gec_vernac "Vernac.rec_definition" + let hint_info = gec_vernac "hint_info" (* Main vernac entry *) let main_entry = Gram.entry_create "vernac" let noedit_mode = gec_vernac "noedit_command" diff --git a/parsing/pcoq.mli b/parsing/pcoq.mli index 635b0170ae..37165f6ceb 100644 --- a/parsing/pcoq.mli +++ b/parsing/pcoq.mli @@ -39,7 +39,7 @@ module Gram : module type of Compat.GrammarMake(CLexer) | (together with a constr entry level, e.g. 50, and indications of) | (subentries, e.g. x in constr next level and y constr same level) | - | spliting into tokens by Metasyntax.split_notation_string + | splitting into tokens by Metasyntax.split_notation_string V [String "x"; String "+"; String "y"] : symbol_token list | @@ -96,7 +96,7 @@ module Gram : module type of Compat.GrammarMake(CLexer) *) -(** Temporary activate camlp4 verbosity *) +(** Temporarily activate camlp4 verbosity *) val camlp4_verbosity : bool -> ('a -> unit) -> 'a -> unit @@ -157,6 +157,7 @@ module Constr : val operconstr : constr_expr Gram.entry val ident : Id.t Gram.entry val global : reference Gram.entry + val universe_level : glob_level Gram.entry val sort : glob_sort Gram.entry val pattern : cases_pattern_expr Gram.entry val constr_pattern : constr_expr Gram.entry @@ -192,6 +193,7 @@ module Tactic : val red_expr : raw_red_expr Gram.entry val simple_tactic : raw_tactic_expr Gram.entry val simple_intropattern : constr_expr intro_pattern_expr located Gram.entry + val in_clause : Names.Id.t Loc.located Locus.clause_expr Gram.entry val clause_dft_concl : Names.Id.t Loc.located Locus.clause_expr Gram.entry val tactic_arg : raw_tactic_arg Gram.entry val tactic_expr : raw_tactic_expr Gram.entry @@ -211,6 +213,7 @@ module Vernac_ : val vernac_eoi : vernac_expr Gram.entry val noedit_mode : vernac_expr Gram.entry val command_entry : vernac_expr Gram.entry + val hint_info : Vernacexpr.hint_info_expr Gram.entry end (** The main entry: reads an optional vernac command *) @@ -229,14 +232,14 @@ type gram_reinit = gram_assoc * gram_position val grammar_extend : 'a Gram.entry -> gram_reinit option -> 'a Extend.extend_statment -> unit -(** Extend the grammar of Coq, without synchronizing it with the bactracking +(** Extend the grammar of Coq, without synchronizing it with the backtracking mechanism. This means that grammar extensions defined this way will survive an undo. *) (** {5 Extending the parser with summary-synchronized commands} *) module GramState : Store.S -(** Auxilliary state of the grammar. Any added data must be marshallable. *) +(** Auxiliary state of the grammar. Any added data must be marshallable. *) type 'a grammar_command (** Type of synchronized parsing extensions. The ['a] type should be diff --git a/parsing/tok.ml b/parsing/tok.ml index 8ae1065120..f4b60aeec4 100644 --- a/parsing/tok.ml +++ b/parsing/tok.ml @@ -53,7 +53,7 @@ let to_string = function | INT s -> Format.sprintf "INT %s" s | STRING s -> Format.sprintf "STRING %S" s | LEFTQMARK -> "LEFTQMARK" - | BULLET s -> Format.sprintf "STRING %S" s + | BULLET s -> Format.sprintf "BULLET %S" s | EOI -> "EOI" let match_keyword kwd = function diff --git a/plugins/extraction/json.ml b/plugins/extraction/json.ml index 8874afef33..e43c47d050 100644 --- a/plugins/extraction/json.ml +++ b/plugins/extraction/json.ml @@ -142,7 +142,8 @@ let rec json_expr env = function ("what", json_str "fix:item"); ("name", json_id fi); ("body", json_function env' ti) - ]) (Array.map2 (fun a b -> a,b) ids' defs))) + ]) (Array.map2 (fun a b -> a,b) ids' defs))); + ("for", json_int i); ] | MLexn s -> json_dict [ ("what", json_str "expr:exception"); diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index 1c29a9bc24..5d10cb939d 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -618,12 +618,13 @@ let rec pp_specif = function with Not_found -> pp_spec s) | (l,Smodule mt) -> let def = pp_module_type [] mt in - let def' = pp_module_type [] mt in let name = pp_modname (MPdot (top_visible_mp (), l)) in hov 1 (str "module " ++ name ++ str " :" ++ fnl () ++ def) ++ (try let ren = Common.check_duplicate (top_visible_mp ()) l in - fnl () ++ hov 1 (str ("module "^ren^" :") ++ fnl () ++ def') + fnl () ++ + hov 1 (str ("module "^ren^" :") ++ spc () ++ + str "module type of struct include " ++ name ++ str " end") with Not_found -> Pp.mt ()) | (l,Smodtype mt) -> let def = pp_module_type [] mt in diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4 index 95095b09cb..43fac8ad83 100644 --- a/plugins/firstorder/g_ground.ml4 +++ b/plugins/firstorder/g_ground.ml4 @@ -116,9 +116,9 @@ open Pp open Genarg open Ppconstr open Printer -let pr_firstorder_using_raw _ _ _ l = str "using " ++ prlist_with_sep pr_comma pr_reference l -let pr_firstorder_using_glob _ _ _ l = str "using " ++ prlist_with_sep pr_comma (pr_or_var (fun x -> (pr_global (snd x)))) l -let pr_firstorder_using_typed _ _ _ l = str "using " ++ prlist_with_sep pr_comma pr_global l +let pr_firstorder_using_raw _ _ _ = Pptactic.pr_auto_using pr_reference +let pr_firstorder_using_glob _ _ _ = Pptactic.pr_auto_using (pr_or_var (fun x -> pr_global (snd x))) +let pr_firstorder_using_typed _ _ _ = Pptactic.pr_auto_using pr_global let warn_deprecated_syntax = CWarnings.create ~name:"firstorder-deprecated-syntax" ~category:"deprecated" diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 62f3071151..fa84e4ddf3 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -1538,7 +1538,9 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num begin if do_observe () then Feedback.msg_debug (str "Cannot create equation Lemma " ++ CErrors.print e) - else anomaly (Pp.str "Cannot create equation Lemma") + else CErrors.errorlabstrm "Cannot create equation Lemma" + (str "Cannot create equation lemma." ++ spc () ++ + str "This may be because the function is nested-recursive.") ; true end diff --git a/plugins/ltac/LtacDummy.v b/plugins/ltac/LtacDummy.v new file mode 100644 index 0000000000..4f96bbaeb9 --- /dev/null +++ b/plugins/ltac/LtacDummy.v @@ -0,0 +1,2 @@ +(* The sole reason of this file is to trick coq's build system to build the dummy ltac plugin *) +Declare ML Module "ltac_plugin". diff --git a/plugins/ltac/ltac_dummy.ml b/plugins/ltac/ltac_dummy.ml new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/plugins/ltac/ltac_dummy.ml diff --git a/plugins/ltac/ltac_dummy.mli b/plugins/ltac/ltac_dummy.mli new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/plugins/ltac/ltac_dummy.mli diff --git a/plugins/ltac/ltac_plugin.mlpack b/plugins/ltac/ltac_plugin.mlpack new file mode 100644 index 0000000000..6efb477cce --- /dev/null +++ b/plugins/ltac/ltac_plugin.mlpack @@ -0,0 +1 @@ +Ltac_dummy diff --git a/plugins/ltac/vo.itarget b/plugins/ltac/vo.itarget new file mode 100644 index 0000000000..4eff76566a --- /dev/null +++ b/plugins/ltac/vo.itarget @@ -0,0 +1 @@ +LtacDummy.vo diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index a063cbbfe3..e4b58a56f9 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -1517,27 +1517,27 @@ let rec apply_ids t ids = | [] -> t | i::ids -> apply_ids (Term.mkApp(t,[| Term.mkVar i |])) ids -let coq_Node = +let coq_Node = lazy (Coqlib.gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Node") -let coq_Leaf = +let coq_Leaf = lazy (Coqlib.gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Leaf") -let coq_Empty = +let coq_Empty = lazy (Coqlib.gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ;"VarMap"];["VarMap"]] "Empty") -let coq_VarMap = +let coq_VarMap = lazy (Coqlib.gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t") let rec dump_varmap typ m = match m with - | Mc.Empty -> Term.mkApp(coq_Empty,[| typ |]) - | Mc.Leaf v -> Term.mkApp(coq_Leaf,[| typ; v|]) - | Mc.Node(l,o,r) -> - Term.mkApp (coq_Node, [| typ; dump_varmap typ l; o ; dump_varmap typ r |]) + | Mc.Empty -> Term.mkApp(Lazy.force coq_Empty,[| typ |]) + | Mc.Leaf v -> Term.mkApp(Lazy.force coq_Leaf,[| typ; v|]) + | Mc.Node(l,o,r) -> + Term.mkApp (Lazy.force coq_Node, [| typ; dump_varmap typ l; o ; dump_varmap typ r |]) let vm_of_list env = @@ -1709,7 +1709,7 @@ let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic* (set [ ("__ff", ff, Term.mkApp(Lazy.force coq_Formula, [|formula_typ |])); - ("__varmap", vm, Term.mkApp( coq_VarMap, [|spec.typ|])); + ("__varmap", vm, Term.mkApp(Lazy.force coq_VarMap, [|spec.typ|])); ("__wit", cert, cert_typ) ] (Tacmach.pf_concl gl)) diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index a34fa4cae7..d21223d43d 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -112,8 +112,7 @@ let guard_term ch1 s i = match s.[i] with (* The call 'guard s i' should return true if the contents of s *) (* starting at i need bracketing to avoid ambiguities. *) let pr_guarded guard prc c = - msg_with Format.str_formatter (prc c); - let s = Format.flush_str_formatter () ^ "$" in + let s = Pp.string_of_ppcmds (prc c) ^ "$" in if guard s (skip_wschars s 0) then pr_paren prc c else prc c (* More sensible names for constr printers *) let pr_constr = pr_constr @@ -355,7 +354,7 @@ let nf_open_term sigma0 ise c = !s', Evd.evar_universe_context s, c' let unif_end env sigma0 ise0 pt ok = - let ise = Evarconv.consider_remaining_unif_problems env ise0 in + let ise = Evarconv.solve_unif_constraints_with_heuristics env ise0 in let s, uc, t = nf_open_term sigma0 ise pt in let ise1 = create_evar_defs s in let ise1 = Evd.set_universe_context ise1 uc in @@ -391,7 +390,8 @@ let iter_constr_LR f c = match kind_of_term c with | Case (_, p, v, b) -> f v; f p; Array.iter f b | Fix (_, (_, t, b)) | CoFix (_, (_, t, b)) -> for i = 0 to Array.length t - 1 do f t.(i); f b.(i) done - | _ -> () + | Proj(_,a) -> f a + | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> () (* The comparison used to determine which subterms matches is KEYED *) (* CONVERSION. This looks for convertible terms that either have the same *) @@ -435,7 +435,7 @@ let proj_nparams c = try 1 + Recordops.find_projection_nparams (ConstRef c) with _ -> 0 let isFixed c = match kind_of_term c with - | Var _ | Ind _ | Construct _ | Const _ -> true + | Var _ | Ind _ | Construct _ | Const _ | Proj _ -> true | _ -> false let isRigid c = match kind_of_term c with @@ -487,6 +487,7 @@ let mk_tpattern ?p_origin ?(hack=false) env sigma0 (ise, t) ok dir p = let np = proj_nparams p in if np = 0 || np > List.length a then KpatConst, f, a else let a1, a2 = List.chop np a in KpatProj p, applist(f, a1), a2 + | Proj (p,arg) -> KpatProj (Projection.constant p), f, a | Var _ | Ind _ | Construct _ -> KpatFixed, f, a | Evar (k, _) -> if Evd.mem sigma0 k then KpatEvar k, f, a else @@ -524,7 +525,13 @@ let nb_cs_proj_args pc f u = try match kind_of_term f with | Prod _ -> na Prod_cs | Sort s -> na (Sort_cs (family_of_sort s)) - | Const (c',_) when Constant.equal c' pc -> Array.length (snd (destApp u.up_f)) + | Const (c',_) when Constant.equal c' pc -> + begin match kind_of_term u.up_f with + | App(_,args) -> Array.length args + | Proj _ -> 0 (* if splay_app calls expand_projection, this has to be + the number of arguments including the projected *) + | _ -> assert false + end | Var _ | Ind _ | Construct _ | Const _ -> na (Const_cs (global_of_constr f)) | _ -> -1 with Not_found -> -1 @@ -567,6 +574,10 @@ let filter_upat i0 f n u fpats = if np < na then fpats else let () = if !i0 < np then i0 := n in (u, np) :: fpats +let eq_prim_proj c t = match kind_of_term t with + | Proj(p,_) -> Constant.equal (Projection.constant p) c + | _ -> false + let filter_upat_FO i0 f n u fpats = let np = nb_args u.up_FO in if n < np then fpats else @@ -577,7 +588,7 @@ let filter_upat_FO i0 f n u fpats = | KpatLet -> isLetIn f | KpatLam -> isLambda f | KpatRigid -> isRigid f - | KpatProj pc -> Term.eq_constr f (mkConst pc) + | KpatProj pc -> Term.eq_constr f (mkConst pc) || eq_prim_proj pc f | KpatFlex -> i0 := n; true in if ok then begin if !i0 < np then i0 := np; (u, np) :: fpats end else fpats @@ -908,9 +919,47 @@ let glob_ssrterm gs = function fst x, Some c | ct -> ct +(* This piece of code asserts the following notations are reserved *) +(* Reserved Notation "( a 'in' b )" (at level 0). *) +(* Reserved Notation "( a 'as' b )" (at level 0). *) +(* Reserved Notation "( a 'in' b 'in' c )" (at level 0). *) +(* Reserved Notation "( a 'as' b 'in' c )" (at level 0). *) +let glob_cpattern gs p = + pp(lazy(str"globbing pattern: " ++ pr_term p)); + let glob x = snd (glob_ssrterm gs (mk_lterm x)) in + let encode k s l = + let name = Name (id_of_string ("_ssrpat_" ^ s)) in + k, (mkRCast mkRHole (mkRLambda name mkRHole (mkRApp mkRHole l)), None) in + let bind_in t1 t2 = + let d = dummy_loc in let n = Name (destCVar t1) in + fst (glob (mkCCast d (mkCHole d) (mkCLambda d n (mkCHole d) t2))) in + let check_var t2 = if not (isCVar t2) then + loc_error (constr_loc t2) "Only identifiers are allowed here" in + match p with + | _, (_, None) as x -> x + | k, (v, Some t) as orig -> + if k = 'x' then glob_ssrterm gs ('(', (v, Some t)) else + match t with + | CNotation(_, "( _ in _ )", ([t1; t2], [], [])) -> + (try match glob t1, glob t2 with + | (r1, None), (r2, None) -> encode k "In" [r1;r2] + | (r1, Some _), (r2, Some _) when isCVar t1 -> + encode k "In" [r1; r2; bind_in t1 t2] + | (r1, Some _), (r2, Some _) -> encode k "In" [r1; r2] + | _ -> CErrors.anomaly (str"where are we?") + with _ when isCVar t1 -> encode k "In" [bind_in t1 t2]) + | CNotation(_, "( _ in _ in _ )", ([t1; t2; t3], [], [])) -> + check_var t2; encode k "In" [fst (glob t1); bind_in t2 t3] + | CNotation(_, "( _ as _ )", ([t1; t2], [], [])) -> + encode k "As" [fst (glob t1); fst (glob t2)] + | CNotation(_, "( _ as _ in _ )", ([t1; t2; t3], [], [])) -> + check_var t2; encode k "As" [fst (glob t1); bind_in t2 t3] + | _ -> glob_ssrterm gs orig +;; + let glob_rpattern s p = match p with - | T t -> T (glob_ssrterm s t) + | T t -> T (glob_cpattern s t) | In_T t -> In_T (glob_ssrterm s t) | X_In_T(x,t) -> X_In_T (x,glob_ssrterm s t) | In_X_In_T(x,t) -> In_X_In_T (x,glob_ssrterm s t) @@ -995,44 +1044,6 @@ let input_ssrtermkind strm = match Compat.get_tok (stream_nth 0 strm) with | _ -> ' ' let ssrtermkind = Gram.Entry.of_parser "ssrtermkind" input_ssrtermkind -(* This piece of code asserts the following notations are reserved *) -(* Reserved Notation "( a 'in' b )" (at level 0). *) -(* Reserved Notation "( a 'as' b )" (at level 0). *) -(* Reserved Notation "( a 'in' b 'in' c )" (at level 0). *) -(* Reserved Notation "( a 'as' b 'in' c )" (at level 0). *) -let glob_cpattern gs p = - pp(lazy(str"globbing pattern: " ++ pr_term p)); - let glob x = snd (glob_ssrterm gs (mk_lterm x)) in - let encode k s l = - let name = Name (id_of_string ("_ssrpat_" ^ s)) in - k, (mkRCast mkRHole (mkRLambda name mkRHole (mkRApp mkRHole l)), None) in - let bind_in t1 t2 = - let d = dummy_loc in let n = Name (destCVar t1) in - fst (glob (mkCCast d (mkCHole d) (mkCLambda d n (mkCHole d) t2))) in - let check_var t2 = if not (isCVar t2) then - loc_error (constr_loc t2) "Only identifiers are allowed here" in - match p with - | _, (_, None) as x -> x - | k, (v, Some t) as orig -> - if k = 'x' then glob_ssrterm gs ('(', (v, Some t)) else - match t with - | CNotation(_, "( _ in _ )", ([t1; t2], [], [])) -> - (try match glob t1, glob t2 with - | (r1, None), (r2, None) -> encode k "In" [r1;r2] - | (r1, Some _), (r2, Some _) when isCVar t1 -> - encode k "In" [r1; r2; bind_in t1 t2] - | (r1, Some _), (r2, Some _) -> encode k "In" [r1; r2] - | _ -> CErrors.anomaly (str"where are we?") - with _ when isCVar t1 -> encode k "In" [bind_in t1 t2]) - | CNotation(_, "( _ in _ in _ )", ([t1; t2; t3], [], [])) -> - check_var t2; encode k "In" [fst (glob t1); bind_in t2 t3] - | CNotation(_, "( _ as _ )", ([t1; t2], [], [])) -> - encode k "As" [fst (glob t1); fst (glob t2)] - | CNotation(_, "( _ as _ in _ )", ([t1; t2; t3], [], [])) -> - check_var t2; encode k "As" [fst (glob t1); bind_in t2 t3] - | _ -> glob_ssrterm gs orig -;; - let interp_ssrterm _ gl t = Tacmach.project gl, t ARGUMENT EXTEND cpattern diff --git a/plugins/ssrmatching/ssrmatching.mli b/plugins/ssrmatching/ssrmatching.mli index 74a603e51c..288a04e60a 100644 --- a/plugins/ssrmatching/ssrmatching.mli +++ b/plugins/ssrmatching/ssrmatching.mli @@ -213,7 +213,7 @@ val assert_done : 'a option ref -> 'a (** Very low level APIs. these are calls to evarconv's [the_conv_x] followed by - [consider_remaining_unif_problems] and [resolve_typeclasses]. + [solve_unif_constraints_with_heuristics] and [resolve_typeclasses]. In case of failure they raise [NoMatch] *) val unify_HO : env -> evar_map -> constr -> constr -> evar_map diff --git a/pretyping/arguments_renaming.ml b/pretyping/arguments_renaming.ml index ca1d0b7fba..e18aece090 100644 --- a/pretyping/arguments_renaming.ml +++ b/pretyping/arguments_renaming.ml @@ -16,12 +16,12 @@ open Libobject (*i*) let name_table = - Summary.ref (Refmap.empty : Name.t list list Refmap.t) + Summary.ref (Refmap.empty : Name.t list Refmap.t) ~name:"rename-arguments" type req = | ReqLocal - | ReqGlobal of global_reference * Name.t list list + | ReqGlobal of global_reference * Name.t list let load_rename_args _ (_, (_, (r, names))) = name_table := Refmap.add r names !name_table @@ -49,7 +49,7 @@ let discharge_rename_args = function let vars,_,_ = section_segment_of_reference c in let c' = pop_global_reference c in let var_names = List.map (fun (id, _,_,_) -> Name id) vars in - let names' = List.map (fun l -> var_names @ l) names in + let names' = var_names @ names in Some (ReqGlobal (c', names), (c', names')) with Not_found -> Some req) | _ -> None @@ -83,7 +83,7 @@ let rec rename_prod c = function | _ -> c let rename_type ty ref = - try rename_prod ty (List.hd (arguments_names ref)) + try rename_prod ty (arguments_names ref) with Not_found -> ty let rename_type_of_constant env c = diff --git a/pretyping/arguments_renaming.mli b/pretyping/arguments_renaming.mli index a334055011..e123e77862 100644 --- a/pretyping/arguments_renaming.mli +++ b/pretyping/arguments_renaming.mli @@ -11,10 +11,10 @@ open Globnames open Environ open Term -val rename_arguments : bool -> global_reference -> Name.t list list -> unit +val rename_arguments : bool -> global_reference -> Name.t list -> unit -(** [Not_found] is raised is no names are defined for [r] *) -val arguments_names : global_reference -> Name.t list list +(** [Not_found] is raised if no names are defined for [r] *) +val arguments_names : global_reference -> Name.t list val rename_type_of_constant : env -> pconstant -> types val rename_type_of_inductive : env -> pinductive -> types diff --git a/pretyping/cases.ml b/pretyping/cases.ml index e89c3ea719..ef3e53bf1f 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -62,13 +62,15 @@ let error_wrong_numarg_constructor_loc loc env c n = let error_wrong_numarg_inductive_loc loc env c n = raise_pattern_matching_error (loc, env, Evd.empty, WrongNumargInductive(c,n)) -let rec list_try_compile f = function - | [a] -> f a - | [] -> anomaly (str "try_find_f") +let list_try_compile f l = + let rec aux errors = function + | [] -> if errors = [] then anomaly (str "try_find_f") else iraise (List.last errors) | h::t -> try f h - with UserError _ | TypeError _ | PretypeError _ | PatternMatchingError _ -> - list_try_compile f t + with UserError _ | TypeError _ | PretypeError _ | PatternMatchingError _ as e -> + let e = CErrors.push e in + aux (e::errors) t in + aux [] l let force_name = let nx = Name default_dependent_ident in function Anonymous -> nx | na -> na @@ -845,7 +847,7 @@ let subst_predicate (subst,copt) ccl tms = | Some c -> c::subst in substnl_predicate sigma 0 ccl tms -let specialize_predicate_var (cur,typ,dep) tms ccl = +let specialize_predicate_var (cur,typ,dep) env tms ccl = let c = match dep with | Anonymous -> None | Name _ -> Some cur @@ -853,7 +855,9 @@ let specialize_predicate_var (cur,typ,dep) tms ccl = let l = match typ with | IsInd (_, IndType (_, _), []) -> [] - | IsInd (_, IndType (_, realargs), names) -> realargs + | IsInd (_, IndType (indf, realargs), names) -> + let arsign,_ = get_arity env indf in + subst_of_rel_context_instance arsign realargs | NotInd _ -> [] in subst_predicate (l,c) ccl tms @@ -1388,7 +1392,7 @@ and match_current pb (initial,tomatch) = and shift_problem ((current,t),_,na) pb = let ty = type_of_tomatch t in let tomatch = lift_tomatch_stack 1 pb.tomatch in - let pred = specialize_predicate_var (current,t,na) pb.tomatch pb.pred in + let pred = specialize_predicate_var (current,t,na) pb.env pb.tomatch pb.pred in let pb = { pb with env = push_rel (LocalDef (na,current,ty)) pb.env; @@ -1405,7 +1409,7 @@ and shift_problem ((current,t),_,na) pb = are already introduced in the context, we avoid creating aliases to themselves by treating this case specially. *) and pop_problem ((current,t),_,na) pb = - let pred = specialize_predicate_var (current,t,na) pb.tomatch pb.pred in + let pred = specialize_predicate_var (current,t,na) pb.env pb.tomatch pb.pred in let pb = { pb with pred = pred; @@ -1870,22 +1874,16 @@ let inh_conv_coerce_to_tycon loc env evdref j tycon = (* We put the tycon inside the arity signature, possibly discovering dependencies. *) -let add_subst c len (rel_subst,var_subst) = - match kind_of_term c with - | Rel n -> (n,len) :: rel_subst, var_subst - | Var id -> rel_subst, (id,len) :: var_subst - | _ -> assert false - let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c = let nar = List.fold_left (fun n sign -> Context.Rel.nhyps sign + n) 0 arsign in - let (rel_subst,var_subst), len = + let subst, len = List.fold_right2 (fun (tm, tmtype) sign (subst, len) -> let signlen = List.length sign in match kind_of_term tm with - | Rel _ | Var _ when dependent tm c + | Rel n when dependent tm c && Int.equal signlen 1 (* The term to match is not of a dependent type itself *) -> - (add_subst tm len subst, len - signlen) - | Rel _ | Var _ when signlen > 1 (* The term is of a dependent type, + ((n, len) :: subst, len - signlen) + | Rel n when signlen > 1 (* The term is of a dependent type, maybe some variable in its type appears in the tycon. *) -> (match tmtype with NotInd _ -> (subst, len - signlen) @@ -1894,36 +1892,28 @@ let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c = List.fold_left (fun (subst, len) arg -> match kind_of_term arg with - | Rel _ | Var _ when dependent arg c -> - (add_subst arg len subst, pred len) + | Rel n when dependent arg c -> + ((n, len) :: subst, pred len) | _ -> (subst, pred len)) (subst, len) realargs in let subst = - if dependent tm c && List.for_all (fun c -> isRel c || isVar c) realargs - then add_subst tm len subst else subst + if dependent tm c && List.for_all isRel realargs + then (n, len) :: subst else subst in (subst, pred len)) | _ -> (subst, len - signlen)) - (List.rev tomatchs) arsign (([],[]), nar) + (List.rev tomatchs) arsign ([], nar) in let rec predicate lift c = match kind_of_term c with | Rel n when n > lift -> (try (* Make the predicate dependent on the matched variable *) - let idx = Int.List.assoc (n - lift) rel_subst in + let idx = Int.List.assoc (n - lift) subst in mkRel (idx + lift) with Not_found -> - (* A variable that is not matched, lift over the arsign *) + (* A variable that is not matched, lift over the arsign. *) mkRel (n + nar)) - | Var id -> - (try - (* Make the predicate dependent on the matched variable *) - let idx = Id.List.assoc id var_subst in - mkRel (idx + lift) - with Not_found -> - (* A variable that is not matched *) - c) | _ -> map_constr_with_binders succ predicate lift c in @@ -1939,44 +1929,54 @@ let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c = * type and 1 assumption for each term not _syntactically_ in an * inductive type. - * Each matched term is independently considered dependent or not. + * Each matched terms are independently considered dependent or not. + + * A type constraint but no annotation case: we try to specialize the + * tycon to make the predicate if it is not closed. *) let prepare_predicate loc typing_fun env sigma tomatchs arsign tycon pred = + let refresh_tycon sigma t = + (** If we put the typing constraint in the term, it has to be + refreshed to preserve the invariant that no algebraic universe + can appear in the term. *) + refresh_universes ~status:Evd.univ_flexible ~onlyalg:true (Some true) + env sigma t + in let preds = - match pred with + match pred, tycon with (* No return clause *) - | None -> - let sigma,t = - match tycon with - | Some t -> sigma, t - | None -> - (* No type constraint: we first create a generic evar type constraint *) - let src = (loc, Evar_kinds.CasesType false) in - let sigma = Sigma.Unsafe.of_evar_map sigma in - let Sigma ((t, _), sigma, _) = new_type_evar env sigma univ_flexible_alg ~src in - let sigma = Sigma.to_evar_map sigma in - sigma, t in - (* First strategy: we build an "inversion" predicate, also replacing the *) - (* dependencies with existential variables *) - let sigma1,pred1 = build_inversion_problem loc env sigma tomatchs t in - (* Optional second strategy: we abstract the tycon wrt to the dependencies *) - let p2 = + | None, Some t when not (noccur_with_meta 0 max_int t) -> + (* If the tycon is not closed w.r.t real variables, we try *) + (* two different strategies *) + (* First strategy: we abstract the tycon wrt to the dependencies *) + let sigma, t = refresh_tycon sigma t in + let p1 = prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign t in - (* Third strategy: we take the type constraint as it is; of course we could *) - (* need something inbetween, abstracting some but not all of the dependencies *) - (* the "inversion" strategy deals with that but unification may not be *) - (* powerful enough so strategy 2 and 3 helps; moreover, inverting does not *) - (* work (yet) when a constructor has a type not precise enough for the inversion *) - (* see log message for details *) - let pred3 = lift (List.length (List.flatten arsign)) t in - (match p2 with - | Some (sigma2,pred2) when not (Constr.equal pred2 pred3) -> - [sigma1, pred1; sigma2, pred2; sigma, pred3] - | _ -> - [sigma1, pred1; sigma, pred3]) + (* Second strategy: we build an "inversion" predicate *) + let sigma2,pred2 = build_inversion_problem loc env sigma tomatchs t in + (match p1 with + | Some (sigma1,pred1) -> [sigma1, pred1; sigma2, pred2] + | None -> [sigma2, pred2]) + | None, _ -> + (* No dependent type constraint, or no constraints at all: *) + (* we use two strategies *) + let sigma,t = match tycon with + | Some t -> refresh_tycon sigma t + | None -> + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma ((t, _), sigma, _) = + new_type_evar env sigma univ_flexible_alg ~src:(loc, Evar_kinds.CasesType false) in + let sigma = Sigma.to_evar_map sigma in + sigma, t + in + (* First strategy: we build an "inversion" predicate *) + let sigma1,pred1 = build_inversion_problem loc env sigma tomatchs t in + (* Second strategy: we directly use the evar as a non dependent pred *) + let pred2 = lift (List.length (List.flatten arsign)) t in + [sigma1, pred1; sigma, pred2] (* Some type annotation *) - | Some rtntyp -> + | Some rtntyp, _ -> (* We extract the signature of the arity *) let envar = List.fold_right push_rel_context arsign env in let sigma, newt = new_sort_variable univ_flexible_alg sigma in @@ -2577,6 +2577,9 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e typing_function = typing_fun } in let j = compile pb in + + (* We coerce to the tycon (if an elim predicate was provided) *) + let j = inh_conv_coerce_to_tycon loc env myevdref j tycon in evdref := !myevdref; j in @@ -2587,6 +2590,4 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e (* We check for unused patterns *) List.iter (check_unused_pattern env) matx; - (* We coerce to the tycon (if an elim predicate was provided) *) - inh_conv_coerce_to_tycon loc env evdref j tycon - + j diff --git a/pretyping/cases.mli b/pretyping/cases.mli index ba566f3744..ee4148de64 100644 --- a/pretyping/cases.mli +++ b/pretyping/cases.mli @@ -114,10 +114,11 @@ val compile : 'a pattern_matching_problem -> Environ.unsafe_judgment val prepare_predicate : Loc.t -> (Evarutil.type_constraint -> - Environ.env -> Evd.evar_map ref -> 'a -> Environ.unsafe_judgment) -> + Environ.env -> Evd.evar_map ref -> glob_constr -> Environ.unsafe_judgment) -> Environ.env -> Evd.evar_map -> (Term.types * tomatch_type) list -> Context.Rel.t list -> Constr.constr option -> - 'a option -> (Evd.evar_map * Names.name list * Term.constr) list + glob_constr option -> + (Evd.evar_map * Names.name list * Term.constr) list diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index b033f5a395..9fd55a488e 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -42,12 +42,7 @@ let _ = Goptions.declare_bool_option { let unfold_projection env evd ts p c = let cst = Projection.constant p in if is_transparent_constant ts cst then - let c' = Some (mkProj (Projection.make cst true, c)) in - match ReductionBehaviour.get (Globnames.ConstRef cst) with - | None -> c' - | Some (recargs, nargs, flags) -> - if (List.mem `ReductionNeverUnfold flags) then None - else c' + Some (mkProj (Projection.make cst true, c)) else None let eval_flexible_term ts env evd c = @@ -102,19 +97,19 @@ let position_problem l2r = function | CONV -> None | CUMUL -> Some l2r -let occur_rigidly ev evd t = +let occur_rigidly (evk,_ as ev) evd t = let rec aux t = match kind_of_term (whd_evar evd t) with | App (f, c) -> if aux f then Array.exists aux c else false | Construct _ | Ind _ | Sort _ | Meta _ | Fix _ | CoFix _ -> true | Proj (p, c) -> not (aux c) - | Evar (ev',_) -> if Evar.equal ev ev' then raise Occur else false + | Evar (evk',_) -> if Evar.equal evk evk' then raise Occur else false | Cast (p, _, _) -> aux p | Lambda _ | LetIn _ -> false | Const _ -> false | Prod (_, b, t) -> ignore(aux b || aux t); true | Rel _ | Var _ -> false - | Case _ -> false + | Case (_,_,c,_) -> if eq_constr (mkEvar ev) c then raise Occur else false in try ignore(aux t); false with Occur -> true (* [check_conv_record env sigma (t1,stack1) (t2,stack2)] tries to decompose @@ -483,7 +478,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty ise_try evd [eta;(* Postpone the use of an heuristic *) (fun i -> - if not (occur_rigidly (fst ev) i tR) then + if not (occur_rigidly ev i tR) then let i,tF = if isRel tR || isVar tR then (* Optimization so as to generate candidates *) @@ -1086,7 +1081,7 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = match evar_conv_x ts env_evar evd CUMUL idty evty with | UnifFailure _ -> error "Cannot find an instance" | Success evd -> - match reconsider_conv_pbs (evar_conv_x ts) evd with + match reconsider_unif_constraints (evar_conv_x ts) evd with | UnifFailure _ -> error "Cannot find an instance" | Success evd -> evd @@ -1152,7 +1147,7 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = let f env evd pbty x y = is_fconv ~reds:ts pbty env evd x y in Success (solve_refl ~can_drop:true f env evd (position_problem true pbty) evk1 args1 args2) - | Evar ev1, Evar ev2 -> + | Evar ev1, Evar ev2 when app_empty -> Success (solve_evar_evar ~force:true (evar_define (evar_conv_x ts) ~choose:true) (evar_conv_x ts) env evd (position_problem true pbty) ev1 ev2) @@ -1180,9 +1175,14 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = (* Some head evar have been instantiated, or unknown kind of problem *) evar_conv_x ts env evd pbty t1 t2 +let error_cannot_unify env evd pb ?reason t1 t2 = + Pretype_errors.error_cannot_unify_loc + (loc_of_conv_pb evd pb) env + evd ?reason (t1, t2) + let check_problems_are_solved env evd = match snd (extract_all_conv_pbs evd) with - | (pbty,env,t1,t2)::_ -> Pretype_errors.error_cannot_unify env evd (t1, t2) + | (pbty,env,t1,t2) as pb::_ -> error_cannot_unify env evd pb t1 t2 | _ -> () let max_undefined_with_candidates evd = @@ -1213,7 +1213,7 @@ let rec solve_unconstrained_evars_with_candidates ts evd = let conv_algo = evar_conv_x ts in let evd = check_evar_instance evd evk a conv_algo in let evd = Evd.define evk a evd in - match reconsider_conv_pbs conv_algo evd with + match reconsider_unif_constraints conv_algo evd with | Success evd -> solve_unconstrained_evars_with_candidates ts evd | UnifFailure _ -> aux l with @@ -1236,7 +1236,7 @@ let solve_unconstrained_impossible_cases env evd = Evd.define evk ty evd' | _ -> evd') evd evd -let consider_remaining_unif_problems env +let solve_unif_constraints_with_heuristics env ?(ts=Conv_oracle.get_transp_state (Environ.oracle env)) evd = let evd = solve_unconstrained_evars_with_candidates ts evd in let rec aux evd pbs progress stuck = @@ -1251,23 +1251,23 @@ let consider_remaining_unif_problems env aux evd pbs progress (pb :: stuck) end | UnifFailure (evd,reason) -> - Pretype_errors.error_cannot_unify_loc (loc_of_conv_pb evd pb) - env evd ~reason (t1, t2)) + error_cannot_unify env evd pb ~reason t1 t2) | _ -> if progress then aux evd stuck false [] else match stuck with | [] -> (* We're finished *) evd | (pbty,env,t1,t2 as pb) :: _ -> - (* There remains stuck problems *) - Pretype_errors.error_cannot_unify_loc (loc_of_conv_pb evd pb) - env evd (t1, t2) + (* There remains stuck problems *) + error_cannot_unify env evd pb t1 t2 in let (evd,pbs) = extract_all_conv_pbs evd in let heuristic_solved_evd = aux evd pbs false [] in check_problems_are_solved env heuristic_solved_evd; solve_unconstrained_impossible_cases env heuristic_solved_evd +let consider_remaining_unif_problems = solve_unif_constraints_with_heuristics + (* Main entry points *) exception UnableToUnify of evar_map * unification_error diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli index 14947c8927..2231e5bc30 100644 --- a/pretyping/evarconv.mli +++ b/pretyping/evarconv.mli @@ -33,7 +33,10 @@ val e_cumul : env -> ?ts:transparent_state -> evar_map ref -> constr -> constr - (** Try heuristics to solve pending unification problems and to solve evars with candidates *) +val solve_unif_constraints_with_heuristics : env -> ?ts:transparent_state -> evar_map -> evar_map + val consider_remaining_unif_problems : env -> ?ts:transparent_state -> evar_map -> evar_map +(** @deprecated Alias for [solve_unif_constraints_with_heuristics] *) (** Check all pending unification problems are solved and raise an error otherwise *) diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 6c8677855a..4fd030845d 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -42,33 +42,39 @@ let get_polymorphic_positions f = templ.template_param_levels) | _ -> assert false -let refresh_level evd s = - match Evd.is_sort_variable evd s with - | None -> true - | Some l -> not (Evd.is_flexible_level evd l) - let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false) pbty env evd t = let evdref = ref evd in let modified = ref false in - let rec refresh status dir t = - match kind_of_term t with - | Sort (Type u as s) when - (match Univ.universe_level u with - | None -> true - | Some l -> not onlyalg && refresh_level evd s) -> + (* direction: true for fresh universes lower than the existing ones *) + let refresh_sort status ~direction s = let s' = evd_comb0 (new_sort_variable status) evdref in let evd = - if dir then set_leq_sort env !evdref s' s + if direction then set_leq_sort env !evdref s' s else set_leq_sort env !evdref s s' in - modified := true; evdref := evd; mkSort s' - | Sort (Prop Pos as s) when refreshset && not dir -> - let s' = evd_comb0 (new_sort_variable status) evdref in - let evd = set_leq_sort env !evdref s s' in - modified := true; evdref := evd; mkSort s' + modified := true; evdref := evd; mkSort s' + in + let rec refresh ~onlyalg status ~direction t = + match kind_of_term t with + | Sort (Type u as s) -> + (match Univ.universe_level u with + | None -> refresh_sort status ~direction s + | Some l -> + (match Evd.universe_rigidity evd l with + | UnivRigid -> + if not onlyalg then refresh_sort status ~direction s + else t + | UnivFlexible alg -> + if onlyalg && alg then + (evdref := Evd.make_flexible_variable !evdref false l; t) + else t)) + | Sort (Prop Pos as s) when refreshset && not direction -> + (* Cannot make a universe "lower" than "Set", + only refreshing when we want higher universes. *) + refresh_sort status ~direction s | Prod (na,u,v) -> - mkProd (na,u,refresh status dir v) + mkProd (na, u, refresh ~onlyalg status ~direction v) | _ -> t (** Refresh the types of evars under template polymorphic references *) and refresh_term_evars onevars top t = @@ -81,7 +87,7 @@ let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false) Array.iter (refresh_term_evars onevars false) args | Evar (ev, a) when onevars -> let evi = Evd.find !evdref ev in - let ty' = refresh univ_flexible true evi.evar_concl in + let ty' = refresh ~onlyalg univ_flexible ~direction:true evi.evar_concl in if !modified then evdref := Evd.add !evdref ev {evi with evar_concl = ty'} else () @@ -101,9 +107,11 @@ let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false) in let t' = if isArity t then - (match pbty with - | None -> t - | Some dir -> refresh status dir t) + match pbty with + | None -> + (* No cumulativity needed, but we still need to refresh the algebraics *) + refresh ~onlyalg:true univ_flexible ~direction:false t + | Some direction -> refresh ~onlyalg status ~direction t else (refresh_term_evars false true t; t) in if !modified then !evdref, t' else !evdref, t @@ -613,7 +621,13 @@ let define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_si * substitution u1..uq. *) +exception MorePreciseOccurCheckNeeeded + let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = + if Evd.is_defined evd evk1 then + (* Some circularity somewhere (see e.g. #3209) *) + raise MorePreciseOccurCheckNeeeded; + let (evk1,args1) = destEvar (whd_evar evd (mkEvar (evk1,args1))) in let evi1 = Evd.find_undefined evd evk1 in let env1,rel_sign = env_rel_context_chop k env in let sign1 = evar_hyps evi1 in @@ -1553,6 +1567,8 @@ and evar_define conv_algo ?(choose=false) env evd pbty (evk,argsv as ev) rhs = postpone_non_unique_projection env evd pbty ev sols rhs | NotEnoughInformationEvarEvar t -> add_conv_oriented_pb (pbty,env,mkEvar ev,t) evd + | MorePreciseOccurCheckNeeeded -> + add_conv_oriented_pb (pbty,env,mkEvar ev,rhs) evd | NotInvertibleUsingOurAlgorithm _ | MetaOccurInBodyInternal as e -> raise e | OccurCheckIn (evd,rhs) -> @@ -1595,7 +1611,7 @@ let status_changed lev (pbty,_,t1,t2) = (try Evar.Set.mem (head_evar t1) lev with NoHeadEvar -> false) || (try Evar.Set.mem (head_evar t2) lev with NoHeadEvar -> false) -let reconsider_conv_pbs conv_algo evd = +let reconsider_unif_constraints conv_algo evd = let (evd,pbs) = extract_changed_conv_pbs evd status_changed in List.fold_left (fun p (pbty,env,t1,t2 as x) -> @@ -1608,6 +1624,8 @@ let reconsider_conv_pbs conv_algo evd = (Success evd) pbs +let reconsider_conv_pbs = reconsider_unif_constraints + (* Tries to solve problem t1 = t2. * Precondition: t1 is an uninstantiated evar * Returns an optional list of evars that were instantiated, or None @@ -1618,7 +1636,7 @@ let solve_simple_eqn conv_algo ?(choose=false) env evd (pbty,(evk1,args1 as ev1) try let t2 = whd_betaiota evd t2 in (* includes whd_evar *) let evd = evar_define conv_algo ~choose env evd pbty ev1 t2 in - reconsider_conv_pbs conv_algo evd + reconsider_unif_constraints conv_algo evd with | NotInvertibleUsingOurAlgorithm t -> UnifFailure (evd,NotClean (ev1,env,t)) diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli index f94c83b6dc..b6bdc07889 100644 --- a/pretyping/evarsolve.mli +++ b/pretyping/evarsolve.mli @@ -54,7 +54,10 @@ val solve_evar_evar : ?force:bool -> val solve_simple_eqn : conv_fun -> ?choose:bool -> env -> evar_map -> bool option * existential * constr -> unification_result +val reconsider_unif_constraints : conv_fun -> evar_map -> unification_result + val reconsider_conv_pbs : conv_fun -> evar_map -> unification_result +(** @deprecated Alias for [reconsider_unif_constraints] *) val is_unification_pattern_evar : env -> evar_map -> existential -> constr list -> constr -> constr list option diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 46f0219f91..4b6d10c640 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -239,25 +239,34 @@ let interp_elimination_sort = function | GSet -> InSet | GType _ -> InType +type inference_hook = env -> evar_map -> evar -> evar_map * constr + type inference_flags = { use_typeclasses : bool; - use_unif_heuristics : bool; - use_hook : (env -> evar_map -> evar -> constr) option; + solve_unification_constraints : bool; + use_hook : inference_hook option; fail_evar : bool; expand_evars : bool } -let frozen_holes (sigma, sigma') = - (); fun ev -> Evar.Map.mem ev (Evd.undefined_map sigma) - -let pending_holes (sigma, sigma') = - let fold evk _ accu = - if not (Evd.mem sigma evk) then Evar.Set.add evk accu else accu - in - Evd.fold_undefined fold sigma' Evar.Set.empty +(* Compute the set of still-undefined initial evars up to restriction + (e.g. clearing) and the set of yet-unsolved evars freshly created + in the extension [sigma'] of [sigma] (excluding the restrictions of + the undefined evars of [sigma] to be freshly created evars of + [sigma']). Otherwise said, we partition the undefined evars of + [sigma'] into those already in [sigma] or deriving from an evar in + [sigma] by restriction, and the evars properly created in [sigma'] *) + +let frozen_and_pending_holes (sigma, sigma') = + let add_derivative_of evk evi acc = + match advance sigma' evk with None -> acc | Some evk' -> Evar.Set.add evk' acc in + let frozen = Evd.fold_undefined add_derivative_of sigma Evar.Set.empty in + let fold evk _ accu = if not (Evar.Set.mem evk frozen) then Evar.Set.add evk accu else accu in + let pending = Evd.fold_undefined fold sigma' Evar.Set.empty in + (frozen,pending) let apply_typeclasses env evdref frozen fail_evar = - let filter_frozen = frozen in + let filter_frozen evk = Evar.Set.mem evk frozen in evdref := Typeclasses.resolve_typeclasses ~filter:(if Flags.is_program_mode () then (fun evk evi -> Typeclasses.no_goals_or_obligations evk evi && not (filter_frozen evk)) @@ -272,7 +281,7 @@ let apply_inference_hook hook evdref pending = if Evd.is_undefined sigma evk (* in particular not defined by side-effect *) then try - let c = hook sigma evk in + let sigma, c = hook sigma evk in Evd.define evk c sigma with Exit -> sigma @@ -281,7 +290,7 @@ let apply_inference_hook hook evdref pending = let apply_heuristics env evdref fail_evar = (* Resolve eagerly, potentially making wrong choices *) - try evdref := consider_remaining_unif_problems + try evdref := solve_unif_constraints_with_heuristics ~ts:(Typeclasses.classes_transparent_state ()) env !evdref with e when CErrors.noncritical e -> let e = CErrors.push e in if fail_evar then iraise e @@ -325,19 +334,17 @@ let check_evars_are_solved env current_sigma frozen pending = (* Try typeclasses, hooks, unification heuristics ... *) let solve_remaining_evars flags env current_sigma pending = - let frozen = frozen_holes pending in - let pending = pending_holes pending in + let frozen,pending = frozen_and_pending_holes pending in let evdref = ref current_sigma in if flags.use_typeclasses then apply_typeclasses env evdref frozen false; if Option.has_some flags.use_hook then apply_inference_hook (Option.get flags.use_hook env) evdref pending; - if flags.use_unif_heuristics then apply_heuristics env evdref false; + if flags.solve_unification_constraints then apply_heuristics env evdref false; if flags.fail_evar then check_evars_are_solved env !evdref frozen pending; !evdref let check_evars_are_solved env current_sigma pending = - let frozen = frozen_holes pending in - let pending = pending_holes pending in + let frozen,pending = frozen_and_pending_holes pending in check_evars_are_solved env current_sigma frozen pending let process_inference_flags flags env initial_sigma (sigma,c) = @@ -1102,14 +1109,14 @@ let ise_pretype_gen flags env sigma lvar kind c = let default_inference_flags fail = { use_typeclasses = true; - use_unif_heuristics = true; + solve_unification_constraints = true; use_hook = None; fail_evar = fail; expand_evars = true } let no_classes_no_fail_inference_flags = { use_typeclasses = false; - use_unif_heuristics = true; + solve_unification_constraints = true; use_hook = None; fail_evar = false; expand_evars = true } @@ -1173,7 +1180,7 @@ let understand_ltac flags env sigma lvar kind c = let constr_flags = { use_typeclasses = true; - use_unif_heuristics = true; + solve_unification_constraints = true; use_hook = None; fail_evar = true; expand_evars = true } diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index 824bb11aa4..0f3f7c3c9a 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -47,10 +47,12 @@ val empty_lvar : ltac_var_map type glob_constr_ltac_closure = ltac_var_map * glob_constr type pure_open_constr = evar_map * constr +type inference_hook = env -> evar_map -> evar -> evar_map * constr + type inference_flags = { use_typeclasses : bool; - use_unif_heuristics : bool; - use_hook : (env -> evar_map -> evar -> constr) option; + solve_unification_constraints : bool; + use_hook : inference_hook option; fail_evar : bool; expand_evars : bool } diff --git a/pretyping/program.ml b/pretyping/program.ml index b4333847b7..62aedcfbf6 100644 --- a/pretyping/program.ml +++ b/pretyping/program.ml @@ -15,10 +15,12 @@ open Term let make_dir l = DirPath.make (List.rev_map Id.of_string l) let find_reference locstr dir s = - let sp = Libnames.make_path (make_dir dir) (Id.of_string s) in + let dp = make_dir dir in + let sp = Libnames.make_path dp (Id.of_string s) in try Nametab.global_of_path sp with Not_found -> - anomaly ~label:locstr (Pp.str "cannot find" ++ spc () ++ Libnames.pr_path sp) + user_err_loc (Loc.ghost, "", str "Library " ++ Libnames.pr_dirpath dp ++ + str " has to be required first.") let coq_reference locstr dir s = find_reference locstr ("Coq"::dir) s let coq_constant locstr dir s = Universes.constr_of_global (coq_reference locstr dir s) diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 332d4e0b26..297f0a1a8e 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -1262,7 +1262,7 @@ let sigma_compare_sorts env pb s0 s1 sigma = match pb with | Reduction.CONV -> Evd.set_eq_sort env sigma s0 s1 | Reduction.CUMUL -> Evd.set_leq_sort env sigma s0 s1 - + let sigma_compare_instances ~flex i0 i1 sigma = try Evd.set_eq_instances ~flex sigma i0 i1 with Evd.UniversesDiffer diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli index e4cca2679c..8ca40f829f 100644 --- a/pretyping/retyping.mli +++ b/pretyping/retyping.mli @@ -46,3 +46,5 @@ val type_of_global_reference_knowing_conclusion : val sorts_of_context : env -> evar_map -> Context.Rel.t -> sorts list val expand_projection : env -> evar_map -> Names.projection -> constr -> constr list -> constr + +val print_retype_error : retype_error -> Pp.std_ppcmds diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 31ef3dfdd7..b8da6b6852 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -65,7 +65,8 @@ type typeclass = { cl_props : Context.Rel.t; (* The method implementaions as projections. *) - cl_projs : (Name.t * (direction * int option) option * constant option) list; + cl_projs : (Name.t * (direction * Vernacexpr.hint_info_expr) option + * constant option) list; cl_strict : bool; @@ -76,10 +77,9 @@ type typeclasses = typeclass Refmap.t type instance = { is_class: global_reference; - is_pri: int option; + is_info: Vernacexpr.hint_info_expr; (* Sections where the instance should be redeclared, - -1 for discard, 0 for none, mutable to avoid redeclarations - when multiple rebuild_object happen. *) + -1 for discard, 0 for none. *) is_global: int; is_poly: bool; is_impl: global_reference; @@ -89,15 +89,15 @@ type instances = (instance Refmap.t) Refmap.t let instance_impl is = is.is_impl -let instance_priority is = is.is_pri +let hint_priority is = is.is_info.Vernacexpr.hint_priority -let new_instance cl pri glob poly impl = +let new_instance cl info glob poly impl = let global = if glob then Lib.sections_depth () else -1 in { is_class = cl.cl_impl; - is_pri = pri ; + is_info = info ; is_global = global ; is_poly = poly; is_impl = impl } @@ -274,7 +274,9 @@ let check_instance env sigma c = not (Evd.has_undefined evd) with e when CErrors.noncritical e -> false -let build_subclasses ~check env sigma glob pri = +open Vernacexpr + +let build_subclasses ~check env sigma glob { hint_priority = pri } = let _id = Nametab.basename_of_global glob in let _next_id = let i = ref (-1) in @@ -297,24 +299,24 @@ let build_subclasses ~check env sigma glob pri = match b with | None -> None | Some (Backward, _) -> None - | Some (Forward, pri') -> + | Some (Forward, info) -> let proj = Option.get proj in let body = it_mkLambda_or_LetIn (mkApp (mkConstU (proj,u), projargs)) rels in if check && check_instance env sigma body then None else - let pri = - match pri, pri' with + let newpri = + match pri, info.hint_priority with | Some p, Some p' -> Some (p + p') | Some p, None -> Some (p + 1) | _, _ -> None in - Some (ConstRef proj, pri, body)) tc.cl_projs + Some (ConstRef proj, { info with hint_priority = newpri }, body)) tc.cl_projs in - let declare_proj hints (cref, pri, body) = + let declare_proj hints (cref, info, body) = let path' = cref :: path in let ty = Retyping.get_type_of env sigma body in let rest = aux pri body ty path' in - hints @ (path', pri, body) :: rest + hints @ (path', info, body) :: rest in List.fold_left declare_proj [] projs in let term = Universes.constr_of_global_univ (glob,Univ.UContext.instance ctx) in @@ -368,11 +370,11 @@ let is_local i = Int.equal i.is_global (-1) let add_instance check inst = let poly = Global.is_polymorphic inst.is_impl in add_instance_hint (IsGlobal inst.is_impl) [inst.is_impl] (is_local inst) - inst.is_pri poly; + inst.is_info poly; List.iter (fun (path, pri, c) -> add_instance_hint (IsConstr c) path (is_local inst) pri poly) (build_subclasses ~check:(check && not (isVarRef inst.is_impl)) - (Global.env ()) (Evd.from_env (Global.env ())) inst.is_impl inst.is_pri) + (Global.env ()) (Evd.from_env (Global.env ())) inst.is_impl inst.is_info) let rebuild_instance (action, inst) = let () = match action with @@ -404,26 +406,22 @@ let remove_instance i = Lib.add_anonymous_leaf (instance_input (RemoveInstance, i)); remove_instance_hint i.is_impl -let declare_instance pri local glob = +let declare_instance info local glob = let ty = Global.type_of_global_unsafe glob in + let info = Option.default {hint_priority = None; hint_pattern = None} info in match class_of_constr ty with | Some (rels, ((tc,_), args) as _cl) -> - add_instance (new_instance tc pri (not local) (Flags.use_polymorphic_flag ()) glob) -(* let path, hints = build_subclasses (not local) (Global.env ()) Evd.empty glob in *) -(* let entries = List.map (fun (path, pri, c) -> (pri, local, path, c)) hints in *) -(* Auto.add_hints local [typeclasses_db] (Auto.HintsResolveEntry entries); *) -(* Auto.add_hints local [typeclasses_db] *) -(* (Auto.HintsCutEntry (PathSeq (PathStar (PathAtom PathAny), path))) *) + add_instance (new_instance tc info (not local) (Flags.use_polymorphic_flag ()) glob) | None -> () let add_class cl = add_class cl; List.iter (fun (n, inst, body) -> match inst with - | Some (Backward, pri) -> + | Some (Backward, info) -> (match body with | None -> CErrors.error "Non-definable projection can not be declared as a subinstance" - | Some b -> declare_instance pri false (ConstRef b)) + | Some b -> declare_instance (Some info) false (ConstRef b)) | _ -> ()) cl.cl_projs diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli index 2530f5dfae..620bc367bd 100644 --- a/pretyping/typeclasses.mli +++ b/pretyping/typeclasses.mli @@ -32,7 +32,7 @@ type typeclass = { Some may be undefinable due to sorting restrictions or simply undefined if no name is provided. The [int option option] indicates subclasses whose hint has the given priority. *) - cl_projs : (Name.t * (direction * int option) option * constant option) list; + cl_projs : (Name.t * (direction * Vernacexpr.hint_info_expr) option * constant option) list; (** Whether we use matching or full unification during resolution *) cl_strict : bool; @@ -50,7 +50,7 @@ val all_instances : unit -> instance list val add_class : typeclass -> unit -val new_instance : typeclass -> int option -> bool -> Decl_kinds.polymorphic -> +val new_instance : typeclass -> Vernacexpr.hint_info_expr -> bool -> Decl_kinds.polymorphic -> global_reference -> instance val add_instance : instance -> unit val remove_instance : instance -> unit @@ -71,7 +71,7 @@ val class_of_constr : constr -> (Context.Rel.t * (typeclass puniverses * constr val instance_impl : instance -> global_reference -val instance_priority : instance -> int option +val hint_priority : instance -> int option val is_class : global_reference -> bool val is_instance : global_reference -> bool @@ -113,21 +113,22 @@ val classes_transparent_state : unit -> transparent_state val add_instance_hint_hook : (global_reference_or_constr -> global_reference list -> - bool (* local? *) -> int option -> Decl_kinds.polymorphic -> unit) Hook.t + bool (* local? *) -> Vernacexpr.hint_info_expr -> Decl_kinds.polymorphic -> unit) Hook.t val remove_instance_hint_hook : (global_reference -> unit) Hook.t val add_instance_hint : global_reference_or_constr -> global_reference list -> - bool -> int option -> Decl_kinds.polymorphic -> unit + bool -> Vernacexpr.hint_info_expr -> Decl_kinds.polymorphic -> unit val remove_instance_hint : global_reference -> unit val solve_all_instances_hook : (env -> evar_map -> evar_filter -> bool -> bool -> bool -> evar_map) Hook.t val solve_one_instance_hook : (env -> evar_map -> types -> bool -> open_constr) Hook.t -val declare_instance : int option -> bool -> global_reference -> unit +val declare_instance : Vernacexpr.hint_info_expr option -> bool -> global_reference -> unit (** Build the subinstances hints for a given typeclass object. check tells if we should check for existence of the subinstances and add only the missing ones. *) -val build_subclasses : check:bool -> env -> evar_map -> global_reference -> int option (* priority *) -> - (global_reference list * int option * constr) list +val build_subclasses : check:bool -> env -> evar_map -> global_reference -> + Vernacexpr.hint_info_expr -> + (global_reference list * Vernacexpr.hint_info_expr * constr) list diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 6573bd238c..259318693f 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -1220,7 +1220,7 @@ let is_mimick_head ts f = let try_to_coerce env evd c cty tycon = let j = make_judge c cty in let (evd',j') = inh_conv_coerce_rigid_to true Loc.ghost env evd j tycon in - let evd' = Evarconv.consider_remaining_unif_problems env evd' in + let evd' = Evarconv.solve_unif_constraints_with_heuristics env evd' in let evd' = Evd.map_metas_fvalue (nf_evar evd') evd' in (evd',j'.uj_val) @@ -1270,7 +1270,11 @@ let solve_simple_evar_eqn ts env evd ev rhs = | UnifFailure (evd,reason) -> error_cannot_unify env evd ~reason (mkEvar ev,rhs); | Success evd -> - Evarconv.consider_remaining_unif_problems env evd + if Flags.version_less_or_equal Flags.V8_5 then + (* We used to force solving unrelated problems at arbitrary times *) + Evarconv.solve_unif_constraints_with_heuristics env evd + else (* solve_simple_eqn calls reconsider_unif_constraints itself *) + evd (* [w_merge env sigma b metas evars] merges common instances in metas or in evars, possibly generating new unification problems; if [b] @@ -1297,7 +1301,6 @@ let w_merge env with_types flags (evd,metas,evars) = if is_mimick_head flags.modulo_delta f then let evd' = mimick_undefined_evar evd flags f (Array.length cl) evk in - (* let evd' = Evarconv.consider_remaining_unif_problems env evd' in *) w_merge_rec evd' metas evars eqns else let evd' = @@ -1389,10 +1392,11 @@ let w_merge env with_types flags (evd,metas,evars) = in w_merge_rec evd [] [] eqns in let res = (* merge constraints *) - w_merge_rec evd (order_metas metas) (List.rev evars) [] + w_merge_rec evd (order_metas metas) + (* Assign evars in the order of assignments during unification *) + (List.rev evars) [] in - if with_types then check_types res - else res + if with_types then check_types res else res let w_unify_meta_types env ?(flags=default_unify_flags ()) evd = let metas,evd = retract_coercible_metas evd in @@ -1450,7 +1454,7 @@ let w_typed_unify_array env evd flags f1 l1 f2 l2 = let subst = Array.fold_left2 fold_subst subst l1 l2 in let evd = w_merge env true flags.merge_unify_flags subst in try_resolve_typeclasses env evd flags.resolve_evars - (mkApp(f1,l1)) (mkApp(f2,l2)) + (mkApp(f1,l1)) (mkApp(f2,l2)) (* takes a substitution s, an open term op and a closed term cl try to find a subterm of cl which matches op, if op is just a Meta @@ -1587,7 +1591,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = let x = id_of_name_using_hdchar (Global.env()) t name in let ids = ids_of_named_context (named_context env) in if name == Anonymous then next_ident_away_in_goal x ids else - if mem_named_context x (named_context env) then + if mem_named_context_val x (named_context_val env) then errorlabstrm "Unification.make_abstraction_core" (str "The variable " ++ Nameops.pr_id x ++ str " is already declared.") else @@ -1879,21 +1883,14 @@ let secondOrderAbstraction env evd flags typ (p, oplist) = error_wrong_abstraction_type env evd' (Evd.meta_name evd p) pred typp predtyp; w_merge env false flags.merge_unify_flags - (evd',[p,pred,(Conv,TypeProcessed)],[]) - - (* let evd',metas,evars = *) - (* try unify_0 env evd' CUMUL flags predtyp typp *) - (* with NotConvertible -> *) - (* error_wrong_abstraction_type env evd *) - (* (Evd.meta_name evd p) pred typp predtyp *) - (* in *) - (* w_merge env false flags (evd',(p,pred,(Conv,TypeProcessed))::metas,evars) *) + (evd',[p,pred,(Conv,TypeProcessed)],[]) let secondOrderDependentAbstraction env evd flags typ (p, oplist) = let typp = Typing.meta_type evd p in let evd, pred = abstract_list_all_with_dependencies env evd typp typ oplist in w_merge env false flags.merge_unify_flags - (evd,[p,pred,(Conv,TypeProcessed)],[]) + (evd,[p,pred,(Conv,TypeProcessed)],[]) + let secondOrderAbstractionAlgo dep = if dep then secondOrderDependentAbstraction else secondOrderAbstraction diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index a00e4bab30..80ddd669f4 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -129,7 +129,7 @@ end) = struct str "`" ++ str hd ++ c ++ str tl let pr_com_at n = - if Flags.do_beautify() && not (Int.equal n 0) then comment n + if !Flags.beautify && not (Int.equal n 0) then comment (CLexer.extract_comments n) else mt() let pr_with_comments loc pp = pr_located (fun x -> x) (loc,pp) @@ -149,6 +149,12 @@ end) = struct | GType [] -> tag_type (str "Type") | GType u -> hov 0 (tag_type (str "Type") ++ pr_univ_annot pr_univ u) + let pr_glob_level = function + | GProp -> tag_type (str "Prop") + | GSet -> tag_type (str "Set") + | GType None -> tag_type (str "Type") + | GType (Some (_, u)) -> tag_type (str u) + let pr_qualid sp = let (sl, id) = repr_qualid sp in let id = tag_ref (pr_id id) in @@ -364,13 +370,13 @@ end) = struct let n = begin_of_binders bl in match bl with | [LocalRawAssum (nal,k,t)] -> - pr_com_at n ++ kw() ++ pr_binder false pr_c (nal,k,t) + kw n ++ pr_binder false pr_c (nal,k,t) | (LocalRawAssum _ | LocalPattern _) :: _ as bdl -> - pr_com_at n ++ kw() ++ pr_undelimited_binders sep pr_c bdl + kw n ++ pr_undelimited_binders sep pr_c bdl | _ -> assert false let pr_binders_gen pr_c sep is_open = - if is_open then pr_delimited_binders mt sep pr_c + if is_open then pr_delimited_binders pr_com_at sep pr_c else pr_undelimited_binders sep pr_c let rec extract_prod_binders = function @@ -436,7 +442,7 @@ end) = struct let pr_recursive_decl pr pr_dangling dangling_with_for id bl annot t c = let pr_body = if dangling_with_for then pr_dangling else pr in - pr_id id ++ str" " ++ + pr_id id ++ (if bl = [] then mt () else str" ") ++ hov 0 (pr_undelimited_binders spc (pr ltop) bl ++ annot) ++ pr_opt_type_spc pr t ++ str " :=" ++ pr_sep_com (fun () -> brk(1,2)) (pr_body ltop) c @@ -519,9 +525,9 @@ end) = struct prlist_with_sep pr_semicolon (fun (id, c) -> h 1 (pr_reference id ++ spc () ++ str":=" ++ pr ltop c)) l - let pr_forall () = keyword "forall" ++ spc () + let pr_forall n = keyword "forall" ++ pr_com_at n ++ spc () - let pr_fun () = keyword "fun" ++ spc () + let pr_fun n = keyword "fun" ++ pr_com_at n ++ spc () let pr_fun_sep = spc () ++ str "=>" diff --git a/printing/ppconstrsig.mli b/printing/ppconstrsig.mli index a59fc6d67d..3de0d805c4 100644 --- a/printing/ppconstrsig.mli +++ b/printing/ppconstrsig.mli @@ -44,6 +44,7 @@ module type Pp = sig val pr_qualid : qualid -> std_ppcmds val pr_patvar : patvar -> std_ppcmds + val pr_glob_level : glob_level -> std_ppcmds val pr_glob_sort : glob_sort -> std_ppcmds val pr_guard_annot : (constr_expr -> std_ppcmds) -> local_binder list -> diff --git a/printing/pptactic.ml b/printing/pptactic.ml index f3117db170..fcc30d702f 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -219,7 +219,7 @@ module Make | ConstrContext ((_,id),c) -> hov 0 (keyword "context" ++ spc () ++ pr_id id ++ spc () ++ - str "[" ++ prlc c ++ str "]") + str "[ " ++ prlc c ++ str " ]") | ConstrTypeOf c -> hov 1 (keyword "type of" ++ spc() ++ prc c) | ConstrTerm c when test c -> @@ -583,13 +583,13 @@ module Make | None -> mt() let pr_hyp_location pr_id = function - | occs, InHyp -> spc () ++ pr_with_occurrences pr_id occs + | occs, InHyp -> pr_with_occurrences pr_id occs | occs, InHypTypeOnly -> - spc () ++ pr_with_occurrences (fun id -> + pr_with_occurrences (fun id -> str "(" ++ keyword "type of" ++ spc () ++ pr_id id ++ str ")" ) occs | occs, InHypValueOnly -> - spc () ++ pr_with_occurrences (fun id -> + pr_with_occurrences (fun id -> str "(" ++ keyword "value of" ++ spc () ++ pr_id id ++ str ")" ) occs @@ -603,6 +603,17 @@ module Make | None -> mt () | Some (id,ipat) -> pr_in (spc () ++ pr_id id) ++ pr_as_ipat prc ipat + let pr_in_clause pr_id = function + | { onhyps=None; concl_occs=NoOccurrences } -> + (str "* |-") + | { onhyps=None; concl_occs=occs } -> + (pr_with_occurrences (fun () -> str "*") (occs,())) + | { onhyps=Some l; concl_occs=NoOccurrences } -> + prlist_with_sep (fun () -> str ", ") (pr_hyp_location pr_id) l + | { onhyps=Some l; concl_occs=occs } -> + let pr_occs = pr_with_occurrences (fun () -> str" |- *") (occs,()) in + (prlist_with_sep (fun () -> str", ") (pr_hyp_location pr_id) l ++ pr_occs) + let pr_clauses default_is_concl pr_id = function | { onhyps=Some []; concl_occs=occs } when (match default_is_concl with Some true -> true | _ -> false) -> @@ -619,7 +630,8 @@ module Make | _ -> pr_with_occurrences (fun () -> str" |- *") (occs,()) in pr_in - (prlist_with_sep (fun () -> str",") (pr_hyp_location pr_id) l ++ pr_occs) + (prlist_with_sep (fun () -> str",") + (fun id -> spc () ++ pr_hyp_location pr_id id) l ++ pr_occs) let pr_orient b = if b then mt () else str "<- " @@ -664,9 +676,9 @@ module Make | Subterm (b,None,a) -> (** ppedrot: we don't make difference between [appcontext] and [context] anymore, and the interpretation is governed by a flag instead. *) - keyword "context" ++ str" [" ++ pr_pat a ++ str "]" + keyword "context" ++ str" [ " ++ pr_pat a ++ str " ]" | Subterm (b,Some id,a) -> - keyword "context" ++ spc () ++ pr_id id ++ str "[" ++ pr_pat a ++ str "]" + keyword "context" ++ spc () ++ pr_id id ++ str "[ " ++ pr_pat a ++ str " ]" let pr_match_hyps pr_pat = function | Hyp (nal,mp) -> @@ -1205,7 +1217,7 @@ module Make | TacNumgoals -> keyword "numgoals" | (TacCall _|Tacexp _ | TacGeneric _) as a -> - keyword "ltac:" ++ pr_tac (latom,E) (TacArg (Loc.ghost,a)) + hov 0 (keyword "ltac:" ++ surround (pr_tac ltop (TacArg (Loc.ghost,a)))) in pr_tac diff --git a/printing/pptacticsig.mli b/printing/pptacticsig.mli index c08d6044db..665e055f23 100644 --- a/printing/pptacticsig.mli +++ b/printing/pptacticsig.mli @@ -29,6 +29,9 @@ module type Pp = sig val pr_and_short_name : ('a -> std_ppcmds) -> 'a and_short_name -> std_ppcmds val pr_or_by_notation : ('a -> std_ppcmds) -> 'a or_by_notation -> std_ppcmds + val pr_in_clause : + ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds + val pr_clauses : bool option -> ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds diff --git a/printing/pputils.ml b/printing/pputils.ml index 906b463a85..50ce56fb02 100644 --- a/printing/pputils.ml +++ b/printing/pputils.ml @@ -9,7 +9,11 @@ open Pp let pr_located pr (loc, x) = - if Flags.do_beautify () && loc <> Loc.ghost then + if !Flags.beautify && loc <> Loc.ghost then let (b, e) = Loc.unloc loc in - Pp.comment b ++ pr x ++ Pp.comment e + (* Side-effect: order matters *) + let before = Pp.comment (CLexer.extract_comments b) in + let x = pr x in + let after = Pp.comment (CLexer.extract_comments e) in + before ++ x ++ after else pr x diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index 40ce28dc0c..5d6d36d569 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -166,14 +166,17 @@ module Make | ModeNoHeadEvar -> str"!" | ModeOutput -> str"-" + let pr_hint_info pr_pat { hint_priority = pri; hint_pattern = pat } = + pr_opt (fun x -> str"|" ++ int x) pri ++ + pr_opt (fun y -> (if Option.is_empty pri then str"| " else mt()) ++ pr_pat y) pat + let pr_hints db h pr_c pr_pat = let opth = pr_opt_hintbases db in let pph = match h with | HintsResolve l -> keyword "Resolve " ++ prlist_with_sep sep - (fun (pri, _, c) -> pr_reference_or_constr pr_c c ++ - match pri with Some x -> spc () ++ str"(" ++ int x ++ str")" | None -> mt ()) + (fun (info, _, c) -> pr_reference_or_constr pr_c c ++ pr_hint_info pr_pat info) l | HintsImmediate l -> keyword "Immediate" ++ spc() ++ @@ -263,7 +266,7 @@ module Make let pr_decl_notation prc ((loc,ntn),c,scopt) = fnl () ++ keyword "where " ++ qs ntn ++ str " := " - ++ Flags.without_option Flags.beautify_file prc c ++ + ++ Flags.without_option Flags.beautify prc c ++ pr_opt (fun sc -> str ": " ++ str sc) scopt let pr_binders_arg = @@ -367,8 +370,8 @@ module Make | SetAssoc NonA -> keyword "no associativity" | SetEntryType (x,typ) -> str x ++ spc() ++ pr_set_entry_type typ | SetOnlyPrinting -> keyword "only printing" - | SetOnlyParsing Flags.Current -> keyword "only parsing" - | SetOnlyParsing v -> keyword("compat \"" ^ Flags.pr_version v ^ "\"") + | SetOnlyParsing -> keyword "only parsing" + | SetCompatVersion v -> keyword("compat \"" ^ Flags.pr_version v ^ "\"") | SetFormat("text",s) -> keyword "format " ++ pr_located qs s | SetFormat(k,s) -> keyword "format " ++ qs k ++ spc() ++ pr_located qs s @@ -383,7 +386,7 @@ module Make | Some pl -> str"@{" ++ prlist_with_sep spc pr_lident pl ++ str"}" let pr_rec_definition ((((loc,id),pl),ro,bl,type_,def),ntn) = - let pr_pure_lconstr c = Flags.without_option Flags.beautify_file pr_lconstr c in + let pr_pure_lconstr c = Flags.without_option Flags.beautify pr_lconstr c in let annot = pr_guard_annot pr_lconstr_expr bl ro in pr_id id ++ pr_univs pl ++ pr_binders_arg bl ++ annot ++ pr_type_option (fun c -> spc() ++ pr_lconstr_expr c) type_ @@ -678,7 +681,7 @@ module Make | VernacNotation (_,c,((_,s),l),opt) -> return ( hov 2 (keyword "Notation" ++ spc() ++ qs s ++ - str " :=" ++ Flags.without_option Flags.beautify_file pr_constrarg c ++ pr_syntax_modifiers l ++ + str " :=" ++ Flags.without_option Flags.beautify pr_constrarg c ++ pr_syntax_modifiers l ++ (match opt with | None -> mt() | Some sc -> str" :" ++ spc() ++ str sc)) @@ -760,7 +763,7 @@ module Make let pr_constructor (coe,(id,c)) = hov 2 (pr_lident id ++ str" " ++ (if coe then str":>" else str":") ++ - Flags.without_option Flags.beautify_file pr_spc_lconstr c) + Flags.without_option Flags.beautify pr_spc_lconstr c) in let pr_constructor_list b l = match l with | Constructors [] -> mt() @@ -838,7 +841,8 @@ module Make ) | VernacConstraint v -> let pr_uconstraint (l, d, r) = - pr_lident l ++ spc () ++ Univ.pr_constraint_type d ++ spc () ++ pr_lident r + pr_glob_level l ++ spc () ++ Univ.pr_constraint_type d ++ spc () ++ + pr_glob_level r in return ( hov 2 (keyword "Constraint" ++ spc () ++ @@ -887,7 +891,7 @@ module Make spc() ++ pr_class_rawexpr c2) ) - | VernacInstance (abst, sup, (instid, bk, cl), props, pri) -> + | VernacInstance (abst, sup, (instid, bk, cl), props, info) -> return ( hov 1 ( (if abst then keyword "Declare" ++ spc () else mt ()) ++ @@ -898,7 +902,7 @@ module Make pr_and_type_binders_arg sup ++ str":" ++ spc () ++ (match bk with Implicit -> str "! " | Explicit -> mt ()) ++ - pr_constr cl ++ pr_priority pri ++ + pr_constr cl ++ pr_hint_info pr_constr_pattern_expr info ++ (match props with | Some (true,CRecord (_,l)) -> spc () ++ str":=" ++ spc () ++ str"{" ++ pr_record_body l ++ str "}" | Some (true,_) -> assert false @@ -909,14 +913,17 @@ module Make | VernacContext l -> return ( hov 1 ( - keyword "Context" ++ spc () ++ pr_and_type_binders_arg l) + keyword "Context" ++ pr_and_type_binders_arg l) ) - | VernacDeclareInstances (ids, pri) -> - return ( + | VernacDeclareInstances insts -> + let pr_inst (id, info) = + pr_reference id ++ pr_hint_info pr_constr_pattern_expr info + in + return ( hov 1 (keyword "Existing" ++ spc () ++ - keyword(String.plural (List.length ids) "Instance") ++ - spc () ++ prlist_with_sep spc pr_reference ids ++ pr_priority pri) + keyword(String.plural (List.length insts) "Instance") ++ + spc () ++ prlist_with_sep (fun () -> str", ") pr_inst insts) ) | VernacDeclareClass id -> @@ -1002,13 +1009,16 @@ module Make ) | VernacHints (_, dbnames,h) -> return (pr_hints dbnames h pr_constr pr_constr_pattern_expr) - | VernacSyntacticDefinition (id,(ids,c),_,onlyparsing) -> + | VernacSyntacticDefinition (id,(ids,c),_,compat) -> return ( hov 2 (keyword "Notation" ++ spc () ++ pr_lident id ++ spc () ++ prlist_with_sep spc pr_id ids ++ str":=" ++ pr_constrarg c ++ pr_syntax_modifiers - (match onlyparsing with None -> [] | Some v -> [SetOnlyParsing v])) + (match compat with + | None -> [] + | Some Flags.Current -> [SetOnlyParsing] + | Some v -> [SetCompatVersion v])) ) | VernacDeclareImplicits (q,[]) -> return ( @@ -1022,25 +1032,36 @@ module Make str"[" ++ prlist_with_sep sep pr_explanation imps ++ str"]") impls) ) - | VernacArguments (q, impl, nargs, mods) -> + | VernacArguments (q, args, more_implicits, nargs, mods) -> return ( hov 2 ( keyword "Arguments" ++ spc() ++ pr_smart_global q ++ let pr_s = function None -> str"" | Some (_,s) -> str "%" ++ str s in let pr_if b x = if b then x else str "" in - let pr_br imp max x = match imp, max with - | true, false -> str "[" ++ x ++ str "]" - | true, true -> str "{" ++ x ++ str "}" - | _ -> x in - let rec aux n l = + let pr_br imp x = match imp with + | Vernacexpr.Implicit -> str "[" ++ x ++ str "]" + | Vernacexpr.MaximallyImplicit -> str "{" ++ x ++ str "}" + | Vernacexpr.NotImplicit -> x in + let rec print_arguments n l = match n, l with - | 0, l -> spc () ++ str"/" ++ aux ~-1 l + | Some 0, l -> spc () ++ str"/" ++ print_arguments None l | _, [] -> mt() - | n, (id,k,s,imp,max) :: tl -> - spc() ++ pr_br imp max (pr_if k (str"!") ++ pr_name id ++ pr_s s) ++ - aux (n-1) tl in - prlist_with_sep (fun () -> str", ") (aux nargs) impl ++ + | n, { name = id; recarg_like = k; + notation_scope = s; + implicit_status = imp } :: tl -> + spc() ++ pr_br imp (pr_if k (str"!") ++ pr_name id ++ pr_s s) ++ + print_arguments (Option.map pred n) tl + in + let rec print_implicits = function + | [] -> mt () + | (name, impl) :: rest -> + spc() ++ pr_br impl (pr_name name) ++ print_implicits rest + in + print_arguments nargs args ++ + if not (List.is_empty more_implicits) then + prlist (fun l -> str"," ++ print_implicits l) more_implicits + else (mt ()) ++ (if not (List.is_empty mods) then str" : " else str"") ++ prlist_with_sep (fun () -> str", " ++ spc()) (function | `ReductionDontExposeCase -> keyword "simpl nomatch" @@ -1107,6 +1128,11 @@ module Make return ( hov 2 (keyword "Set" ++ spc() ++ pr_set_option na v) ) + | VernacSetAppendOption (na,v) -> + return ( + hov 2 (keyword "Set" ++ spc() ++ pr_printoption na None ++ + spc() ++ keyword "Append" ++ spc() ++ qs v) + ) | VernacAddOption (na,l) -> return ( hov 2 (keyword "Add" ++ spc() ++ pr_printoption na (Some l)) diff --git a/printing/prettyp.ml b/printing/prettyp.ml index f71719cb9a..e117f1dcb0 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -241,7 +241,7 @@ let print_name_infos ref = let impls = implicits_of_global ref in let scopes = Notation.find_arguments_scope ref in let renames = - try List.hd (Arguments_renaming.arguments_names ref) with Not_found -> [] in + try Arguments_renaming.arguments_names ref with Not_found -> [] in let type_info_for_implicit = if need_expansion (select_impargs_size 0 impls) ref then (* Need to reduce since implicits are computed with products flattened *) @@ -281,7 +281,7 @@ let print_inductive_implicit_args = let print_inductive_renames = print_args_data_of_inductive_ids (fun r -> - try List.hd (Arguments_renaming.arguments_names r) with Not_found -> []) + try Arguments_renaming.arguments_names r with Not_found -> []) ((!=) Anonymous) print_renames_list @@ -872,7 +872,7 @@ let pr_instance env i = (* gallina_print_constant_with_infos i.is_impl *) (* lighter *) print_ref false (instance_impl i) ++ - begin match instance_priority i with + begin match hint_priority i with | None -> mt () | Some i -> spc () ++ str "|" ++ spc () ++ int i end diff --git a/printing/printer.ml b/printing/printer.ml index 6d54a5b3d5..04337f6be8 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -424,7 +424,16 @@ let pr_evgl_sign sigma evi = (str "(" ++ prlist_with_sep pr_comma pr_id ids ++ str " cannot be used)") in let pc = pr_lconstr_env env sigma evi.evar_concl in - hov 0 (str"[" ++ ps ++ spc () ++ str"|- " ++ pc ++ str"]" ++ spc () ++ warn) + let candidates = + match evi.evar_body, evi.evar_candidates with + | Evar_empty, Some l -> + spc () ++ str "= {" ++ + prlist_with_sep (fun () -> str "|") (pr_lconstr_env env sigma) l ++ str "}" + | _ -> + mt () + in + hov 0 (str"[" ++ ps ++ spc () ++ str"|- " ++ pc ++ str"]" ++ + candidates ++ spc () ++ warn) (* Print an existential variable *) @@ -471,7 +480,7 @@ let default_pr_subgoal n sigma = let pr_internal_existential_key ev = str (string_of_existential ev) -let print_evar_constraints gl sigma cstrs = +let print_evar_constraints gl sigma = let pr_env = match gl with | None -> fun e' -> pr_context_of e' sigma @@ -487,6 +496,14 @@ let print_evar_constraints gl sigma cstrs = let pr_evconstr (pbty,env,t1,t2) = let t1 = Evarutil.nf_evar sigma t1 and t2 = Evarutil.nf_evar sigma t2 in + let env = + (** We currently allow evar instances to refer to anonymous de Bruijn + indices, so we protect the error printing code in this case by giving + names to every de Bruijn variable in the rel_context of the conversion + problem. MS: we should rather stop depending on anonymous variables, they + can be used to indicate independency. Also, this depends on a strategy for + naming/renaming *) + Namegen.make_all_name_different env in str" " ++ hov 2 (pr_env env ++ pr_lconstr_env env sigma t1 ++ spc () ++ str (match pbty with @@ -494,9 +511,25 @@ let print_evar_constraints gl sigma cstrs = | Reduction.CUMUL -> "<=") ++ spc () ++ pr_lconstr_env env sigma t2) in - prlist_with_sep fnl pr_evconstr cstrs + let pr_candidate ev evi (candidates,acc) = + if Option.has_some evi.evar_candidates then + (succ candidates, acc ++ pr_evar sigma (ev,evi) ++ fnl ()) + else (candidates, acc) + in + let constraints = + let _, cstrs = Evd.extract_all_conv_pbs sigma in + if List.is_empty cstrs then mt () + else fnl () ++ str (String.plural (List.length cstrs) "unification constraint") + ++ str":" ++ fnl () ++ hov 0 (prlist_with_sep fnl pr_evconstr cstrs) + in + let candidates, ppcandidates = Evd.fold_undefined pr_candidate sigma (0,mt ()) in + constraints ++ + if candidates > 0 then + fnl () ++ str (String.plural candidates "existential") ++ + str" with candidates:" ++ fnl () ++ hov 0 ppcandidates + else mt () -let should_print_dependent_evars = ref true +let should_print_dependent_evars = ref false let _ = let open Goptions in @@ -509,12 +542,7 @@ let _ = optwrite = (fun v -> should_print_dependent_evars := v) } let print_dependent_evars gl sigma seeds = - let constraints = - let _, cstrs = Evd.extract_all_conv_pbs sigma in - if List.is_empty cstrs then mt () - else fnl () ++ str (String.plural (List.length cstrs) "unification constraint") - ++ str":" ++ fnl () ++ hov 0 (print_evar_constraints gl sigma cstrs) - in + 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 diff --git a/printing/printmod.ml b/printing/printmod.ml index c939f54e80..dfa66d4376 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -247,19 +247,24 @@ let get_typ_expr_alg mtb = match mtb.mod_type_alg with | _ -> raise Not_found let nametab_register_modparam mbid mtb = + let id = MBId.to_id mbid in match mtb.mod_type with - | MoreFunctor _ -> () (* functorial param : nothing to register *) + | MoreFunctor _ -> id (* functorial param : nothing to register *) | NoFunctor struc -> (* We first try to use the algebraic type expression if any, via a Declaremods function that converts back to module entries *) try - Declaremods.process_module_binding mbid (get_typ_expr_alg mtb) + let () = Declaremods.process_module_binding mbid (get_typ_expr_alg mtb) in + id with e when CErrors.noncritical e -> (* Otherwise, we try to play with the nametab ourselves *) let mp = MPbound mbid in - let dir = DirPath.make [MBId.to_id mbid] in + let check id = Nametab.exists_dir (DirPath.make [id]) in + let id = Namegen.next_ident_away_from id check in + let dir = DirPath.make [id] in nametab_register_dir mp; - List.iter (nametab_register_body mp dir) struc + List.iter (nametab_register_body mp dir) struc; + id let print_body is_impl env mp (l,body) = let name = pr_label l in @@ -353,7 +358,7 @@ let print_mod_expr env mp locals = function let rec print_functor fty fatom is_type env mp locals = function |NoFunctor me -> fatom is_type env mp locals me |MoreFunctor (mbid,mtb1,me2) -> - nametab_register_modparam mbid mtb1; + let id = nametab_register_modparam mbid mtb1 in let mp1 = MPbound mbid in let pr_mtb1 = fty env mp1 locals mtb1 in let env' = Option.map (Modops.add_module_type mp1 mtb1) env in @@ -361,7 +366,7 @@ let rec print_functor fty fatom is_type env mp locals = function let kwd = if is_type then "Funsig" else "Functor" in hov 2 (keyword kwd ++ spc () ++ - str "(" ++ pr_id (MBId.to_id mbid) ++ str ":" ++ pr_mtb1 ++ str ")" ++ + str "(" ++ pr_id id ++ str ":" ++ pr_mtb1 ++ str ")" ++ spc() ++ print_functor fty fatom is_type env' mp locals' me2) let rec print_expression x = diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index 5f0cc73d2c..29cad06352 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -46,7 +46,7 @@ let w_refine (evk,evi) (ltac_var,rawc) sigma = let sigma',typed_c = let flags = { Pretyping.use_typeclasses = true; - Pretyping.use_unif_heuristics = true; + Pretyping.solve_unification_constraints = true; Pretyping.use_hook = None; Pretyping.fail_evar = false; Pretyping.expand_evars = true } in diff --git a/proofs/logic.ml b/proofs/logic.ml index e4c833627a..65497c80dd 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -538,7 +538,7 @@ let prim_refiner r sigma goal = nexthyp, t,cl,sigma else - (if !check && mem_named_context id (named_context_of_val sign) then + (if !check && mem_named_context_val id sign then errorlabstrm "Logic.prim_refiner" (str "Variable " ++ pr_id id ++ str " is already declared."); push_named_context_val (LocalAssum (id,t)) sign,t,cl,sigma) in diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index e4bae20128..eddbf72a89 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -13,6 +13,17 @@ open Entries open Environ open Evd +let use_unification_heuristics_ref = ref true +let _ = Goptions.declare_bool_option { + Goptions.optsync = true; Goptions.optdepr = false; + Goptions.optname = "Solve unification constraints at every \".\""; + Goptions.optkey = ["Solve";"Unification";"Constraints"]; + Goptions.optread = (fun () -> !use_unification_heuristics_ref); + Goptions.optwrite = (fun a -> use_unification_heuristics_ref:=a); +} + +let use_unification_heuristics () = !use_unification_heuristics_ref + let refining = Proof_global.there_are_pending_proofs let check_no_pending_proofs = Proof_global.check_no_pending_proof @@ -119,6 +130,11 @@ let solve ?with_end_tac gi info_lvl tac pr = | Vernacexpr.SelectId id -> Proofview.tclFOCUSID id tac | Vernacexpr.SelectAll -> tac in + let tac = + if use_unification_heuristics () then + Proofview.tclTHEN tac Refine.solve_constraints + else tac + in let (p,(status,info)) = Proof.run_tactic (Global.env ()) tac pr in let () = match info_lvl with @@ -161,11 +177,12 @@ let build_constant_by_tactic id ctx sign ?(goal_kind = Global, false, Proof Theo delete_current_proof (); iraise reraise -let build_by_tactic ?(side_eff=true) env ctx ?(poly=false) typ tac = +let build_by_tactic ?(side_eff=true) env sigma ?(poly=false) typ tac = let id = Id.of_string ("temporary_proof"^string_of_int (next())) in let sign = val_of_named_context (named_context env) in let gk = Global, poly, Proof Theorem in - let ce, status, univs = build_constant_by_tactic id ctx sign ~goal_kind:gk typ tac in + let ce, status, univs = + build_constant_by_tactic id sigma sign ~goal_kind:gk typ tac in let ce = if side_eff then Safe_typing.inline_private_constants_in_definition_entry env ce else { ce with @@ -232,8 +249,9 @@ let solve_by_implicit_tactic env sigma evk = (try let c = Evarutil.nf_evars_universes sigma evi.evar_concl in if Evarutil.has_undefined_evars sigma c then raise Exit; - let (ans, _, _) = + let (ans, _, ctx) = build_by_tactic env (Evd.evar_universe_context sigma) c tac in - ans + let sigma = Evd.set_universe_context sigma ctx in + sigma, ans with e when Logic.catchable_exception e -> raise Exit) | _ -> raise Exit diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index 666730e1af..ea604e08eb 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -167,7 +167,8 @@ val instantiate_nth_evar_com : int -> Constrexpr.constr_expr -> unit val build_constant_by_tactic : Id.t -> Evd.evar_universe_context -> named_context_val -> ?goal_kind:goal_kind -> types -> unit Proofview.tactic -> - Safe_typing.private_constants Entries.definition_entry * bool * Evd.evar_universe_context + Safe_typing.private_constants Entries.definition_entry * bool * + Evd.evar_universe_context val build_by_tactic : ?side_eff:bool -> env -> Evd.evar_universe_context -> ?poly:polymorphic -> types -> unit Proofview.tactic -> @@ -189,5 +190,4 @@ val declare_implicit_tactic : unit Proofview.tactic -> unit val clear_implicit_tactic : unit -> unit (* Raise Exit if cannot solve *) -(* FIXME: interface: it may incur some new universes etc... *) -val solve_by_implicit_tactic : env -> Evd.evar_map -> Evd.evar -> constr +val solve_by_implicit_tactic : env -> Evd.evar_map -> Evd.evar -> Evd.evar_map * constr diff --git a/proofs/proof.ml b/proofs/proof.ml index 5fe29653d3..5c963d53e7 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -351,7 +351,14 @@ let run_tactic env tac pr = Proofview.apply env tac sp in let sigma = Proofview.return proofview in - let shelf = (undef sigma pr.shelf)@retrieved@(undef sigma to_shelve) in + let to_shelve = undef sigma to_shelve in + let shelf = (undef sigma pr.shelf)@retrieved@to_shelve in + let proofview = + List.fold_left + Proofview.Unsafe.mark_as_unresolvable + proofview + to_shelve + in let given_up = pr.given_up@give_up in let proofview = Proofview.Unsafe.reset_future_goals proofview in { pr with proofview ; shelf ; given_up },(status,info_trace) diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 7605f63872..e753e972da 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -617,7 +617,7 @@ module Bullet = struct let _ = register_behavior strict end - (* Current bullet behavior, controled by the option *) + (* Current bullet behavior, controlled by the option *) let current_behavior = ref Strict.strict let _ = diff --git a/proofs/refine.ml b/proofs/refine.ml index dc6f4cea10..3f55270609 100644 --- a/proofs/refine.ml +++ b/proofs/refine.ml @@ -51,6 +51,23 @@ let typecheck_proof c concl env sigma = let (pr_constrv,pr_constr) = Hook.make ~default:(fun _env _sigma _c -> Pp.str"<constr>") () +(* Get the side-effect's constant declarations to update the monad's + * environmnent *) +let add_if_undefined kn cb env = + try ignore(Environ.lookup_constant kn env); env + with Not_found -> Environ.add_constant kn cb env + +(* Add the side effects to the monad's environment, if not already done. *) +let add_side_effect env = function + | { Entries.eff = Entries.SEsubproof (kn, cb, eff_env) } -> + add_if_undefined kn cb env + | { Entries.eff = Entries.SEscheme (l,_) } -> + List.fold_left (fun env (_,kn,cb,eff_env) -> + add_if_undefined kn cb env) env l + +let add_side_effects env effects = + List.fold_left (fun env eff -> add_side_effect env eff) env effects + let make_refine_enter ?(unsafe = true) f = { enter = fun gl -> let gl = Proofview.Goal.assume gl in @@ -66,6 +83,10 @@ let make_refine_enter ?(unsafe = true) f = let ((v,c), sigma) = Sigma.run (Evd.reset_future_goals sigma) f in let evs = Evd.future_goals sigma in let evkmain = Evd.principal_future_goal sigma in + (** Redo the effects in sigma in the monad's env *) + let privates_csts = Evd.eval_side_effects sigma in + let sideff = Safe_typing.side_effects_of_private_constants privates_csts in + let env = add_side_effects env sideff in (** Check that the introduced evars are well-typed *) let fold accu ev = typecheck_evar ev env accu in let sigma = if unsafe then sigma else CList.fold_left fold sigma evs in @@ -94,6 +115,7 @@ let make_refine_enter ?(unsafe = true) f = let sigma = CList.fold_left Proofview.Unsafe.mark_as_goal sigma comb in let trace () = Pp.(hov 2 (str"simple refine"++spc()++ Hook.get pr_constrv env sigma c)) in Proofview.Trace.name_tactic trace (Proofview.tclUNIT v) >>= fun v -> + Proofview.Unsafe.tclSETENV (Environ.reset_context env) <*> Proofview.Unsafe.tclEVARS sigma <*> Proofview.Unsafe.tclSETGOALS comb <*> Proofview.tclUNIT v @@ -127,3 +149,14 @@ let refine_casted ?unsafe f = Proofview.Goal.enter { enter = begin fun gl -> } in refine ?unsafe f end } + +(** {7 solve_constraints} + + Ensure no remaining unification problems are left. Run at every "." by default. *) + +let solve_constraints = + let open Proofview in + tclENV >>= fun env -> tclEVARMAP >>= fun sigma -> + try let sigma = Evarconv.solve_unif_constraints_with_heuristics env sigma in + Unsafe.tclEVARSADVANCE sigma + with e -> tclZERO e diff --git a/proofs/refine.mli b/proofs/refine.mli index 3d140f036b..a44632eff5 100644 --- a/proofs/refine.mli +++ b/proofs/refine.mli @@ -43,3 +43,8 @@ val with_type : Environ.env -> Evd.evar_map -> val refine_casted : ?unsafe:bool -> Constr.t Sigma.run -> unit tactic (** Like {!refine} except the refined term is coerced to the conclusion of the current goal. *) + +(** {7 Unification constraint handling} *) + +val solve_constraints : unit tactic +(** Solve any remaining unification problems, applying heuristics. *) diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index b9330ff007..330594af5c 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -171,6 +171,9 @@ module New = struct let pf_unsafe_type_of gl t = pf_apply unsafe_type_of gl t + let pf_get_type_of gl t = + pf_apply (Retyping.get_type_of ~lax:true) gl t + let pf_type_of gl t = pf_apply type_of gl t @@ -187,9 +190,9 @@ module New = struct next_ident_away id ids let pf_get_hyp id gl = - let hyps = Proofview.Goal.hyps gl in + let hyps = Proofview.Goal.env gl in let sign = - try Context.Named.lookup id hyps + try Environ.lookup_named id hyps with Not_found -> raise (RefinerError (NoSuchHyp id)) in sign diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index 727efcf6dc..59f296f64e 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -108,7 +108,16 @@ module New : sig val pf_env : ('a, 'r) Proofview.Goal.t -> Environ.env val pf_concl : ([ `NF ], 'r) Proofview.Goal.t -> types + (** WRONG: To be avoided at all costs, it typechecks the term entirely but + forgets the universe constraints necessary to retypecheck it *) val pf_unsafe_type_of : ('a, 'r) Proofview.Goal.t -> Term.constr -> Term.types + + (** This function does no type inference and expects an already well-typed term. + It recomputes its type in the fastest way possible (no conversion is ever involved) *) + val pf_get_type_of : ('a, 'r) Proofview.Goal.t -> Term.constr -> Term.types + + (** This function entirely type-checks the term and computes its type + and the implied universe constraints. *) val pf_type_of : ('a, 'r) Proofview.Goal.t -> Term.constr -> evar_map * Term.types val pf_conv_x : ('a, 'r) Proofview.Goal.t -> Term.constr -> Term.constr -> bool diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index fa6422cdc5..8acc3c233a 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -170,7 +170,7 @@ module Make(T : Task) = struct | Unix.WSIGNALED sno -> Printf.sprintf "signalled(%d)" sno | Unix.WSTOPPED sno -> Printf.sprintf "stopped(%d)" sno) in let more_univs n = - CList.init 10 (fun _ -> + CList.init n (fun _ -> Universes.new_univ_level (Global.current_dirpath ())) in let rec kill_if () = diff --git a/stm/lemmas.ml b/stm/lemmas.ml index 50f2b82c3b..022c89ad9a 100644 --- a/stm/lemmas.ml +++ b/stm/lemmas.ml @@ -449,7 +449,7 @@ let start_proof_with_initialization kind ctx recguard thms snl hook = call_hook (fun exn -> exn) hook strength ref) thms_data in start_proof_univs id ?pl kind ctx t ?init_tac (fun ctx -> mk_hook (hook ctx)) ~compute_guard:guard -let start_proof_com kind thms hook = +let start_proof_com ?inference_hook kind thms hook = let env0 = Global.env () in let levels = Option.map snd (fst (List.hd thms)) in let evdref = ref (match levels with @@ -459,7 +459,9 @@ let start_proof_com kind thms hook = let thms = List.map (fun (sopt,(bl,t,guard)) -> let impls, ((env, ctx), imps) = interp_context_evars env0 evdref bl in let t', imps' = interp_type_evars_impls ~impls env evdref t in - evdref := solve_remaining_evars all_and_fail_flags env !evdref (Evd.empty,!evdref); + let flags = all_and_fail_flags in + let flags = { flags with use_hook = inference_hook } in + evdref := solve_remaining_evars flags env !evdref (Evd.empty,!evdref); let ids = List.map get_name ctx in (compute_proof_name (pi1 kind) sopt, (nf_evar !evdref (it_mkProd_or_LetIn t' ctx), diff --git a/stm/lemmas.mli b/stm/lemmas.mli index f751598f04..39c089be9f 100644 --- a/stm/lemmas.mli +++ b/stm/lemmas.mli @@ -33,7 +33,9 @@ val start_proof_univs : Id.t -> ?pl:universe_binders -> goal_kind -> Evd.evar_ma ?init_tac:unit Proofview.tactic -> ?compute_guard:lemma_possible_guards -> (Evd.evar_universe_context option -> unit declaration_hook) -> unit -val start_proof_com : goal_kind -> Vernacexpr.proof_expr list -> +val start_proof_com : + ?inference_hook:Pretyping.inference_hook -> + goal_kind -> Vernacexpr.proof_expr list -> unit declaration_hook -> unit val start_proof_with_initialization : diff --git a/stm/proofBlockDelimiter.ml b/stm/proofBlockDelimiter.ml index ce12185cba..8162fc3bb5 100644 --- a/stm/proofBlockDelimiter.ml +++ b/stm/proofBlockDelimiter.ml @@ -83,7 +83,7 @@ let static_bullet ({ entry_point; prev_node } as view) = if node.indentation > base then `Cont node else match node.ast with | Vernacexpr.VernacBullet b' when b = b' -> - `Found { stop = entry_point.id; start = prev.id; + `Found { block_stop = entry_point.id; block_start = prev.id; dynamic_switch = node.id; carry_on_data = of_bullet_val b } | _ -> `Stop) entry_point | _ -> assert false @@ -108,7 +108,7 @@ let static_curly_brace ({ entry_point; prev_node } as view) = crawl view (fun (nesting,prev) node -> match node.ast with | Vernacexpr.VernacSubproof _ when nesting = 0 -> - `Found { stop = entry_point.id; start = prev.id; + `Found { block_stop = entry_point.id; block_start = prev.id; dynamic_switch = node.id; carry_on_data = unit_val } | Vernacexpr.VernacSubproof _ -> `Cont (nesting - 1,node) @@ -135,7 +135,7 @@ let static_par { entry_point; prev_node } = match prev_node entry_point with | None -> None | Some { id = pid } -> - Some { stop = entry_point.id; start = pid; + Some { block_stop = entry_point.id; block_start = pid; dynamic_switch = pid; carry_on_data = unit_val } let dynamic_par { dynamic_switch = id } = @@ -162,7 +162,7 @@ let static_indent ({ entry_point; prev_node } as view) = crawl view ~init:(Some last_tac) (fun prev node -> if node.indentation >= last_tac.indentation then `Cont node else - `Found { stop = entry_point.id; start = node.id; + `Found { block_stop = entry_point.id; block_start = node.id; dynamic_switch = node.id; carry_on_data = of_vernac_expr_val entry_point.ast } ) last_tac diff --git a/stm/stm.ml b/stm/stm.ml index c53bd958aa..f577994ffa 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -256,8 +256,8 @@ and pt = { (* TODO: inline records in OCaml 4.03 *) qed : Stateid.t; } and static_block_declaration = { - start : Stateid.t; - stop : Stateid.t; + block_start : Stateid.t; + block_stop : Stateid.t; dynamic_switch : Stateid.t; carry_on_data : DynBlockData.t; } @@ -362,10 +362,10 @@ module VCS : sig val get_state : id -> cached_state (* cuts from start -> stop, raising Expired if some nodes are not there *) - val slice : start:id -> stop:id -> vcs - val nodes_in_slice : start:id -> stop:id -> Stateid.t list + val slice : block_start:id -> block_stop:id -> vcs + val nodes_in_slice : block_start:id -> block_stop:id -> Stateid.t list - val create_proof_task_box : id list -> qed:id -> start:id -> unit + val create_proof_task_box : id list -> qed:id -> block_start:id -> unit val create_proof_block : static_block_declaration -> string -> unit val box_of : id -> box list val delete_boxes_of : id -> unit @@ -582,20 +582,20 @@ end = struct (* {{{ *) let visit id = Vcs_aux.visit !vcs id - let nodes_in_slice ~start ~stop = + let nodes_in_slice ~block_start ~block_stop = let rec aux id = - if Stateid.equal id start then [] else + if Stateid.equal id block_start then [] else match visit id with | { next = n; step = `Cmd x } -> (id,Cmd x) :: aux n | { next = n; step = `Alias x } -> (id,Alias x) :: aux n | { next = n; step = `Sideff (`Ast (x,_)) } -> (id,Sideff (Some x)) :: aux n - | _ -> anomaly(str("Cannot slice from "^ Stateid.to_string start ^ - " to "^Stateid.to_string stop)) - in aux stop + | _ -> anomaly(str("Cannot slice from "^ Stateid.to_string block_start ^ + " to "^Stateid.to_string block_stop)) + in aux block_stop - let slice ~start ~stop = - let l = nodes_in_slice ~start ~stop in + let slice ~block_start ~block_stop = + let l = nodes_in_slice ~block_start ~block_stop in let copy_info v id = Vcs_.set_info v id { (get_info id) with state = Empty; vcs_backup = None,None } in @@ -611,27 +611,27 @@ end = struct (* {{{ *) (Stateid.Set.elements (Vcs_.Dag.Property.having_it p)) (Vcs_.Dag.Property.data p)) v props in - let v = Vcs_.empty start in - let v = copy_info v start in + let v = Vcs_.empty block_start in + let v = copy_info v block_start in let v = List.fold_right (fun (id,tr) v -> let v = Vcs_.commit v id tr in let v = copy_info v id in v) l v in (* Stm should have reached the beginning of proof *) - assert (match (get_info start).state with Valid _ -> true | _ -> false); + assert (match (get_info block_start).state with Valid _ -> true | _ -> false); (* We put in the new dag the most recent state known to master *) let rec fill id = match (get_info id).state with | Empty | Error _ -> fill (Vcs_aux.visit v id).next | Valid _ -> copy_info_w_state v id in - let v = fill stop in + let v = fill block_stop in (* We put in the new dag the first state (since Qed shall run on it, * see check_task_aux) *) - let v = copy_info_w_state v start in + let v = copy_info_w_state v block_start in copy_proof_blockes v - let nodes_in_slice ~start ~stop = - List.rev (List.map fst (nodes_in_slice ~start ~stop)) + let nodes_in_slice ~block_start ~block_stop = + List.rev (List.map fst (nodes_in_slice ~block_start ~block_stop)) let topo_invariant l = let all = List.fold_right Stateid.Set.add l Stateid.Set.empty in @@ -642,11 +642,11 @@ end = struct (* {{{ *) List.for_all (fun s -> Stateid.Set.(subset s all || subset all s)) sets) l - let create_proof_task_box l ~qed ~start:lemma = + let create_proof_task_box l ~qed ~block_start:lemma = if not (topo_invariant l) then anomaly (str "overlapping boxes"); vcs := create_property !vcs l (ProofTask { qed; lemma }) - let create_proof_block ({ start; stop} as decl) name = - let l = nodes_in_slice ~start ~stop in + let create_proof_block ({ block_start; block_stop} as decl) name = + let l = nodes_in_slice ~block_start ~block_stop in if not (topo_invariant l) then anomaly (str "overlapping boxes"); vcs := create_property !vcs l (ProofBlock (decl, name)) let box_of id = List.map Dag.Property.data (property_of !vcs id) @@ -746,7 +746,7 @@ module State : sig val is_cached_and_valid : ?cache:Summary.marshallable -> Stateid.t -> bool - val exn_on : Stateid.t -> ?valid:Stateid.t -> iexn -> iexn + val exn_on : Stateid.t -> valid:Stateid.t -> iexn -> iexn (* to send states across worker/master *) type frozen_state val get_cached : Stateid.t -> frozen_state @@ -854,14 +854,14 @@ end = struct (* {{{ *) VCS.set_state id (Valid s) with VCS.Expired -> () - let exn_on id ?valid (e, info) = + let exn_on id ~valid (e, info) = match Stateid.get info with | Some _ -> (e, info) | None -> let loc = Option.default Loc.ghost (Loc.get_loc info) in let (e, info) = Hooks.(call_process_error_once (e, info)) in Hooks.(call execution_error id loc (iprint (e, info))); - (e, Stateid.add info ?valid id) + (e, Stateid.add info ~valid id) let same_env { system = s1 } { system = s2 } = let s1 = States.summary_of_state s1 in @@ -896,6 +896,7 @@ end = struct (* {{{ *) with e -> let (e, info) = CErrors.push e in let good_id = !cur_id in + cur_id := Stateid.dummy; VCS.reached id; let ie = match Stateid.get info, safe_id with @@ -1139,7 +1140,7 @@ let detect_proof_block id name = let static, _ = List.assoc name !proof_block_delimiters in begin match static { prev_node; entry_point } with | None -> () - | Some ({ start; stop } as decl) -> + | Some ({ block_start; block_stop } as decl) -> VCS.create_proof_block decl name end with Not_found -> @@ -1251,7 +1252,7 @@ end = struct (* {{{ *) try Some (ReqBuildProof ({ Stateid.exn_info = t_exn_info; stop = t_stop; - document = VCS.slice ~start:t_start ~stop:t_stop; + document = VCS.slice ~block_start:t_start ~block_stop:t_stop; loc = t_loc; uuid = t_uuid; name = t_name }, t_drop, t_states)) @@ -1401,7 +1402,7 @@ and Slaves : sig (* (eventually) remote calls *) val build_proof : loc:Loc.t -> drop_pt:bool -> - exn_info:(Stateid.t * Stateid.t) -> start:Stateid.t -> stop:Stateid.t -> + exn_info:(Stateid.t * Stateid.t) -> block_start:Stateid.t -> block_stop:Stateid.t -> name:string -> future_proof * cancel_switch (* blocking function that waits for the task queue to be empty *) @@ -1560,7 +1561,7 @@ end = struct (* {{{ *) BuildProof { t_states = s2 } -> overlap_rel s1 s2 | _ -> 0) - let build_proof ~loc ~drop_pt ~exn_info ~start ~stop ~name:pname = + let build_proof ~loc ~drop_pt ~exn_info ~block_start ~block_stop ~name:pname = let id, valid as t_exn_info = exn_info in let cancel_switch = ref false in if TaskQueue.n_workers (Option.get !queue) = 0 then @@ -1569,21 +1570,21 @@ end = struct (* {{{ *) Future.create_delegate ~blocking:true ~name:pname (State.exn_on id ~valid) in let t_uuid = Future.uuid f in let task = ProofTask.(BuildProof { - t_exn_info; t_start = start; t_stop = stop; t_drop = drop_pt; + t_exn_info; t_start = block_start; t_stop = block_stop; t_drop = drop_pt; t_assign = assign; t_loc = loc; t_uuid; t_name = pname; - t_states = VCS.nodes_in_slice ~start ~stop }) in + t_states = VCS.nodes_in_slice ~block_start ~block_stop }) in TaskQueue.enqueue_task (Option.get !queue) (task,cancel_switch); f, cancel_switch end else - ProofTask.build_proof_here ~drop_pt t_exn_info loc stop, cancel_switch + ProofTask.build_proof_here ~drop_pt t_exn_info loc block_stop, cancel_switch else let f, t_assign = Future.create_delegate ~name:pname (State.exn_on id ~valid) in let t_uuid = Future.uuid f in feedback (InProgress 1); let task = ProofTask.(BuildProof { - t_exn_info; t_start = start; t_stop = stop; t_assign; t_drop = drop_pt; + t_exn_info; t_start = block_start; t_stop = block_stop; t_assign; t_drop = drop_pt; t_loc = loc; t_uuid; t_name = pname; - t_states = VCS.nodes_in_slice ~start ~stop }) in + t_states = VCS.nodes_in_slice ~block_start ~block_stop }) in TaskQueue.enqueue_task (Option.get !queue) (task,cancel_switch); f, cancel_switch @@ -1665,7 +1666,7 @@ end = struct (* {{{ *) r_state_fb = t_state_fb; r_document = if age <> `Fresh then None - else Some (VCS.slice ~start:t_state ~stop:t_state); + else Some (VCS.slice ~block_start:t_state ~block_stop:t_state); r_ast = t_ast; r_goal = t_goal; r_name = t_name } @@ -1823,7 +1824,7 @@ end = struct (* {{{ *) try Some { r_where = t_where; r_for = t_for; - r_doc = VCS.slice ~start:t_where ~stop:t_where; + r_doc = VCS.slice ~block_start:t_where ~block_stop:t_where; r_what = t_what } with VCS.Expired -> None @@ -2026,7 +2027,7 @@ let known_state ?(redefine_qed=false) ~cache id = let boxes = VCS.box_of id in let valid_boxes = CList.map_filter (function - | ProofBlock ({ stop } as decl, name) when Stateid.equal stop id -> + | ProofBlock ({ block_stop } as decl, name) when Stateid.equal block_stop id -> Some (decl, name) | _ -> None) boxes in assert(List.length valid_boxes < 2); @@ -2156,12 +2157,12 @@ let known_state ?(redefine_qed=false) ~cache id = ), `Yes, true | `Qed ({ qast = x; keep; brinfo; brname } as qed, eop) -> let rec aux = function - | `ASync (start, pua, nodes, name, delegate) -> (fun () -> + | `ASync (block_start, pua, nodes, name, delegate) -> (fun () -> assert(keep == VtKeep || keep == VtKeepAsAxiom); let drop_pt = keep == VtKeepAsAxiom in - let stop, exn_info, loc = eop, (id, eop), x.loc in + let block_stop, exn_info, loc = eop, (id, eop), x.loc in log_processing_async id name; - VCS.create_proof_task_box nodes ~qed:id ~start; + VCS.create_proof_task_box nodes ~qed:id ~block_start; begin match brinfo, qed.fproof with | { VCS.kind = `Edit _ }, None -> assert false | { VCS.kind = `Edit (_,_,_, okeep, _) }, Some (ofp, cancel) -> @@ -2175,19 +2176,22 @@ let known_state ?(redefine_qed=false) ~cache id = ^"the proof's statement to avoid that.")); let fp, cancel = Slaves.build_proof - ~loc ~drop_pt ~exn_info ~start ~stop ~name in + ~loc ~drop_pt ~exn_info ~block_start ~block_stop ~name in Future.replace ofp fp; - qed.fproof <- Some (fp, cancel) + qed.fproof <- Some (fp, cancel); + (* We don't generate a new state, but we still need + * to install the right one *) + State.install_cached id | { VCS.kind = `Proof _ }, Some _ -> assert false | { VCS.kind = `Proof _ }, None -> - reach ~cache:`Shallow start; + reach ~cache:`Shallow block_start; let fp, cancel = if delegate then Slaves.build_proof - ~loc ~drop_pt ~exn_info ~start ~stop ~name + ~loc ~drop_pt ~exn_info ~block_start ~block_stop ~name else ProofTask.build_proof_here - ~drop_pt exn_info loc stop, ref false + ~drop_pt exn_info loc block_stop, ref false in qed.fproof <- Some (fp, cancel); let proof = @@ -2351,7 +2355,7 @@ let finish_tasks name u d p (t,rcbackup as tasks) = msg_error (str"File " ++ str name ++ str ":" ++ spc () ++ iprint e); exit 1 -let merge_proof_branch ?valid ?id qast keep brname = +let merge_proof_branch ~valid ?id qast keep brname = let brinfo = VCS.get_branch brname in let qed fproof = { qast; keep; brname; brinfo; fproof } in match brinfo with @@ -2374,7 +2378,7 @@ let merge_proof_branch ?valid ?id qast keep brname = VCS.checkout VCS.Branch.master; `Unfocus qed_id | { VCS.kind = `Master } -> - iraise (State.exn_on ?valid Stateid.dummy (Proof_global.NoCurrentProof, Exninfo.null)) + iraise (State.exn_on ~valid Stateid.dummy (Proof_global.NoCurrentProof, Exninfo.null)) (* When tty is true, this code also does some of the job of the user interface: jump back to a state that is valid *) @@ -2443,9 +2447,10 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty | VtStm (VtBack oid, true), w -> let id = VCS.new_node ~id:newtip () in let { mine; others } = Backtrack.branches_of oid in + let valid = VCS.get_branch_pos head in List.iter (fun branch -> if not (List.mem_assoc branch (mine::others)) then - ignore(merge_proof_branch x VtDrop branch)) + ignore(merge_proof_branch ~valid x VtDrop branch)) (VCS.branches ()); VCS.checkout_shallowest_proof_branch (); let head = VCS.current_branch () in @@ -2540,8 +2545,8 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty detect_proof_block id cblock; *) Backtrack.record (); if w == VtNow then finish (); `Ok | VtQed keep, w -> - let valid = if tty then Some(VCS.get_branch_pos head) else None in - let rc = merge_proof_branch ?valid ~id:newtip x keep head in + let valid = VCS.get_branch_pos head in + let rc = merge_proof_branch ~valid ~id:newtip x keep head in VCS.checkout_shallowest_proof_branch (); Backtrack.record (); if w == VtNow then finish (); rc @@ -2579,12 +2584,12 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty if not in_proof && Proof_global.there_are_pending_proofs () then begin let bname = VCS.mk_branch_name x in - let opacity_of_produced_term = - match x.expr with + let rec opacity_of_produced_term = function (* This AST is ambiguous, hence we check it dynamically *) | VernacInstance (false, _,_ , None, _) -> GuaranteesOpacity + | VernacLocal (_,e) -> opacity_of_produced_term e | _ -> Doesn'tGuaranteeOpacity in - VCS.commit id (Fork (x,bname,opacity_of_produced_term,[])); + VCS.commit id (Fork (x,bname,opacity_of_produced_term x.expr,[])); let proof_mode = default_proof_mode () in VCS.branch bname (`Proof (proof_mode, VCS.proof_nesting () + 1)); Proof_global.activate_proof_mode proof_mode; diff --git a/stm/stm.mli b/stm/stm.mli index 37ec1f0a13..b8a2a38596 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -139,8 +139,8 @@ module QueryTask : AsyncTaskQueue.Task module DynBlockData : Dyn.S type static_block_declaration = { - start : Stateid.t; - stop : Stateid.t; + block_start : Stateid.t; + block_stop : Stateid.t; dynamic_switch : Stateid.t; carry_on_data : DynBlockData.t; } diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index fa7acd00ab..dc5be08a37 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -181,7 +181,7 @@ let rec classify_vernac e = | VernacReserve _ | VernacGeneralizable _ | VernacSetOpacity _ | VernacSetStrategy _ - | VernacUnsetOption _ | VernacSetOption _ + | VernacUnsetOption _ | VernacSetOption _ | VernacSetAppendOption _ | VernacAddOption _ | VernacRemoveOption _ | VernacMemOption _ | VernacPrintOption _ | VernacGlobalCheck _ diff --git a/tactics/auto.ml b/tactics/auto.ml index 962af4b5c5..bc6448577f 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -35,6 +35,10 @@ open Hints let priority l = List.filter (fun (_, hint) -> Int.equal hint.pri 0) l +let compute_secvars gl = + let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in + secvars_of_hyps hyps + (* tell auto not to reuse already instantiated metas in unification (for compatibility, since otherwise, apply succeeds oftener) *) @@ -260,31 +264,25 @@ let pr_info_atom (d,pp) = let pr_info_trace = function | (Info,_,{contents=(d,Some pp)::l}) -> - prlist_with_sep fnl pr_info_atom (cleanup_info_trace d [(d,pp)] l) - | _ -> mt () + Feedback.msg_info (prlist_with_sep fnl pr_info_atom (cleanup_info_trace d [(d,pp)] l)) + | _ -> () let pr_info_nop = function - | (Info,_,_) -> str "idtac." - | _ -> mt () + | (Info,_,_) -> Feedback.msg_info (str "idtac.") + | _ -> () let pr_dbg_header = function - | (Off,_,_) -> mt () - | (Debug,0,_) -> str "(* debug trivial : *)" - | (Debug,_,_) -> str "(* debug auto : *)" - | (Info,0,_) -> str "(* info trivial : *)" - | (Info,_,_) -> str "(* info auto : *)" + | (Off,_,_) -> () + | (Debug,0,_) -> Feedback.msg_debug (str "(* debug trivial: *)") + | (Debug,_,_) -> Feedback.msg_debug (str "(* debug auto: *)") + | (Info,0,_) -> Feedback.msg_info (str "(* info trivial: *)") + | (Info,_,_) -> Feedback.msg_info (str "(* info auto: *)") let tclTRY_dbg d tac = - let (level, _, _) = d in let delay f = Proofview.tclUNIT () >>= fun () -> f () in - let tac = match level with - | Off -> tac - | Debug | Info -> delay (fun () -> Feedback.msg_debug (pr_dbg_header d ++ fnl () ++ pr_info_trace d); tac) - in - let after = match level with - | Info -> delay (fun () -> Feedback.msg_debug (pr_info_nop d); Proofview.tclUNIT ()) - | Off | Debug -> Proofview.tclUNIT () - in + let tac = delay (fun () -> pr_dbg_header d; tac) >>= + fun () -> pr_info_trace d; Proofview.tclUNIT () in + let after = delay (fun () -> pr_info_nop d; Proofview.tclUNIT ()) in Tacticals.New.tclORELSE0 tac after (**************************************************************************) @@ -301,12 +299,13 @@ let flags_of_state st = let auto_flags_of_state st = auto_unif_flags_of full_transparent_state st false -let hintmap_of hdc concl = +let hintmap_of secvars hdc concl = match hdc with - | None -> Hint_db.map_none + | None -> Hint_db.map_none ~secvars | Some hdc -> - if occur_existential concl then Hint_db.map_existential hdc concl - else Hint_db.map_auto hdc concl + if occur_existential concl then + Hint_db.map_existential ~secvars hdc concl + else Hint_db.map_auto ~secvars hdc concl let exists_evaluable_reference env = function | EvalConstRef _ -> true @@ -331,22 +330,23 @@ let rec trivial_fail_db dbg mod_delta db_list local_db = in Proofview.Goal.enter { enter = begin fun gl -> let concl = Tacmach.New.pf_nf_concl gl in + let secvars = compute_secvars gl in Tacticals.New.tclFIRST ((dbg_assumption dbg)::intro_tac:: (List.map Tacticals.New.tclCOMPLETE - (trivial_resolve dbg mod_delta db_list local_db concl))) + (trivial_resolve dbg mod_delta db_list local_db secvars concl))) end } -and my_find_search_nodelta db_list local_db hdc concl = +and my_find_search_nodelta db_list local_db secvars hdc concl = List.map (fun hint -> (None,hint)) - (List.map_append (hintmap_of hdc concl) (local_db::db_list)) + (List.map_append (hintmap_of secvars hdc concl) (local_db::db_list)) and my_find_search mod_delta = if mod_delta then my_find_search_delta else my_find_search_nodelta -and my_find_search_delta db_list local_db hdc concl = - let f = hintmap_of hdc concl in +and my_find_search_delta db_list local_db secvars hdc concl = + let f = hintmap_of secvars hdc concl in if occur_existential concl then List.map_append (fun db -> @@ -366,16 +366,16 @@ and my_find_search_delta db_list local_db hdc concl = let (ids, csts as st) = Hint_db.transparent_state db in let flags, l = let l = - match hdc with None -> Hint_db.map_none db + match hdc with None -> Hint_db.map_none ~secvars db | Some hdc -> if (Id.Pred.is_empty ids && Cpred.is_empty csts) - then Hint_db.map_auto hdc concl db - else Hint_db.map_existential hdc concl db + then Hint_db.map_auto ~secvars hdc concl db + else Hint_db.map_existential ~secvars hdc concl db in auto_flags_of_state st, l in List.map (fun x -> (Some flags,x)) l) (local_db::db_list) -and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly})) = +and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly;db=dbname})) = let tactic = function | Res_pf (c,cl) -> unify_resolve_gen poly flags (c,cl) | ERes_pf _ -> Proofview.V82.tactic (fun gl -> error "eres_pf") @@ -394,9 +394,16 @@ and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly})) | Extern tacast -> conclPattern concl p tacast in - tclLOG dbg (fun () -> pr_hint t) (run_hint t tactic) + let pr_hint () = + let origin = match dbname with + | None -> mt () + | Some n -> str " (in " ++ str n ++ str ")" + in + pr_hint t ++ origin + in + tclLOG dbg pr_hint (run_hint t tactic) -and trivial_resolve dbg mod_delta db_list local_db cl = +and trivial_resolve dbg mod_delta db_list local_db secvars cl = try let head = try let hdconstr = decompose_app_bound cl in @@ -405,7 +412,7 @@ and trivial_resolve dbg mod_delta db_list local_db cl = in List.map (tac_of_hint dbg db_list local_db cl) (priority - (my_find_search mod_delta db_list local_db head cl)) + (my_find_search mod_delta db_list local_db secvars head cl)) with Not_found -> [] (** The use of the "core" database can be de-activated by passing @@ -443,7 +450,7 @@ let h_trivial ?(debug=Off) lems l = gen_trivial ~debug lems l (* The classical Auto tactic *) (**************************************************************************) -let possible_resolve dbg mod_delta db_list local_db cl = +let possible_resolve dbg mod_delta db_list local_db secvars cl = try let head = try let hdconstr = decompose_app_bound cl in @@ -451,7 +458,7 @@ let possible_resolve dbg mod_delta db_list local_db cl = with Bound -> None in List.map (tac_of_hint dbg db_list local_db cl) - (my_find_search mod_delta db_list local_db head cl) + (my_find_search mod_delta db_list local_db secvars head cl) with Not_found -> [] let extend_local_db decl db gl = @@ -482,11 +489,12 @@ let search d n mod_delta db_list local_db = (Tacticals.New.tclORELSE0 (intro_register d (search d n) local_db) ( Proofview.Goal.enter { enter = begin fun gl -> let concl = Tacmach.New.pf_nf_concl gl in + let secvars = compute_secvars gl in let d' = incr_dbg d in Tacticals.New.tclFIRST (List.map (fun ntac -> Tacticals.New.tclTHEN ntac (search d' (n-1) local_db)) - (possible_resolve d mod_delta db_list local_db concl)) + (possible_resolve d mod_delta db_list local_db secvars concl)) end })) end [] in diff --git a/tactics/auto.mli b/tactics/auto.mli index 1608a0ea63..3befaaadeb 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -15,7 +15,7 @@ open Pattern open Decl_kinds open Hints -val priority : ('a * full_hint) list -> ('a * full_hint) list +val compute_secvars : ('a,'b) Proofview.Goal.t -> Id.Pred.t val default_search_depth : int ref @@ -50,17 +50,15 @@ val new_auto : ?debug:Tacexpr.debug -> (** auto with default search depth and with the hint database "core" *) val default_auto : unit Proofview.tactic -(** auto with all hint databases except the "v62" compatibility database *) +(** auto with all hint databases *) val full_auto : ?debug:Tacexpr.debug -> int -> Tacexpr.delayed_open_constr list -> unit Proofview.tactic -(** auto with all hint databases except the "v62" compatibility database - and doing delta *) +(** auto with all hint databases and doing delta *) val new_full_auto : ?debug:Tacexpr.debug -> int -> Tacexpr.delayed_open_constr list -> unit Proofview.tactic -(** auto with default search depth and with all hint databases - except the "v62" compatibility database *) +(** auto with default search depth and with all hint databases *) val default_full_auto : unit Proofview.tactic (** The generic form of auto (second arg [None] means all bases) *) diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index c5b0e149a8..d1ae85e7be 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -9,7 +9,6 @@ (* TODO: - Find an interface allowing eauto to backtrack when shelved goals remain, e.g. to force instantiations. - - unique solutions *) open Pp @@ -43,7 +42,11 @@ let typeclasses_modulo_eta = ref false let set_typeclasses_modulo_eta d = (:=) typeclasses_modulo_eta d let get_typeclasses_modulo_eta () = !typeclasses_modulo_eta -let typeclasses_limit_intros = ref false +(** When this flag is enabled, the resolution of type classes tries to avoid + useless introductions. This is no longer useful since we have eta, but is + here for compatibility purposes. Another compatibility issues is that the + cost (in terms of search depth) can differ. *) +let typeclasses_limit_intros = ref true let set_typeclasses_limit_intros d = (:=) typeclasses_limit_intros d let get_typeclasses_limit_intros () = !typeclasses_limit_intros @@ -55,31 +58,22 @@ let typeclasses_iterative_deepening = ref false let set_typeclasses_iterative_deepening d = (:=) typeclasses_iterative_deepening d let get_typeclasses_iterative_deepening () = !typeclasses_iterative_deepening -let get_compat_version d = - match d with - | "8.5" -> Flags.V8_5 - | _ -> Flags.Current - -let typeclasses_unif_compat = ref Flags.V8_5 -let set_typeclasses_unif_compat d = - if d == Flags.Current then set_typeclasses_limit_intros false - else set_typeclasses_limit_intros true; - (:=) typeclasses_unif_compat d - -let get_typeclasses_unif_compat () = !typeclasses_unif_compat -let set_typeclasses_unif_compat_string d = - set_typeclasses_unif_compat (get_compat_version d) -let get_typeclasses_unif_compat_string () = - Flags.pr_version (get_typeclasses_unif_compat ()) - -let typeclasses_compat = ref Flags.Current -let set_typeclasses_compat d = (:=) typeclasses_compat d -let get_typeclasses_compat () = !typeclasses_compat -let set_typeclasses_compat_string d = - set_typeclasses_compat (get_compat_version d) - -let get_typeclasses_compat_string () = - Flags.pr_version (get_typeclasses_compat ()) +(** [typeclasses_filtered_unif] governs the unification algorithm used by type + classes. If enabled, a new algorithm based on pattern filtering and refine + will be used. When disabled, the previous algorithm based on apply will be + used. *) +let typeclasses_filtered_unification = ref false +let set_typeclasses_filtered_unification d = + (:=) typeclasses_filtered_unification d +let get_typeclasses_filtered_unification () = + !typeclasses_filtered_unification + +(** [typeclasses_legacy_resolution] falls back to the 8.5 resolution algorithm, + instead of the 8.6 one which uses the native backtracking facilities of the + proof engine. *) +let typeclasses_legacy_resolution = ref false +let set_typeclasses_legacy_resolution d = (:=) typeclasses_legacy_resolution d +let get_typeclasses_legacy_resolution () = !typeclasses_legacy_resolution let set_typeclasses_debug d = (:=) typeclasses_debug (if d then 1 else 0) let get_typeclasses_debug () = if !typeclasses_debug > 0 then true else false @@ -98,7 +92,7 @@ open Goptions let _ = declare_bool_option { optsync = true; - optdepr = false; + optdepr = true; optname = "do typeclass search modulo eta conversion"; optkey = ["Typeclasses";"Modulo";"Eta"]; optread = get_typeclasses_modulo_eta; @@ -133,22 +127,22 @@ let _ = optwrite = set_typeclasses_iterative_deepening; } let _ = - declare_string_option + declare_bool_option { optsync = true; optdepr = false; optname = "compat"; - optkey = ["Typeclasses";"Compatibility"]; - optread = get_typeclasses_compat_string; - optwrite = set_typeclasses_compat_string; } + optkey = ["Typeclasses";"Legacy";"Resolution"]; + optread = get_typeclasses_legacy_resolution; + optwrite = set_typeclasses_legacy_resolution; } let _ = - declare_string_option + declare_bool_option { optsync = true; optdepr = false; optname = "compat"; - optkey = ["Typeclasses";"Unification";"Compatibility"]; - optread = get_typeclasses_unif_compat_string; - optwrite = set_typeclasses_unif_compat_string; } + optkey = ["Typeclasses";"Filtered";"Unification"]; + optread = get_typeclasses_filtered_unification; + optwrite = set_typeclasses_filtered_unification; } let set_typeclasses_debug = declare_bool_option @@ -186,6 +180,12 @@ let set_typeclasses_depth = optread = get_typeclasses_depth; optwrite = set_typeclasses_depth; } +type search_strategy = Dfs | Bfs + +let set_typeclasses_strategy = function + | Dfs -> set_typeclasses_iterative_deepening false + | Bfs -> set_typeclasses_iterative_deepening true + let pr_ev evs ev = Printer.pr_constr_env (Goal.V82.env evs ev) evs (Evarutil.nf_evar evs (Goal.V82.concl evs ev)) @@ -245,12 +245,11 @@ let unify_resolve poly flags = { enter = begin fun gls (c,_,clenv) -> end } (** Application of a lemma using [refine] instead of the old [w_unify] *) -let unify_resolve_refine poly flags = +let unify_resolve_refine poly flags gls ((c, t, ctx),n,clenv) = let open Clenv in - { enter = begin fun gls ((c, t, ctx),n,clenv) -> - let env = Proofview.Goal.env gls in - let concl = Proofview.Goal.concl gls in - Refine.refine ~unsafe:true { Sigma.run = fun sigma -> + let env = Proofview.Goal.env gls in + let concl = Proofview.Goal.concl gls in + Refine.refine ~unsafe:true { Sigma.run = fun sigma -> let sigma = Sigma.to_evar_map sigma in let sigma, term, ty = if poly then @@ -265,15 +264,20 @@ let unify_resolve_refine poly flags = let sigma', cl = Clenv.make_evar_clause env sigma ?len:n ty in let term = applistc term (List.map (fun x -> x.hole_evar) cl.cl_holes) in let sigma' = - let evdref = ref sigma' in - if not (Evarconv.e_cumul env ~ts:flags.core_unify_flags.modulo_delta - evdref cl.cl_concl concl) then - Type_errors.error_actual_type env - {Environ.uj_val = term; Environ.uj_type = cl.cl_concl} - concl; - !evdref + Evarconv.the_conv_x_leq env ~ts:flags.core_unify_flags.modulo_delta + cl.cl_concl concl sigma' in Sigma.here term (Sigma.Unsafe.of_evar_map sigma') } - end } + +let unify_resolve_refine poly flags gl clenv = + Proofview.tclORELSE + (unify_resolve_refine poly flags gl clenv) + (fun ie -> + match fst ie with + | Evarconv.UnableToUnify _ -> + Tacticals.New.tclZEROMSG (str "Unable to unify") + | e when CErrors.noncritical e -> + Tacticals.New.tclZEROMSG (str "Unexpected error") + | _ -> iraise ie) (** Dealing with goals of the form A -> B and hints of the form C -> A -> B. @@ -285,18 +289,20 @@ let clenv_of_prods poly nprods (c, clenv) gl = let ty = Retyping.get_type_of (Proofview.Goal.env gl) (Sigma.to_evar_map (Proofview.Goal.sigma gl)) c in let diff = nb_prod ty - nprods in - if Pervasives.(>=) diff 0 then - (* Was Some clenv... *) - Some (Some diff, - Tacmach.New.of_old (fun gls -> mk_clenv_from_n gls (Some diff) (c,ty)) gl) - else None + if Pervasives.(>=) diff 0 then + (* Was Some clenv... *) + Some (Some diff, + Tacmach.New.of_old (fun gls -> mk_clenv_from_n gls (Some diff) (c,ty)) gl) + else None let with_prods nprods poly (c, clenv) f = if get_typeclasses_limit_intros () then Proofview.Goal.nf_enter { enter = begin fun gl -> - match clenv_of_prods poly nprods (c, clenv) gl with - | None -> Tacticals.New.tclZEROMSG (str"Not enough premisses") - | Some (diff, clenv') -> f.enter gl (c, diff, clenv') end } + try match clenv_of_prods poly nprods (c, clenv) gl with + | None -> Tacticals.New.tclZEROMSG (str"Not enough premisses") + | Some (diff, clenv') -> f.enter gl (c, diff, clenv') + with e when CErrors.noncritical e -> + Tacticals.New.tclZEROMSG (CErrors.print e) end } else Proofview.Goal.nf_enter { enter = begin fun gl -> if Int.equal nprods 0 then f.enter gl (c, None, clenv) @@ -311,7 +317,7 @@ let matches_pattern concl pat = if Constr_matching.is_matching env sigma pat concl then Proofview.tclUNIT () else - Tacticals.New.tclZEROMSG (str "conclPattern") + Tacticals.New.tclZEROMSG (str "pattern does not match") in Proofview.Goal.enter { enter = fun gl -> let env = Proofview.Goal.env gl in @@ -339,12 +345,21 @@ let pr_gls sigma gls = let shelve_dependencies gls = let open Proofview in tclEVARMAP >>= fun sigma -> - (if !typeclasses_debug > 1 then - Feedback.msg_debug (str" shelving goals: " ++ pr_gls sigma gls); + (if !typeclasses_debug > 1 && List.length gls > 0 then + Feedback.msg_debug (str" shelving dependent subgoals: " ++ pr_gls sigma gls); shelve_goals gls) +let hintmap_of hdc secvars concl = + match hdc with + | None -> fun db -> Hint_db.map_none secvars db + | Some hdc -> + fun db -> + if Hint_db.use_dn db then (* Using dnet *) + Hint_db.map_eauto secvars hdc concl db + else Hint_db.map_existential secvars hdc concl db + (** Hack to properly solve dependent evars that are typeclasses *) -let rec e_trivial_fail_db only_classes db_list local_db = +let rec e_trivial_fail_db only_classes db_list local_db secvars = let open Tacticals.New in let open Tacmach.New in let trivial_fail = @@ -355,13 +370,13 @@ let rec e_trivial_fail_db only_classes db_list local_db = let d = pf_last_hyp gl in let hintl = make_resolve_hyp env sigma d in let hints = Hint_db.add_list env sigma hintl local_db in - e_trivial_fail_db only_classes db_list hints + e_trivial_fail_db only_classes db_list hints secvars end } in let trivial_resolve = Proofview.Goal.nf_enter { enter = begin fun gl -> - let tacs = e_trivial_resolve db_list local_db only_classes + let tacs = e_trivial_resolve db_list local_db secvars only_classes (project gl) (pf_concl gl) in tclFIRST (List.map (fun (x,_,_,_,_) -> x) tacs) end} @@ -372,69 +387,77 @@ let rec e_trivial_fail_db only_classes db_list local_db = in tclFIRST (List.map tclCOMPLETE tacl) -and e_my_find_search db_list local_db hdc complete only_classes sigma concl = +and e_my_find_search db_list local_db secvars hdc complete only_classes sigma concl = let open Proofview.Notations in let prods, concl = decompose_prod_assum concl in let nprods = List.length prods in let freeze = try - let cl = Typeclasses.class_info (fst hdc) in - if cl.cl_strict then - Evd.evars_of_term concl - else Evar.Set.empty + match hdc with + | Some (hd,_) when only_classes -> + let cl = Typeclasses.class_info hd in + if cl.cl_strict then + Evd.evars_of_term concl + else Evar.Set.empty + | _ -> Evar.Set.empty with e when CErrors.noncritical e -> Evar.Set.empty in + let hint_of_db = hintmap_of hdc secvars concl in let hintl = List.map_append (fun db -> - let tacs = - if Hint_db.use_dn db then (* Using dnet *) - Hint_db.map_eauto hdc concl db - else Hint_db.map_existential hdc concl db - in + let tacs = hint_of_db db in let flags = auto_unif_flags freeze (Hint_db.transparent_state db) in List.map (fun x -> (flags, x)) tacs) (local_db::db_list) in let tac_of_hint = - fun (flags, {pri = b; pat = p; poly = poly; code = t; name = name}) -> + fun (flags, {pri = b; pat = p; poly = poly; code = t; secvars; name = name}) -> let tac = function | Res_pf (term,cl) -> - if get_typeclasses_unif_compat () = Flags.Current then + if get_typeclasses_filtered_unification () then let tac = with_prods nprods poly (term,cl) ({ enter = fun gl clenv -> - (matches_pattern concl p) <*> - ((unify_resolve_refine poly flags).enter gl clenv)}) + matches_pattern concl p <*> + unify_resolve_refine poly flags gl clenv}) in Tacticals.New.tclTHEN tac Proofview.shelve_unifiable else let tac = with_prods nprods poly (term,cl) (unify_resolve poly flags) in - if get_typeclasses_compat () = Flags.V8_5 then + if get_typeclasses_legacy_resolution () then Tacticals.New.tclTHEN tac Proofview.shelve_unifiable else Proofview.tclBIND (Proofview.with_shelf tac) (fun (gls, ()) -> shelve_dependencies gls) | ERes_pf (term,cl) -> - if get_typeclasses_unif_compat () = Flags.Current then + if get_typeclasses_filtered_unification () then let tac = (with_prods nprods poly (term,cl) ({ enter = fun gl clenv -> - (matches_pattern concl p) <*> - ((unify_resolve_refine poly flags).enter gl clenv)})) in + matches_pattern concl p <*> + unify_resolve_refine poly flags gl clenv})) in Tacticals.New.tclTHEN tac Proofview.shelve_unifiable else let tac = with_prods nprods poly (term,cl) (unify_e_resolve poly flags) in - if get_typeclasses_compat () = Flags.V8_5 then + if get_typeclasses_legacy_resolution () then Tacticals.New.tclTHEN tac Proofview.shelve_unifiable else Proofview.tclBIND (Proofview.with_shelf tac) (fun (gls, ()) -> shelve_dependencies gls) - | Give_exact c -> Proofview.V82.tactic (e_give_exact flags poly c) + | Give_exact (c,clenv) -> + if get_typeclasses_filtered_unification () then + let tac = + matches_pattern concl p <*> + Proofview.Goal.nf_enter + { enter = fun gl -> unify_resolve_refine poly flags gl (c,None,clenv) } in + Tacticals.New.tclTHEN tac Proofview.shelve_unifiable + else + Proofview.V82.tactic (e_give_exact flags poly (c,clenv)) | Res_pf_THEN_trivial_fail (term,cl) -> let fst = with_prods nprods poly (term,cl) (unify_e_resolve poly flags) in let snd = if complete then Tacticals.New.tclIDTAC - else e_trivial_fail_db only_classes db_list local_db in + else e_trivial_fail_db only_classes db_list local_db secvars in Tacticals.New.tclTHEN fst snd | Unfold_nth c -> let tac = Proofview.V82.of_tactic (unfold_in_concl [AllOccurrences,c]) in @@ -445,7 +468,7 @@ and e_my_find_search db_list local_db hdc complete only_classes sigma concl = let tac = if complete then Tacticals.New.tclCOMPLETE tac else tac in let pp = match p with - | Some pat when get_typeclasses_unif_compat () = Flags.Current -> + | Some pat when get_typeclasses_filtered_unification () -> str " with pattern " ++ Printer.pr_constr_pattern pat | _ -> mt () in @@ -454,17 +477,17 @@ and e_my_find_search db_list local_db hdc complete only_classes sigma concl = | _ -> (tac, b, false, name, lazy (pr_hint t ++ pp)) in List.map tac_of_hint hintl -and e_trivial_resolve db_list local_db only_classes sigma concl = +and e_trivial_resolve db_list local_db secvars only_classes sigma concl = + let hd = try Some (decompose_app_bound concl) with Bound -> None in try - e_my_find_search db_list local_db - (decompose_app_bound concl) true only_classes sigma concl - with Bound | Not_found -> [] + e_my_find_search db_list local_db secvars hd true only_classes sigma concl + with Not_found -> [] -let e_possible_resolve db_list local_db only_classes sigma concl = +let e_possible_resolve db_list local_db secvars only_classes sigma concl = + let hd = try Some (decompose_app_bound concl) with Bound -> None in try - e_my_find_search db_list local_db - (decompose_app_bound concl) false only_classes sigma concl - with Bound | Not_found -> [] + e_my_find_search db_list local_db secvars hd false only_classes sigma concl + with Not_found -> [] let cut_of_hints h = List.fold_left (fun cut db -> PathOr (Hint_db.cut db, cut)) PathEmpty h @@ -544,10 +567,16 @@ let make_resolve_hyp env sigma st flags only_classes pri decl = let name = PathHints [VarRef id] in let hints = if is_class then - let hints = build_subclasses ~check:false env sigma (VarRef id) None in + let hints = build_subclasses ~check:false env sigma (VarRef id) empty_hint_info in (List.map_append - (fun (path,pri, c) -> make_resolves env sigma ~name:(PathHints path) - (true,false,Flags.is_verbose()) pri false + (fun (path,info,c) -> + let info = + { info with Vernacexpr.hint_pattern = + Option.map (Constrintern.intern_constr_pattern env) + info.Vernacexpr.hint_pattern } + in + make_resolves env sigma ~name:(PathHints path) + (true,false,Flags.is_verbose()) info false (IsConstr (c,Univ.ContextSet.empty))) hints) else [] @@ -572,7 +601,7 @@ let make_hints g st only_classes sign = in if consider then let hint = - pf_apply make_resolve_hyp g st (true,false,false) only_classes None hyp + pf_apply make_resolve_hyp g st (true,false,false) only_classes empty_hint_info hyp in hint @ hints else hints) ([]) sign @@ -641,7 +670,7 @@ module V85 = struct let env = Goal.V82.env s g' in let context = Environ.named_context_of_val (Goal.V82.hyps s g') in let hint = make_resolve_hyp env s (Hint_db.transparent_state info.hints) - (true,false,false) info.only_classes None (List.hd context) in + (true,false,false) info.only_classes empty_hint_info (List.hd context) in let ldb = Hint_db.add_list env s hint info.hints in (g', { info with is_evar = None; hints = ldb; auto_last_tac = lazy (str"intro") })) gls @@ -678,7 +707,8 @@ module V85 = struct let env = Goal.V82.env s gl in let concl = Goal.V82.concl s gl in let tacgl = {it = gl; sigma = s;} in - let poss = e_possible_resolve hints info.hints info.only_classes s concl in + let secvars = secvars_of_hyps (Environ.named_context_of_val (Goal.V82.hyps s gl)) in + let poss = e_possible_resolve hints info.hints secvars info.only_classes s concl in let unique = is_unique env concl in let rec aux i foundone = function | (tac, _, extern, name, pp) :: tl -> @@ -884,19 +914,20 @@ module V85 = struct let eauto_tac hints = then_tac normevars_tac (or_tac (hints_tac hints) intro_tac) - let eauto_tac depth hints = - if get_typeclasses_iterative_deepening () then - match depth with - | None -> fix_iterative (eauto_tac hints) - | Some depth -> fix_iterative_limit depth (eauto_tac hints) - else - match depth with - | None -> fix (eauto_tac hints) - | Some depth -> fix_limit depth (eauto_tac hints) - - let real_eauto ?depth unique st hints p evd = + let eauto_tac strategy depth hints = + match strategy with + | Bfs -> + begin match depth with + | None -> fix_iterative (eauto_tac hints) + | Some depth -> fix_iterative_limit depth (eauto_tac hints) end + | Dfs -> + match depth with + | None -> fix (eauto_tac hints) + | Some depth -> fix_limit depth (eauto_tac hints) + + let real_eauto ?depth strategy unique st hints p evd = let res = - run_on_evars ~st ~unique p evd hints (eauto_tac depth hints) + run_on_evars ~st ~unique p evd hints (eauto_tac strategy depth hints) in match res with | None -> evd @@ -909,12 +940,18 @@ module V85 = struct let resolve_all_evars_once debug depth unique p evd = let db = searchtable_map typeclasses_db in - real_eauto ?depth unique (Hint_db.transparent_state db) [db] p evd - - let eauto85 ?(only_classes=true) ?st depth hints g = + let strategy = if get_typeclasses_iterative_deepening () then Bfs else Dfs in + real_eauto ?depth strategy unique (Hint_db.transparent_state db) [db] p evd + + let eauto85 ?(only_classes=true) ?st ?strategy depth hints g = + let strategy = + match strategy with + | None -> if get_typeclasses_iterative_deepening () then Bfs else Dfs + | Some s -> s + in let gl = { it = make_autogoal ~only_classes ?st (cut_of_hints hints) None g; sigma = project g; } in - match run_tac (eauto_tac depth hints) gl with + match run_tac (eauto_tac strategy depth hints) gl with | None -> raise Not_found | Some {it = goals; sigma = s; } -> {it = List.map fst goals; sigma = s;} @@ -990,6 +1027,18 @@ module Search = struct Evd.add sigma gl evi') sigma goals + let fail_if_nonclass info = + Proofview.Goal.enter { enter = fun gl -> + let gl = Proofview.Goal.assume gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + if is_class_type sigma (Proofview.Goal.concl gl) then + Proofview.tclUNIT () + else (if !typeclasses_debug > 1 then + Feedback.msg_debug (pr_depth info.search_depth ++ + str": failure due to non-class subgoal " ++ + pr_ev sigma (Proofview.Goal.goal gl)); + Proofview.tclZERO NotApplicableEx) } + (** The general hint application tactic. tac1 + tac2 .... The choice of OR or ORELSE is determined depending on the dependencies of the goal and the unique/Prop @@ -1009,8 +1058,9 @@ module Search = struct Printer.pr_constr_env (Goal.env gl) s concl ++ (if backtrack then str" with backtracking" else str" without backtracking")); + let secvars = compute_secvars gl in let poss = - e_possible_resolve hints info.search_hints info.search_only_classes s concl in + e_possible_resolve hints info.search_hints secvars info.search_only_classes s concl in (* If no goal depends on the solution of this one or the instances are irrelevant/assumed to be unique, then we don't need to backtrack, as long as no evar appears in the goal @@ -1021,13 +1071,18 @@ module Search = struct let foundone = ref false in let rec onetac e (tac, pat, b, name, pp) tl = let derivs = path_derivate info.search_cut name in - (if !typeclasses_debug > 1 then - Feedback.msg_debug - (pr_depth (!idx :: info.search_depth) ++ str": trying " ++ + let pr_error ie = + if !typeclasses_debug > 1 then + let msg = + pr_depth (!idx :: info.search_depth) ++ str": " ++ Lazy.force pp ++ (if !foundone != true then str" on" ++ spc () ++ pr_ev s (Proofview.Goal.goal gl) - else mt ()))); + else mt ()) + in + Feedback.msg_debug (msg ++ str " failed with " ++ CErrors.iprint ie) + else () + in let tac_of gls i j = Goal.nf_enter { enter = fun gl' -> let sigma' = Goal.sigma gl' in let s' = Sigma.to_evar_map sigma' in @@ -1069,12 +1124,12 @@ module Search = struct else tclDISPATCH (List.init j (fun j' -> (tac_of gls i (Option.default 0 k + j)))) in - let finish sigma = + let finish nestedshelf sigma = let filter ev = try let evi = Evd.find_undefined sigma ev in if info.search_only_classes then - Some (ev, is_class_type sigma (Evd.evar_concl evi)) + Some (ev, not (is_class_type sigma (Evd.evar_concl evi))) else Some (ev, true) with Not_found -> None in @@ -1092,9 +1147,9 @@ module Search = struct begin (* Some existentials produced by the original tactic were not solved in the subgoals, turn them into subgoals now. *) - let shelved, goals = List.split_when (fun (ev, s) -> s) remaining in - let shelved = List.map fst shelved and goals = List.map fst goals in - if !typeclasses_debug > 1 then + let shelved, goals = List.partition (fun (ev, s) -> s) remaining in + let shelved = List.map fst shelved @ nestedshelf and goals = List.map fst goals in + if !typeclasses_debug > 1 && not (List.is_empty shelved && List.is_empty goals) then Feedback.msg_debug (str"Adding shelved subgoals to the search: " ++ prlist_with_sep spc (pr_ev sigma) goals ++ @@ -1107,13 +1162,23 @@ module Search = struct with_shelf (Unsafe.tclEVARS sigma' <*> Unsafe.tclNEWGOALS goals) >>= fun s -> result s i (Some (Option.default 0 k + j))) end - in res <*> tclEVARMAP >>= finish + in with_shelf res >>= fun (sh, ()) -> + tclEVARMAP >>= finish sh in if path_matches derivs [] then aux e tl - else ortac - (with_shelf tac >>= fun s -> + else + let filter = + if false (* in 8.6, still allow non-class subgoals + info.search_only_classes *) then fail_if_nonclass info + else Proofview.tclUNIT () + in + ortac + (with_shelf (tac <*> filter) >>= fun s -> let i = !idx in incr idx; result s i None) - (fun e' -> aux (merge_exceptions e e') tl) + (fun e' -> + if CErrors.noncritical (fst e') then + (pr_error e'; aux (merge_exceptions e e') tl) + else iraise e') and aux e = function | x :: xs -> onetac e x xs | [] -> @@ -1143,10 +1208,11 @@ module Search = struct let decl = Tacmach.New.pf_last_hyp gl in let hint = make_resolve_hyp env s (Hint_db.transparent_state info.search_hints) - (true,false,false) info.search_only_classes None decl in + (true,false,false) info.search_only_classes empty_hint_info decl in let ldb = Hint_db.add_list env s hint info.search_hints in let info' = - { info with search_hints = ldb; last_tac = lazy (str"intro") } + { info with search_hints = ldb; last_tac = lazy (str"intro"); + search_depth = 1 :: 1 :: info.search_depth } in kont info' let intro info kont = @@ -1174,9 +1240,12 @@ module Search = struct unit Proofview.tactic = let open Proofview in let open Proofview.Notations in - let dep = dep || Proofview.unifiable sigma (Goal.goal gl) gls in - let info = make_autogoal ?st only_classes dep (cut_of_hints hints) i gl in - search_tac hints depth 1 info + if false (* In 8.6, still allow non-class goals only_classes && not (is_class_type sigma (Goal.concl gl)) *) then + Tacticals.New.tclZEROMSG (str"Not a subgoal for a class") + else + let dep = dep || Proofview.unifiable sigma (Goal.goal gl) gls in + let info = make_autogoal ?st only_classes dep (cut_of_hints hints) i gl in + search_tac hints depth 1 info let search_tac ?(st=full_transparent_state) only_classes dep hints depth = let open Proofview in @@ -1207,16 +1276,24 @@ module Search = struct | (e,ie) -> Proofview.tclZERO ~info:ie e) in aux 1 - let eauto_tac ?(st=full_transparent_state) ~only_classes ~depth ~dep hints = + let eauto_tac ?(st=full_transparent_state) ?(unique=false) + ~only_classes ?strategy ~depth ~dep hints = + let open Proofview in let tac = let search = search_tac ~st only_classes dep hints in - if get_typeclasses_iterative_deepening () then + let dfs = + match strategy with + | None -> not (get_typeclasses_iterative_deepening ()) + | Some Dfs -> true + | Some Bfs -> false + in + if dfs then + let depth = match depth with None -> -1 | Some d -> d in + search depth + else match depth with | None -> fix_iterative search | Some l -> fix_iterative_limit l search - else - let depth = match depth with None -> -1 | Some d -> d in - search depth in let error (e, ie) = match e with @@ -1226,10 +1303,28 @@ module Search = struct Tacticals.New.tclFAIL 0 (str"Proof search failed" ++ (if Option.is_empty depth then mt() else str" without reaching its limit")) + | Proofview.MoreThanOneSuccess -> + Tacticals.New.tclFAIL 0 (str"Proof search failed: " ++ + str"more than one success found") | e -> Proofview.tclZERO ~info:ie e - in Proofview.tclOR tac error - - let run_on_evars ?(unique=false) p evm tac = + in + let tac = Proofview.tclOR tac error in + let tac = + if unique then + Proofview.tclEXACTLY_ONCE Proofview.MoreThanOneSuccess tac + else tac + in + with_shelf numgoals >>= fun (initshelf, i) -> + (if !typeclasses_debug > 1 then + Feedback.msg_debug (str"Starting resolution with " ++ int i ++ + str" goal(s) under focus and " ++ + int (List.length initshelf) ++ str " shelved goal(s)" ++ + (if only_classes then str " in only_classes mode" else str " in regular mode") ++ + match depth with None -> str ", unbounded" + | Some i -> str ", with depth limit " ++ int i)); + tac + + let run_on_evars p evm tac = match evars_to_goals p evm with | None -> None (* This happens only because there's no evar having p *) | Some (goals, evm') -> @@ -1261,16 +1356,15 @@ module Search = struct else raise Not_found with Logic_monad.TacticFailure _ -> raise Not_found - let eauto depth only_classes unique dep st hints p evd = - let eauto_tac = eauto_tac ~st ~only_classes ~depth ~dep hints in - let res = run_on_evars ~unique p evd eauto_tac in + let evars_eauto depth only_classes unique dep st hints p evd = + let eauto_tac = eauto_tac ~st ~unique ~only_classes ~depth ~dep:(unique || dep) hints in + let res = run_on_evars p evd eauto_tac in match res with | None -> evd | Some evd' -> evd' - (* TODO treat unique solutions *) let typeclasses_eauto ?depth unique st hints p evd = - eauto depth true unique false st hints p evd + evars_eauto depth true unique false st hints p evd (** Typeclasses eauto is an eauto which tries to resolve only goals of typeclass type, and assumes that the initially selected evars in evd are independent of the rest of the evars *) @@ -1281,11 +1375,9 @@ module Search = struct end (** Binding to either V85 or Search implementations. *) -let eauto depth ~only_classes ~st ~dep dbs = - Search.eauto_tac ~st ~only_classes ~depth ~dep dbs let typeclasses_eauto ?(only_classes=false) ?(st=full_transparent_state) - ~depth dbs = + ?strategy ~depth dbs = let dbs = List.map_filter (fun db -> try Some (searchtable_map db) with e when CErrors.noncritical e -> None) @@ -1293,13 +1385,13 @@ let typeclasses_eauto ?(only_classes=false) ?(st=full_transparent_state) in let st = match dbs with x :: _ -> Hint_db.transparent_state x | _ -> st in let depth = match depth with None -> get_typeclasses_depth () | Some l -> Some l in - if get_typeclasses_compat () = Flags.V8_5 then + if get_typeclasses_legacy_resolution () then Proofview.V82.tactic (fun gl -> - try V85.eauto85 depth ~only_classes ~st dbs gl + try V85.eauto85 depth ~only_classes ~st ?strategy dbs gl with Not_found -> Refiner.tclFAIL 0 (str"Proof search failed") gl) - else eauto depth ~only_classes ~st ~dep:true dbs + else Search.eauto_tac ~st ~only_classes ?strategy ~depth ~dep:true dbs (** We compute dependencies via a union-find algorithm. Beware of the imperative effects on the partition structure, @@ -1419,10 +1511,10 @@ let resolve_all_evars debug depth unique env p oevd do_split fail = let p = select_and_update_evars p oevd (in_comp comp) in try let evd' = - if get_typeclasses_compat () = Flags.Current then - Search.typeclasses_resolve debug depth unique p evd - else + if get_typeclasses_legacy_resolution () then V85.resolve_all_evars_once debug depth unique p evd + else + Search.typeclasses_resolve debug depth unique p evd in if has_undefined p oevd evd' then raise Unresolved; docomp evd' comps @@ -1442,7 +1534,7 @@ let initial_select_evars filter = let resolve_typeclass_evars debug depth unique env evd filter split fail = let evd = - try Evarconv.consider_remaining_unif_problems + try Evarconv.solve_unif_constraints_with_heuristics ~ts:(Typeclasses.classes_transparent_state ()) env evd with e when CErrors.noncritical e -> evd in @@ -1467,12 +1559,13 @@ let resolve_one_typeclass env ?(sigma=Evd.empty) gl unique = let st = Hint_db.transparent_state hints in let depth = get_typeclasses_depth () in let gls' = - if get_typeclasses_compat () = Flags.Current then + if get_typeclasses_legacy_resolution () then + V85.eauto85 depth ~st [hints] gls + else try Proofview.V82.of_tactic (Search.eauto_tac ~st ~only_classes:true ~depth [hints] ~dep:true) gls with Refiner.FailError _ -> raise Not_found - else V85.eauto85 depth ~st [hints] gls in let evd = sig_sig gls' in let t' = let (ev, inst) = destEvar t in diff --git a/tactics/class_tactics.mli b/tactics/class_tactics.mli index 8db264ad95..76760db025 100644 --- a/tactics/class_tactics.mli +++ b/tactics/class_tactics.mli @@ -20,7 +20,11 @@ val get_typeclasses_debug : unit -> bool val set_typeclasses_depth : int option -> unit val get_typeclasses_depth : unit -> int option -val typeclasses_eauto : ?only_classes:bool -> ?st:transparent_state -> +type search_strategy = Dfs | Bfs + +val set_typeclasses_strategy : search_strategy -> unit + +val typeclasses_eauto : ?only_classes:bool -> ?st:transparent_state -> ?strategy:search_strategy -> depth:(Int.t option) -> Hints.hint_db_name list -> unit Proofview.tactic @@ -36,8 +40,12 @@ module Search : sig val eauto_tac : ?st:Names.transparent_state -> (** The transparent_state used when working with local hypotheses *) + ?unique:bool -> + (** Should we force a unique solution *) only_classes:bool -> (** Should non-class goals be shelved and resolved at the end *) + ?strategy:search_strategy -> + (** Is a traversing-strategy specified? *) depth:Int.t option -> (** Bounded or unbounded search *) dep:bool -> diff --git a/tactics/eauto.ml b/tactics/eauto.ml index ba9a2d95c8..23ff582253 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -119,12 +119,13 @@ let unify_e_resolve poly flags (c,clenv) = (Proofview.V82.of_tactic (Tactics.Simple.eapply c)) gls) end } -let hintmap_of hdc concl = +let hintmap_of secvars hdc concl = match hdc with - | None -> fun db -> Hint_db.map_none db + | None -> fun db -> Hint_db.map_none ~secvars db | Some hdc -> - if occur_existential concl then (fun db -> Hint_db.map_existential hdc concl db) - else (fun db -> Hint_db.map_auto hdc concl db) + if occur_existential concl then + (fun db -> Hint_db.map_existential ~secvars hdc concl db) + else (fun db -> Hint_db.map_auto ~secvars hdc concl db) (* FIXME: should be (Hint_db.map_eauto hdc concl db) *) let e_exact poly flags (c,clenv) = @@ -142,16 +143,17 @@ let rec e_trivial_fail_db db_list local_db = e_trivial_fail_db db_list (Hint_db.add_list (Tacmach.New.pf_env gl) (Tacmach.New.project gl) hintl local_db) end } in Proofview.Goal.enter { enter = begin fun gl -> + let secvars = compute_secvars gl in let tacl = registered_e_assumption :: (Tacticals.New.tclTHEN Tactics.intro next) :: - (List.map fst (e_trivial_resolve db_list local_db (Tacmach.New.pf_nf_concl gl))) + (List.map fst (e_trivial_resolve db_list local_db secvars (Tacmach.New.pf_nf_concl gl))) in Tacticals.New.tclFIRST (List.map Tacticals.New.tclCOMPLETE tacl) end } -and e_my_find_search db_list local_db hdc concl = - let hint_of_db = hintmap_of hdc concl in +and e_my_find_search db_list local_db secvars hdc concl = + let hint_of_db = hintmap_of secvars hdc concl in let hintl = List.map_append (fun db -> let flags = auto_flags_of_state (Hint_db.transparent_state db) in @@ -179,14 +181,15 @@ and e_my_find_search db_list local_db hdc concl = in List.map tac_of_hint hintl -and e_trivial_resolve db_list local_db gl = +and e_trivial_resolve db_list local_db secvars gl = let hd = try Some (decompose_app_bound gl) with Bound -> None in - try priority (e_my_find_search db_list local_db hd gl) + try priority (e_my_find_search db_list local_db secvars hd gl) with Not_found -> [] -let e_possible_resolve db_list local_db gl = +let e_possible_resolve db_list local_db secvars gl = let hd = try Some (decompose_app_bound gl) with Bound -> None in - try List.map (fun (b, (tac, pp)) -> (tac, b, pp)) (e_my_find_search db_list local_db hd gl) + try List.map (fun (b, (tac, pp)) -> (tac, b, pp)) + (e_my_find_search db_list local_db secvars hd gl) with Not_found -> [] let find_first_goal gls = @@ -255,9 +258,11 @@ module SearchProblem = struct let nbgl = List.length (sig_it lg) in assert (nbgl > 0); let g = find_first_goal lg in + let hyps = pf_ids_of_hyps g in + let secvars = secvars_of_hyps (pf_hyps g) in let map_assum id = (e_give_exact (mkVar id), (-1), lazy (str "exact" ++ spc () ++ pr_id id)) in let assumption_tacs = - let tacs = List.map map_assum (pf_ids_of_hyps g) in + let tacs = List.map map_assum hyps in let l = filter_tactics s.tacres tacs in List.map (fun (res, cost, pp) -> { depth = s.depth; priority = cost; tacres = res; last_tactic = pp; dblist = s.dblist; @@ -282,7 +287,9 @@ module SearchProblem = struct in let rec_tacs = let l = - filter_tactics s.tacres (e_possible_resolve s.dblist (List.hd s.localdb) (pf_concl g)) + let concl = Reductionops.nf_evar (project g)(pf_concl g) in + filter_tactics s.tacres + (e_possible_resolve s.dblist (List.hd s.localdb) secvars concl) in List.map (fun (lgls, cost, pp) -> @@ -345,13 +352,13 @@ let mk_eauto_dbg d = else Off let pr_info_nop = function - | Info -> Feedback.msg_debug (str "idtac.") + | Info -> Feedback.msg_info (str "idtac.") | _ -> () let pr_dbg_header = function | Off -> () - | Debug -> Feedback.msg_debug (str "(* debug eauto : *)") - | Info -> Feedback.msg_debug (str "(* info eauto : *)") + | Debug -> Feedback.msg_debug (str "(* debug eauto: *)") + | Info -> Feedback.msg_info (str "(* info eauto: *)") let pr_info dbg s = if dbg != Info then () @@ -362,7 +369,7 @@ let pr_info dbg s = | State sp -> let mindepth = loop sp in let indent = String.make (mindepth - sp.depth) ' ' in - Feedback.msg_debug (str indent ++ Lazy.force s.last_tactic ++ str "."); + Feedback.msg_info (str indent ++ Lazy.force s.last_tactic ++ str "."); mindepth in ignore (loop s) @@ -409,9 +416,7 @@ let eauto ?(debug=Off) np lems dbnames = tclTRY (e_search_auto debug np lems db_list) let full_eauto ?(debug=Off) n lems gl = - let dbnames = current_db_names () in - let dbnames = String.Set.remove "v62" dbnames in - let db_list = List.map searchtable_map (String.Set.elements dbnames) in + let db_list = current_pure_db () in tclTRY (e_search_auto debug n lems db_list) gl let gen_eauto ?(debug=Off) np lems = function diff --git a/tactics/equality.ml b/tactics/equality.ml index 3e5b7b65ff..bb3cbad92b 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -701,16 +701,16 @@ let replace_in_clause_maybe_by c1 c2 cl tac_opt = exception DiscrFound of (constructor * int) list * constructor * constructor -let injection_on_proofs = ref false +let keep_proof_equalities_for_injection = ref false let _ = declare_bool_option { optsync = true; optdepr = false; optname = "injection on prop arguments"; - optkey = ["Injection";"On";"Proofs"]; - optread = (fun () -> !injection_on_proofs) ; - optwrite = (fun b -> injection_on_proofs := b) } + optkey = ["Keep";"Proof";"Equalities"]; + optread = (fun () -> !keep_proof_equalities_for_injection) ; + optwrite = (fun b -> keep_proof_equalities_for_injection := b) } let find_positions env sigma t1 t2 = @@ -755,7 +755,7 @@ let find_positions env sigma t1 t2 = project env sorts posn t1_0 t2_0 in try - let sorts = if !injection_on_proofs then [InSet;InType;InProp] + let sorts = if !keep_proof_equalities_for_injection then [InSet;InType;InProp] else [InSet;InType] in Inr (findrec sorts [] t1 t2) @@ -1163,7 +1163,8 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = let dflt_typ = unsafe_type_of env sigma dflt in try let () = evdref := Evarconv.the_conv_x_leq env dflt_typ p_i !evdref in - let () = evdref := Evarconv.consider_remaining_unif_problems env !evdref in + let () = + evdref := Evarconv.solve_unif_constraints_with_heuristics env !evdref in dflt with Evarconv.UnableToUnify _ -> error "Cannot solve a unification problem." @@ -1389,7 +1390,10 @@ let injEqThen tac l2r (eq,_,(t,t1,t2) as u) eq_clause = | Inl _ -> tclZEROMSG (strbrk"This equality is discriminable. You should use the discriminate tactic to solve the goal.") | Inr [] -> - let suggestion = if !injection_on_proofs then "" else " You can try to use option Set Injection On Proofs." in + let suggestion = + if !keep_proof_equalities_for_injection then + "" else + " You can try to use option Set Keep Proof Equalities." in tclZEROMSG (strbrk("No information can be deduced from this equality and the injectivity of constructors. This may be because the terms are convertible, or due to pattern matching restrictions in the sort Prop." ^ suggestion)) | Inr [([],_,_)] when Flags.version_strictly_greater Flags.V8_3 -> tclZEROMSG (str"Nothing to inject.") @@ -1761,35 +1765,38 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = let gl = Proofview.Goal.assume gl in let env = Proofview.Goal.env gl in let find_eq_data_decompose = find_eq_data_decompose gl in - let test decl = + let select_equation_name decl = try let lbeq,u,(_,x,y) = find_eq_data_decompose (get_type decl) in let eq = Universes.constr_of_global_univ (lbeq.eq,u) in if flags.only_leibniz then restrict_to_eq_and_identity eq; match kind_of_term x, kind_of_term y with - | Var z, _ | _, Var z when not (is_evaluable env (EvalVarRef z)) -> + | Var z, _ when not (is_evaluable env (EvalVarRef z)) -> + Some (get_id decl) + | _, Var z when not (is_evaluable env (EvalVarRef z)) -> Some (get_id decl) | _ -> None with Constr_matching.PatternMatchingFailure -> None in let hyps = Proofview.Goal.hyps gl in - List.rev (List.map_filter test hyps) + List.rev (List.map_filter select_equation_name hyps) in (* Second step: treat equations *) let process hyp = Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in + let env = Proofview.Goal.env gl in let find_eq_data_decompose = find_eq_data_decompose gl in let c = pf_get_hyp hyp gl |> get_type in let _,_,(_,x,y) = find_eq_data_decompose c in (* J.F.: added to prevent failure on goal containing x=x as an hyp *) if Term.eq_constr x y then Proofview.tclUNIT () else match kind_of_term x, kind_of_term y with - | Var x', _ when not (occur_term x y) -> + | Var x', _ when not (occur_term x y) && not (is_evaluable env (EvalVarRef x')) -> subst_one flags.rewrite_dependent_proof x' (hyp,y,true) - | _, Var y' when not (occur_term y x) -> + | _, Var y' when not (occur_term y x) && not (is_evaluable env (EvalVarRef y')) -> subst_one flags.rewrite_dependent_proof y' (hyp,x,false) | _ -> Proofview.tclUNIT () diff --git a/tactics/hints.ml b/tactics/hints.ml index 8f3eb5eb51..9a96b73898 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -66,6 +66,28 @@ let decompose_app_bound t = | Proj (p, c) -> ConstRef (Projection.constant p), Array.cons c args | _ -> raise Bound +(** Compute the set of section variables that remain in the named context. + Starts from the top to the bottom of the context, stops at the first + different declaration between the named hyps and the section context. *) +let secvars_of_hyps hyps = + let secctx = Global.named_context () in + let pred, all = + List.fold_left (fun (pred,all) decl -> + try let _ = Context.Named.lookup (get_id decl) hyps in + (* Approximation, it might be an hypothesis reintroduced with same name and unconvertible types, + we must allow it currently, as comparing the declarations for syntactic equality is too + strong a check (e.g. an unfold in a section variable would make it unusable). *) + (Id.Pred.add (get_id decl) pred, all) + with Not_found -> (pred, false)) + (Id.Pred.empty,true) secctx + in + if all then Id.Pred.full (* If the whole section context is available *) + else pred + +let empty_hint_info = + let open Vernacexpr in + { hint_priority = None; hint_pattern = None } + (************************************************************************) (* The Type of Constructions Autotactic Hints *) (************************************************************************) @@ -78,18 +100,25 @@ type 'a hint_ast = | Unfold_nth of evaluable_global_reference (* Hint Unfold *) | Extern of Genarg.glob_generic_argument (* Hint Extern *) -type hints_path_atom = - | PathHints of global_reference list + +type 'a hints_path_atom_gen = + | PathHints of 'a list + (* For forward hints, their names is the list of projections *) | PathAny -type hints_path = - | PathAtom of hints_path_atom - | PathStar of hints_path - | PathSeq of hints_path * hints_path - | PathOr of hints_path * hints_path +type hints_path_atom = global_reference hints_path_atom_gen + +type 'a hints_path_gen = + | PathAtom of 'a hints_path_atom_gen + | PathStar of 'a hints_path_gen + | PathSeq of 'a hints_path_gen * 'a hints_path_gen + | PathOr of 'a hints_path_gen * 'a hints_path_gen | PathEmpty | PathEpsilon +type pre_hints_path = Libnames.reference hints_path_gen +type hints_path = global_reference hints_path_gen + type hint_term = | IsGlobRef of global_reference | IsConstr of constr * Univ.universe_context_set @@ -104,11 +133,13 @@ type raw_hint = constr * types * Univ.universe_context_set type hint = (raw_hint * clausenv) hint_ast with_uid type 'a with_metadata = { - pri : int; (* A number lower is higher priority *) - poly : polymorphic; (** Is the hint polymorpic and hence should be refreshed at each application *) - pat : constr_pattern option; (* A pattern for the concl of the Goal *) - name : hints_path_atom; (* A potential name to refer to the hint *) - code : 'a; (* the tactic to apply when the concl matches pat *) + pri : int; (* A number lower is higher priority *) + poly : polymorphic; (** Is the hint polymorpic and hence should be refreshed at each application *) + pat : constr_pattern option; (* A pattern for the concl of the Goal *) + name : hints_path_atom; (* A potential name to refer to the hint *) + db : string option; (** The database from which the hint comes *) + secvars : Id.Pred.t; (* The set of section variables the hint depends on *) + code : 'a; (* the tactic to apply when the concl matches pat *) } type full_hint = hint with_metadata @@ -369,21 +400,40 @@ let rec normalize_path h = let path_derivate hp hint = normalize_path (path_derivate hp hint) -let pp_hints_path_atom a = +let pp_hints_path_atom prg a = match a with | PathAny -> str"_" - | PathHints grs -> pr_sequence pr_global grs - -let rec pp_hints_path = function - | PathAtom pa -> pp_hints_path_atom pa - | PathStar (PathAtom PathAny) -> str"_*" - | PathStar p -> str "(" ++ pp_hints_path p ++ str")*" - | PathSeq (p, p') -> pp_hints_path p ++ spc () ++ pp_hints_path p' - | PathOr (p, p') -> - str "(" ++ pp_hints_path p ++ spc () ++ str"|" ++ cut () ++ spc () ++ - pp_hints_path p' ++ str ")" + | PathHints grs -> pr_sequence prg grs + +let pp_hints_path_gen prg = + let rec aux = function + | PathAtom pa -> pp_hints_path_atom prg pa + | PathStar (PathAtom PathAny) -> str"_*" + | PathStar p -> str "(" ++ aux p ++ str")*" + | PathSeq (p, p') -> aux p ++ spc () ++ aux p' + | PathOr (p, p') -> + str "(" ++ aux p ++ spc () ++ str"|" ++ cut () ++ spc () ++ + aux p' ++ str ")" | PathEmpty -> str"emp" | PathEpsilon -> str"eps" + in aux + +let pp_hints_path = pp_hints_path_gen pr_global + +let glob_hints_path_atom p = + match p with + | PathHints g -> PathHints (List.map Nametab.global g) + | PathAny -> PathAny + +let glob_hints_path = + let rec aux = function + | PathAtom pa -> PathAtom (glob_hints_path_atom pa) + | PathStar p -> PathStar (aux p) + | PathSeq (p, p') -> PathSeq (aux p, aux p') + | PathOr (p, p') -> PathOr (aux p, aux p') + | PathEmpty -> PathEmpty + | PathEpsilon -> PathEpsilon + in aux let subst_path_atom subst p = match p with @@ -410,7 +460,38 @@ let rec subst_hints_path subst hp = if p' == p && q' == q then hp else PathOr (p', q') | _ -> hp -module Hint_db = struct +type hint_db_name = string + +module Hint_db : +sig +type t +val empty : ?name:hint_db_name -> transparent_state -> bool -> t +val find : global_reference -> t -> search_entry +val map_none : secvars:Id.Pred.t -> t -> full_hint list +val map_all : secvars:Id.Pred.t -> global_reference -> t -> full_hint list +val map_existential : secvars:Id.Pred.t -> + (global_reference * constr array) -> constr -> t -> full_hint list +val map_eauto : secvars:Id.Pred.t -> + (global_reference * constr array) -> constr -> t -> full_hint list +val map_auto : secvars:Id.Pred.t -> + (global_reference * constr array) -> constr -> t -> full_hint list +val add_one : env -> evar_map -> hint_entry -> t -> t +val add_list : env -> evar_map -> hint_entry list -> t -> t +val remove_one : global_reference -> t -> t +val remove_list : global_reference list -> t -> t +val iter : (global_reference option -> hint_mode array list -> full_hint list -> unit) -> t -> unit +val use_dn : t -> bool +val transparent_state : t -> transparent_state +val set_transparent_state : t -> transparent_state -> t +val add_cut : hints_path -> t -> t +val add_mode : global_reference -> hint_mode array -> t -> t +val cut : t -> hints_path +val unfolds : t -> Id.Set.t * Cset.t +val fold : (global_reference option -> hint_mode array list -> full_hint list -> 'a -> 'a) -> + t -> 'a -> 'a + +end = +struct type t = { hintdb_state : Names.transparent_state; @@ -421,26 +502,32 @@ module Hint_db = struct hintdb_map : search_entry Constr_map.t; (* A list of unindexed entries starting with an unfoldable constant or with no associated pattern. *) - hintdb_nopat : (global_reference option * stored_data) list + hintdb_nopat : (global_reference option * stored_data) list; + hintdb_name : string option; } let next_hint_id db = let h = db.hintdb_max_id in { db with hintdb_max_id = succ db.hintdb_max_id }, h - let empty st use_dn = { hintdb_state = st; + let empty ?name st use_dn = { hintdb_state = st; hintdb_cut = PathEmpty; hintdb_unfolds = (Id.Set.empty, Cset.empty); hintdb_max_id = 0; use_dn = use_dn; hintdb_map = Constr_map.empty; - hintdb_nopat = [] } + hintdb_nopat = []; + hintdb_name = name; } let find key db = try Constr_map.find key db.hintdb_map with Not_found -> empty_se - let realize_tac (id,tac) = tac + let realize_tac secvars (id,tac) = + if Id.Pred.subset tac.secvars secvars then Some tac + else + (** Warn about no longer typable hint? *) + None let match_mode m arg = match m with @@ -458,40 +545,40 @@ module Hint_db = struct if List.is_empty modes then true else List.exists (matches_mode args) modes - let merge_entry db nopat pat = + let merge_entry secvars db nopat pat = let h = List.sort pri_order_int (List.map snd db.hintdb_nopat) in let h = List.merge pri_order_int h nopat in let h = List.merge pri_order_int h pat in - List.map realize_tac h + List.map_filter (realize_tac secvars) h - let map_none db = - merge_entry db [] [] + let map_none ~secvars db = + merge_entry secvars db [] [] - let map_all k db = + let map_all ~secvars k db = let se = find k db in - merge_entry db se.sentry_nopat se.sentry_pat + merge_entry secvars db se.sentry_nopat se.sentry_pat (** Precondition: concl has no existentials *) - let map_auto (k,args) concl db = + let map_auto ~secvars (k,args) concl db = let se = find k db in let st = if db.use_dn then (Some db.hintdb_state) else None in let pat = lookup_tacs concl st se in - merge_entry db [] pat + merge_entry secvars db [] pat - let map_existential (k,args) concl db = + let map_existential ~secvars (k,args) concl db = let se = find k db in if matches_modes args se.sentry_mode then - merge_entry db se.sentry_nopat se.sentry_pat - else merge_entry db [] [] + merge_entry secvars db se.sentry_nopat se.sentry_pat + else merge_entry secvars db [] [] (* [c] contains an existential *) - let map_eauto (k,args) concl db = + let map_eauto ~secvars (k,args) concl db = let se = find k db in if matches_modes args se.sentry_mode then let st = if db.use_dn then Some db.hintdb_state else None in let pat = lookup_tacs concl st se in - merge_entry db [] pat - else merge_entry db [] [] + merge_entry secvars db [] pat + else merge_entry secvars db [] [] let is_exact = function | Give_exact _ -> true @@ -502,7 +589,7 @@ module Hint_db = struct | _ -> false let addkv gr id v db = - let idv = id, v in + let idv = id, { v with db = db.hintdb_name } in let k = match gr with | Some gr -> if db.use_dn && is_transparent_gr db.hintdb_state gr && is_unfold v.code.obj then None else Some gr @@ -567,11 +654,11 @@ module Hint_db = struct let get_entry se = let h = List.merge pri_order_int se.sentry_nopat se.sentry_pat in - List.map realize_tac h + List.map snd h let iter f db = let iter_se k se = f (Some k) se.sentry_mode (get_entry se) in - f None [] (List.map (fun x -> realize_tac (snd x)) db.hintdb_nopat); + f None [] (List.map (fun x -> snd (snd x)) db.hintdb_nopat); Constr_map.iter iter_se db.hintdb_map let fold f db accu = @@ -606,8 +693,6 @@ type hint_db = Hint_db.t type hint_db_table = hint_db Hintdbmap.t ref -type hint_db_name = string - (** Initially created hint databases, for typeclasses and rewrite *) let typeclasses_db = "typeclass_instances" @@ -628,8 +713,7 @@ let searchtable_add (name,db) = let current_db_names () = Hintdbmap.domain !searchtable let current_db () = Hintdbmap.bindings !searchtable -let current_pure_db () = - List.map snd (Hintdbmap.bindings (Hintdbmap.remove "v62" !searchtable)) +let current_pure_db () = List.map snd (current_db ()) let error_no_such_hint_database x = errorlabstrm "Hints" (str "No such Hint database: " ++ str x ++ str ".") @@ -669,7 +753,20 @@ let try_head_pattern c = let with_uid c = { obj = c; uid = fresh_key () } -let make_exact_entry env sigma pri poly ?(name=PathAny) (c, cty, ctx) = +let secvars_of_idset s = + Id.Set.fold (fun id p -> + if is_section_variable id then + Id.Pred.add id p + else p) s Id.Pred.empty + +let secvars_of_constr env c = + secvars_of_idset (global_vars_set env c) + +let secvars_of_global env gr = + secvars_of_idset (vars_of_global_reference env gr) + +let make_exact_entry env sigma info poly ?(name=PathAny) (c, cty, ctx) = + let secvars = secvars_of_constr env c in let cty = strip_outer_cast cty in match kind_of_term cty with | Prod _ -> failwith "make_exact_entry" @@ -679,14 +776,17 @@ let make_exact_entry env sigma pri poly ?(name=PathAny) (c, cty, ctx) = try head_pattern_bound pat with BoundPattern -> failwith "make_exact_entry" in - (Some hd, - { pri = (match pri with None -> 0 | Some p -> p); - poly = poly; - pat = Some pat; - name = name; - code = with_uid (Give_exact (c, cty, ctx)); }) + let pri = match info.hint_priority with None -> 0 | Some p -> p in + let pat = match info.hint_pattern with + | Some pat -> snd pat + | None -> pat + in + (Some hd, + { pri; poly; pat = Some pat; name; + db = None; secvars; + code = with_uid (Give_exact (c, cty, ctx)); }) -let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, cty, ctx) = +let make_apply_entry env sigma (eapply,hnf,verbose) info poly ?(name=PathAny) (c, cty, ctx) = let cty = if hnf then hnf_constr env sigma cty else cty in match kind_of_term cty with | Prod _ -> @@ -698,12 +798,16 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, try head_pattern_bound pat with BoundPattern -> failwith "make_apply_entry" in let nmiss = List.length (clenv_missing ce) in + let secvars = secvars_of_constr env c in + let pri = match info.hint_priority with None -> nb_hyp cty + nmiss | Some p -> p in + let pat = match info.hint_pattern with + | Some p -> snd p | None -> pat + in if Int.equal nmiss 0 then (Some hd, - { pri = (match pri with None -> nb_hyp cty | Some p -> p); - poly = poly; - pat = Some pat; - name = name; + { pri; poly; pat = Some pat; name; + db = None; + secvars; code = with_uid (Res_pf(c,cty,ctx)); }) else begin if not eapply then failwith "make_apply_entry"; @@ -711,10 +815,8 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, Feedback.msg_info (str "the hint: eapply " ++ pr_lconstr c ++ str " will only be used by eauto"); (Some hd, - { pri = (match pri with None -> nb_hyp cty + nmiss | Some p -> p); - poly = poly; - pat = Some pat; - name = name; + { pri; poly; pat = Some pat; name; + db = None; secvars; code = with_uid (ERes_pf(c,cty,ctx)); }) end | _ -> failwith "make_apply_entry" @@ -765,13 +867,14 @@ let fresh_global_or_constr env sigma poly cr = (c, Univ.ContextSet.empty) end -let make_resolves env sigma flags pri poly ?name cr = +let make_resolves env sigma flags info poly ?name cr = let c, ctx = fresh_global_or_constr env sigma poly cr in let cty = Retyping.get_type_of env sigma c in let try_apply f = try Some (f (c, cty, ctx)) with Failure _ -> None in let ents = List.map_filter try_apply - [make_exact_entry env sigma pri poly ?name; make_apply_entry env sigma flags pri poly ?name] + [make_exact_entry env sigma info poly ?name; + make_apply_entry env sigma flags info poly ?name] in if List.is_empty ents then errorlabstrm "Hint" @@ -783,15 +886,17 @@ let make_resolves env sigma flags pri poly ?name cr = (* used to add an hypothesis to the local hint database *) let make_resolve_hyp env sigma decl = let hname = get_id decl in + let c = mkVar hname in try - [make_apply_entry env sigma (true, true, false) None false + [make_apply_entry env sigma (true, true, false) empty_hint_info false ~name:(PathHints [VarRef hname]) - (mkVar hname, get_type decl, Univ.ContextSet.empty)] + (c, get_type decl, Univ.ContextSet.empty)] with | Failure _ -> [] | e when Logic.catchable_exception e -> anomaly (Pp.str "make_resolve_hyp") (* REM : in most cases hintname = id *) + let make_unfold eref = let g = global_of_evaluable_reference eref in (Some g, @@ -799,6 +904,8 @@ let make_unfold eref = poly = false; pat = None; name = PathHints [g]; + db = None; + secvars = secvars_of_global (Global.env ()) g; code = with_uid (Unfold_nth eref) }) let make_extern pri pat tacast = @@ -809,6 +916,8 @@ let make_extern pri pat tacast = poly = false; pat = pat; name = PathAny; + db = None; + secvars = Id.Pred.empty; (* Approximation *) code = with_uid (Extern tacast) }) let make_mode ref m = @@ -832,6 +941,8 @@ let make_trivial env sigma poly ?(name=PathAny) r = poly = poly; pat = Some (Patternops.pattern_of_constr env ce.evd (clenv_type ce)); name = name; + db = None; + secvars = secvars_of_constr env c; code= with_uid (Res_pf_THEN_trivial_fail(c,t,ctx)) }) @@ -845,7 +956,7 @@ let make_trivial env sigma poly ?(name=PathAny) r = let get_db dbname = try searchtable_map dbname - with Not_found -> Hint_db.empty empty_transparent_state false + with Not_found -> Hint_db.empty ~name:dbname empty_transparent_state false let add_hint dbname hintlist = let check (_, h) = @@ -905,7 +1016,7 @@ type hint_obj = { let load_autohint _ (kn, h) = let name = h.hint_name in match h.hint_action with - | CreateDB (b, st) -> searchtable_add (name, Hint_db.empty st b) + | CreateDB (b, st) -> searchtable_add (name, Hint_db.empty ~name st b) | AddTransparency (grs, b) -> add_transparency name grs b | AddHints hints -> add_hint name hints | RemoveHints grs -> remove_hint name grs @@ -1061,16 +1172,17 @@ let add_transparency l b local dbnames = Lib.add_anonymous_leaf (inAutoHint hint)) dbnames -let add_extern pri pat tacast local dbname = - let pat = match pat with +let add_extern info tacast local dbname = + let pat = match info.hint_pattern with | None -> None | Some (_, pat) -> Some pat in - let hint = make_hint ~local dbname (AddHints [make_extern pri pat tacast]) in + let hint = make_hint ~local dbname + (AddHints [make_extern (Option.get info.hint_priority) pat tacast]) in Lib.add_anonymous_leaf (inAutoHint hint) -let add_externs pri pat tacast local dbnames = - List.iter (add_extern pri pat tacast local) dbnames +let add_externs info tacast local dbnames = + List.iter (add_extern info tacast local) dbnames let add_trivials env sigma l local dbnames = List.iter @@ -1084,15 +1196,16 @@ let (forward_intern_tac, extern_intern_tac) = Hook.make () type hnf = bool +type hint_info = (patvar list * constr_pattern) hint_info_gen + type hints_entry = - | HintsResolveEntry of (int option * polymorphic * hnf * hints_path_atom * hint_term) list + | HintsResolveEntry of (hint_info * polymorphic * hnf * hints_path_atom * hint_term) list | HintsImmediateEntry of (hints_path_atom * polymorphic * hint_term) list | HintsCutEntry of hints_path | HintsUnfoldEntry of evaluable_global_reference list | HintsTransparencyEntry of evaluable_global_reference list * bool | HintsModeEntry of global_reference * hint_mode list - | HintsExternEntry of - int * (patvar list * constr_pattern) option * glob_tactic_expr + | HintsExternEntry of hint_info * glob_tactic_expr let default_prepare_hint_ident = Id.of_string "H" @@ -1156,11 +1269,12 @@ let interp_hints poly = (PathHints [gr], poly, IsGlobRef gr) | HintsConstr c -> (PathAny, poly, f poly c) in - let fres (pri, b, r) = + let fp = Constrintern.intern_constr_pattern (Global.env()) in + let fres (info, b, r) = let path, poly, gr = fi r in - (pri, poly, b, path, gr) + let info = { info with hint_pattern = Option.map fp info.hint_pattern } in + (info, poly, b, path, gr) in - let fp = Constrintern.intern_constr_pattern (Global.env()) in match h with | HintsResolve lhints -> HintsResolveEntry (List.map fres lhints) | HintsImmediate lhints -> HintsImmediateEntry (List.map fi lhints) @@ -1176,14 +1290,14 @@ let interp_hints poly = List.init (nconstructors ind) (fun i -> let c = (ind,i+1) in let gr = ConstructRef c in - None, mib.Declarations.mind_polymorphic, true, + empty_hint_info, mib.Declarations.mind_polymorphic, true, PathHints [gr], IsGlobRef gr) in HintsResolveEntry (List.flatten (List.map constr_hints_of_ind lqid)) | HintsExtern (pri, patcom, tacexp) -> let pat = Option.map fp patcom in let l = match pat with None -> [] | Some (l, _) -> l in let tacexp = Hook.get forward_intern_tac l tacexp in - HintsExternEntry (pri, pat, tacexp) + HintsExternEntry ({ hint_priority = Some pri; hint_pattern = pat }, tacexp) let add_hints local dbnames0 h = if String.List.mem "nocore" dbnames0 then @@ -1199,8 +1313,8 @@ let add_hints local dbnames0 h = | HintsUnfoldEntry lhints -> add_unfolds lhints local dbnames | HintsTransparencyEntry (lhints, b) -> add_transparency lhints b local dbnames - | HintsExternEntry (pri, pat, tacexp) -> - add_externs pri pat tacexp local dbnames + | HintsExternEntry (info, tacexp) -> + add_externs info tacexp local dbnames let expand_constructor_hints env sigma lems = List.map_append (fun (evd,lem) -> @@ -1224,7 +1338,7 @@ let add_hint_lemmas env sigma eapply lems hint_db = let lems = expand_constructor_hints env sigma lems in let hintlist' = List.map_append (fun (poly, lem) -> - make_resolves env sigma (eapply,true,false) None poly lem) lems in + make_resolves env sigma (eapply,true,false) empty_hint_info poly lem) lems in Hint_db.add_list env sigma hintlist' hint_db let make_local_hint_db env sigma ts eapply lems = @@ -1262,11 +1376,11 @@ let make_db_list dbnames = let pr_hint_elt (c, _, _) = pr_constr c let pr_hint h = match h.obj with - | Res_pf (c, _) -> (str"apply " ++ pr_hint_elt c) - | ERes_pf (c, _) -> (str"eapply " ++ pr_hint_elt c) + | Res_pf (c, _) -> (str"simple apply " ++ pr_hint_elt c) + | ERes_pf (c, _) -> (str"simple eapply " ++ pr_hint_elt c) | Give_exact (c, _) -> (str"exact " ++ pr_hint_elt c) | Res_pf_THEN_trivial_fail (c, _) -> - (str"apply " ++ pr_hint_elt c ++ str" ; trivial") + (str"simple apply " ++ pr_hint_elt c ++ str" ; trivial") | Unfold_nth c -> (str"unfold " ++ pr_evaluable_reference c) | Extern tac -> let env = @@ -1278,7 +1392,9 @@ let pr_hint h = match h.obj with (str "(*external*) " ++ Pptactic.pr_glb_generic env tac) let pr_id_hint (id, v) = - (pr_hint v.code ++ str"(level " ++ int v.pri ++ str", id " ++ int id ++ str ")" ++ spc ()) + let pr_pat p = str", pattern " ++ pr_lconstr_pattern p in + (pr_hint v.code ++ str"(level " ++ int v.pri ++ pr_opt_no_spc pr_pat v.pat + ++ str", id " ++ int id ++ str ")" ++ spc ()) let pr_hint_list hintlist = (str " " ++ hov 0 (prlist pr_id_hint hintlist) ++ fnl ()) @@ -1292,7 +1408,7 @@ let pr_hints_db (name,db,hintlist) = let pr_hint_list_for_head c = let dbs = current_db () in let validate (name, db) = - let hints = List.map (fun v -> 0, v) (Hint_db.map_all c db) in + let hints = List.map (fun v -> 0, v) (Hint_db.map_all Id.Pred.full c db) in (name, db, hints) in let valid_dbs = List.map validate dbs in @@ -1314,9 +1430,9 @@ let pr_hint_term cl = let fn = try let hdc = decompose_app_bound cl in if occur_existential cl then - Hint_db.map_existential hdc cl - else Hint_db.map_auto hdc cl - with Bound -> Hint_db.map_none + Hint_db.map_existential ~secvars:Id.Pred.full hdc cl + else Hint_db.map_auto ~secvars:Id.Pred.full hdc cl + with Bound -> Hint_db.map_none ~secvars:Id.Pred.full in let fn db = List.map (fun x -> 0, x) (fn db) in List.map (fun (name, db) -> (name, db, fn db)) dbs diff --git a/tactics/hints.mli b/tactics/hints.mli index 6f5ee8ba5e..1be3e0c52f 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -25,6 +25,10 @@ exception Bound val decompose_app_bound : constr -> global_reference * constr array +val secvars_of_hyps : Context.Named.t -> Id.Pred.t + +val empty_hint_info : 'a hint_info_gen + (** Pre-created hint databases *) type 'a hint_ast = @@ -38,17 +42,22 @@ type 'a hint_ast = type hint type raw_hint = constr * types * Univ.universe_context_set -type hints_path_atom = - | PathHints of global_reference list +type 'a hints_path_atom_gen = + | PathHints of 'a list (* For forward hints, their names is the list of projections *) | PathAny +type hints_path_atom = global_reference hints_path_atom_gen +type hint_db_name = string + type 'a with_metadata = private { pri : int; (** A number between 0 and 4, 4 = lower priority *) poly : polymorphic; (** Is the hint polymorpic and hence should be refreshed at each application *) pat : constr_pattern option; (** A pattern for the concl of the Goal *) name : hints_path_atom; (** A potential name to refer to the hint *) - code : 'a; (** the tactic to apply when the concl matches pat *) + db : hint_db_name option; + secvars : Id.Pred.t; (** The section variables this hint depends on, as a predicate *) + code : 'a; (** the tactic to apply when the concl matches pat *) } type full_hint = hint with_metadata @@ -59,42 +68,56 @@ type search_entry type hint_entry -type hints_path = - | PathAtom of hints_path_atom - | PathStar of hints_path - | PathSeq of hints_path * hints_path - | PathOr of hints_path * hints_path +type 'a hints_path_gen = + | PathAtom of 'a hints_path_atom_gen + | PathStar of 'a hints_path_gen + | PathSeq of 'a hints_path_gen * 'a hints_path_gen + | PathOr of 'a hints_path_gen * 'a hints_path_gen | PathEmpty | PathEpsilon +type pre_hints_path = Libnames.reference hints_path_gen +type hints_path = global_reference hints_path_gen + val normalize_path : hints_path -> hints_path val path_matches : hints_path -> hints_path_atom list -> bool val path_derivate : hints_path -> hints_path_atom -> hints_path -val pp_hints_path_atom : hints_path_atom -> Pp.std_ppcmds +val pp_hints_path_gen : ('a -> Pp.std_ppcmds) -> 'a hints_path_gen -> Pp.std_ppcmds +val pp_hints_path_atom : ('a -> Pp.std_ppcmds) -> 'a hints_path_atom_gen -> Pp.std_ppcmds val pp_hints_path : hints_path -> Pp.std_ppcmds val pp_hint_mode : hint_mode -> Pp.std_ppcmds +val glob_hints_path_atom : + Libnames.reference hints_path_atom_gen -> Globnames.global_reference hints_path_atom_gen +val glob_hints_path : + Libnames.reference hints_path_gen -> Globnames.global_reference hints_path_gen module Hint_db : sig type t - val empty : transparent_state -> bool -> t + val empty : ?name:hint_db_name -> transparent_state -> bool -> t val find : global_reference -> t -> search_entry - val map_none : t -> full_hint list + + (** All hints which have no pattern. + * [secvars] represent the set of section variables that + * can be used in the hint. *) + val map_none : secvars:Id.Pred.t -> t -> full_hint list (** All hints associated to the reference *) - val map_all : global_reference -> t -> full_hint list + val map_all : secvars:Id.Pred.t -> global_reference -> t -> full_hint list (** All hints associated to the reference, respecting modes if evars appear in the arguments, _not_ using the discrimination net. *) - val map_existential : (global_reference * constr array) -> constr -> t -> full_hint list + val map_existential : secvars:Id.Pred.t -> + (global_reference * constr array) -> constr -> t -> full_hint list (** All hints associated to the reference, respecting modes if evars appear in the arguments and using the discrimination net. *) - val map_eauto : (global_reference * constr array) -> constr -> t -> full_hint list + val map_eauto : secvars:Id.Pred.t -> (global_reference * constr array) -> constr -> t -> full_hint list (** All hints associated to the reference, respecting modes if evars appear in the arguments. *) - val map_auto : (global_reference * constr array) -> constr -> t -> full_hint list + val map_auto : secvars:Id.Pred.t -> + (global_reference * constr array) -> constr -> t -> full_hint list val add_one : env -> evar_map -> hint_entry -> t -> t val add_list : env -> evar_map -> hint_entry list -> t -> t @@ -113,26 +136,25 @@ module Hint_db : val unfolds : t -> Id.Set.t * Cset.t end -type hint_db_name = string - type hint_db = Hint_db.t type hnf = bool +type hint_info = (patvar list * constr_pattern) hint_info_gen + type hint_term = | IsGlobRef of global_reference | IsConstr of constr * Univ.universe_context_set type hints_entry = - | HintsResolveEntry of (int option * polymorphic * hnf * hints_path_atom * - hint_term) list + | HintsResolveEntry of + (hint_info * polymorphic * hnf * hints_path_atom * hint_term) list | HintsImmediateEntry of (hints_path_atom * polymorphic * hint_term) list | HintsCutEntry of hints_path | HintsUnfoldEntry of evaluable_global_reference list | HintsTransparencyEntry of evaluable_global_reference list * bool | HintsModeEntry of global_reference * hint_mode list - | HintsExternEntry of - int * (patvar list * constr_pattern) option * Tacexpr.glob_tactic_expr + | HintsExternEntry of hint_info * Tacexpr.glob_tactic_expr val searchtable_map : hint_db_name -> hint_db @@ -159,22 +181,34 @@ val prepare_hint : bool (* Check no remaining evars *) -> (bool * bool) (* polymorphic or monomorphic, local or global *) -> env -> evar_map -> open_constr -> hint_term -(** [make_exact_entry pri (c, ctyp)]. +(** [make_exact_entry info (c, ctyp, ctx)]. [c] is the term given as an exact proof to solve the goal; - [ctyp] is the type of [c]. *) - -val make_exact_entry : env -> evar_map -> int option -> polymorphic -> ?name:hints_path_atom -> + [ctyp] is the type of [c]. + [ctx] is its (refreshable) universe context. + In info: + [hint_priority] is the hint's desired priority, it is 0 if unspecified + [hint_pattern] is the hint's desired pattern, it is inferred if not specified +*) + +val make_exact_entry : env -> evar_map -> hint_info -> polymorphic -> ?name:hints_path_atom -> (constr * types * Univ.universe_context_set) -> hint_entry -(** [make_apply_entry (eapply,hnf,verbose) pri (c,cty)]. +(** [make_apply_entry (eapply,hnf,verbose) info (c,cty,ctx))]. [eapply] is true if this hint will be used only with EApply; [hnf] should be true if we should expand the head of cty before searching for products; [c] is the term given as an exact proof to solve the goal; - [cty] is the type of [c]. *) + [cty] is the type of [c]. + [ctx] is its (refreshable) universe context. + In info: + [hint_priority] is the hint's desired priority, it is computed as the number of products in [cty] + if unspecified + [hint_pattern] is the hint's desired pattern, it is inferred from the conclusion of [cty] + if not specified +*) val make_apply_entry : - env -> evar_map -> bool * bool * bool -> int option -> polymorphic -> ?name:hints_path_atom -> + env -> evar_map -> bool * bool * bool -> hint_info -> polymorphic -> ?name:hints_path_atom -> (constr * types * Univ.universe_context_set) -> hint_entry (** A constr which is Hint'ed will be: @@ -185,7 +219,7 @@ val make_apply_entry : has missing arguments. *) val make_resolves : - env -> evar_map -> bool * bool * bool -> int option -> polymorphic -> ?name:hints_path_atom -> + env -> evar_map -> bool * bool * bool -> hint_info -> polymorphic -> ?name:hints_path_atom -> hint_term -> hint_entry list (** [make_resolve_hyp hname htyp]. diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 642bf520b1..40b600c890 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -202,11 +202,11 @@ let inversion_scheme env sigma t sort dep_option inv_op = tclTHEN intro (onLastHypId inv_op)) pf) in let pfterm = List.hd (Proof.partial_proof pf) in - let global_named_context = Global.named_context () in + let global_named_context = Global.named_context_val () in let ownSign = ref begin fold_named_context (fun env d sign -> - if mem_named_context (get_id d) global_named_context then sign + if mem_named_context_val (get_id d) global_named_context then sign else Context.Named.add d sign) invEnv ~init:Context.Named.empty end in diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 87fdcf14d4..66da9ee182 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -322,7 +322,7 @@ module New = struct try Refiner.catch_failerror e; tclUNIT () - with e -> tclZERO e + with e when CErrors.noncritical e -> tclZERO e (* spiwack: I chose to give the Ltac + the same semantics as [Proofview.tclOR], however, for consistency with the or-else diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 2d901c2dbc..9d64e7c599 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -48,7 +48,11 @@ let inj_with_occurrences e = (AllOccurrences,e) let dloc = Loc.ghost -let typ_of env sigma c = Retyping.get_type_of env (Sigma.to_evar_map sigma) c +let typ_of env sigma c = + let open Retyping in + try get_type_of ~lax:true env (Sigma.to_evar_map sigma) c + with RetypeError e -> + user_err_loc (Loc.ghost, "", print_retype_error e) open Goptions @@ -79,7 +83,7 @@ let _ = let apply_solve_class_goals = ref (false) let _ = Goptions.declare_bool_option { - Goptions.optsync = true; Goptions.optdepr = false; + Goptions.optsync = true; Goptions.optdepr = true; Goptions.optname = "Perform typeclass resolution on apply-generated subgoals."; Goptions.optkey = ["Typeclass";"Resolution";"After";"Apply"]; @@ -179,10 +183,10 @@ let introduction ?(check=true) id = let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in - let hyps = Proofview.Goal.hyps gl in + let hyps = named_context_val (Proofview.Goal.env gl) in let store = Proofview.Goal.extra gl in let env = Proofview.Goal.env gl in - let () = if check && mem_named_context id hyps then + let () = if check && mem_named_context_val id hyps then errorlabstrm "Tactics.introduction" (str "Variable " ++ pr_id id ++ str " is already declared.") in @@ -518,7 +522,7 @@ let mutual_fix f n rest j = Proofview.Goal.nf_enter { enter = begin fun gl -> let (sp', u') = check_mutind env sigma n ar in if not (eq_mind sp sp') then error "Fixpoints should be on the same mutual inductive declaration."; - if mem_named_context f (named_context_of_val sign) then + if mem_named_context_val f sign then errorlabstrm "Logic.prim_refiner" (str "Name " ++ pr_id f ++ str " already used in the environment"); mk_sign (push_named_context_val (LocalAssum (f, ar)) sign) oth @@ -571,7 +575,7 @@ let mutual_cofix f others j = Proofview.Goal.nf_enter { enter = begin fun gl -> | [] -> sign | (f, ar) :: oth -> let open Context.Named.Declaration in - if mem_named_context f (named_context_of_val sign) then + if mem_named_context_val f sign then error "Name already used in the environment."; mk_sign (push_named_context_val (LocalAssum (f, ar)) sign) oth in @@ -1137,7 +1141,7 @@ let run_delayed env sigma c = let tactic_infer_flags with_evar = { Pretyping.use_typeclasses = true; - Pretyping.use_unif_heuristics = true; + Pretyping.solve_unification_constraints = true; Pretyping.use_hook = Some solve_by_implicit_tactic; Pretyping.fail_evar = not with_evar; Pretyping.expand_evars = true } @@ -1937,9 +1941,7 @@ let exact_check c = let cast_no_check cast c = Proofview.Goal.enter { enter = begin fun gl -> let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in - Refine.refine ~unsafe:true { run = begin fun sigma -> - Sigma.here (Term.mkCast (c, cast, concl)) sigma - end } + exact_no_check (Term.mkCast (c, cast, concl)) end } let vm_cast_no_check c = cast_no_check Term.VMcast c @@ -1976,7 +1978,7 @@ let assumption = in if is_same_type then (Proofview.Unsafe.tclEVARS sigma) <*> - Refine.refine ~unsafe:true { run = fun h -> Sigma.here (mkVar (get_id decl)) h } + exact_no_check (mkVar (get_id decl)) else arec gl only_eq rest in let assumption_tac = { enter = begin fun gl -> @@ -2712,7 +2714,7 @@ let forward b usetac ipat c = match usetac with | None -> Proofview.Goal.enter { enter = begin fun gl -> - let t = Tacmach.New.pf_unsafe_type_of gl c in + let t = Tacmach.New.pf_get_type_of gl c in let hd = head_ident c in Tacticals.New.tclTHENFIRST (assert_as true hd ipat t) (exact_no_check c) end } @@ -2793,7 +2795,7 @@ let old_generalize_dep ?(with_let=false) c gl = let tothin = List.filter (fun id -> not (Id.List.mem id init_ids)) qhyps in let tothin' = match kind_of_term c with - | Var id when mem_named_context id sign && not (Id.List.mem id init_ids) + | Var id when mem_named_context_val id (val_of_named_context sign) && not (Id.List.mem id init_ids) -> id::tothin | _ -> tothin in @@ -2807,6 +2809,8 @@ let old_generalize_dep ?(with_let=false) c gl = in let cl'',evd = generalize_goal gl 0 ((AllOccurrences,c,body),Anonymous) (cl',project gl) in + (** Check that the generalization is indeed well-typed *) + let (evd, _) = Typing.type_of env evd cl'' in let args = Context.Named.to_instance to_quantify_rev in tclTHENLIST [tclEVARS evd; @@ -2819,10 +2823,12 @@ let generalize_dep ?(with_let = false) c = (** *) let generalize_gen_let lconstr = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let env = Proofview.Goal.env gl in let newcl, evd = List.fold_right_i (Tacmach.New.of_old generalize_goal gl) 0 lconstr (Tacmach.New.pf_concl gl,Tacmach.New.project gl) in + let (evd, _) = Typing.type_of env evd newcl in let map ((_, c, b),_) = if Option.is_empty b then Some c else None in let tac = apply_type newcl (List.map_filter map lconstr) in Sigma.Unsafe.of_pair (tac, evd) @@ -2943,8 +2949,8 @@ let unfold_body x = let open Context.Named.Declaration in Proofview.Goal.enter { enter = begin fun gl -> (** We normalize the given hypothesis immediately. *) - let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in - let xval = match Context.Named.lookup x hyps with + let env = Proofview.Goal.env (Proofview.Goal.assume gl) in + let xval = match Environ.lookup_named x env with | LocalAssum _ -> errorlabstrm "unfold_body" (pr_id x ++ str" is not a defined hypothesis.") | LocalDef (_,xval,_) -> xval @@ -4366,7 +4372,7 @@ let induction_gen clear_flag isrec with_evars elim let cls = Option.default allHypsAndConcl cls in let t = typ_of env sigma c in let is_arg_pure_hyp = - isVar c && not (mem_named_context (destVar c) (Global.named_context())) + isVar c && not (mem_named_context_val (destVar c) (Global.named_context_val ())) && lbind == NoBindings && not with_evars && Option.is_empty eqname && clear_flag == None && has_generic_occurrences_but_goal cls (destVar c) env ccl in @@ -4413,7 +4419,7 @@ let induction_gen_l isrec with_evars elim names lc = | [] -> Proofview.tclUNIT () | c::l' -> match kind_of_term c with - | Var id when not (mem_named_context id (Global.named_context())) + | Var id when not (mem_named_context_val id (Global.named_context_val ())) && not with_evars -> let _ = newlc:= id::!newlc in atomize_list l' @@ -4835,7 +4841,7 @@ let abstract_subproof id gk tac = let open Context.Named.Declaration in Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in - let current_sign = Global.named_context() + let current_sign = Global.named_context_val () and global_sign = Proofview.Goal.hyps gl in let sigma = Sigma.to_evar_map sigma in let evdref = ref sigma in @@ -4843,8 +4849,8 @@ let abstract_subproof id gk tac = List.fold_right (fun d (s1,s2) -> let id = get_id d in - if mem_named_context id current_sign && - interpretable_as_section_decl evdref (Context.Named.lookup id current_sign) d + if mem_named_context_val id current_sign && + interpretable_as_section_decl evdref (lookup_named_val id current_sign) d then (s1,push_named_context_val d s2) else (Context.Named.add d s1,s2)) global_sign (Context.Named.empty, empty_named_context_val) in @@ -4967,9 +4973,16 @@ module New = struct open Locus let reduce_after_refine = + let onhyps = + (** We reduced everywhere in the hyps before 8.6 *) + if Flags.version_compare !Flags.compat_version Flags.V8_5 == 0 + then None + else Some [] + in reduce - (Lazy {rBeta=true;rMatch=true;rFix=true;rCofix=true;rZeta=false;rDelta=false;rConst=[]}) - {onhyps=Some []; concl_occs=AllOccurrences } + (Lazy {rBeta=true;rMatch=true;rFix=true;rCofix=true; + rZeta=false;rDelta=false;rConst=[]}) + {onhyps; concl_occs=AllOccurrences } let refine ?unsafe c = Refine.refine ?unsafe c <*> diff --git a/test-suite/.csdp.cache b/test-suite/.csdp.cache Binary files differindex b8c07512f3..ba85286dd3 100644 --- a/test-suite/.csdp.cache +++ b/test-suite/.csdp.cache diff --git a/test-suite/Makefile b/test-suite/Makefile index a40ea80ae4..c10cd4ed44 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -51,7 +51,7 @@ SINGLE_QUOTE=" get_coq_prog_args_in_parens = $(subst $(SINGLE_QUOTE),,$(if $(call get_coq_prog_args,$(1)), ($(call get_coq_prog_args,$(1))))) # get the command to use with this set of arguments; if there's -compile, use coqc, else use coqtop has_compile_flag = $(filter "-compile",$(call get_coq_prog_args,$(1))) -has_profile_ltac_or_compile_flag = $(filter "-profile-ltac" "-compile",$(call get_coq_prog_args,$(1))) +has_profile_ltac_or_compile_flag = $(filter "-profile-ltac-cutoff" "-profile-ltac" "-compile",$(call get_coq_prog_args,$(1))) get_command_based_on_flags = $(if $(call has_profile_ltac_or_compile_flag,$(1)),$(coqc),$(command)) @@ -88,6 +88,9 @@ VSUBSYSTEMS := prerequisite success failure $(BUGS) output \ # All subsystems SUBSYSTEMS := $(VSUBSYSTEMS) misc bugs ide vio coqchk +PREREQUISITELOG = prerequisite/admit.v.log \ + prerequisite/make_local.v.log prerequisite/make_notation.v.log + ####################################################################### # Phony targets ####################################################################### @@ -102,7 +105,7 @@ run: $(SUBSYSTEMS) bugs: $(BUGS) clean: - rm -f trace lia.cache + rm -f trace .lia.cache $(SHOW) "RM <**/*.stamp> <**/*.vo> <**/*.vio> <**/*.log>" $(HIDE)find . \( \ -name '*.stamp' -o -name '*.vo' -o -name '*.vio' -o -name '*.log' \ @@ -226,7 +229,7 @@ $(addsuffix .log,$(wildcard prerequisite/*.v)): %.v.log: %.v fi; \ } > "$@" -$(addsuffix .log,$(wildcard success/*.v micromega/*.v modules/*.v)): %.v.log: %.v +$(addsuffix .log,$(wildcard success/*.v micromega/*.v modules/*.v)): %.v.log: %.v $(PREREQUISITELOG) @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ opts="$(if $(findstring modules/,$<),-R modules Mods -impredicative-set)"; \ @@ -257,7 +260,7 @@ $(addsuffix .log,$(wildcard stm/*.v)): %.v.log: %.v fi; \ } > "$@" -$(addsuffix .log,$(wildcard failure/*.v)): %.v.log: %.v +$(addsuffix .log,$(wildcard failure/*.v)): %.v.log: %.v $(PREREQUISITELOG) @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ @@ -271,7 +274,7 @@ $(addsuffix .log,$(wildcard failure/*.v)): %.v.log: %.v fi; \ } > "$@" -$(addsuffix .log,$(wildcard output/*.v)): %.v.log: %.v %.out +$(addsuffix .log,$(wildcard output/*.v)): %.v.log: %.v %.out $(PREREQUISITELOG) @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ @@ -281,6 +284,7 @@ $(addsuffix .log,$(wildcard output/*.v)): %.v.log: %.v %.out | grep -v "\[Loading ML file" \ | grep -v "Skipping rcfile loading" \ | grep -v "^<W>" \ + | sed 's/File "[^"]*"/File "stdin"/' \ > $$tmpoutput; \ diff -u $*.out $$tmpoutput 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ @@ -304,16 +308,19 @@ $(addsuffix .log,$(wildcard output-modulo-time/*.v)): %.v.log: %.v %.out | grep -v "\[Loading ML file" \ | grep -v "Skipping rcfile loading" \ | grep -v "^<W>" \ - | sed -e 's/\s*[0-9]*\.[0-9][0-9]*\s*//g' \ + | sed -e 's/\s*[-+0-9]*\.[0-9][0-9]*\s*//g' \ -e 's/\s*0\.\s*//g' \ -e 's/\s*[-+]nan\s*//g' \ -e 's/\s*[-+]inf\s*//g' \ + -e 's/^[^a-zA-Z]*//' \ + | sort \ > $$tmpoutput; \ - sed -e 's/\s*[0-9]*\.[0-9][0-9]*\s*//g' \ + sed -e 's/\s*[-+0-9]*\.[0-9][0-9]*\s*//g' \ -e 's/\s*0\.\s*//g' \ -e 's/\s*[-+]nan\s*//g' \ -e 's/\s*[-+]inf\s*//g' \ - $*.out > $$tmpexpected; \ + -e 's/^[^a-zA-Z]*//' \ + $*.out | sort > $$tmpexpected; \ diff -b -u $$tmpexpected $$tmpoutput 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ echo $(log_success); \ @@ -326,7 +333,7 @@ $(addsuffix .log,$(wildcard output-modulo-time/*.v)): %.v.log: %.v %.out rm $$tmpexpected; \ } > "$@" -$(addsuffix .log,$(wildcard interactive/*.v)): %.v.log: %.v +$(addsuffix .log,$(wildcard interactive/*.v)): %.v.log: %.v $(PREREQUISITELOG) @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ @@ -344,7 +351,7 @@ $(addsuffix .log,$(wildcard interactive/*.v)): %.v.log: %.v # the .v file with exactly two digits after the dot. The reference for # time is a 6120 bogomips cpu. ifneq (,$(bogomips)) -$(addsuffix .log,$(wildcard complexity/*.v)): %.v.log: %.v +$(addsuffix .log,$(wildcard complexity/*.v)): %.v.log: %.v $(PREREQUISITELOG) @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ @@ -375,7 +382,7 @@ $(addsuffix .log,$(wildcard complexity/*.v)): %.v.log: %.v endif # Ideal-features tests -$(addsuffix .log,$(wildcard ideal-features/*.v)): %.v.log: %.v +$(addsuffix .log,$(wildcard ideal-features/*.v)): %.v.log: %.v $(PREREQUISITELOG) @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ diff --git a/test-suite/bugs/closed/2310.v b/test-suite/bugs/closed/2310.v index 0be859eddf..7fae328715 100644 --- a/test-suite/bugs/closed/2310.v +++ b/test-suite/bugs/closed/2310.v @@ -14,4 +14,8 @@ Definition replace a (y:Nest (prod a a)) : a = a -> Nest a. (P:=\a.Nest (prod a a) and P:=\_.Nest (prod a a)) and refine should either leave P as subgoal or choose itself one solution *) -intros. refine (Cons (cast H _ y)).
\ No newline at end of file + intros. Fail refine (Cons (cast H _ y)). + Unset Solve Unification Constraints. (* Keep the unification constraint around *) + refine (Cons (cast H _ y)). + intros. + refine (Nest (prod X X)). Qed.
\ No newline at end of file diff --git a/test-suite/bugs/closed/3045.v b/test-suite/bugs/closed/3045.v index ef110ad0d0..5f80013df2 100644 --- a/test-suite/bugs/closed/3045.v +++ b/test-suite/bugs/closed/3045.v @@ -12,7 +12,7 @@ Record SpecializedCategory (obj : Type) := Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d' }. -Arguments Compose {obj} [C s d d'] m1 m2 : rename. +Arguments Compose {obj} [C s d d'] _ _ : rename. Inductive ReifiedMorphism : forall objC (C : SpecializedCategory objC), C -> C -> Type := | ReifiedComposedMorphism : forall objC C s d d', ReifiedMorphism C d d' -> ReifiedMorphism C s d -> @ReifiedMorphism objC C s d'. diff --git a/test-suite/bugs/closed/3209.v b/test-suite/bugs/closed/3209.v new file mode 100644 index 0000000000..855058b011 --- /dev/null +++ b/test-suite/bugs/closed/3209.v @@ -0,0 +1,75 @@ +(* Avoiding some occur-check *) + +(* 1. Original example *) + +Inductive eqT {A} (x : A) : A -> Type := + reflT : eqT x x. +Definition Bi_inv (A B : Type) (f : (A -> B)) := + sigT (fun (g : B -> A) => + sigT (fun (h : B -> A) => + sigT (fun (α : forall b : B, eqT (f (g b)) b) => + forall a : A, eqT (h (f a)) a))). +Definition TEquiv (A B : Type) := sigT (fun (f : A -> B) => Bi_inv _ _ f). + +Axiom UA : forall (A B : Type), TEquiv (TEquiv A B) (eqT A B). +Definition idtoeqv {A B} (e : eqT A B) : TEquiv A B := + sigT_rect (fun _ => TEquiv A B) + (fun (f : TEquiv A B -> eqT A B) H => + sigT_rect _ (* (fun _ => TEquiv A B) *) + (fun g _ => g e) + H) + (UA A B). + +(* 2. Alternative example by Guillaume *) + +Inductive foo (A : Prop) : Prop := Foo : foo A. +Axiom bar : forall (A : Prop) (P : foo A -> Prop), (A -> P (Foo A)) -> Prop. + +(* This used to fail with a Not_found, we fail more graciously but a + heuristic could be implemented, e.g. in some smart occur-check + function, to find a solution of then form ?P := fun _ => ?P' *) + +Fail Check (fun e : ?[T] => bar ?[A] ?[P] (fun g : ?[A'] => g e)). + +(* This works and tells which solution we could have inferred *) + +Check (fun e : ?[T] => bar ?[A] (fun _ => ?[P]) (fun g : ?[A'] => g e)). + +(* For the record, here is the trace in the failing example: + +In (fun e : ?T => bar ?[A] ?[P] (fun g : ?A' => g e)), we have the existential variables + +e:?T |- ?A : Prop +e:?T |- ?P : foo ?A -> Prop +e:?T |- ?A' : Type + +with constraints + +?A' == ?A +?A' == ?T -> ?P (Foo ?A) + +To type (g e), unification first defines + +?A := forall x:?B, ?P'{e:=e,x:=x} +with ?T <= ?B +and ?P'@{e:=e,x:=e} <= ?P@{e:=e} (Foo (forall x:?B, ?P'{e:=e,x:=x})) + +Then, since ?P'@{e:=e,x:=e} may use "e" in two different ways, it is +not a pattern and we define a new + +e:?T x:?B|- ?P'' : foo (?B' -> ?P''') -> Prop + +for some ?B' and ?P''', together with + +?P'@{e,x} := ?P''{e:=e,x:=e} (Foo (?B -> ?P') +?P@{e} := ?P''{e:=e,x:=e} + +Moreover, ?B' and ?P''' have to satisfy + +?B'@{e:=e,x:=e} == ?B@{e:=e} +?P'''@{e:=e,x:=e} == ?P'@{e:=e,x:=x} + +and this leads to define ?P' which was the initial existential +variable to define. +*) + diff --git a/test-suite/bugs/closed/3441.v b/test-suite/bugs/closed/3441.v new file mode 100644 index 0000000000..50d2978077 --- /dev/null +++ b/test-suite/bugs/closed/3441.v @@ -0,0 +1,23 @@ +Axiom f : nat -> nat -> nat. +Fixpoint do_n (n : nat) (k : nat) := + match n with + | 0 => k + | S n' => do_n n' (f k k) + end. + +Notation big := (_ = _). +Axiom k : nat. +Goal True. +Timeout 1 let H := fresh "H" in + let x := constr:(let n := 17 in do_n n = do_n n) in + let y := (eval lazy in x) in + pose proof y as H. (* Finished transaction in 1.102 secs (1.084u,0.016s) (successful) *) +Timeout 1 let H := fresh "H" in + let x := constr:(let n := 17 in do_n n = do_n n) in + let y := (eval lazy in x) in + pose y as H; clearbody H. (* Finished transaction in 0.412 secs (0.412u,0.s) (successful) *) + +Timeout 1 Time let H := fresh "H" in + let x := constr:(let n := 17 in do_n n = do_n n) in + let y := (eval lazy in x) in + assert (H := y). (* Finished transaction in 1.19 secs (1.164u,0.024s) (successful) *)
\ No newline at end of file diff --git a/test-suite/bugs/closed/3495.v b/test-suite/bugs/closed/3495.v new file mode 100644 index 0000000000..102a2aba0d --- /dev/null +++ b/test-suite/bugs/closed/3495.v @@ -0,0 +1,18 @@ +Require Import RelationClasses. + +Axiom R : Prop -> Prop -> Prop. +Declare Instance : Reflexive R. + +Class bar := { x : False }. +Record foo := { a : Prop ; b : bar }. + +Definition default_foo (a0 : Prop) `{b : bar} : foo := {| a := a0 ; b := b |}. + +Goal exists k, R k True. +Proof. +eexists. +evar (b : bar). +let e := match goal with |- R ?e _ => constr:(e) end in +unify e (a (default_foo True)). +subst b. +reflexivity. diff --git a/test-suite/bugs/closed/3513.v b/test-suite/bugs/closed/3513.v index fcdfa0057b..9ed0926a66 100644 --- a/test-suite/bugs/closed/3513.v +++ b/test-suite/bugs/closed/3513.v @@ -1,4 +1,3 @@ -Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 5752 lines to 3828 lines, then from 2707 lines to 558 lines, then from 472 lines to 168 lines, then from 110 lines to 101 lines, then from 96 lines to 77 lines, then from 80 lines to 64 lines *) Require Coq.Setoids.Setoid. Import Coq.Setoids.Setoid. @@ -35,7 +34,7 @@ Local Existing Instance ILFun_Ops. Local Existing Instance ILFun_ILogic. Definition catOP (P Q: OPred) : OPred := admit. Add Parametric Morphism : catOP with signature lentails ==> lentails ==> lentails as catOP_entails_m. -admit. +apply admit. Defined. Definition catOPA (P Q R : OPred) : catOP (catOP P Q) R -|- catOP P (catOP Q R) := admit. Class IsPointed (T : Type) := point : T. @@ -69,8 +68,27 @@ Goal forall (T : Type) (O0 : T -> OPred) (O1 : T -> PointedOPred) pose P; refine (P _ _) end; unfold Basics.flip. - 2: solve [ apply reflexivity ]. - Undo. - 2: reflexivity. (* Toplevel input, characters 18-29: -Error: -Tactic failure: The relation lentails is not a declared reflexive relation. Maybe you need to require the Setoid library. *)
\ No newline at end of file + Focus 2. + Set Typeclasses Debug. + Set Typeclasses Legacy Resolution. + apply reflexivity. + (* Debug: 1.1: apply @IsPointed_catOP on +(IsPointed (exists x0 : Actions, (catOP ?Goal O2 : OPred) x0)) +Debug: 1.1.1.1: apply OPred_inhabited on (IsPointed (exists x0 : Actions, ?Goal x0)) +Debug: 1.1.2.1: apply OPred_inhabited on (IsPointed (exists x : Actions, O2 x)) +Debug: 2.1: apply @Equivalence_Reflexive on (Reflexive lentails) +Debug: 2.1.1: no match for (Equivalence lentails) , 5 possibilities +Debug: Backtracking after apply @Equivalence_Reflexive +Debug: 2.2: apply @PreOrder_Reflexive on (Reflexive lentails) +Debug: 2.2.1.1: apply @lentailsPre on (PreOrder lentails) +Debug: 2.2.1.1.1.1: apply ILFun_ILogic on (ILogic OPred) +*) + Undo. Unset Typeclasses Legacy Resolution. + Test Typeclasses Unique Solutions. + Test Typeclasses Unique Instances. + Show Existentials. + Set Typeclasses Debug Verbosity 2. + Set Printing All. + (* As in 8.5, allow a shelved subgoal to remain *) + apply reflexivity. +
\ No newline at end of file diff --git a/test-suite/bugs/closed/3647.v b/test-suite/bugs/closed/3647.v index 495e67e09e..f5a22bd508 100644 --- a/test-suite/bugs/closed/3647.v +++ b/test-suite/bugs/closed/3647.v @@ -650,4 +650,5 @@ Goal forall (ptest : program) (cond : Condition) (value : bool) Grab Existential Variables. subst_body; simpl. - refine (all_behead (projT2 _)). + Fail refine (all_behead (projT2 _)). + Unset Solve Unification Constraints. refine (all_behead (projT2 _)). diff --git a/test-suite/bugs/closed/3699.v b/test-suite/bugs/closed/3699.v index 8dadc2419c..efa4325264 100644 --- a/test-suite/bugs/closed/3699.v +++ b/test-suite/bugs/closed/3699.v @@ -34,8 +34,7 @@ Module NonPrim. : forall b:B, P b. Proof. intros b. - unshelve (refine (pr1 (isconnected_elim _ _))). - exact b. + unshelve (refine (pr1 (isconnected_elim (A:=hfiber f b) _ _))). intro x. exact (transport P x.2 (d x.1)). Defined. @@ -47,8 +46,7 @@ Module NonPrim. : forall b:B, P b. Proof. intros b. - unshelve (refine (pr1 (isconnected_elim _ _))). - exact b. + unshelve (refine (pr1 (isconnected_elim (A:=hfiber f b) _ _))). intros [a p]. exact (transport P p (d a)). Defined. @@ -111,8 +109,7 @@ Module Prim. : forall b:B, P b. Proof. intros b. - unshelve (refine (pr1 (isconnected_elim _ _))). - exact b. + unshelve (refine (pr1 (isconnected_elim (A:=hfiber f b) _ _))). intro x. exact (transport P x.2 (d x.1)). Defined. @@ -124,8 +121,7 @@ Module Prim. : forall b:B, P b. Proof. intros b. - unshelve (refine (pr1 (isconnected_elim _ _))). - exact b. + unshelve (refine (pr1 (isconnected_elim (A:=hfiber f b) _ _))). intros [a p]. exact (transport P p (d a)). Defined. diff --git a/test-suite/bugs/opened/3753.v b/test-suite/bugs/closed/3753.v index 05d77c831b..5bfbee9494 100644 --- a/test-suite/bugs/opened/3753.v +++ b/test-suite/bugs/closed/3753.v @@ -1,4 +1,4 @@ Axiom foo : Type -> Type. Axiom bar : forall (T : Type), T -> foo T. Arguments bar A x : rename. -Fail About bar. +About bar.
\ No newline at end of file diff --git a/test-suite/bugs/closed/4095.v b/test-suite/bugs/closed/4095.v new file mode 100644 index 0000000000..ffd33d3813 --- /dev/null +++ b/test-suite/bugs/closed/4095.v @@ -0,0 +1,87 @@ +(* File reduced by coq-bug-finder from original input, then from 5752 lines to 3828 lines, then from 2707 lines to 558 lines, then from 472 lines to 168 lines, then from 110 lines to 101 lines, then from 96 lines to 77 lines, then from 80 lines to 64 lines, then from 92 lines to 79 lines *) +(* coqc version 8.5beta1 (February 2015) compiled on Feb 23 2015 18:32:3 with OCaml 4.01.0 + coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-8.5,v8.5 (ebfc19d792492417b129063fb511aa423e9d9e08) *) +Require Import Coq.Setoids.Setoid. +Generalizable All Variables. +Axiom admit : forall {T}, T. +Ltac admit := apply admit. +Class Equiv (A : Type) := equiv : relation A. +Class type (A : Type) {e : Equiv A} := eq_equiv : Equivalence equiv. +Class ILogicOps Frm := { lentails: relation Frm; + ltrue: Frm; + land: Frm -> Frm -> Frm; + lor: Frm -> Frm -> Frm }. +Infix "|--" := lentails (at level 79, no associativity). +Class ILogic Frm {ILOps: ILogicOps Frm} := { lentailsPre:> PreOrder lentails }. +Definition lequiv `{ILogic Frm} P Q := P |-- Q /\ Q |-- P. +Infix "-|-" := lequiv (at level 85, no associativity). +Instance lequiv_inverse_lentails `{ILogic Frm} : subrelation lequiv (inverse lentails) := admit. +Record ILFunFrm (T : Type) `{e : Equiv T} `{ILOps : ILogicOps Frm} := mkILFunFrm { ILFunFrm_pred :> T -> Frm }. +Section ILogic_Fun. + Context (T: Type) `{TType: type T}. + Context `{IL: ILogic Frm}. + Local Instance ILFun_Ops : ILogicOps (@ILFunFrm T _ Frm _) := admit. + Definition ILFun_ILogic : ILogic (@ILFunFrm T _ Frm _) := admit. +End ILogic_Fun. +Implicit Arguments ILFunFrm [[ILOps] [e]]. +Instance ILogicOps_Prop : ILogicOps Prop | 2 := {| lentails P Q := (P : Prop) -> Q; + ltrue := True; + land P Q := P /\ Q; + lor P Q := P \/ Q |}. +Axiom Action : Set. +Definition Actions := list Action. +Instance ActionsEquiv : Equiv Actions := { equiv a1 a2 := a1 = a2 }. +Definition OPred := ILFunFrm Actions Prop. +Local Existing Instance ILFun_Ops. +Local Existing Instance ILFun_ILogic. +Definition catOP (P Q: OPred) : OPred := admit. +Add Parametric Morphism : catOP with signature lentails ==> lentails ==> lentails as catOP_entails_m. +admit. +Defined. +Definition catOPA (P Q R : OPred) : catOP (catOP P Q) R -|- catOP P (catOP Q R) := admit. +Class IsPointed (T : Type) := point : T. +Notation IsPointed_OPred P := (IsPointed (exists x : Actions, (P : OPred) x)). +Record PointedOPred := mkPointedOPred { + OPred_pred :> OPred; + OPred_inhabited: IsPointed_OPred OPred_pred + }. +Existing Instance OPred_inhabited. +Canonical Structure default_PointedOPred O `{IsPointed_OPred O} : PointedOPred + := {| OPred_pred := O ; OPred_inhabited := _ |}. +Instance IsPointed_catOP `{IsPointed_OPred P, IsPointed_OPred Q} : IsPointed_OPred (catOP P Q) := admit. +Goal forall (T : Type) (O0 : T -> OPred) (O1 : T -> PointedOPred) + (tr : T -> T) (O2 : PointedOPred) (x : T) + (H : forall x0 : T, catOP (O0 x0) (O1 (tr x0)) |-- O1 x0), + exists e1 e2, + catOP (O0 e1) (OPred_pred e2) |-- catOP (O1 x) O2. + intros; do 2 esplit. + rewrite <- catOPA. + lazymatch goal with + | |- ?R (?f ?a ?b) (?f ?a' ?b') => + let P := constr:(fun H H' => @Morphisms.proper_prf (OPred -> OPred -> OPred) + (@Morphisms.respectful OPred (OPred -> OPred) + (@lentails OPred + (@ILFun_Ops Actions ActionsEquiv Prop ILogicOps_Prop)) + (@lentails OPred + (@ILFun_Ops Actions ActionsEquiv Prop ILogicOps_Prop) ==> + @lentails OPred + (@ILFun_Ops Actions ActionsEquiv Prop ILogicOps_Prop))) catOP + catOP_entails_m_Proper a a' H b b' H') in + pose P; + refine (P _ _) + end. + Undo. + Fail lazymatch goal with + | |- ?R (?f ?a ?b) (?f ?a' ?b') => + let P := constr:(fun H H' => Morphisms.proper_prf a a' H b b' H') in + set(p:=P) + end. (* Toplevel input, characters 15-182: +Error: Cannot infer an instance of type +"PointedOPred" for the variable p in environment: +T : Type +O0 : T -> OPred +O1 : T -> PointedOPred +tr : T -> T +O2 : PointedOPred +x0 : T +H : forall x0 : T, catOP (O0 x0) (O1 (tr x0)) |-- O1 x0 *)
\ No newline at end of file diff --git a/test-suite/bugs/closed/4416.v b/test-suite/bugs/closed/4416.v new file mode 100644 index 0000000000..3189685ec0 --- /dev/null +++ b/test-suite/bugs/closed/4416.v @@ -0,0 +1,4 @@ +Goal exists x, x. +Unset Solve Unification Constraints. +unshelve refine (ex_intro _ _ _); match goal with _ => refine (_ _) end. +(* Error: Incorrect number of goals (expected 2 tactics). *)
\ No newline at end of file diff --git a/test-suite/bugs/closed/4464.v b/test-suite/bugs/closed/4464.v new file mode 100644 index 0000000000..f8e9405d93 --- /dev/null +++ b/test-suite/bugs/closed/4464.v @@ -0,0 +1,4 @@ +Goal True -> True. +Proof. + intro H'. + let H := H' in destruct H; try destruct H. diff --git a/test-suite/bugs/closed/4471.v b/test-suite/bugs/closed/4471.v new file mode 100644 index 0000000000..36efc42d47 --- /dev/null +++ b/test-suite/bugs/closed/4471.v @@ -0,0 +1,6 @@ +Goal forall (A B : Type) (P : forall _ : prod A B, Type) (a : A) (b : B) (p p0 : forall (x : A) (x' : B), P (@pair A B x x')), + @eq (P (@pair A B a b)) (p (@fst A B (@pair A B a b)) (@snd A B (@pair A B a b))) + (p0 (@fst A B (@pair A B a b)) (@snd A B (@pair A B a b))). +Proof. + intros. + Fail generalize dependent (a, b). diff --git a/test-suite/bugs/closed/4527.v b/test-suite/bugs/closed/4527.v index 4ca6fe78cd..08628377f0 100644 --- a/test-suite/bugs/closed/4527.v +++ b/test-suite/bugs/closed/4527.v @@ -249,10 +249,10 @@ Section Reflective_Subuniverse. exact H. Defined. - Definition inO_paths@{i j} (S : Type@{i}) {S_inO : In@{Ou Oa i} O S} (x y : + Definition inO_paths@{i} (S : Type@{i}) {S_inO : In@{Ou Oa i} O S} (x y : S) : In@{Ou Oa i} O (x=y). Proof. - simple refine (inO_to_O_retract@{i j} _ _ _); intro u. + simple refine (inO_to_O_retract@{i} _ _ _); intro u. - assert (p : (fun _ : O (x=y) => x) == (fun _=> y)). { @@ -264,4 +264,4 @@ S) : In@{Ou Oa i} O (x=y). hnf. rewrite O_indpaths_beta; reflexivity. Qed. - Check inO_paths@{Type Type}. + Check inO_paths@{Type}. diff --git a/test-suite/bugs/closed/4529.v b/test-suite/bugs/closed/4529.v new file mode 100644 index 0000000000..8b3c24fec6 --- /dev/null +++ b/test-suite/bugs/closed/4529.v @@ -0,0 +1,45 @@ +(* File reduced by coq-bug-finder from original input, then from 1334 lines to 1518 lines, then from 849 lines to 59 lines *) +(* coqc version 8.5 (January 2016) compiled on Jan 22 2016 18:20:47 with OCaml 4.02.3 + coqtop version r-schnelltop:/home/r/src/coq/coq,(HEAD detached at V8.5) (5e23fb90b39dfa014ae5c4fb46eb713cca09dbff) *) +Require Coq.Setoids.Setoid. +Import Coq.Setoids.Setoid. + +Class Equiv A := equiv: relation A. +Infix "≡" := equiv (at level 70, no associativity). +Notation "(≡)" := equiv (only parsing). + +(* If I remove this line, everything compiles. *) +Set Primitive Projections. + +Class Dist A := dist : nat -> relation A. +Notation "x ={ n }= y" := (dist n x y) + (at level 70, n at next level, format "x ={ n }= y"). + +Record CofeMixin A `{Equiv A, Dist A} := { + mixin_equiv_dist x y : x ≡ y <-> forall n, x ={n}= y; + mixin_dist_equivalence n : Equivalence (dist n); +}. + +Structure cofeT := CofeT { + cofe_car :> Type; + cofe_equiv : Equiv cofe_car; + cofe_dist : Dist cofe_car; + cofe_mixin : CofeMixin cofe_car +}. +Existing Instances cofe_equiv cofe_dist. +Arguments cofe_car : simpl never. + +Section cofe_mixin. + Context {A : cofeT}. + Implicit Types x y : A. + Lemma equiv_dist x y : x ≡ y <-> forall n, x ={n}= y. +Admitted. +End cofe_mixin. + Context {A : cofeT}. + Global Instance cofe_equivalence : Equivalence ((≡) : relation A). + Proof. + split. + * + intros x. +apply equiv_dist. + diff --git a/test-suite/bugs/closed/4544.v b/test-suite/bugs/closed/4544.v index 048f31ce3d..da140c9318 100644 --- a/test-suite/bugs/closed/4544.v +++ b/test-suite/bugs/closed/4544.v @@ -652,7 +652,7 @@ Defined. Definition ReflectiveSubuniverse := Modality. - Definition O_reflector := O_reflector. + Definition O_reflector@{u a i} := O_reflector@{u a i}. Definition In@{u a i} : forall (O : ReflectiveSubuniverse@{u a}), Type2le@{i a} -> Type2le@{i a} @@ -660,7 +660,7 @@ Defined. Definition O_inO@{u a i} : forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}), In@{u a i} O (O_reflector@{u a i} O T) := O_inO@{u a i}. - Definition to := to. + Definition to@{u a i} := to@{u a i}. Definition inO_equiv_inO@{u a i j k} : forall (O : ReflectiveSubuniverse@{u a}) (T : Type@{i}) (U : Type@{j}) (T_inO : In@{u a i} O T) (f : T -> U) (feq : IsEquiv f), diff --git a/test-suite/bugs/closed/4661.v b/test-suite/bugs/closed/4661.v new file mode 100644 index 0000000000..03d2350a69 --- /dev/null +++ b/test-suite/bugs/closed/4661.v @@ -0,0 +1,10 @@ +Module Type Test. + Parameter t : Type. +End Test. + +Module Type Func (T:Test). + Parameter x : Type. +End Func. + +Module Shortest_path (T : Test). +Print Func. diff --git a/test-suite/bugs/closed/4708.v b/test-suite/bugs/closed/4708.v new file mode 100644 index 0000000000..ad2e581004 --- /dev/null +++ b/test-suite/bugs/closed/4708.v @@ -0,0 +1,8 @@ +(*Doc, it hurts when I poke myself.*) + +Notation "'" := 1. (* was: +Setting notation at level 0. +Toplevel input, characters 0-18: +> Notation "'" := 1. +> ^^^^^^^^^^^^^^^^^^ +Anomaly: Uncaught exception Invalid_argument("index out of bounds"). Please report. *) diff --git a/test-suite/bugs/closed/4718.v b/test-suite/bugs/closed/4718.v new file mode 100644 index 0000000000..12a4e8fc1a --- /dev/null +++ b/test-suite/bugs/closed/4718.v @@ -0,0 +1,15 @@ +(*Congruence is weaker than reflexivity when it comes to higher level than necessary equalities:*) + +Goal @eq Set nat nat. +congruence. +Qed. + +Goal @eq Type nat nat. +congruence. (*bug*) +Qed. + +Variable T : Type. + +Goal @eq Type T T. +congruence. +Qed. diff --git a/test-suite/bugs/closed/4722.v b/test-suite/bugs/closed/4722.v new file mode 100644 index 0000000000..f047624c84 --- /dev/null +++ b/test-suite/bugs/closed/4722.v @@ -0,0 +1 @@ +(* -*- coq-prog-args: ("-emacs" "-R" "4722" "Foo") -*- *) diff --git a/test-suite/bugs/closed/4722/tata b/test-suite/bugs/closed/4722/tata new file mode 120000 index 0000000000..b38e66e75f --- /dev/null +++ b/test-suite/bugs/closed/4722/tata @@ -0,0 +1 @@ +toto
\ No newline at end of file diff --git a/test-suite/bugs/closed/4723.v b/test-suite/bugs/closed/4723.v new file mode 100644 index 0000000000..8884812102 --- /dev/null +++ b/test-suite/bugs/closed/4723.v @@ -0,0 +1,28 @@ + +Require Coq.Program.Tactics. + +Record Matrix (m n : nat). + +Definition kp {m n p q: nat} (A: Matrix m n) (B: Matrix p q): + Matrix (m*p) (n*q). Admitted. + +Fail Program Fact kp_assoc + (xr xc yr yc zr zc: nat) + (x: Matrix xr xc) (y: Matrix yr yc) (z: Matrix zr zc): + kp x (kp y z) = kp (kp x y) z. + +Ltac Obligation Tactic := admit. +Fail Program Fact kp_assoc + (xr xc yr yc zr zc: nat) + (x: Matrix xr xc) (y: Matrix yr yc) (z: Matrix zr zc): + kp x (kp y z) = kp (kp x y) z. + +Axiom cheat : forall {A}, A. +Obligation Tactic := apply cheat. + +Program Fact kp_assoc + (xr xc yr yc zr zc: nat) + (x: Matrix xr xc) (y: Matrix yr yc) (z: Matrix zr zc): + kp x (kp y z) = kp (kp x y) z. +admit. +Admitted.
\ No newline at end of file diff --git a/test-suite/bugs/closed/4727.v b/test-suite/bugs/closed/4727.v new file mode 100644 index 0000000000..3854bbffdd --- /dev/null +++ b/test-suite/bugs/closed/4727.v @@ -0,0 +1,10 @@ +(* -*- coq-prog-args: ("-emacs" "-compat" "8.4") -*- *) +Goal forall (P : Set) (l : P) (P0 : Set) (w w0 : P0) (T : Type) (a : P * T) (o : P -> option P0), + (forall (l1 l2 : P) (w1 : P0), o l1 = Some w1 -> o l2 = Some w1 -> l1 = l2) -> + o l = Some w -> o (fst a) = Some w0 -> {w = w0} + {w <> w0} -> False. +Proof. + clear; intros ???????? inj H0 H1 H2. + destruct H2; intuition subst. + eapply inj in H1; [ | eauto ]. + progress subst. (* should succeed, used to not succeed *) +Abort. diff --git a/test-suite/bugs/closed/4733.v b/test-suite/bugs/closed/4733.v index ac0653492a..a6ebda61cf 100644 --- a/test-suite/bugs/closed/4733.v +++ b/test-suite/bugs/closed/4733.v @@ -25,16 +25,16 @@ Check [ _ ]%list : list _. Check [ _ ]%vector : Vector.t _ _. Check [ _ ; _ ]%list : list _. Check [ _ ; _ ]%vector : Vector.t _ _. -Fail Check [ _ ; _ ]%mylist : mylist _. (* ideally, this should work, but that requires removing notations from the parser *) +Check [ _ ; _ ]%mylist : mylist _. Check [ _ ; _ ; _ ]%list : list _. Check [ _ ; _ ; _ ]%vector : Vector.t _ _. -Fail Check [ _ ; _ ; _ ]%mylist : mylist _. (* ideally, this should work, but that requires removing notations from the parser *) +Check [ _ ; _ ; _ ]%mylist : mylist _. Check [ _ ; _ ; _ ; _ ]%list : list _. Check [ _ ; _ ; _ ; _ ]%vector : Vector.t _ _. -Fail Check [ _ ; _ ; _ ; _ ]%mylist : mylist _. (* ideally, this should work, but that requires removing notations from the parser *) +Check [ _ ; _ ; _ ; _ ]%mylist : mylist _. Notation " [ x ; y ; .. ; z ] " := (mycons x (mycons y .. (mycons z mynil) ..)) : mylist_scope. -(* Now these all work, but not so in 8.4. If we get the ability to remove notations, and the above fails can be removed, this section can also just be removed. *) +(* Now these all work, but not so in 8.4. If we get the ability to remove notations, this section can also just be removed. *) Check [ ]%mylist : mylist _. Check [ ]%list : list _. Check []%vector : Vector.t _ _. diff --git a/test-suite/bugs/closed/4745.v b/test-suite/bugs/closed/4745.v new file mode 100644 index 0000000000..c090125e64 --- /dev/null +++ b/test-suite/bugs/closed/4745.v @@ -0,0 +1,35 @@ +(*I get an Anomaly in the following code. + +```*) +Require Vector. + +Module M. + Lemma Vector_map_map : + forall A B C (f : A -> B) (g : B -> C) n (v : Vector.t A n), + Vector.map g (Vector.map f v) = Vector.map (fun a => g (f a)) v. + Proof. + induction v; simpl; auto using f_equal. + Qed. + + Lemma Vector_map_map_transparent : + forall A B C (f : A -> B) (g : B -> C) n (v : Vector.t A n), + Vector.map g (Vector.map f v) = Vector.map (fun a => g (f a)) v. + Proof. + induction v; simpl; auto using f_equal. + Defined. + (* Anomaly: constant not found in kind_of_head: Coq.Vectors.Vector.t_ind. Please report. *) + + (* strangely, explicitly passing the principle to induction works *) + Lemma Vector_map_map_transparent' : + forall A B C (f : A -> B) (g : B -> C) n (v : Vector.t A n), + Vector.map g (Vector.map f v) = Vector.map (fun a => g (f a)) v. + Proof. + induction v using Vector.t_ind; simpl; auto using f_equal. + Defined. +End M. +(*``` + +Changing any of the following things eliminates the Anomaly + * moving the lemma out of the module M to the top level + * proving the lemma as a Fixpoint instead of using induction + * proving the analogous lemma on lists instead of vectors*) diff --git a/test-suite/bugs/closed/4762.v b/test-suite/bugs/closed/4762.v new file mode 100644 index 0000000000..7a87b07a8e --- /dev/null +++ b/test-suite/bugs/closed/4762.v @@ -0,0 +1,24 @@ +Inductive myand (P Q : Prop) := myconj : P -> Q -> myand P Q. + +Lemma foo P Q R : R = myand P Q -> P -> Q -> R. +Proof. intros ->; constructor; auto. Qed. + +Hint Extern 0 (myand _ _) => eapply foo; [reflexivity| |] : test1. + +Goal forall P Q R : Prop, P -> Q -> R -> myand P (myand Q R). +Proof. + intros. + eauto with test1. +Qed. + +Hint Extern 0 => + match goal with + | |- myand _ _ => eapply foo; [reflexivity| |] + end : test2. + +Goal forall P Q R : Prop, P -> Q -> R -> myand P (myand Q R). +Proof. + intros. + eauto with test2. (* works *) +Qed. + diff --git a/test-suite/bugs/closed/4763.v b/test-suite/bugs/closed/4763.v new file mode 100644 index 0000000000..ae8ed0e6e8 --- /dev/null +++ b/test-suite/bugs/closed/4763.v @@ -0,0 +1,13 @@ +Require Import Coq.Arith.Arith Coq.Classes.Morphisms Coq.Classes.RelationClasses. +Coercion is_true : bool >-> Sortclass. +Global Instance: Transitive leb. +Admitted. + +Goal forall x y z, leb x y -> leb y z -> True. + intros ??? H H'. + lazymatch goal with + | [ H : is_true (?R ?x ?y), H' : is_true (?R ?y ?z) |- _ ] + => pose proof (transitivity H H' : is_true (R x z)) + end. + exact I. +Qed.
\ No newline at end of file diff --git a/test-suite/bugs/closed/4772.v b/test-suite/bugs/closed/4772.v new file mode 100644 index 0000000000..c3109fa31c --- /dev/null +++ b/test-suite/bugs/closed/4772.v @@ -0,0 +1,6 @@ + +Record TruncType := BuildTruncType { + trunctype_type : Type +}. + +Fail Arguments BuildTruncType _ _ {_}. (* This should fail *) diff --git a/test-suite/bugs/closed/4785.v b/test-suite/bugs/closed/4785.v index 14af2d91df..c3c97d3f59 100644 --- a/test-suite/bugs/closed/4785.v +++ b/test-suite/bugs/closed/4785.v @@ -21,7 +21,7 @@ Delimit Scope mylist_scope with mylist. Bind Scope mylist_scope with mylist. Arguments mynil {_}, _. Arguments mycons {_} _ _. -Notation " [] " := mynil : mylist_scope. +Notation " [] " := mynil (compat "8.5") : mylist_scope. Notation " [ ] " := mynil (format "[ ]") : mylist_scope. Notation " [ x ] " := (mycons x nil) : mylist_scope. Notation " [ x ; y ; .. ; z ] " := (mycons x (mycons y .. (mycons z nil) ..)) : mylist_scope. diff --git a/test-suite/bugs/closed/4785_compat_85.v b/test-suite/bugs/closed/4785_compat_85.v new file mode 100644 index 0000000000..9d65840acd --- /dev/null +++ b/test-suite/bugs/closed/4785_compat_85.v @@ -0,0 +1,46 @@ +(* -*- coq-prog-args: ("-emacs" "-compat" "8.5") -*- *) +Require Coq.Lists.List Coq.Vectors.Vector. +Require Coq.Compat.Coq85. + +Module A. +Import Coq.Lists.List Coq.Vectors.Vector. +Import ListNotations. +Check [ ]%list : list _. +Import VectorNotations ListNotations. +Delimit Scope vector_scope with vector. +Check [ ]%vector : Vector.t _ _. +Check []%vector : Vector.t _ _. +Check [ ]%list : list _. +Fail Check []%list : list _. + +Goal True. + idtac; [ ]. (* Note that vector notations break the [ | .. | ] syntax of Ltac *) +Abort. + +Inductive mylist A := mynil | mycons (x : A) (xs : mylist A). +Delimit Scope mylist_scope with mylist. +Bind Scope mylist_scope with mylist. +Arguments mynil {_}, _. +Arguments mycons {_} _ _. +Notation " [] " := mynil (compat "8.5") : mylist_scope. +Notation " [ ] " := mynil (format "[ ]") : mylist_scope. +Notation " [ x ] " := (mycons x nil) : mylist_scope. +Notation " [ x ; y ; .. ; z ] " := (mycons x (mycons y .. (mycons z nil) ..)) : mylist_scope. + +Import Coq.Compat.Coq85. +Locate Module VectorNotations. +Import VectorDef.VectorNotations. + +Check []%vector : Vector.t _ _. +Check []%mylist : mylist _. +Check [ ]%mylist : mylist _. +Check [ ]%list : list _. +End A. + +Module B. +Import Coq.Compat.Coq85. + +Goal True. + idtac; []. (* Check that importing the compat file doesn't break the [ | .. | ] syntax of Ltac *) +Abort. +End B. diff --git a/test-suite/bugs/closed/4798.v b/test-suite/bugs/closed/4798.v new file mode 100644 index 0000000000..dbc3d46fce --- /dev/null +++ b/test-suite/bugs/closed/4798.v @@ -0,0 +1,3 @@ +Check match 2 with 0 => 0 | S n => n end. +Notation "|" := 1 (compat "8.4"). +Check match 2 with 0 => 0 | S n => n end. (* fails *) diff --git a/test-suite/bugs/closed/4863.v b/test-suite/bugs/closed/4863.v new file mode 100644 index 0000000000..1e47f2957b --- /dev/null +++ b/test-suite/bugs/closed/4863.v @@ -0,0 +1,33 @@ +Require Import Classes.DecidableClass. + +Inductive Foo : Set := +| foo1 | foo2. + +Lemma Decidable_sumbool : forall P, {P}+{~P} -> Decidable P. +Proof. + intros P H. + refine (Build_Decidable _ (if H then true else false) _). + intuition congruence. +Qed. + +Hint Extern 100 (Decidable (?A = ?B)) => abstract (abstract (abstract (apply Decidable_sumbool; decide equality))) : typeclass_instances. + +Goal forall (a b : Foo), {a=b}+{a<>b}. +intros. +abstract (abstract (decide equality)). (*abstract works here*) +Qed. + +Check ltac:(abstract (exact I)) : True. + +Goal forall (a b : Foo), Decidable (a=b) * Decidable (a=b). +intros. +split. typeclasses eauto. +typeclasses eauto. Qed. + +Goal forall (a b : Foo), Decidable (a=b) * Decidable (a=b). +intros. +split. +refine _. +refine _. +Defined. +(*fails*) diff --git a/test-suite/bugs/closed/4869.v b/test-suite/bugs/closed/4869.v new file mode 100644 index 0000000000..6d21b66fe9 --- /dev/null +++ b/test-suite/bugs/closed/4869.v @@ -0,0 +1,18 @@ +Universes i. + +Fail Constraint i < Set. +Fail Constraint i <= Set. +Fail Constraint i = Set. +Constraint Set <= i. +Constraint Set < i. +Fail Constraint i < j. (* undeclared j *) +Fail Constraint i < Type. (* anonymous *) + +Set Universe Polymorphism. + +Section Foo. + Universe j. + Constraint Set < j. + + Definition foo := Type@{j}. +End Foo.
\ No newline at end of file diff --git a/test-suite/bugs/closed/4955.v b/test-suite/bugs/closed/4955.v new file mode 100644 index 0000000000..dce1f764c3 --- /dev/null +++ b/test-suite/bugs/closed/4955.v @@ -0,0 +1,98 @@ +(* An example involving a first-order unification triggering a cyclic constraint *) + +Module A. +Notation "{ x : A | P }" := (sigT (fun x:A => P)). +Notation "( x ; y )" := (existT _ x y) : fibration_scope. +Open Scope fibration_scope. +Notation "p @ q" := (eq_trans p q) (at level 20). +Notation "p ^" := (eq_sym p) (at level 3). +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) +: P y := + match p with eq_refl => u end. +Notation "p # x" := (transport _ p x) (right associativity, at level 65, only +parsing). +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with eq_refl => eq_refl end. +Definition apD {A:Type} {B:A->Type} (f:forall a:A, B a) {x y:A} (p:x=y): p # (f +x) = f y + := match p with eq_refl => eq_refl end. +Axiom transport_compose + : forall {A B} {x y : A} (P : B -> Type) (f : A -> B) (p : x = y) (z : P (f +x)), + transport (fun x => P (f x)) p z = transport P (ap f p) z. +Delimit Scope morphism_scope with morphism. +Delimit Scope category_scope with category. +Delimit Scope object_scope with object. +Record PreCategory := { object :> Type ; morphism : object -> object -> Type }. +Delimit Scope functor_scope with functor. +Record Functor (C D : PreCategory) := + { object_of :> C -> D; + morphism_of : forall s d, morphism C s d -> morphism D (object_of s) +(object_of d) }. +Arguments object_of {C%category D%category} f%functor c%object : rename, simpl +nomatch. +Arguments morphism_of [C%category] [D%category] f%functor [s%object d%object] +m%morphism : rename, simpl nomatch. +Section path_functor. + Variable C : PreCategory. + Variable D : PreCategory. + + Local Notation path_functor'_T F G + := { HO : object_of F = object_of G + | transport (fun GO => forall s d, morphism C s d -> morphism D (GO s) +(GO d)) + HO + (morphism_of F) + = morphism_of G } + (only parsing). + Definition path_functor'_sig_inv (F G : Functor C D) : F = G -> +path_functor'_T F G + := fun H' + => (ap object_of H'; + (transport_compose _ object_of _ _) ^ @ apD (@morphism_of _ _) H'). + +End path_functor. +End A. + +(* A variant of it with more axioms *) + +Module B. +Notation "{ x : A | P }" := (sigT (fun x:A => P)). +Notation "( x ; y )" := (existT _ x y). +Notation "p @ q" := (eq_trans p q) (at level 20). +Notation "p ^" := (eq_sym p) (at level 3). +Axiom transport : forall {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x), P y. +Notation "p # x" := (transport _ p x) (right associativity, at level 65, only +parsing). +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with eq_refl => eq_refl end. +Axiom apD : forall {A:Type} {B:A->Type} (f:forall a:A, B a) {x y:A} (p:x=y), p # (f +x) = f y. +Axiom transport_compose + : forall {A B} {x y : A} (P : B -> Type) (f : A -> B) (p : x = y) (z : P (f +x)), + transport (fun x => P (f x)) p z = transport P (ap f p) z. +Record PreCategory := { object :> Type ; morphism : object -> object -> Type }. +Record Functor (C D : PreCategory) := + { object_of :> C -> D; + morphism_of : forall s d, morphism C s d -> morphism D (object_of s) +(object_of d) }. +Arguments object_of {C D} f c : rename, simpl nomatch. +Arguments morphism_of [C] [D] f [s d] m : rename, simpl nomatch. +Section path_functor. + Variable C D : PreCategory. + Local Notation path_functor'_T F G + := { HO : object_of F = object_of G + | transport (fun GO => forall s d, morphism C s d -> morphism D (GO s) +(GO d)) + HO + (morphism_of F) + = morphism_of G }. + Definition path_functor'_sig_inv (F G : Functor C D) : F = G -> +path_functor'_T F G + := fun H' + => (ap object_of H'; + (transport_compose _ object_of _ _) ^ @ apD (@morphism_of _ _) H'). + +End path_functor. +End B. diff --git a/test-suite/bugs/closed/4966.v b/test-suite/bugs/closed/4966.v new file mode 100644 index 0000000000..bd93cdc858 --- /dev/null +++ b/test-suite/bugs/closed/4966.v @@ -0,0 +1,10 @@ +(* Interpretation of auto as an argument of an ltac function (i.e. as an ident) was wrongly "auto with *" *) + +Axiom proof_admitted : False. +Hint Extern 0 => case proof_admitted : unused. +Ltac do_tac tac := tac. + +Goal False. + Set Ltac Profiling. + Fail solve [ do_tac auto ]. +Abort. diff --git a/test-suite/bugs/closed/4970.v b/test-suite/bugs/closed/4970.v new file mode 100644 index 0000000000..7a896582f5 --- /dev/null +++ b/test-suite/bugs/closed/4970.v @@ -0,0 +1,3 @@ +(* Check "{{" is not confused with "{" in notations *) +Reserved Notation "x {{ y }}" (at level 40). +Notation "x {{ y }}" := (x y) (only parsing). diff --git a/test-suite/bugs/closed/5011.v b/test-suite/bugs/closed/5011.v new file mode 100644 index 0000000000..c3043ca5d1 --- /dev/null +++ b/test-suite/bugs/closed/5011.v @@ -0,0 +1,2 @@ +Record decoder (n : nat) W := { decode : W -> nat }. +Existing Class decoder. diff --git a/test-suite/bugs/closed/5036.v b/test-suite/bugs/closed/5036.v new file mode 100644 index 0000000000..12c958be67 --- /dev/null +++ b/test-suite/bugs/closed/5036.v @@ -0,0 +1,10 @@ +Section foo. + Context (F : Type -> Type). + Context (admit : forall {T}, F T = True). + Hint Rewrite (fun T => @admit T). + Lemma bad : F False. + Proof. + autorewrite with core. + constructor. + Qed. +End foo. (* Anomaly: Universe Top.16 undefined. Please report. *)
\ No newline at end of file diff --git a/test-suite/bugs/closed/5045.v b/test-suite/bugs/closed/5045.v new file mode 100644 index 0000000000..dc38738d8f --- /dev/null +++ b/test-suite/bugs/closed/5045.v @@ -0,0 +1,3 @@ +Axiom silly : 1 = 1 -> nat -> nat. +Goal forall pf : 1 = 1, silly pf 0 = 0 -> True. + Fail generalize (@eq nat). diff --git a/test-suite/bugs/closed/5066.v b/test-suite/bugs/closed/5066.v new file mode 100644 index 0000000000..eed7f0f3ff --- /dev/null +++ b/test-suite/bugs/closed/5066.v @@ -0,0 +1,7 @@ +Require Import Vector. + +Fail Program Fixpoint vector_rev {A : Type} {n1 n2 : nat} (v1 : Vector.t A n1) (v2 : Vector.t A n2) : Vector.t A (n1+n2) := + match v1 with + | nil _ => v2 + | cons _ e n' sv => vector_rev sv (cons A e n2 v2) + end. diff --git a/test-suite/bugs/closed/5097.v b/test-suite/bugs/closed/5097.v new file mode 100644 index 0000000000..37b239cf61 --- /dev/null +++ b/test-suite/bugs/closed/5097.v @@ -0,0 +1,7 @@ +(* Tracing existing evars along the weakening rule ("clear") *) +Goal forall y, exists x, x=0->x=y. +intros. +eexists ?[x]. +intros. +let x:=constr:(ltac:(clear y; exact 0)) in idtac x. +Abort. diff --git a/test-suite/bugs/closed/5123.v b/test-suite/bugs/closed/5123.v new file mode 100644 index 0000000000..bcde510ee6 --- /dev/null +++ b/test-suite/bugs/closed/5123.v @@ -0,0 +1,33 @@ +(* IN 8.5pl2 and 8.6 (4da2131), the following shows different typeclass resolution behaviors following an unshelve tactical vs. an Unshelve command: *) + +(*Pose an open constr to prevent immediate typeclass resolution in holes:*) +Tactic Notation "opose" open_constr(x) "as" ident(H) := pose x as H. + +Inductive vect A : nat -> Type := +| vnil : vect A 0 +| vcons : forall (h:A) (n:nat), vect A n -> vect A (S n). + +Class Eqdec A := eqdec : forall a b : A, {a=b}+{a<>b}. + +Require Bool. + +Instance Bool_eqdec : Eqdec bool := Bool.bool_dec. + +Context `{vect_sigT_eqdec : forall A : Type, Eqdec A -> Eqdec {a : nat & vect A a}}. + +Typeclasses eauto := debug. + +Goal True. + unshelve opose (@vect_sigT_eqdec _ _ _ _) as H. + all:cycle 2. + eapply existT. (*BUG: Why does this do typeclass resolution in the evar?*) + Focus 5. +Abort. + +Goal True. + opose (@vect_sigT_eqdec _ _ _ _) as H. + Unshelve. + all:cycle 3. + eapply existT. (*This does no typeclass resultion, which is correct.*) + Focus 5. +Abort.
\ No newline at end of file diff --git a/test-suite/bugs/closed/5127.v b/test-suite/bugs/closed/5127.v new file mode 100644 index 0000000000..831e8fb507 --- /dev/null +++ b/test-suite/bugs/closed/5127.v @@ -0,0 +1,15 @@ +Fixpoint arrow (n: nat) := + match n with + | S n => bool -> arrow n + | O => bool + end. + +Fixpoint apply (n : nat) : arrow n -> bool := + match n return arrow n -> bool with + | S n => fun f => apply _ (f true) + | O => fun x => x + end. + +Axiom f : arrow 10000. +Definition v : bool := Eval compute in apply _ f. +Definition w : bool := Eval vm_compute in v. diff --git a/test-suite/bugs/closed/5145.v b/test-suite/bugs/closed/5145.v new file mode 100644 index 0000000000..0533d21e0c --- /dev/null +++ b/test-suite/bugs/closed/5145.v @@ -0,0 +1,10 @@ +Class instructions := + { + W : Type; + ldi : nat -> W + }. + +Fail Definition foo := + let y2 := ldi 0 in + let '(CF, _) := (true, 0) in + y2. diff --git a/test-suite/bugs/closed/5149.v b/test-suite/bugs/closed/5149.v new file mode 100644 index 0000000000..684dba1961 --- /dev/null +++ b/test-suite/bugs/closed/5149.v @@ -0,0 +1,47 @@ +Goal forall x x' : nat, x = x' -> S x = S x -> exists y, S y = S x. +intros. +eexists. +rewrite <- H. +eassumption. +Qed. + +Goal forall (base_type_code : Type) (t : base_type_code) (flat_type : Type) + (t' : flat_type) (exprf interp_flat_type0 interp_flat_type1 : +flat_type -> Type) + (v v' : interp_flat_type1 t'), + v = v' -> + forall (interpf : forall t0 : flat_type, exprf t0 -> interp_flat_type1 t0) + (SmartVarVar : forall t0 : flat_type, interp_flat_type1 t0 -> +interp_flat_type0 t0) + (Tbase : base_type_code -> flat_type) (x : exprf (Tbase t)) + (x' : interp_flat_type1 (Tbase t)) (T : Type) + (flatten_binding_list : forall t0 : flat_type, + interp_flat_type0 t0 -> interp_flat_type1 t0 -> list T) + (P : T -> list T -> Prop) (prod : Type -> Type -> Type) + (s : forall x0 : base_type_code, prod (exprf (Tbase x0)) +(interp_flat_type1 (Tbase x0)) -> T) + (pair : forall A B : Type, A -> B -> prod A B), + P (s t (pair (exprf (Tbase t)) (interp_flat_type1 (Tbase t)) x x')) + (flatten_binding_list t' (SmartVarVar t' v') v) -> + (forall (t0 : base_type_code) (t'0 : flat_type) (v0 : interp_flat_type1 +t'0) + (x0 : exprf (Tbase t0)) (x'0 : interp_flat_type1 (Tbase t0)), + P (s t0 (pair (exprf (Tbase t0)) (interp_flat_type1 (Tbase t0)) x0 +x'0)) + (flatten_binding_list t'0 (SmartVarVar t'0 v0) v0) -> interpf +(Tbase t0) x0 = x'0) -> + interpf (Tbase t) x = x'. +Proof. + intros ?????????????????????? interpf_SmartVarVar. + solve [ unshelve (subst; eapply interpf_SmartVarVar; eassumption) ] || fail +"too early". + Undo. + (** Implicitely at the dot. The first fails because unshelve adds a goal, and solve hence fails. The second has an ambiant unification problem that is solved after solve *) + Fail solve [ unshelve (eapply interpf_SmartVarVar; subst; eassumption) ]. + solve [eapply interpf_SmartVarVar; subst; eassumption]. + Undo. + Unset Solve Unification Constraints. + (* User control of when constraints are solved *) + solve [ unshelve (eapply interpf_SmartVarVar; subst; eassumption); solve_constraints ]. +Qed. + diff --git a/test-suite/bugs/closed/5161.v b/test-suite/bugs/closed/5161.v new file mode 100644 index 0000000000..d28303b8ab --- /dev/null +++ b/test-suite/bugs/closed/5161.v @@ -0,0 +1,27 @@ +(* Check that the presence of binders with type annotation do not + prevent the recursive binder part to be found *) + +From Coq Require Import Utf8. + +Delimit Scope C_scope with C. +Global Open Scope C_scope. + +Delimit Scope uPred_scope with I. + +Definition FORALL {T : Type} (f : T → Prop) : Prop := ∀ x, f x. + +Notation "∀ x .. y , P" := + (FORALL (λ x, .. (FORALL (λ y, P)) ..)%I) + (at level 200, x binder, y binder, right associativity) : uPred_scope. +Infix "∧" := and : uPred_scope. + +(* The next command fails with + In recursive notation with binders, Φ is expected to come without type. + I would expect this notation to work fine, since the ∀ does support + type annotation. +*) +Notation "'{{{' P } } } e {{{ x .. y ; pat , Q } } }" := + (∀ Φ : _ → _, + (∀ x, .. (∀ y, Q ∧ Φ pat) .. ))%I + (at level 20, x closed binder, y closed binder, + format "{{{ P } } } e {{{ x .. y ; pat , Q } } }") : uPred_scope. diff --git a/test-suite/bugs/closed/5180.v b/test-suite/bugs/closed/5180.v new file mode 100644 index 0000000000..261092ee6d --- /dev/null +++ b/test-suite/bugs/closed/5180.v @@ -0,0 +1,64 @@ +Universes a b c ω ω'. +Definition Typeω := Type@{ω}. +Definition Type2 : Typeω := Type@{c}. +Definition Type1 : Type2 := Type@{b}. +Definition Type0 : Type1 := Type@{a}. + +Set Universe Polymorphism. +Set Printing Universes. + +Definition Typei' (n : nat) + := match n return Type@{ω'} with + | 0 => Type0 + | 1 => Type1 + | 2 => Type2 + | _ => Typeω + end. +Definition TypeOfTypei' {n} (x : Typei' n) : Type@{ω'} + := match n return Typei' n -> Type@{ω'} with + | 0 | 1 | 2 | _ => fun x => x + end x. +Definition Typei (n : nat) : Typei' (S n) + := match n return Typei' (S n) with + | 0 => Type0 + | 1 => Type1 + | _ => Type2 + end. +Definition TypeOfTypei {n} (x : TypeOfTypei' (Typei n)) : Type@{ω'} + := match n return TypeOfTypei' (Typei n) -> Type@{ω'} with + | 0 | 1 | _ => fun x => x + end x. +Check Typei 0 : Typei 1. +Check Typei 1 : Typei 2. + +Definition lift' {n} : TypeOfTypei' (Typei n) -> TypeOfTypei' (Typei (S n)) + := match n return TypeOfTypei' (Typei n) -> TypeOfTypei' (Typei (S n)) with + | 0 | 1 | 2 | _ => fun x => (x : Type) + end. +Definition lift'' {n} : TypeOfTypei' (Typei n) -> TypeOfTypei' (Typei (S n)) + := match n return TypeOfTypei' (Typei n) -> TypeOfTypei' (Typei (S n)) with + | 0 | 1 | 2 | _ => fun x => x + end. (* The command has indeed failed with message: +In environment +n : nat +x : TypeOfTypei' (Typei 0) +The term "x" has type "TypeOfTypei' (Typei 0)" while it is expected to have type + "TypeOfTypei' (Typei 1)" (universe inconsistency: Cannot enforce b = a because a < b). + *) +Check (fun x : TypeOfTypei' (Typei 0) => TypeOfTypei' (Typei 1)). + +Definition lift''' {n} : TypeOfTypei' (Typei n) -> TypeOfTypei' (Typei (S n)). + refine match n return TypeOfTypei' (Typei n) -> TypeOfTypei' (Typei (S n)) with + | 0 | 1 | 2 | _ => fun x => _ + end. + exact x. + Undo. + (* The command has indeed failed with message: +In environment +n : nat +x : TypeOfTypei' (Typei 0) +The term "x" has type "TypeOfTypei' (Typei 0)" while it is expected to have type + "TypeOfTypei' (Typei 1)" (universe inconsistency: Cannot enforce b = a because a < b). + *) + all:compute in *. + all:exact x.
\ No newline at end of file diff --git a/test-suite/bugs/closed/5181.v b/test-suite/bugs/closed/5181.v new file mode 100644 index 0000000000..0e6d471979 --- /dev/null +++ b/test-suite/bugs/closed/5181.v @@ -0,0 +1,3 @@ +Definition foo (x y : nat) := x. +Fail Arguments foo {_} : assert. + diff --git a/test-suite/bugs/closed/5188.v b/test-suite/bugs/closed/5188.v new file mode 100644 index 0000000000..e29ebfb4ec --- /dev/null +++ b/test-suite/bugs/closed/5188.v @@ -0,0 +1,5 @@ +Set Printing All. +Axiom relation : forall (T : Type), Set. +Axiom T : forall A (R : relation A), Set. +Set Printing Universes. +Parameter (A:_) (R:_) (e:@T A R). diff --git a/test-suite/bugs/closed/5198.v b/test-suite/bugs/closed/5198.v new file mode 100644 index 0000000000..7254afb429 --- /dev/null +++ b/test-suite/bugs/closed/5198.v @@ -0,0 +1,39 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-boot" "-nois") -*- *) +(* File reduced by coq-bug-finder from original input, then from 286 lines to +27 lines, then from 224 lines to 53 lines, then from 218 lines to 56 lines, +then from 269 lines to 180 lines, then from 132 lines to 48 lines, then from +253 lines to 65 lines, then from 79 lines to 65 lines *) +(* coqc version 8.6.0 (November 2016) compiled on Nov 12 2016 14:43:52 with +OCaml 4.02.3 + coqtop version jgross-Leopard-WS:/home/jgross/Downloads/coq/coq-v8.6,v8.6 +(7e992fa784ee6fa48af8a2e461385c094985587d) *) +Axiom admit : forall {T}, T. +Set Printing Implicit. +Inductive nat := O | S (_ : nat). +Axiom f : forall (_ _ : nat), nat. +Class ZLikeOps (e : nat) + := { LargeT : Type ; SmallT : Type ; CarryAdd : forall (_ _ : LargeT), LargeT +}. +Class BarrettParameters := + { b : nat ; k : nat ; ops : ZLikeOps (f b k) }. +Axiom barrett_reduce_function_bundled : forall {params : BarrettParameters} + (_ : @LargeT _ (@ops params)), + @SmallT _ (@ops params). + +Global Instance ZZLikeOps e : ZLikeOps (f (S O) e) + := { LargeT := nat ; SmallT := nat ; CarryAdd x y := y }. +Definition SRep := nat. +Local Instance x86_25519_Barrett : BarrettParameters + := { b := S O ; k := O ; ops := ZZLikeOps O }. +Definition SRepAdd : forall (_ _ : SRep), SRep + := let v := (fun x y => barrett_reduce_function_bundled (CarryAdd x y)) in + v. +Definition SRepAdd' : forall (_ _ : SRep), SRep + := (fun x y => barrett_reduce_function_bundled (CarryAdd x y)). +(* Error: +In environment +x : SRep +y : SRep +The term "x" has type "SRep" while it is expected to have type + "@LargeT ?e ?ZLikeOps". + *) diff --git a/test-suite/bugs/closed/5203.v b/test-suite/bugs/closed/5203.v new file mode 100644 index 0000000000..ed137395fc --- /dev/null +++ b/test-suite/bugs/closed/5203.v @@ -0,0 +1,5 @@ +Goal True. + Typeclasses eauto := debug. + Fail solve [ typeclasses eauto ]. + Fail typeclasses eauto. +
\ No newline at end of file diff --git a/test-suite/bugs/closed/5208.v b/test-suite/bugs/closed/5208.v new file mode 100644 index 0000000000..b7a684a27c --- /dev/null +++ b/test-suite/bugs/closed/5208.v @@ -0,0 +1,222 @@ +Require Import Program. + +Require Import Coq.Strings.String. +Require Import Coq.Strings.Ascii. +Require Import Coq.Numbers.BinNums. + +Set Implicit Arguments. +Set Strict Implicit. +Set Universe Polymorphism. +Set Printing Universes. + +Local Open Scope positive. + +Definition field : Type := positive. + +Section poly. + Universe U. + + Inductive fields : Type := + | pm_Leaf : fields + | pm_Branch : fields -> option Type@{U} -> fields -> fields. + + Definition fields_left (f : fields) : fields := + match f with + | pm_Leaf => pm_Leaf + | pm_Branch l _ _ => l + end. + + Definition fields_right (f : fields) : fields := + match f with + | pm_Leaf => pm_Leaf + | pm_Branch _ _ r => r + end. + + Definition fields_here (f : fields) : option Type@{U} := + match f with + | pm_Leaf => None + | pm_Branch _ s _ => s + end. + + Fixpoint fields_get (p : field) (m : fields) {struct p} : option Type@{U} := + match p with + | xH => match m with + | pm_Leaf => None + | pm_Branch _ x _ => x + end + | xO p' => fields_get p' match m with + | pm_Leaf => pm_Leaf + | pm_Branch L _ _ => L + end + | xI p' => fields_get p' match m with + | pm_Leaf => pm_Leaf + | pm_Branch _ _ R => R + end + end. + + Definition fields_leaf : fields := pm_Leaf. + + Inductive member (val : Type@{U}) : fields -> Type := + | pmm_H : forall L R, member val (pm_Branch L (Some val) R) + | pmm_L : forall (V : option Type@{U}) L R, member val L -> member val (pm_Branch L V R) + | pmm_R : forall (V : option Type@{U}) L R, member val R -> member val (pm_Branch L V R). + Arguments pmm_H {_ _ _}. + Arguments pmm_L {_ _ _ _} _. + Arguments pmm_R {_ _ _ _} _. + + Fixpoint get_member (val : Type@{U}) p {struct p} + : forall m, fields_get p m = @Some Type@{U} val -> member val m := + match p as p return forall m, fields_get p m = @Some Type@{U} val -> member@{U} val m with + | xH => fun m => + match m as m return fields_get xH m = @Some Type@{U} val -> member@{U} val m with + | pm_Leaf => fun pf : None = @Some Type@{U} _ => + match pf in _ = Z return match Z with + | Some _ => _ + | None => unit + end + with + | eq_refl => tt + end + | pm_Branch _ None _ => fun pf : None = @Some Type@{U} _ => + match pf in _ = Z return match Z with + | Some _ => _ + | None => unit + end + with + | eq_refl => tt + end + | pm_Branch _ (Some x) _ => fun pf : @Some Type@{U} x = @Some Type@{U} val => + match eq_sym pf in _ = Z return member@{U} val (pm_Branch _ Z _) with + | eq_refl => pmm_H + end + end + | xO p' => fun m => + match m as m return fields_get (xO p') m = @Some Type@{U} val -> member@{U} val m with + | pm_Leaf => fun pf : fields_get p' pm_Leaf = @Some Type@{U} val => + @get_member _ p' pm_Leaf pf + | pm_Branch l _ _ => fun pf : fields_get p' l = @Some Type@{U} val => + @pmm_L _ _ _ _ (@get_member _ p' l pf) + end + | xI p' => fun m => + match m as m return fields_get (xI p') m = @Some Type@{U} val -> member@{U} val m with + | pm_Leaf => fun pf : fields_get p' pm_Leaf = @Some Type@{U} val => + @get_member _ p' pm_Leaf pf + | pm_Branch l _ r => fun pf : fields_get p' r = @Some Type@{U} val => + @pmm_R _ _ _ _ (@get_member _ p' r pf) + end + end. + + Inductive record : fields -> Type := + | pr_Leaf : record pm_Leaf + | pr_Branch : forall L R (V : option Type@{U}), + record L -> + match V return Type@{U} with + | None => unit + | Some t => t + end -> + record R -> + record (pm_Branch L V R). + + + Definition record_left {L} {V : option Type@{U}} {R} + (r : record (pm_Branch L V R)) : record L := + match r in record z + return match z with + | pm_Branch L _ _ => record L + | _ => unit + end + with + | pr_Branch _ l _ _ => l + | pr_Leaf => tt + end. +Set Printing All. + Definition record_at {L} {V : option Type@{U}} {R} (r : record (pm_Branch L V R)) + : match V return Type@{U} with + | None => unit + | Some t => t + end := + match r in record z + return match z (* return ?X *) with + | pm_Branch _ V _ => match V return Type@{U} with + | None => unit + | Some t => t + end + | _ => unit + end + with + | pr_Branch _ _ v _ => v + | pr_Leaf => tt + end. + + Definition record_here {L : fields} (v : Type@{U}) {R : fields} + (r : record (pm_Branch L (@Some Type@{U} v) R)) : v := + match r in record z + return match z return Type@{U} with + | pm_Branch _ (Some v) _ => v + | _ => unit + end + with + | pr_Branch _ _ v _ => v + | pr_Leaf => tt + end. + + Definition record_right {L V R} (r : record (pm_Branch L V R)) : record R := + match r in record z return match z with + | pm_Branch _ _ R => record R + | _ => unit + end + with + | pr_Branch _ _ _ r => r + | pr_Leaf => tt + end. + + Fixpoint record_get {val : Type@{U}} {pm : fields} (m : member val pm) : record pm -> val := + match m in member _ pm return record pm -> val with + | pmm_H => fun r => record_here r + | pmm_L m' => fun r => record_get m' (record_left r) + | pmm_R m' => fun r => record_get m' (record_right r) + end. + + Fixpoint record_set {val : Type@{U}} {pm : fields} (m : member val pm) (x : val) {struct m} + : record pm -> record pm := + match m in member _ pm return record pm -> record pm with + | pmm_H => fun r => + pr_Branch (Some _) + (record_left r) + x + (record_right r) + | pmm_L m' => fun r => + pr_Branch _ + (record_set m' x (record_left r)) + (record_at r) + (record_right r) + | pmm_R m' => fun r => + pr_Branch _ (record_left r) + (record_at r) + (record_set m' x (record_right r)) + end. +End poly. +Axiom cheat : forall {A}, A. +Lemma record_get_record_set_different: + forall (T: Type) (vars: fields) + (pmr pmw: member T vars) + (diff: pmr <> pmw) + (r: record vars) (val: T), + record_get pmr (record_set pmw val r) = record_get pmr r. +Proof. + intros. + revert pmr diff r val. + induction pmw; simpl; intros. + - dependent destruction pmr. + + congruence. + + auto. + + auto. + - dependent destruction pmr. + + auto. + + simpl. apply IHpmw. congruence. + + auto. + - dependent destruction pmr. + + auto. + + auto. + + simpl. apply IHpmw. congruence. +Qed. diff --git a/test-suite/bugs/closed/5322.v b/test-suite/bugs/closed/5322.v new file mode 100644 index 0000000000..01aec8f29b --- /dev/null +++ b/test-suite/bugs/closed/5322.v @@ -0,0 +1,14 @@ +(* Regression in computing types of branches in "match" *) +Inductive flat_type := Unit | Prod (A B : flat_type). +Inductive exprf (op : flat_type -> flat_type -> Type) {var : Type} : flat_type +-> Type := +| Op {t1 tR} (opc : op t1 tR) (args : exprf op t1) : exprf op tR. +Inductive op : flat_type -> flat_type -> Type := a : op Unit Unit. +Arguments Op {_ _ _ _} _ _. +Definition bound_op {var} + {src2 dst2} + (opc2 : op src2 dst2) + : forall (args2 : exprf op (var:=var) src2), Op opc2 args2 = Op opc2 args2. + refine match opc2 return (forall args2, Op opc2 args2 = Op opc2 args2) with + | _ => _ + end. diff --git a/test-suite/bugs/closed/5323.v b/test-suite/bugs/closed/5323.v new file mode 100644 index 0000000000..295b7cd9f5 --- /dev/null +++ b/test-suite/bugs/closed/5323.v @@ -0,0 +1,26 @@ +(* Revealed a missing re-consideration of postponed problems *) + +Module A. +Inductive flat_type := Unit | Prod (A B : flat_type). +Inductive exprf (op : flat_type -> flat_type -> Type) {var : Type} : flat_type +-> Type := +| Op {t1 tR} (opc : op t1 tR) (args : exprf op t1) : exprf op tR. +Inductive op : flat_type -> flat_type -> Type := . +Arguments Op {_ _ _ _} _ _. +Definition bound_op {var} + {src2 dst2} + (opc2 : op src2 dst2) + : forall (args2 : exprf op (var:=var) src2), Op opc2 args2 = Op opc2 args2 + := match opc2 return (forall args2, Op opc2 args2 = Op opc2 args2) with end. +End A. + +(* A shorter variant *) +Module B. +Inductive exprf (op : unit -> Type) : Type := +| A : exprf op +| Op tR (opc : op tR) (args : exprf op) : exprf op. +Inductive op : unit -> Type := . +Definition bound_op (dst2 : unit) (opc2 : op dst2) + : forall (args2 : exprf op), Op op dst2 opc2 args2 = A op + := match opc2 in op h return (forall args2 : exprf ?[U], Op ?[V] ?[I] opc2 args2 = A op) with end. +End B. diff --git a/test-suite/bugs/closed/5331.v b/test-suite/bugs/closed/5331.v new file mode 100644 index 0000000000..28743736d3 --- /dev/null +++ b/test-suite/bugs/closed/5331.v @@ -0,0 +1,11 @@ +(* Checking no anomaly on some unexpected intropattern *) + +Ltac ih H := induction H as H. +Ltac ih' H H' := induction H as H'. + +Goal True -> True. +Fail intro H; ih H. +intro H; ih' H ipattern:([]). +exact I. +Qed. + diff --git a/test-suite/bugs/closed/5346.v b/test-suite/bugs/closed/5346.v new file mode 100644 index 0000000000..0118c18704 --- /dev/null +++ b/test-suite/bugs/closed/5346.v @@ -0,0 +1,29 @@ +Inductive comp : Type -> Type := +| Ret {T} : forall (v:T), comp T +| Bind {T T'} : forall (p: comp T') (p': T' -> comp T), comp T. + +Notation "'do' x .. y <- p1 ; p2" := + (Bind p1 (fun x => .. (fun y => p2) ..)) + (at level 60, right associativity, + x binder, y binder). + +Definition Fst1 A B (p: comp (A*B)) : comp A := + do '(a, b) <- p; + Ret a. + +Definition Fst2 A B (p: comp (A*B)) : comp A := + match tt with + | _ => Bind p (fun '(a, b) => Ret a) + end. + +Definition Fst3 A B (p: comp (A*B)) : comp A := + match tt with + | _ => do a <- p; + Ret (fst a) + end. + +Definition Fst A B (p: comp (A * B)) : comp A := + match tt with + | _ => do '(a, b) <- p; + Ret a + end. diff --git a/test-suite/bugs/closed/HoTT_coq_117.v b/test-suite/bugs/closed/HoTT_coq_117.v index 5fbcfef4e0..de60fd0ae4 100644 --- a/test-suite/bugs/closed/HoTT_coq_117.v +++ b/test-suite/bugs/closed/HoTT_coq_117.v @@ -16,10 +16,29 @@ Definition path_forall `{Funext} {A : Type} {P : A -> Type} (f g : forall x : A, Admitted. Inductive Empty : Set := . -Instance contr_from_Empty {_ : Funext} (A : Type) : +Fail Instance contr_from_Empty {_ : Funext} (A : Type) : + Contr_internal (Empty -> A) := + BuildContr _ + (Empty_rect (fun _ => A)) + (fun f => path_forall _ f (fun x => Empty_rect _ x)). + +Fail Instance contr_from_Empty {F : Funext} (A : Type) : Contr_internal (Empty -> A) := BuildContr _ (Empty_rect (fun _ => A)) (fun f => path_forall _ f (fun x => Empty_rect _ x)). + +(** This could be disallowed, this uses the Funext argument *) +Instance contr_from_Empty {_ : Funext} (A : Type) : + Contr_internal (Empty -> A) := + BuildContr _ + (Empty_rect (fun _ => A)) + (fun f => path_forall _ f (fun x => Empty_rect (fun _ => _ x = f x) x)). + +Instance contr_from_Empty' {_ : Funext} (A : Type) : + Contr_internal (Empty -> A) := + BuildContr _ + (Empty_rect (fun _ => A)) + (fun f => path_forall _ f (fun x => Empty_rect (fun _ => _ x = f x) x)). (* Toplevel input, characters 15-220: Anomaly: unknown meta ?190. Please report. *) diff --git a/test-suite/bugs/opened/4701.v b/test-suite/bugs/opened/4701.v new file mode 100644 index 0000000000..9286f0f1f0 --- /dev/null +++ b/test-suite/bugs/opened/4701.v @@ -0,0 +1,23 @@ +(*Suppose we have*) + + Inductive my_if {A B} : bool -> Type := + | then_case (_ : A) : my_if true + | else_case (_ : B) : my_if false. + Notation "'If' b 'Then' A 'Else' B" := (@my_if A B b) (at level 10). + +(*then here are three inductive type declarations that work:*) + + Inductive I1 := + | i1 (x : I1). + Inductive I2 := + | i2 (x : nat). + Inductive I3 := + | i3 (b : bool) (x : If b Then I3 Else nat). + +(*and here is one that does not, despite being equivalent to [I3]:*) + + Fail Inductive I4 := + | i4 (b : bool) (x : if b then I4 else nat). (* Error: Non strictly positive occurrence of "I4" in + "forall b : bool, (if b then I4 else nat) -> I4". *) + +(*I think this one should work. I believe this is a conservative extension over CIC: Since [match] statements returning types can always be re-encoded as inductive type families, the analysis should be independent of whether the constructor uses an inductive or a [match] statement.*) diff --git a/test-suite/bugs/opened/4717.v b/test-suite/bugs/opened/4717.v new file mode 100644 index 0000000000..9ad4746723 --- /dev/null +++ b/test-suite/bugs/opened/4717.v @@ -0,0 +1,19 @@ +(*See below. They sometimes work, and sometimes do not. Is this a bug?*) + +Require Import Omega Psatz. + +Definition foo := nat. + +Goal forall (n : foo), 0 = n - n. +Proof. intros. omega. (* works *) Qed. + +Goal forall (x n : foo), x = x + n - n. +Proof. + intros. + Fail omega. (* Omega can't solve this system *) + Fail lia. (* Cannot find witness. *) + unfold foo in *. + omega. (* works *) +Qed. + +(* Guillaume Melquiond: What matters is the equality. In the first case, it is @eq nat. In the second case, it is @eq foo. The same issue exists for ring and field. So it is not a bug, but it is worth fixing.*) diff --git a/test-suite/bugs/opened/4721.v b/test-suite/bugs/opened/4721.v new file mode 100644 index 0000000000..1f184b3930 --- /dev/null +++ b/test-suite/bugs/opened/4721.v @@ -0,0 +1,13 @@ +Variables S1 S2 : Set. + +Goal @eq Type S1 S2 -> @eq Type S1 S2. +intro H. +Fail tauto. +assumption. +Qed. + +(*This is in 8.5pl1, and Matthieq Sozeau says: "That's a regression in tauto indeed, which now requires exact equality of the universes, through a non linear goal pattern matching: +match goal with ?X1 |- ?X1 forces both instances of X1 to be convertible, +with no additional universe constraints currently, but the two types are +initially different. This can be fixed easily to allow the same flexibility +as in 8.4 (or assumption) to unify the universes as well."*) diff --git a/test-suite/bugs/opened/4728.v b/test-suite/bugs/opened/4728.v new file mode 100644 index 0000000000..230b4beb6c --- /dev/null +++ b/test-suite/bugs/opened/4728.v @@ -0,0 +1,72 @@ +(*I'd like the final [Check] in the following to work:*) + +Ltac fin_eta_expand := + [ > lazymatch goal with + | [ H : _ |- _ ] => clear H + end.. + | lazymatch goal with + | [ H : ?T |- ?T ] + => exact H + | [ |- ?G ] + => fail 0 "No hypothesis matching" G + end ]; + let n := numgoals in + tryif constr_eq numgoals 0 + then idtac + else fin_eta_expand. + +Ltac pre_eta_expand x := + let T := type of x in + let G := match goal with |- ?G => G end in + unify T G; + unshelve econstructor; + destruct x; + fin_eta_expand. + +Ltac eta_expand x := + let v := constr:(ltac:(pre_eta_expand x)) in + idtac v; + let v := (eval cbv beta iota zeta in v) in + exact v. + +Notation eta_expand x := (ltac:(eta_expand x)) (only parsing). + +Ltac partial_unify eqn := + lazymatch eqn with + | ?x = ?x => idtac + | ?f ?x = ?g ?y + => partial_unify (f = g); + (tryif unify x y then + idtac + else tryif has_evar x then + unify x y + else tryif has_evar y then + unify x y + else + idtac) + | ?x = ?y + => idtac; + (tryif unify x y then + idtac + else tryif has_evar x then + unify x y + else tryif has_evar y then + unify x y + else + idtac) + end. + +Tactic Notation "{" open_constr(old_record) "with" open_constr(new_record) "}" := + let old_record' := eta_expand old_record in + partial_unify (old_record = new_record); + eexact new_record. + +Set Implicit Arguments. +Record prod A B := pair { fst : A ; snd : B }. +Infix "*" := prod : type_scope. +Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope. + +Notation "{ old 'with' new }" := (ltac:({ old with new })) (only parsing). + +Check ltac:({ (1, 1) with {| snd := 2 |} }). +Fail Check { (1, 1) with {| snd := 2 |} }. (* Error: Cannot infer this placeholder of type "Type"; should succeed *) diff --git a/test-suite/bugs/opened/4755.v b/test-suite/bugs/opened/4755.v new file mode 100644 index 0000000000..9cc0d361ea --- /dev/null +++ b/test-suite/bugs/opened/4755.v @@ -0,0 +1,34 @@ +(*I'm not sure which behavior is better. But if the change is intentional, it should be documented (I don't think it is), and it'd be nice if there were a flag for this, or if -compat 8.4 restored the old behavior.*) + +Require Import Coq.Setoids.Setoid Coq.Classes.Morphisms. +Definition f (v : option nat) := match v with + | Some k => Some k + | None => None + end. + +Axioms F G : (option nat -> option nat) -> Prop. +Axiom FG : forall f, f None = None -> F f = G f. + +Axiom admit : forall {T}, T. + +Existing Instance eq_Reflexive. + +Global Instance foo (A := nat) + : Proper ((pointwise_relation _ eq) + ==> eq ==> forall_relation (fun _ => Basics.flip Basics.impl)) + (@option_rect A (fun _ => Prop)) | 0. +exact admit. +Qed. + +Global Instance bar (A := nat) + : Proper ((pointwise_relation _ eq) + ==> eq ==> eq ==> Basics.flip Basics.impl) + (@option_rect A (fun _ => Prop)) | 0. +exact admit. +Qed. + +Goal forall k, option_rect (fun _ => Prop) (fun v : nat => v = v /\ F f) True k. +Proof. + intro. + pose proof (_ : (Proper (_ ==> eq ==> _) and)). + Fail setoid_rewrite (FG _ _); []. (* In 8.5: Error: Tactic failure: Incorrect number of goals (expected 2 tactics); works in 8.4 *) diff --git a/test-suite/bugs/opened/4771.v b/test-suite/bugs/opened/4771.v new file mode 100644 index 0000000000..396d74bdbf --- /dev/null +++ b/test-suite/bugs/opened/4771.v @@ -0,0 +1,22 @@ +Module Type Foo. + +Parameter Inline t : nat. + +End Foo. + +Module F(X : Foo). + +Tactic Notation "foo" ref(x) := idtac. + +Ltac g := foo X.t. + +End F. + +Module N. +Definition t := 0 + 0. +End N. + +Module K := F(N). + +(* Was +Anomaly: Uncaught exception Not_found. Please report. *) diff --git a/test-suite/bugs/opened/4778.v b/test-suite/bugs/opened/4778.v new file mode 100644 index 0000000000..633d158e96 --- /dev/null +++ b/test-suite/bugs/opened/4778.v @@ -0,0 +1,35 @@ +Require Import Coq.Setoids.Setoid Coq.Classes.Morphisms. +Definition f (v : option nat) := match v with + | Some k => Some k + | None => None + end. + +Axioms F G : (option nat -> option nat) -> Prop. +Axiom FG : forall f, f None = None -> F f = G f. + +Axiom admit : forall {T}, T. + +Existing Instance eq_Reflexive. + +(* This instance is needed in 8.4, but is useless in 8.5 *) +Global Instance foo (A := nat) + : Proper ((pointwise_relation _ eq) + ==> eq ==> forall_relation (fun _ => Basics.flip Basics.impl)) + (@option_rect A (fun _ => Prop)) | 0. +exact admit. +Qed. + +(* +(* This is required in 8.5, but useless in 8.4 *) +Global Instance bar (A := nat) + : Proper ((pointwise_relation _ eq) + ==> eq ==> eq ==> Basics.flip Basics.impl) + (@option_rect A (fun _ => Prop)) | 0. +exact admit. +Qed. +*) + +Goal forall k, option_rect (fun _ => Prop) (fun v : nat => v = v /\ F f) True k. Proof. + intro. + pose proof (_ : (Proper (_ ==> eq ==> _) and)). + Fail setoid_rewrite (FG _ _); [ | reflexivity.. ]. (* this should succeed without [Fail], as it does in 8.4 *) diff --git a/test-suite/bugs/opened/4781.v b/test-suite/bugs/opened/4781.v new file mode 100644 index 0000000000..8b651ac22e --- /dev/null +++ b/test-suite/bugs/opened/4781.v @@ -0,0 +1,94 @@ +Ltac force_clear := + clear; + repeat match goal with + | [ H : _ |- _ ] => clear H + | [ H := _ |- _ ] => clearbody H + end. + +Class abstract_term {T} (x : T) := by_abstract_term : T. +Hint Extern 0 (@abstract_term ?T ?x) => force_clear; change T; abstract (exact x) : typeclass_instances. + +Goal True. +(* These work: *) + let term := constr:(I) in + let T := type of term in + let x := constr:((_ : abstract_term term) : T) in + pose x. + let term := constr:(I) in + let T := type of term in + let x := constr:((_ : abstract_term term) : T) in + let x := (eval cbv iota in (let v : T := x in v)) in + pose x. + let term := constr:(I) in + let T := type of term in + let x := constr:((_ : abstract_term term) : T) in + let x := match constr:(Set) with ?y => constr:(y) end in + pose x. +(* This fails with an error: *) + Fail let term := constr:(I) in + let T := type of term in + let x := constr:((_ : abstract_term term) : T) in + let x := match constr:(x) with ?y => constr:(y) end in + pose x. (* The command has indeed failed with message: +Error: Variable y should be bound to a term. *) +(* And the rest fail with Anomaly: Uncaught exception Not_found. Please report. *) + Fail let term := constr:(I) in + let T := type of term in + let x := constr:((_ : abstract_term term) : T) in + let x := match constr:(x) with ?y => y end in + pose x. + Fail let term := constr:(I) in + let T := type of term in + let x := constr:((_ : abstract_term term) : T) in + let x := (eval cbv iota in x) in + pose x. + Fail let term := constr:(I) in + let T := type of term in + let x := constr:((_ : abstract_term term) : T) in + let x := type of x in + pose x. (* should succeed *) + Fail let term := constr:(I) in + let T := type of term in + let x := constr:(_ : abstract_term term) in + let x := type of x in + pose x. (* should succeed *) + +(*Apparently what [cbv iota] doesn't see can't hurt it, and [pose] is perfectly happy with abstracted lemmas only some of the time. + +Even stranger, consider:*) + let term := constr:(I) in + let T := type of term in + let x := constr:((_ : abstract_term term) : T) in + let y := (eval cbv iota in (let v : T := x in v)) in + pose y; + let x' := fresh "x'" in + pose x as x'. + let x := (eval cbv delta [x'] in x') in + pose x; + let z := (eval cbv iota in x) in + pose z. + +(*This works fine. But if I change the period to a semicolon, I get:*) + + Fail let term := constr:(I) in + let T := type of term in + let x := constr:((_ : abstract_term term) : T) in + let y := (eval cbv iota in (let v : T := x in v)) in + pose y; + let x' := fresh "x'" in + pose x as x'; + let x := (eval cbv delta [x'] in x') in + pose x. (* Anomaly: Uncaught exception Not_found. Please report. *) + (* should succeed *) +(*and if I use the second one instead of [pose x] (note that using [idtac] works fine), I get:*) + + Fail let term := constr:(I) in + let T := type of term in + let x := constr:((_ : abstract_term term) : T) in + let y := (eval cbv iota in (let v : T := x in v)) in + pose y; + let x' := fresh "x'" in + pose x as x'; + let x := (eval cbv delta [x'] in x') in + let z := (eval cbv iota in x) in (* Error: Variable x should be bound to a term. *) + idtac. (* should succeed *) diff --git a/test-suite/bugs/opened/4803.v b/test-suite/bugs/opened/4803.v index 3ca5c095f5..4530548b8f 100644 --- a/test-suite/bugs/opened/4803.v +++ b/test-suite/bugs/opened/4803.v @@ -25,10 +25,24 @@ Check [ _ ]%list : list _. Check [ _ ]%vector : Vector.t _ _. Check [ _ ; _ ]%list : list _. Check [ _ ; _ ]%vector : Vector.t _ _. -Fail Check [ _ ; _ ]%mylist : mylist _. (* ideally, this should work, but that requires removing notations from the parser; it should be added to Compat/Coq84.v *) +Check [ _ ; _ ]%mylist : mylist _. Check [ _ ; _ ; _ ]%list : list _. Check [ _ ; _ ; _ ]%vector : Vector.t _ _. -Fail Check [ _ ; _ ; _ ]%mylist : mylist _. (* ideally, this should work, but that requires removing notations from the parser *) +Check [ _ ; _ ; _ ]%mylist : mylist _. Check [ _ ; _ ; _ ; _ ]%list : list _. Check [ _ ; _ ; _ ; _ ]%vector : Vector.t _ _. -Fail Check [ _ ; _ ; _ ; _ ]%mylist : mylist _. (* ideally, this should work, but that requires removing notations from the parser *) +Check [ _ ; _ ; _ ; _ ]%mylist : mylist _. + +(** Now check that we can add and then remove notations from the parser *) +(* We should be able to stick some vernacular here to remove [] from the parser *) +Fail Remove Notation "[]". +Goal True. + (* This should not be a syntax error; before moving this file to closed, uncomment this line. *) + (* idtac; []. *) + constructor. +Qed. + +Check { _ : _ & _ }. +Reserved Infix "&" (at level 0). +Fail Remove Infix "&". +(* Check { _ : _ & _ }. *) diff --git a/test-suite/output-modulo-time/ltacprof.v b/test-suite/output-modulo-time/ltacprof.v index d79451f0f7..6611db70e2 100644 --- a/test-suite/output-modulo-time/ltacprof.v +++ b/test-suite/output-modulo-time/ltacprof.v @@ -1,4 +1,4 @@ -(* -*- coq-prog-args: ("-emacs" "-profile-ltac") -*- *) +(* -*- coq-prog-args: ("-emacs" "-profile-ltac-cutoff" "0.0") -*- *) Ltac sleep' := do 100 (do 100 (do 100 idtac)). Ltac sleep := sleep'. diff --git a/test-suite/output-modulo-time/ltacprof_cutoff.out b/test-suite/output-modulo-time/ltacprof_cutoff.out new file mode 100644 index 0000000000..0cd5777ccf --- /dev/null +++ b/test-suite/output-modulo-time/ltacprof_cutoff.out @@ -0,0 +1,31 @@ +total time: 1.584s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─foo2 ---------------------------------- 0.0% 100.0% 1 1.584s +─sleep --------------------------------- 100.0% 100.0% 3 0.572s +─foo1 ---------------------------------- 0.0% 63.9% 1 1.012s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─foo2 ---------------------------------- 0.0% 100.0% 1 1.584s +└foo1 ---------------------------------- 0.0% 63.9% 1 1.012s + +total time: 1.584s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─sleep --------------------------------- 100.0% 100.0% 3 0.572s +─foo2 ---------------------------------- 0.0% 100.0% 1 1.584s +─foo1 ---------------------------------- 0.0% 63.9% 1 1.012s +─foo0 ---------------------------------- 0.0% 31.3% 1 0.496s + + tactic local total calls max +────────────────────────────────────────┴──────┴──────┴───────┴─────────┘ +─foo2 ---------------------------------- 0.0% 100.0% 1 1.584s + ├─foo1 -------------------------------- 0.0% 63.9% 1 1.012s + │ ├─sleep ----------------------------- 32.6% 32.6% 1 0.516s + │ └─foo0 ------------------------------ 0.0% 31.3% 1 0.496s + │ └sleep ----------------------------- 31.3% 31.3% 1 0.496s + └─sleep ------------------------------- 36.1% 36.1% 1 0.572s + diff --git a/test-suite/output-modulo-time/ltacprof_cutoff.v b/test-suite/output-modulo-time/ltacprof_cutoff.v new file mode 100644 index 0000000000..50131470eb --- /dev/null +++ b/test-suite/output-modulo-time/ltacprof_cutoff.v @@ -0,0 +1,12 @@ +(* -*- coq-prog-args: ("-emacs" "-profile-ltac") -*- *) +Require Coq.ZArith.BinInt. +Ltac sleep := do 50 (idtac; let sleep := (eval vm_compute in Coq.ZArith.BinInt.Z.div_eucl) in idtac). + +Ltac foo0 := idtac; sleep. +Ltac foo1 := sleep; foo0. +Ltac foo2 := sleep; foo1. +Goal True. + foo2. + Show Ltac Profile CutOff 47. + constructor. +Qed. diff --git a/test-suite/output/Arguments.out b/test-suite/output/Arguments.out index 2c7b04c62a..a2ee2d4c8e 100644 --- a/test-suite/output/Arguments.out +++ b/test-suite/output/Arguments.out @@ -101,4 +101,4 @@ Error: Unknown interpretation for notation "$". w 3 true = tt : Prop The command has indeed failed with message: -Error: Extra argument _. +Error: Extra arguments: _, _. diff --git a/test-suite/output/Arguments_renaming.out b/test-suite/output/Arguments_renaming.out index 3488cb3056..b084ad4984 100644 --- a/test-suite/output/Arguments_renaming.out +++ b/test-suite/output/Arguments_renaming.out @@ -1,9 +1,11 @@ The command has indeed failed with message: Error: To rename arguments the "rename" flag must be specified. Argument A renamed to B. -The command has indeed failed with message: -Error: To rename arguments the "rename" flag must be specified. -Argument A renamed to T. +File "stdin", line 2, characters 0-25: +Warning: This command is just asserting the names of arguments of identity. +If this is what you want add ': assert' to silence the warning. If you want +to clear implicit arguments add ': clear implicits'. If you want to clear +notation scopes add ': clear scopes' [arguments-assert,vernacular] @eq_refl : forall (B : Type) (y : B), y = y eq_refl @@ -101,15 +103,15 @@ Expands to: Constant Top.myplus @myplus : forall Z : Type, Z -> nat -> nat -> nat The command has indeed failed with message: -Error: All arguments lists must declare the same names. +Error: Argument lists should agree on the names they provide. The command has indeed failed with message: -Error: The following arguments are not declared: x. +Error: Sequences of implicit arguments must be of different lengths. The command has indeed failed with message: -Error: Arguments names must be distinct. +Error: Some argument names are duplicated: F The command has indeed failed with message: Error: Argument z cannot be declared implicit. The command has indeed failed with message: -Error: Extra argument y. +Error: Extra arguments: y. The command has indeed failed with message: Error: To rename arguments the "rename" flag must be specified. Argument A renamed to R. diff --git a/test-suite/output/Arguments_renaming.v b/test-suite/output/Arguments_renaming.v index b6fbeb6ec7..0cb331347d 100644 --- a/test-suite/output/Arguments_renaming.v +++ b/test-suite/output/Arguments_renaming.v @@ -1,5 +1,5 @@ Fail Arguments eq_refl {B y}, [B] y. -Fail Arguments identity T _ _. +Arguments identity A _ _. Arguments eq_refl A x : assert. Arguments eq_refl {B y}, [B] y : rename. @@ -46,9 +46,9 @@ About myplus. Check @myplus. Fail Arguments eq_refl {F g}, [H] k. -Fail Arguments eq_refl {F}, [F]. -Fail Arguments eq_refl {F F}, [F] F. -Fail Arguments eq {F} x [z]. +Fail Arguments eq_refl {F}, [F] : rename. +Fail Arguments eq_refl {F F}, [F] F : rename. +Fail Arguments eq {F} x [z] : rename. Fail Arguments eq {F} x z y. Fail Arguments eq {R} s t. diff --git a/test-suite/output/Cases.out b/test-suite/output/Cases.out index 2b828d382a..8ce6f9795c 100644 --- a/test-suite/output/Cases.out +++ b/test-suite/output/Cases.out @@ -56,3 +56,19 @@ match H with else fun _ : P false => Logic.I) x end : B -> True +The command has indeed failed with message: +Non exhaustive pattern-matching: no clause found for pattern +gadtTy _ _ +The command has indeed failed with message: +In environment +texpDenote : forall t : type, texp t -> typeDenote t +t : type +e : texp t +t1 : type +t2 : type +t0 : type +b : tbinop t1 t2 t0 +e1 : texp t1 +e2 : texp t2 +The term "0" has type "nat" while it is expected to have type + "typeDenote t0". diff --git a/test-suite/output/Cases.v b/test-suite/output/Cases.v index 3c2eaf42c9..4074896420 100644 --- a/test-suite/output/Cases.v +++ b/test-suite/output/Cases.v @@ -77,3 +77,32 @@ destruct b as [|] ; exact Logic.I. Defined. Print f. + +(* Was enhancement request #5142 (error message reported on the most + general return clause heuristic) *) + +Inductive gadt : Type -> Type := +| gadtNat : nat -> gadt nat +| gadtTy : forall T, T -> gadt T. + +Fail Definition gadt_id T (x: gadt T) : gadt T := + match x with + | gadtNat n => gadtNat n + end. + +(* A variant of #5142 (see Satrajit Roy's example on coq-club (Oct 17, 2016)) *) + +Inductive type:Set:=Nat. +Inductive tbinop:type->type->type->Set:= TPlus : tbinop Nat Nat Nat. +Inductive texp:type->Set:= + |TNConst:nat->texp Nat + |TBinop:forall t1 t2 t, tbinop t1 t2 t->texp t1->texp t2->texp t. +Definition typeDenote(t:type):Set:= match t with Nat => nat end. + +(* We expect a failure on TBinop *) +Fail Fixpoint texpDenote t (e:texp t):typeDenote t:= + match e with + | TNConst n => n + | TBinop t1 t2 _ b e1 e2 => O + end. + diff --git a/test-suite/output/Fixpoint.out b/test-suite/output/Fixpoint.out index a13ae4624a..6879cbc3c2 100644 --- a/test-suite/output/Fixpoint.out +++ b/test-suite/output/Fixpoint.out @@ -10,3 +10,5 @@ let fix f (m : nat) : nat := match m with end in f 0 : nat Ltac f id1 id2 := fix id1 2 with (id2 (n:_) (H:odd n) {struct H} : n >= 1) + = cofix inf : Inf := {| projS := inf |} + : Inf diff --git a/test-suite/output/Fixpoint.v b/test-suite/output/Fixpoint.v index 8afa50ba57..fafb478bad 100644 --- a/test-suite/output/Fixpoint.v +++ b/test-suite/output/Fixpoint.v @@ -44,4 +44,7 @@ fix even_pos_odd_pos 2 with (odd_pos_even_pos n (H:odd n) {struct H} : n >= 1). omega. Qed. - +CoInductive Inf := S { projS : Inf }. +Definition expand_Inf (x : Inf) := S (projS x). +CoFixpoint inf := S inf. +Eval compute in inf. diff --git a/test-suite/output/Notations2.out b/test-suite/output/Notations2.out index 5541ccf57b..ad60aeccce 100644 --- a/test-suite/output/Notations2.out +++ b/test-suite/output/Notations2.out @@ -60,3 +60,27 @@ exist (Q x) y conj : nat -> nat {1, 2} : nat -> Prop +a# + : Set +a# + : Set +a≡ + : Set +a≡ + : Set +.≡ + : Set +.≡ + : Set +.a# + : Set +.a# + : Set +.a≡ + : Set +.a≡ + : Set +.α + : Set +.α + : Set diff --git a/test-suite/output/Notations2.v b/test-suite/output/Notations2.v index 1d8278c088..ceb29d1b9e 100644 --- a/test-suite/output/Notations2.v +++ b/test-suite/output/Notations2.v @@ -116,3 +116,32 @@ Check %j. Notation "{ x , y , .. , v }" := (fun a => (or .. (or (a = x) (a = y)) .. (a = v))). Check ({1, 2}). + +(**********************************************************************) +(* Check notations of the form ".a", ".a≡", "a≡" *) +(* Only "a#", "a≡" and ".≡" were working properly for parsing. The *) +(* other ones were working only for printing. *) + +Notation "a#" := nat. +Check nat. +Check a#. + +Notation "a≡" := nat. +Check nat. +Check a≡. + +Notation ".≡" := nat. +Check nat. +Check .≡. + +Notation ".a#" := nat. +Check nat. +Check .a#. + +Notation ".a≡" := nat. +Check nat. +Check .a≡. + +Notation ".α" := nat. +Check nat. +Check .α. diff --git a/test-suite/output/PatternsInBinders.v b/test-suite/output/PatternsInBinders.v index fff86d6fae..6fa357a90c 100644 --- a/test-suite/output/PatternsInBinders.v +++ b/test-suite/output/PatternsInBinders.v @@ -58,7 +58,7 @@ Definition F '(n,p) : Type := (Fin n * Fin p)%type. Definition both_z '(n,p) : F (n,p) := (Z _,Z _). Print both_z. -(** These tests show examples which do not factorize binders *) +(** Test factorization of binders *) Check fun '((x,y) : A*B) '(z,t) => swap (x,y) = (z,t). Check forall '(x,y) '((z,t) : B*A), swap (x,y) = (z,t). diff --git a/test-suite/output/PrintModule.out b/test-suite/output/PrintModule.out index db464fd07e..751d5fcc48 100644 --- a/test-suite/output/PrintModule.out +++ b/test-suite/output/PrintModule.out @@ -2,3 +2,4 @@ Module N : S with Definition T := nat := M Module N : S with Module T := K := M +Module Type Func = Funsig (T0:Test) Sig Parameter x : T0.t. End diff --git a/test-suite/output/PrintModule.v b/test-suite/output/PrintModule.v index 999d9a9862..5f30f7cda6 100644 --- a/test-suite/output/PrintModule.v +++ b/test-suite/output/PrintModule.v @@ -32,3 +32,19 @@ Module N : S with Module T := K := M. Print Module N. End BAR. + +Module QUX. + +Module Type Test. + Parameter t : Type. +End Test. + +Module Type Func (T:Test). + Parameter x : T.t. +End Func. + +Module Shortest_path (T : Test). +Print Func. +End Shortest_path. + +End QUX. diff --git a/test-suite/output/SearchPattern.out b/test-suite/output/SearchPattern.out index 1eb7eca8f1..f3c12effca 100644 --- a/test-suite/output/SearchPattern.out +++ b/test-suite/output/SearchPattern.out @@ -40,7 +40,6 @@ Nat.land: nat -> nat -> nat Nat.lor: nat -> nat -> nat Nat.ldiff: nat -> nat -> nat Nat.lxor: nat -> nat -> nat - S: nat -> nat Nat.succ: nat -> nat Nat.pred: nat -> nat @@ -74,7 +73,6 @@ le_n: forall n : nat, n <= n pair: forall A B : Type, A -> B -> A * B conj: forall A B : Prop, A -> B -> A /\ B Nat.divmod: nat -> nat -> nat -> nat -> nat * nat - h: n <> newdef n h: n <> newdef n h: P n diff --git a/test-suite/output/Tactics.out b/test-suite/output/Tactics.out index 9949658c44..239edd1da3 100644 --- a/test-suite/output/Tactics.out +++ b/test-suite/output/Tactics.out @@ -1,4 +1,4 @@ Ltac f H := split; [ a H | e H ] Ltac g := match goal with - | |- context [if ?X then _ else _] => case X + | |- context [ if ?X then _ else _ ] => case X end diff --git a/test-suite/output/ltac.out b/test-suite/output/ltac.out index f4254e4e2f..1ff09e3af6 100644 --- a/test-suite/output/ltac.out +++ b/test-suite/output/ltac.out @@ -1,5 +1,6 @@ The command has indeed failed with message: -Error: Ltac variable y depends on pattern variable name z which is not bound in current context. +Error: +Ltac variable y depends on pattern variable name z which is not bound in current context. Ltac f x y z := symmetry in x, y; auto with z; auto; intros **; clearbody x; generalize dependent z @@ -26,3 +27,8 @@ The command has indeed failed with message: In nested Ltac calls to "h" and "injection (destruction_arg)", last call failed. Error: No primitive equality found. +Hx +nat +nat +0 +0 diff --git a/test-suite/output/ltac.v b/test-suite/output/ltac.v index dfa60eeda0..76c37625aa 100644 --- a/test-suite/output/ltac.v +++ b/test-suite/output/ltac.v @@ -43,3 +43,17 @@ Goal True -> False. Fail h I. intro H. Fail h H. + +(* Check printing of the "var" argument "Hx" *) +Ltac m H := idtac H; exact H. +Goal True. +let a:=constr:(let Hx := 0 in ltac:(m Hx)) in idtac. + +(* Check consistency of interpretation scopes (#4398) *) + +Goal nat*(0*0=0) -> nat*(0*0=0). intro. +match goal with H: ?x*?y |- _ => idtac x end. +match goal with |- ?x*?y => idtac x end. +match goal with H: context [?x*?y] |- _ => idtac x end. +match goal with |- context [?x*?y] => idtac x end. +Abort. diff --git a/test-suite/output/qualification.out b/test-suite/output/qualification.out new file mode 100644 index 0000000000..9300c3f546 --- /dev/null +++ b/test-suite/output/qualification.out @@ -0,0 +1,3 @@ +File "stdin", line 19, characters 0-7: +Error: Signature components for label test do not match: expected type +"Top.M2.t = Top.M2.M.t" but found type "Top.M2.t = Top.M2.t". diff --git a/test-suite/output/qualification.v b/test-suite/output/qualification.v new file mode 100644 index 0000000000..d39097e2dd --- /dev/null +++ b/test-suite/output/qualification.v @@ -0,0 +1,19 @@ +Module Type T1. + Parameter t : Type. +End T1. + +Module Type T2. + Declare Module M : T1. + Parameter t : Type. + Parameter test : t = M.t. +End T2. + +Module M1 <: T1. + Definition t : Type := bool. +End M1. + +Module M2 <: T2. + Module M := M1. + Definition t : Type := nat. + Lemma test : t = t. Proof. reflexivity. Qed. +End M2. diff --git a/test-suite/output/unifconstraints.out b/test-suite/output/unifconstraints.out index d152052ba3..ae84603622 100644 --- a/test-suite/output/unifconstraints.out +++ b/test-suite/output/unifconstraints.out @@ -8,11 +8,7 @@ subgoal 2 is: forall n : nat, ?Goal n -> ?Goal (S n) subgoal 3 is: nat -unification constraints: - ?Goal ?Goal2 <= - True /\ True /\ True \/ - veeryyyyyyyyyyyyloooooooooooooonggidentifier = - veeryyyyyyyyyyyyloooooooooooooonggidentifier +unification constraint: ?Goal ?Goal2 <= True /\ True /\ True \/ veeryyyyyyyyyyyyloooooooooooooonggidentifier = @@ -28,11 +24,7 @@ subgoal 2 is: forall n0 : nat, ?Goal@{n:=n; m:=m} n0 -> ?Goal@{n:=n; m:=m} (S n0) subgoal 3 is: nat -unification constraints: - ?Goal@{n:=n; m:=m} ?Goal2@{n:=n; m:=m} <= - True /\ True /\ True \/ - veeryyyyyyyyyyyyloooooooooooooonggidentifier = - veeryyyyyyyyyyyyloooooooooooooonggidentifier +unification constraint: ?Goal@{n:=n; m:=m} ?Goal2@{n:=n; m:=m} <= True /\ True /\ True \/ veeryyyyyyyyyyyyloooooooooooooonggidentifier = @@ -48,12 +40,7 @@ subgoal 2 is: forall n0 : nat, ?Goal1@{m:=m} n0 -> ?Goal1@{m:=m} (S n0) subgoal 3 is: nat -unification constraints: - - n, m : nat |- ?Goal1@{m:=m} ?Goal0@{n:=n; m:=m} <= - True /\ True /\ True \/ - veeryyyyyyyyyyyyloooooooooooooonggidentifier = - veeryyyyyyyyyyyyloooooooooooooonggidentifier +unification constraint: n, m : nat |- ?Goal1@{m:=m} ?Goal0@{n:=n; m:=m} <= True /\ True /\ True \/ @@ -70,12 +57,7 @@ subgoal 2 is: forall n0 : nat, ?Goal0@{m:=m} n0 -> ?Goal0@{m:=m} (S n0) subgoal 3 is: nat -unification constraints: - - n, m : nat |- ?Goal0@{m:=m} ?Goal2@{n:=n} <= - True /\ True /\ True \/ - veeryyyyyyyyyyyyloooooooooooooonggidentifier = - veeryyyyyyyyyyyyloooooooooooooonggidentifier +unification constraint: n, m : nat |- ?Goal0@{m:=m} ?Goal2@{n:=n} <= True /\ True /\ True \/ diff --git a/test-suite/output/unifconstraints.v b/test-suite/output/unifconstraints.v index c76fc74a0c..b9413a4ac2 100644 --- a/test-suite/output/unifconstraints.v +++ b/test-suite/output/unifconstraints.v @@ -1,4 +1,5 @@ (* Set Printing Existential Instances. *) +Unset Solve Unification Constraints. Axiom veeryyyyyyyyyyyyloooooooooooooonggidentifier : nat. Goal True /\ True /\ True \/ veeryyyyyyyyyyyyloooooooooooooonggidentifier = diff --git a/test-suite/success/Case13.v b/test-suite/success/Case13.v index 356a67efec..8f95484cfd 100644 --- a/test-suite/success/Case13.v +++ b/test-suite/success/Case13.v @@ -87,41 +87,3 @@ Check fun (x : E) => match x with c => e c end. Inductive C' : bool -> Set := c' : C' true. Inductive E' (b : bool) : Set := e' :> C' b -> E' b. Check fun (x : E' true) => match x with c' => e' true c' end. - -(* Check use of the no-dependency strategy when a type constraint is - given (and when the "inversion-and-dependencies-as-evars" strategy - is not strong enough because of a constructor with a type whose - pattern structure is not refined enough for it to be captured by - the inversion predicate) *) - -Inductive K : bool -> bool -> Type := F : K true true | G x : K x x. - -Check fun z P Q (y:K true z) (H1 H2:P y) (f:forall y, P y -> Q y z) => - match y with - | F => f y H1 - | G _ => f y H2 - end : Q y z. - -(* Check use of the maximal-dependency-in-variable strategy even when - no explicit type constraint is given (and when the - "inversion-and-dependencies-as-evars" strategy is not strong enough - because of a constructor with a type whose pattern structure is not - refined enough for it to be captured by the inversion predicate) *) - -Check fun z P Q (y:K true z) (H1 H2:P y) (f:forall y z, P y -> Q y z) => - match y with - | F => f y true H1 - | G b => f y b H2 - end. - -(* Check use of the maximal-dependency-in-variable strategy for "Var" - variables *) - -Goal forall z P Q (y:K true z) (H1 H2:P y) (f:forall y z, P y -> Q y z), Q y z. -intros z P Q y H1 H2 f. -Show. -refine (match y with - | F => f y true H1 - | G b => f y b H2 - end). -Qed. diff --git a/test-suite/success/Case22.v b/test-suite/success/Case22.v index 3c696502cd..465b3eb8c0 100644 --- a/test-suite/success/Case22.v +++ b/test-suite/success/Case22.v @@ -41,6 +41,7 @@ Definition F (x:IND True) (A:Type) := Theorem paradox : False. (* This succeeded in 8.3, 8.4 and 8.5beta1 because F had wrong type *) Fail Proof (F C False). +Abort. (* Another bug found in November 2015 (a substitution was wrongly reversed at pretyping level) *) @@ -61,3 +62,30 @@ Inductive Ind2 (b:=1) (c:nat) : Type := Constr2 : Ind2 c. Eval vm_compute in Constr2 2. + +(* A bug introduced in ade2363 (similar to #5322 and #5324). This + commit started to see that some List.rev was wrong in the "var" + case of a pattern-matching problem but it failed to see that a + transformation from a list of arguments into a substitution was + still needed. *) + +(* The order of real arguments was made wrong by ade2363 in the "var" + case of the compilation of "match" *) + +Inductive IND2 : forall X Y:Type, Type := + CONSTR2 : IND2 unit Empty_set. + +Check fun x:IND2 bool nat => + match x in IND2 a b return a with + | y => _ + end = true. + +(* From January 2017, using the proper function to turn arguments into + a substitution up to a context possibly containing let-ins, so that + the following, which was wrong also before ade2363, now works + correctly *) + +Check fun x:Ind bool nat => + match x in Ind _ X Y Z return Z with + | y => (true,0) + end. diff --git a/test-suite/success/CaseInClause.v b/test-suite/success/CaseInClause.v index 599b9566cb..6424fe92dd 100644 --- a/test-suite/success/CaseInClause.v +++ b/test-suite/success/CaseInClause.v @@ -24,3 +24,6 @@ Theorem foo : forall (n m : nat) (pf : n = m), (* Check redundant clause is removed *) Inductive I : nat * nat -> Type := C : I (0,0). Check fun x : I (1,1) => match x in I (y,z) return y = z with C => eq_refl end. + +(* An example of non-local inference of the type of an impossible case *) +Check (fun y n (x:Vector.t nat (S n)) => match x with a::_ => a | _ => y end) 2. diff --git a/test-suite/success/Hints.v b/test-suite/success/Hints.v index 89b8bd7ac1..1abe14774c 100644 --- a/test-suite/success/Hints.v +++ b/test-suite/success/Hints.v @@ -1,4 +1,12 @@ (* Checks syntax of Hints commands *) +(* Old-style syntax *) +Hint Resolve eq_refl eq_sym. +Hint Resolve eq_refl eq_sym: foo. +Hint Immediate eq_refl eq_sym. +Hint Immediate eq_refl eq_sym: foo. +Hint Unfold fst eq_sym. +Hint Unfold fst eq_sym: foo. + (* Checks that qualified names are accepted *) (* New-style syntax *) @@ -8,13 +16,76 @@ Hint Unfold eq_sym: core. Hint Constructors eq: foo bar. Hint Extern 3 (_ = _) => apply eq_refl: foo bar. -(* Old-style syntax *) -Hint Resolve eq_refl eq_sym. -Hint Resolve eq_refl eq_sym: foo. -Hint Immediate eq_refl eq_sym. -Hint Immediate eq_refl eq_sym: foo. -Hint Unfold fst eq_sym. -Hint Unfold fst eq_sym: foo. +(* Extended new syntax with patterns *) +Hint Resolve eq_refl | 4 (_ = _) : baz. +Hint Resolve eq_sym eq_trans : baz. +Hint Extern 3 (_ = _) => apply eq_sym : baz. + +Parameter pred : nat -> Prop. +Parameter pred0 : pred 0. +Parameter f : nat -> nat. +Parameter predf : forall n, pred n -> pred (f n). + +(* No conversion on let-bound variables and constants in pred (the default) *) +Hint Resolve pred0 | 1 (pred _) : pred. +Hint Resolve predf | 0 : pred. + +(* Allow full conversion on let-bound variables and constants *) +Create HintDb predconv discriminated. +Hint Resolve pred0 | 1 (pred _) : predconv. +Hint Resolve predf | 0 : predconv. + +Goal exists n, pred n. + eexists. + Fail Timeout 1 typeclasses eauto with pred. + Set Typeclasses Filtered Unification. + Set Typeclasses Debug Verbosity 2. + (* predf is not tried as it doesn't match the goal *) + typeclasses eauto with pred. +Qed. + +Parameter predconv : forall n, pred n -> pred (0 + S n). + +(* The inferred pattern contains 0 + ?n, syntactic match will fail to see convertible + terms *) +Hint Resolve pred0 : pred2. +Hint Resolve predconv : pred2. + +(** In this database we allow predconv to apply to pred (S _) goals, more generally + than the inferred pattern (pred (0 + S _)). *) +Create HintDb pred2conv discriminated. +Hint Resolve pred0 : pred2conv. +Hint Resolve predconv | 1 (pred (S _)) : pred2conv. + +Goal pred 3. + Fail typeclasses eauto with pred2. + typeclasses eauto with pred2conv. +Abort. + +Set Typeclasses Filtered Unification. +Set Typeclasses Debug Verbosity 2. +Hint Resolve predconv | 1 (pred _) : pred. +Hint Resolve predconv | 1 (pred (S _)) : predconv. +Test Typeclasses Limit Intros. +Goal pred 3. + (* predf is not tried as it doesn't match the goal *) + (* predconv is tried but fails as the transparent state doesn't allow + unfolding + *) + Fail typeclasses eauto with pred. + (* Here predconv succeeds as it matches (pred (S _)) and then + full unification is allowed *) + typeclasses eauto with predconv. +Qed. + +(** The other way around: goal contains redexes instead of instances *) +Goal exists n, pred (0 + n). + eexists. + (* predf is applied indefinitely *) + Fail Timeout 1 typeclasses eauto with pred. + (* pred0 (pred _) matches the goal *) + typeclasses eauto with predconv. +Qed. + (* Checks that local names are accepted *) Section A. @@ -105,4 +176,4 @@ Hint Cut [_* (a_is_b | b_is_c | c_is_d | d_is_e) Timeout 1 Fail apply _. (* 0.06s *) Abort. -End HintCut.
\ No newline at end of file +End HintCut. diff --git a/test-suite/success/Inductive.v b/test-suite/success/Inductive.v index 9661b3bfac..f746def5cb 100644 --- a/test-suite/success/Inductive.v +++ b/test-suite/success/Inductive.v @@ -162,3 +162,24 @@ Inductive L (A:Type) (T:=A) : Type := C : L nat -> L A. hit the Inductiveops.get_arity bug mentioned above (see #3491) *) Inductive IND6 (A:Type) (T:=A) := CONS6 : IND6 T -> IND6 A. + + +Module TemplateProp. + + (** Check lowering of a template universe polymorphic inductive to Prop *) + + Inductive Foo (A : Type) : Type := foo : A -> Foo A. + + Check Foo True : Prop. + +End TemplateProp. + +Module PolyNoLowerProp. + + (** Check lowering of a general universe polymorphic inductive to Prop is _failing_ *) + + Polymorphic Inductive Foo (A : Type) : Type := foo : A -> Foo A. + + Fail Check Foo True : Prop. + +End PolyNoLowerProp. diff --git a/test-suite/success/Injection.v b/test-suite/success/Injection.v index 8745cf2fbd..da2183841d 100644 --- a/test-suite/success/Injection.v +++ b/test-suite/success/Injection.v @@ -135,6 +135,21 @@ intros * [= H]. exact H. Abort. +(* Test the Keep Proof Equalities option. *) +Set Keep Proof Equalities. +Unset Structural Injection. + +Inductive pbool : Prop := Pbool1 | Pbool2. + +Inductive pbool_shell : Set := Pbsc : pbool -> pbool_shell. + +Goal Pbsc Pbool1 = Pbsc Pbool2 -> True. +injection 1. +match goal with + |- Pbool1 = Pbool2 -> True => idtac | |- True => fail +end. +Abort. + (* Injection does not project at positions in Prop... allow it? Inductive t (A:Prop) : Set := c : A -> t A. diff --git a/test-suite/success/Notations.v b/test-suite/success/Notations.v index 2f7c62972a..07bbb60c40 100644 --- a/test-suite/success/Notations.v +++ b/test-suite/success/Notations.v @@ -58,7 +58,7 @@ Check (fun x:nat*nat => match x with R x y => (x,y) end). (* Check multi-tokens recursive notations *) -Local Notation "[ a # ; .. # ; b ]" := (a + .. (b + 0) ..). +Local Notation "[ a # ; .. # ; b ]" := (a + .. (b + 0) ..). Check [ 0 ]. Check [ 0 # ; 1 ]. @@ -110,3 +110,21 @@ Goal True -> True. intros H. exact H. Qed. (* Check absence of collision on ".." in nested notations with ".." *) Notation "[ a , .. , b ]" := (a, (.. (b,tt) ..)). + +(* Check that vector notations do not break Ltac [] (bugs #4785, #4733) *) +Require Import Coq.Vectors.VectorDef. +Import VectorNotations. +Goal True. idtac; []. (* important for test: no space here *) constructor. Qed. + +(* Check parsing of { and } is not affected by notations #3479 *) +Notation " |- {{ a }} b" := (a=b) (no associativity, at level 10). +Goal True. +{{ exact I. }} +Qed. +Check |- {{ 0 }} 0. + +(* Check parsing of { and } is not affected by notations #3479 *) +Notation " |- {{ a }} b" := (a=b) (no associativity, at level 10). +Goal True. +{{ exact I. }} +Qed. diff --git a/test-suite/success/Typeclasses.v b/test-suite/success/Typeclasses.v index dfa438d90a..6b1f0315bc 100644 --- a/test-suite/success/Typeclasses.v +++ b/test-suite/success/Typeclasses.v @@ -1,3 +1,79 @@ +Module onlyclasses. + +(* In 8.6 we still allow non-class subgoals *) + Variable Foo : Type. + Variable foo : Foo. + Hint Extern 0 Foo => exact foo : typeclass_instances. + Goal Foo * Foo. + split. shelve. + Set Typeclasses Debug. + typeclasses eauto. + Unshelve. typeclasses eauto. + Qed. + + Module RJung. + Class Foo (x : nat). + + Instance foo x : x = 2 -> Foo x. + Hint Extern 0 (_ = _) => reflexivity : typeclass_instances. + Typeclasses eauto := debug. + Check (_ : Foo 2). + + + Fail Definition foo := (_ : 0 = 0). + + End RJung. +End onlyclasses. + +Module shelve_non_class_subgoals. + Variable Foo : Type. + Variable foo : Foo. + Hint Extern 0 Foo => exact foo : typeclass_instances. + Class Bar := {}. + Instance bar1 (f:Foo) : Bar := {}. + + Typeclasses eauto := debug. + Set Typeclasses Debug Verbosity 2. + Goal Bar. + (* Solution has shelved subgoals (of non typeclass type) *) + typeclasses eauto. + Abort. +End shelve_non_class_subgoals. + +Module RefineVsNoTceauto. + + Class Foo (A : Type) := foo : A. + Instance: Foo nat := { foo := 0 }. + Instance: Foo nat := { foo := 42 }. + Hint Extern 0 (_ = _) => refine eq_refl : typeclass_instances. + Goal exists (f : Foo nat), @foo _ f = 0. + Proof. + unshelve (notypeclasses refine (ex_intro _ _ _)). + Set Typeclasses Debug. Set Printing All. + all:once (typeclasses eauto). + Fail idtac. (* Check no subgoals are left *) + Undo 3. + (** In this case, the (_ = _) subgoal is not considered + by typeclass resolution *) + refine (ex_intro _ _ _). Fail reflexivity. + Abort. + +End RefineVsNoTceauto. + +Module Leivantex2PR339. + (** Was a bug preventing to find hints associated with no pattern *) + Class Bar := {}. + Instance bar1 (t:Type) : Bar. + Hint Extern 0 => exact True : typeclass_instances. + Typeclasses eauto := debug. + Goal Bar. + Set Typeclasses Debug Verbosity 2. + typeclasses eauto. (* Relies on resolution of a non-class subgoal *) + Undo 1. + typeclasses eauto with typeclass_instances. + Qed. +End Leivantex2PR339. + Module bt. Require Import Equivalence. @@ -5,7 +81,7 @@ Record Equ (A : Type) (R : A -> A -> Prop). Definition equiv {A} R (e : Equ A R) := R. Record Refl (A : Type) (R : A -> A -> Prop). Axiom equ_refl : forall A R (e : Equ A R), Refl _ (@equiv A R e). -Hint Extern 0 (Refl _ _) => unshelve class_apply @equ_refl; [|shelve|] : foo. +Hint Extern 0 (Refl _ _) => unshelve class_apply @equ_refl; [shelve|] : foo. Variable R : nat -> nat -> Prop. Lemma bas : Equ nat R. @@ -22,7 +98,7 @@ Goal exists R, @Refl nat R. solve [typeclasses eauto with foo]. Qed. -(* Set Typeclasses Compatibility "8.5". *) +Set Typeclasses Compatibility "8.5". Parameter f : nat -> Prop. Parameter g : nat -> nat -> Prop. Parameter h : nat -> nat -> nat -> Prop. @@ -32,8 +108,7 @@ Axiom c : forall x y z, h x y z -> f x -> f y. Hint Resolve a b c : mybase. Goal forall x y z, h x y z -> f x -> f y. intros. - Set Typeclasses Debug. - typeclasses eauto with mybase. + Fail Timeout 1 typeclasses eauto with mybase. (* Loops now *) Unshelve. Abort. End bt. @@ -62,7 +137,8 @@ Notation "'return' t" := (unit t). Class A `(e: T) := { a := True }. Class B `(e_: T) := { e := e_; sg_ass :> A e }. -Set Typeclasses Debug. +(* Set Typeclasses Debug. *) +(* Set Typeclasses Debug Verbosity 2. *) Goal forall `{B T}, Prop. intros. apply a. @@ -104,6 +180,40 @@ Section sec. Check U (fun x => e x) _. End sec. +Module UniqueSolutions. + Set Typeclasses Unique Solutions. + Class Eq (A : Type) : Set. + Instance eqa : Eq nat := {}. + Instance eqb : Eq nat := {}. + + Goal Eq nat. + try apply _. + Fail exactly_once typeclasses eauto. + Abort. +End UniqueSolutions. + + +Module UniqueInstances. + (** Optimize proof search on this class by never backtracking on (closed) goals + for it. *) + Set Typeclasses Unique Instances. + Class Eq (A : Type) : Set. + Instance eqa : Eq nat := _. constructor. Qed. + Instance eqb : Eq nat := {}. + Class Foo (A : Type) (e : Eq A) : Set. + Instance fooa : Foo _ eqa := {}. + + Tactic Notation "refineu" open_constr(c) := unshelve refine c. + + Set Typeclasses Debug. + Goal { e : Eq nat & Foo nat e }. + unshelve refineu (existT _ _ _). + all:simpl. + (** Does not backtrack on the (wrong) solution eqb *) + Fail all:typeclasses eauto. + Abort. +End UniqueInstances. + Module IterativeDeepening. Class A. diff --git a/test-suite/success/bteauto.v b/test-suite/success/bteauto.v index bb1cf06541..3178c6fc15 100644 --- a/test-suite/success/bteauto.v +++ b/test-suite/success/bteauto.v @@ -1,3 +1,4 @@ +Require Import Program.Tactics. Module Backtracking. Class A := { foo : nat }. @@ -8,7 +9,6 @@ Module Backtracking. Qed. Arguments foo A : clear implicits. - Example find42 : exists n, n = 42. Proof. eexists. @@ -20,9 +20,13 @@ Module Backtracking. Fail reflexivity. Undo 2. (* Without multiple successes it fails *) - Fail all:((once typeclasses eauto) + apply eq_refl). + Set Typeclasses Debug Verbosity 2. + Fail all:((once (typeclasses eauto with typeclass_instances)) + + apply eq_refl). (* Does backtrack if other goals fail *) - all:((typeclasses eauto) + reflexivity). + all:[> typeclasses eauto + reflexivity .. ]. + Undo 1. + all:(typeclasses eauto + reflexivity). (* Note "+" is a focussing combinator *) Show Proof. Qed. diff --git a/test-suite/success/clear.v b/test-suite/success/clear.v index 976bec7371..e25510cf09 100644 --- a/test-suite/success/clear.v +++ b/test-suite/success/clear.v @@ -13,3 +13,21 @@ Goal forall y z, (forall x:nat, x=y -> True) -> y=z -> True. reflexivity. Qed. +Class A. + +Section Foo. + + Variable a : A. + + Goal A. + solve [typeclasses eauto]. + Undo 1. + clear a. + try typeclasses eauto. + assert(a:=Build_A). + solve [ typeclasses eauto ]. + Undo 2. + assert(b:=Build_A). + solve [ typeclasses eauto ]. + Qed. +End Foo.
\ No newline at end of file diff --git a/test-suite/success/eauto.v b/test-suite/success/eauto.v index c9c7c611cc..160f2d9deb 100644 --- a/test-suite/success/eauto.v +++ b/test-suite/success/eauto.v @@ -5,7 +5,6 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -Require Import List. Class A (A : Type). Instance an: A nat. @@ -31,6 +30,8 @@ Defined. Hint Extern 0 (_ /\ _) => constructor : typeclass_instances. +Existing Class and. + Goal exists (T : Type) (t : T), A T /\ B T t. Proof. eexists. eexists. typeclasses eauto. @@ -46,7 +47,7 @@ Class C {T} `(a : A T) (t : T). Require Import Classes.Init. Hint Extern 0 { x : ?A & _ } => unshelve class_apply @existT : typeclass_instances. - +Existing Class sigT. Set Typeclasses Debug. Instance can: C an 0. (* Backtrack on instance implementation *) @@ -63,41 +64,6 @@ Proof. Defined. -Parameter in_list : list (nat * nat) -> nat -> Prop. -Definition not_in_list (l : list (nat * nat)) (n : nat) : Prop := - ~ in_list l n. - -(* Hints Unfold not_in_list. *) - -Axiom - lem1 : - forall (l1 l2 : list (nat * nat)) (n : nat), - not_in_list (l1 ++ l2) n -> not_in_list l1 n. - -Axiom - lem2 : - forall (l1 l2 : list (nat * nat)) (n : nat), - not_in_list (l1 ++ l2) n -> not_in_list l2 n. - -Axiom - lem3 : - forall (l : list (nat * nat)) (n p q : nat), - not_in_list ((p, q) :: l) n -> not_in_list l n. - -Axiom - lem4 : - forall (l1 l2 : list (nat * nat)) (n : nat), - not_in_list l1 n -> not_in_list l2 n -> not_in_list (l1 ++ l2) n. - -Hint Resolve lem1 lem2 lem3 lem4: essai. - -Goal -forall (l : list (nat * nat)) (n p q : nat), -not_in_list ((p, q) :: l) n -> not_in_list l n. - intros. - eauto with essai. -Qed. - (* Example from Nicolas Magaud on coq-club - Jul 2000 *) Definition Nat : Set := nat. @@ -117,7 +83,7 @@ Lemma simpl_plus_l_rr1 : Undo. Set Typeclasses Debug. Set Typeclasses Iterative Deepening. - Time typeclasses eauto 2 with nocore. Show Proof. + Time typeclasses eauto 6 with nocore. Show Proof. Undo. Time eauto. (* does EApply H *) Qed. @@ -126,6 +92,9 @@ Qed. Full backtracking on dependent subgoals. *) Require Import Coq.Classes.Init. + +Module NTabareau. + Set Typeclasses Dependency Order. Unset Typeclasses Iterative Deepening. Notation "x .1" := (projT1 x) (at level 3). @@ -149,7 +118,8 @@ Hint Extern 5 (Bar ?D.1) => Hint Extern 5 (Qux ?D.1) => destruct D; simpl : typeclass_instances. -Hint Extern 1 myType => unshelve refine (fooTobar _ _).1 : typeclass_instances. +Hint Extern 1 myType => + unshelve refine (fooTobar _ _).1 : typeclass_instances. Hint Extern 1 myType => unshelve refine (barToqux _ _).1 : typeclass_instances. @@ -158,8 +128,94 @@ Hint Extern 0 { x : _ & _ } => simple refine (existT _ _ _) : typeclass_instance Unset Typeclasses Debug. Definition trivial a (H : Foo a) : {b : myType & Qux b}. Proof. - Time typeclasses eauto 10. + Time typeclasses eauto 10 with typeclass_instances. Undo. Set Typeclasses Iterative Deepening. - Time typeclasses eauto. + Time typeclasses eauto with typeclass_instances. Defined. +End NTabareau. + +Module NTabareauClasses. + +Set Typeclasses Dependency Order. +Unset Typeclasses Iterative Deepening. +Notation "x .1" := (projT1 x) (at level 3). +Notation "x .2" := (projT2 x) (at level 3). + +Parameter myType: Type. +Existing Class myType. + +Class Foo (a:myType) := {}. + +Class Bar (a:myType) := {}. + +Class Qux (a:myType) := {}. + +Parameter fooTobar : forall a (H : Foo a), {b: myType & Bar b}. + +Parameter barToqux : forall a (H : Bar a), {b: myType & Qux b}. + +Hint Extern 5 (Bar ?D.1) => + destruct D; simpl : typeclass_instances. + +Hint Extern 5 (Qux ?D.1) => + destruct D; simpl : typeclass_instances. + +Hint Extern 1 myType => + unshelve notypeclasses refine (fooTobar _ _).1 : typeclass_instances. + +Hint Extern 1 myType => + unshelve notypeclasses refine (barToqux _ _).1 : typeclass_instances. + +Hint Extern 0 { x : _ & _ } => + unshelve notypeclasses refine (existT _ _ _) : typeclass_instances. + +Unset Typeclasses Debug. + +Definition trivial a (H : Foo a) : {b : myType & Qux b}. +Proof. + Time typeclasses eauto 10 with typeclass_instances. + Undo. Set Typeclasses Iterative Deepening. + (* Much faster in iteratove deepening mode *) + Time typeclasses eauto with typeclass_instances. +Defined. + +End NTabareauClasses. + + +Require Import List. + +Parameter in_list : list (nat * nat) -> nat -> Prop. +Definition not_in_list (l : list (nat * nat)) (n : nat) : Prop := + ~ in_list l n. + +(* Hints Unfold not_in_list. *) + +Axiom + lem1 : + forall (l1 l2 : list (nat * nat)) (n : nat), + not_in_list (l1 ++ l2) n -> not_in_list l1 n. + +Axiom + lem2 : + forall (l1 l2 : list (nat * nat)) (n : nat), + not_in_list (l1 ++ l2) n -> not_in_list l2 n. + +Axiom + lem3 : + forall (l : list (nat * nat)) (n p q : nat), + not_in_list ((p, q) :: l) n -> not_in_list l n. + +Axiom + lem4 : + forall (l1 l2 : list (nat * nat)) (n : nat), + not_in_list l1 n -> not_in_list l2 n -> not_in_list (l1 ++ l2) n. + +Hint Resolve lem1 lem2 lem3 lem4: essai. + +Goal +forall (l : list (nat * nat)) (n p q : nat), +not_in_list ((p, q) :: l) n -> not_in_list l n. + intros. + eauto with essai. +Qed. diff --git a/test-suite/success/subst.v b/test-suite/success/subst.v index 8336f6a806..25ee81b587 100644 --- a/test-suite/success/subst.v +++ b/test-suite/success/subst.v @@ -23,3 +23,20 @@ subst. change (y = S (S y)) in H0. change (S y = y). Abort. + +(* A bug revealed by OCaml 4.03 warnings *) +(* fixes in 4e3d464 and 89ec88f for v8.5, 4e3d4646 and 89ec88f1e for v8.6 *) +Goal forall y, let x:=0 in y=x -> y=y. +intros * H; +(* This worked as expected *) +subst. +Fail clear H. +Abort. + +Goal forall y, let x:=0 in x=y -> y=y. +intros * H; +(* Before the fix, this unfolded x instead of + substituting y and erasing H *) +subst. +Fail clear H. +Abort. diff --git a/theories/Arith/Between.v b/theories/Arith/Between.v index f998e86192..58d3a2b38c 100644 --- a/theories/Arith/Between.v +++ b/theories/Arith/Between.v @@ -20,20 +20,20 @@ Section Between. | bet_emp : between k k | bet_S : forall l, between k l -> P l -> between k (S l). - Hint Constructors between: arith v62. + Hint Constructors between: arith. Lemma bet_eq : forall k l, l = k -> between k l. Proof. induction 1; auto with arith. Qed. - Hint Resolve bet_eq: arith v62. + Hint Resolve bet_eq: arith. Lemma between_le : forall k l, between k l -> k <= l. Proof. induction 1; auto with arith. Qed. - Hint Immediate between_le: arith v62. + Hint Immediate between_le: arith. Lemma between_Sk_l : forall k l, between k l -> S k <= l -> between (S k) l. Proof. @@ -41,7 +41,7 @@ Section Between. intros; absurd (S k <= k); auto with arith. destruct H; auto with arith. Qed. - Hint Resolve between_Sk_l: arith v62. + Hint Resolve between_Sk_l: arith. Lemma between_restr : forall k l (m:nat), k <= l -> l <= m -> between k m -> between l m. @@ -53,7 +53,7 @@ Section Between. | exists_S : forall l, exists_between k l -> exists_between k (S l) | exists_le : forall l, k <= l -> Q l -> exists_between k (S l). - Hint Constructors exists_between: arith v62. + Hint Constructors exists_between: arith. Lemma exists_le_S : forall k l, exists_between k l -> S k <= l. Proof. @@ -62,13 +62,13 @@ Section Between. Lemma exists_lt : forall k l, exists_between k l -> k < l. Proof exists_le_S. - Hint Immediate exists_le_S exists_lt: arith v62. + Hint Immediate exists_le_S exists_lt: arith. Lemma exists_S_le : forall k l, exists_between k (S l) -> k <= l. Proof. intros; apply le_S_n; auto with arith. Qed. - Hint Immediate exists_S_le: arith v62. + Hint Immediate exists_S_le: arith. Definition in_int p q r := p <= r /\ r < q. @@ -76,7 +76,7 @@ Section Between. Proof. red; auto with arith. Qed. - Hint Resolve in_int_intro: arith v62. + Hint Resolve in_int_intro: arith. Lemma in_int_lt : forall p q r, in_int p q r -> p < q. Proof. @@ -95,13 +95,13 @@ Section Between. Proof. induction 1; auto with arith. Qed. - Hint Resolve in_int_S: arith v62. + Hint Resolve in_int_S: arith. Lemma in_int_Sp_q : forall p q r, in_int (S p) q r -> in_int p q r. Proof. induction 1; auto with arith. Qed. - Hint Immediate in_int_Sp_q: arith v62. + Hint Immediate in_int_Sp_q: arith. Lemma between_in_int : forall k l, between k l -> forall r, in_int k l r -> P r. @@ -183,5 +183,5 @@ Section Between. End Between. Hint Resolve nth_O bet_S bet_emp bet_eq between_Sk_l exists_S exists_le - in_int_S in_int_intro: arith v62. -Hint Immediate in_int_Sp_q exists_le_S exists_S_le: arith v62. + in_int_S in_int_intro: arith. +Hint Immediate in_int_Sp_q exists_le_S exists_S_le: arith. diff --git a/theories/Arith/EqNat.v b/theories/Arith/EqNat.v index 206fc0ab5d..f998c19fc7 100644 --- a/theories/Arith/EqNat.v +++ b/theories/Arith/EqNat.v @@ -25,7 +25,7 @@ Theorem eq_nat_refl n : eq_nat n n. Proof. induction n; simpl; auto. Qed. -Hint Resolve eq_nat_refl: arith v62. +Hint Resolve eq_nat_refl: arith. (** [eq] restricted to [nat] and [eq_nat] are equivalent *) @@ -46,7 +46,7 @@ Proof. apply eq_nat_is_eq. Qed. -Hint Immediate eq_eq_nat eq_nat_eq: arith v62. +Hint Immediate eq_eq_nat eq_nat_eq: arith. Theorem eq_nat_elim : forall n (P:nat -> Prop), P n -> forall m, eq_nat n m -> P m. diff --git a/theories/Arith/Gt.v b/theories/Arith/Gt.v index dfd5769464..67c94fdf64 100644 --- a/theories/Arith/Gt.v +++ b/theories/Arith/Gt.v @@ -133,14 +133,14 @@ Qed. (** * Hints *) -Hint Resolve gt_Sn_O gt_Sn_n gt_n_S : arith v62. -Hint Immediate gt_S_n gt_pred : arith v62. -Hint Resolve gt_irrefl gt_asym : arith v62. -Hint Resolve le_not_gt gt_not_le : arith v62. -Hint Immediate le_S_gt gt_S_le : arith v62. -Hint Resolve gt_le_S le_gt_S : arith v62. -Hint Resolve gt_trans_S le_gt_trans gt_le_trans: arith v62. -Hint Resolve plus_gt_compat_l: arith v62. +Hint Resolve gt_Sn_O gt_Sn_n gt_n_S : arith. +Hint Immediate gt_S_n gt_pred : arith. +Hint Resolve gt_irrefl gt_asym : arith. +Hint Resolve le_not_gt gt_not_le : arith. +Hint Immediate le_S_gt gt_S_le : arith. +Hint Resolve gt_le_S le_gt_S : arith. +Hint Resolve gt_trans_S le_gt_trans gt_le_trans: arith. +Hint Resolve plus_gt_compat_l: arith. (* begin hide *) Notation gt_O_eq := gt_0_eq (only parsing). diff --git a/theories/Arith/Le.v b/theories/Arith/Le.v index ceb91187ba..0fbcec5721 100644 --- a/theories/Arith/Le.v +++ b/theories/Arith/Le.v @@ -30,8 +30,8 @@ Notation le_refl := Nat.le_refl (compat "8.4"). Notation le_trans := Nat.le_trans (compat "8.4"). Notation le_antisym := Nat.le_antisymm (compat "8.4"). -Hint Resolve le_trans: arith v62. -Hint Immediate le_antisym: arith v62. +Hint Resolve le_trans: arith. +Hint Immediate le_antisym: arith. (** * Properties of [le] w.r.t 0 *) @@ -59,16 +59,16 @@ Notation le_Sn_n := Nat.nle_succ_diag_l (compat "8.4"). (* ~ S n <= n *) Theorem le_Sn_le : forall n m, S n <= m -> n <= m. Proof Nat.lt_le_incl. -Hint Resolve le_0_n le_Sn_0: arith v62. -Hint Resolve le_n_S le_n_Sn le_Sn_n : arith v62. -Hint Immediate le_n_0_eq le_Sn_le le_S_n : arith v62. +Hint Resolve le_0_n le_Sn_0: arith. +Hint Resolve le_n_S le_n_Sn le_Sn_n : arith. +Hint Immediate le_n_0_eq le_Sn_le le_S_n : arith. (** * Properties of [le] w.r.t predecessor *) Notation le_pred_n := Nat.le_pred_l (compat "8.4"). (* pred n <= n *) Notation le_pred := Nat.pred_le_mono (compat "8.4"). (* n<=m -> pred n <= pred m *) -Hint Resolve le_pred_n: arith v62. +Hint Resolve le_pred_n: arith. (** * A different elimination principle for the order on natural numbers *) diff --git a/theories/Arith/Lt.v b/theories/Arith/Lt.v index f824ee6fbe..bfc2b91a9f 100644 --- a/theories/Arith/Lt.v +++ b/theories/Arith/Lt.v @@ -25,7 +25,7 @@ Local Open Scope nat_scope. Notation lt_irrefl := Nat.lt_irrefl (compat "8.4"). (* ~ x < x *) -Hint Resolve lt_irrefl: arith v62. +Hint Resolve lt_irrefl: arith. (** * Relationship between [le] and [lt] *) @@ -44,9 +44,9 @@ Proof. apply Nat.lt_succ_r. Qed. -Hint Immediate lt_le_S: arith v62. -Hint Immediate lt_n_Sm_le: arith v62. -Hint Immediate le_lt_n_Sm: arith v62. +Hint Immediate lt_le_S: arith. +Hint Immediate lt_n_Sm_le: arith. +Hint Immediate le_lt_n_Sm: arith. Theorem le_not_lt n m : n <= m -> ~ m < n. Proof. @@ -58,7 +58,7 @@ Proof. apply Nat.lt_nge. Qed. -Hint Immediate le_not_lt lt_not_le: arith v62. +Hint Immediate le_not_lt lt_not_le: arith. (** * Asymmetry *) @@ -79,8 +79,8 @@ Proof. intros. now apply Nat.neq_sym, Nat.neq_0_lt_0. Qed. -Hint Resolve lt_0_Sn lt_n_0 : arith v62. -Hint Immediate neq_0_lt lt_0_neq: arith v62. +Hint Resolve lt_0_Sn lt_n_0 : arith. +Hint Immediate neq_0_lt lt_0_neq: arith. (** * Order and successor *) @@ -97,8 +97,8 @@ Proof. apply Nat.succ_lt_mono. Qed. -Hint Resolve lt_n_Sn lt_S lt_n_S : arith v62. -Hint Immediate lt_S_n : arith v62. +Hint Resolve lt_n_Sn lt_S lt_n_S : arith. +Hint Immediate lt_S_n : arith. (** * Predecessor *) @@ -117,8 +117,8 @@ Proof. intros. now apply Nat.lt_pred_l, Nat.neq_0_lt_0. Qed. -Hint Immediate lt_pred: arith v62. -Hint Resolve lt_pred_n_n: arith v62. +Hint Immediate lt_pred: arith. +Hint Resolve lt_pred_n_n: arith. (** * Transitivity properties *) @@ -126,7 +126,7 @@ Notation lt_trans := Nat.lt_trans (compat "8.4"). Notation lt_le_trans := Nat.lt_le_trans (compat "8.4"). Notation le_lt_trans := Nat.le_lt_trans (compat "8.4"). -Hint Resolve lt_trans lt_le_trans le_lt_trans: arith v62. +Hint Resolve lt_trans lt_le_trans le_lt_trans: arith. (** * Large = strict or equal *) @@ -139,7 +139,7 @@ Qed. Notation lt_le_weak := Nat.lt_le_incl (compat "8.4"). -Hint Immediate lt_le_weak: arith v62. +Hint Immediate lt_le_weak: arith. (** * Dichotomy *) diff --git a/theories/Arith/Max.v b/theories/Arith/Max.v index 65534b2e3c..49152549a4 100644 --- a/theories/Arith/Max.v +++ b/theories/Arith/Max.v @@ -42,7 +42,7 @@ Notation max_SS := Nat.succ_max_distr (only parsing). (* end hide *) Hint Resolve - Nat.max_l Nat.max_r Nat.le_max_l Nat.le_max_r : arith v62. + Nat.max_l Nat.max_r Nat.le_max_l Nat.le_max_r : arith. Hint Resolve - Nat.min_l Nat.min_r Nat.le_min_l Nat.le_min_r : arith v62. + Nat.min_l Nat.min_r Nat.le_min_l Nat.le_min_r : arith. diff --git a/theories/Arith/Minus.v b/theories/Arith/Minus.v index bc3a318cf3..1fc8f7907a 100644 --- a/theories/Arith/Minus.v +++ b/theories/Arith/Minus.v @@ -107,13 +107,13 @@ Qed. (** * Hints *) -Hint Resolve minus_n_O: arith v62. -Hint Resolve minus_Sn_m: arith v62. -Hint Resolve minus_diag_reverse: arith v62. -Hint Resolve minus_plus_simpl_l_reverse: arith v62. -Hint Immediate plus_minus: arith v62. -Hint Resolve minus_plus: arith v62. -Hint Resolve le_plus_minus: arith v62. -Hint Resolve le_plus_minus_r: arith v62. -Hint Resolve lt_minus: arith v62. -Hint Immediate lt_O_minus_lt: arith v62. +Hint Resolve minus_n_O: arith. +Hint Resolve minus_Sn_m: arith. +Hint Resolve minus_diag_reverse: arith. +Hint Resolve minus_plus_simpl_l_reverse: arith. +Hint Immediate plus_minus: arith. +Hint Resolve minus_plus: arith. +Hint Resolve le_plus_minus: arith. +Hint Resolve le_plus_minus_r: arith. +Hint Resolve lt_minus: arith. +Hint Immediate lt_O_minus_lt: arith. diff --git a/theories/Arith/Mult.v b/theories/Arith/Mult.v index 9658124320..a173efc10a 100644 --- a/theories/Arith/Mult.v +++ b/theories/Arith/Mult.v @@ -31,13 +31,13 @@ Notation mult_0_r := Nat.mul_0_r (compat "8.4"). (* n * 0 = 0 *) Notation mult_1_l := Nat.mul_1_l (compat "8.4"). (* 1 * n = n *) Notation mult_1_r := Nat.mul_1_r (compat "8.4"). (* n * 1 = n *) -Hint Resolve mult_1_l mult_1_r: arith v62. +Hint Resolve mult_1_l mult_1_r: arith. (** ** Commutativity *) Notation mult_comm := Nat.mul_comm (compat "8.4"). (* n * m = m * n *) -Hint Resolve mult_comm: arith v62. +Hint Resolve mult_comm: arith. (** ** Distributivity *) @@ -53,9 +53,9 @@ Notation mult_minus_distr_r := Notation mult_minus_distr_l := Nat.mul_sub_distr_l (compat "8.4"). (* n*(m-p) = n*m - n*p *) -Hint Resolve mult_plus_distr_r: arith v62. -Hint Resolve mult_minus_distr_r: arith v62. -Hint Resolve mult_minus_distr_l: arith v62. +Hint Resolve mult_plus_distr_r: arith. +Hint Resolve mult_minus_distr_r: arith. +Hint Resolve mult_minus_distr_l: arith. (** ** Associativity *) @@ -66,8 +66,8 @@ Proof. symmetry. apply Nat.mul_assoc. Qed. -Hint Resolve mult_assoc_reverse: arith v62. -Hint Resolve mult_assoc: arith v62. +Hint Resolve mult_assoc_reverse: arith. +Hint Resolve mult_assoc: arith. (** ** Inversion lemmas *) @@ -92,7 +92,7 @@ Lemma mult_O_le n m : m = 0 \/ n <= m * n. Proof. destruct m; [left|right]; simpl; trivial using Nat.le_add_r. Qed. -Hint Resolve mult_O_le: arith v62. +Hint Resolve mult_O_le: arith. Lemma mult_le_compat_l n m p : n <= m -> p * n <= p * m. Proof. diff --git a/theories/Arith/Plus.v b/theories/Arith/Plus.v index 3b823da6f3..600e5e518d 100644 --- a/theories/Arith/Plus.v +++ b/theories/Arith/Plus.v @@ -177,12 +177,12 @@ Proof (succ_plus_discr n 3). (** * Compatibility Hints *) -Hint Immediate plus_comm : arith v62. -Hint Resolve plus_assoc plus_assoc_reverse : arith v62. -Hint Resolve plus_le_compat_l plus_le_compat_r : arith v62. -Hint Resolve le_plus_l le_plus_r le_plus_trans : arith v62. -Hint Immediate lt_plus_trans : arith v62. -Hint Resolve plus_lt_compat_l plus_lt_compat_r : arith v62. +Hint Immediate plus_comm : arith. +Hint Resolve plus_assoc plus_assoc_reverse : arith. +Hint Resolve plus_le_compat_l plus_le_compat_r : arith. +Hint Resolve le_plus_l le_plus_r le_plus_trans : arith. +Hint Immediate lt_plus_trans : arith. +Hint Resolve plus_lt_compat_l plus_lt_compat_r : arith. (** For compatibility, we "Require" the same files as before *) diff --git a/theories/Bool/Bool.v b/theories/Bool/Bool.v index 721ab69328..06096c66ac 100644 --- a/theories/Bool/Bool.v +++ b/theories/Bool/Bool.v @@ -39,13 +39,13 @@ Lemma diff_true_false : true <> false. Proof. discriminate. Qed. -Hint Resolve diff_true_false : bool v62. +Hint Resolve diff_true_false : bool. Lemma diff_false_true : false <> true. Proof. discriminate. Qed. -Hint Resolve diff_false_true : bool v62. +Hint Resolve diff_false_true : bool. Hint Extern 1 (false <> true) => exact diff_false_true. Lemma eq_true_false_abs : forall b:bool, b = true -> b = false -> False. @@ -82,7 +82,7 @@ Definition leb (b1 b2:bool) := | true => b2 = true | false => True end. -Hint Unfold leb: bool v62. +Hint Unfold leb: bool. Lemma leb_implb : forall b1 b2, leb b1 b2 <-> implb b1 b2 = true. Proof. @@ -242,14 +242,14 @@ Lemma orb_true_intro : Proof. intros; apply orb_true_iff; trivial. Qed. -Hint Resolve orb_true_intro: bool v62. +Hint Resolve orb_true_intro: bool. Lemma orb_false_intro : forall b1 b2:bool, b1 = false -> b2 = false -> b1 || b2 = false. Proof. intros. subst. reflexivity. Qed. -Hint Resolve orb_false_intro: bool v62. +Hint Resolve orb_false_intro: bool. Lemma orb_false_elim : forall b1 b2:bool, b1 || b2 = false -> b1 = false /\ b2 = false. @@ -268,7 +268,7 @@ Lemma orb_true_r : forall b:bool, b || true = true. Proof. destr_bool. Qed. -Hint Resolve orb_true_r: bool v62. +Hint Resolve orb_true_r: bool. Lemma orb_true_l : forall b:bool, true || b = true. Proof. @@ -284,13 +284,13 @@ Lemma orb_false_r : forall b:bool, b || false = b. Proof. destr_bool. Qed. -Hint Resolve orb_false_r: bool v62. +Hint Resolve orb_false_r: bool. Lemma orb_false_l : forall b:bool, false || b = b. Proof. destr_bool. Qed. -Hint Resolve orb_false_l: bool v62. +Hint Resolve orb_false_l: bool. Notation orb_b_false := orb_false_r (only parsing). Notation orb_false_b := orb_false_l (only parsing). @@ -301,7 +301,7 @@ Lemma orb_negb_r : forall b:bool, b || negb b = true. Proof. destr_bool. Qed. -Hint Resolve orb_negb_r: bool v62. +Hint Resolve orb_negb_r: bool. Notation orb_neg_b := orb_negb_r (only parsing). @@ -318,7 +318,7 @@ Lemma orb_assoc : forall b1 b2 b3:bool, b1 || (b2 || b3) = b1 || b2 || b3. Proof. destr_bool. Qed. -Hint Resolve orb_comm orb_assoc: bool v62. +Hint Resolve orb_comm orb_assoc: bool. (*******************************) (** * Properties of [andb] *) @@ -392,7 +392,7 @@ Lemma andb_false_elim : Proof. destruct b1; simpl; auto. Defined. -Hint Resolve andb_false_elim: bool v62. +Hint Resolve andb_false_elim: bool. (** Complementation *) @@ -400,7 +400,7 @@ Lemma andb_negb_r : forall b:bool, b && negb b = false. Proof. destr_bool. Qed. -Hint Resolve andb_negb_r: bool v62. +Hint Resolve andb_negb_r: bool. Notation andb_neg_b := andb_negb_r (only parsing). @@ -418,7 +418,7 @@ Proof. destr_bool. Qed. -Hint Resolve andb_comm andb_assoc: bool v62. +Hint Resolve andb_comm andb_assoc: bool. (*******************************************) (** * Properties mixing [andb] and [orb] *) @@ -688,7 +688,7 @@ Lemma andb_prop_intro : Proof. destr_bool; tauto. Qed. -Hint Resolve andb_prop_intro: bool v62. +Hint Resolve andb_prop_intro: bool. Notation andb_true_intro2 := (fun b1 b2 H1 H2 => andb_prop_intro b1 b2 (conj H1 H2)) @@ -699,7 +699,7 @@ Lemma andb_prop_elim : Proof. destr_bool; auto. Qed. -Hint Resolve andb_prop_elim: bool v62. +Hint Resolve andb_prop_elim: bool. Notation andb_prop2 := andb_prop_elim (only parsing). diff --git a/theories/Bool/IfProp.v b/theories/Bool/IfProp.v index 11f3d1d6fe..4257b4bc1a 100644 --- a/theories/Bool/IfProp.v +++ b/theories/Bool/IfProp.v @@ -12,7 +12,7 @@ Inductive IfProp (A B:Prop) : bool -> Prop := | Iftrue : A -> IfProp A B true | Iffalse : B -> IfProp A B false. -Hint Resolve Iftrue Iffalse: bool v62. +Hint Resolve Iftrue Iffalse: bool. Lemma Iftrue_inv : forall (A B:Prop) (b:bool), IfProp A B b -> b = true -> A. destruct 1; intros; auto with bool. diff --git a/theories/Compat/Coq84.v b/theories/Compat/Coq84.v index 5eecdc64cc..a3e23f91c9 100644 --- a/theories/Compat/Coq84.v +++ b/theories/Compat/Coq84.v @@ -74,12 +74,6 @@ Coercion sig_of_sigT : sigT >-> sig. Coercion sigT2_of_sig2 : sig2 >-> sigT2. Coercion sig2_of_sigT2 : sigT2 >-> sig2. -(** As per bug #4733 (https://coq.inria.fr/bugs/show_bug.cgi?id=4733), we want the user to be able to create custom list-like notatoins that work in both 8.4 and 8.5. This is necessary. These should become compat 8.4 notations in the relevant files, but these modify the parser (bug #4798), so this cannot happen until that bug is fixed. *) -Require Coq.Lists.List. -Require Coq.Vectors.VectorDef. -Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..) : list_scope. -Notation "[ x ; .. ; y ]" := (VectorDef.cons _ x _ .. (VectorDef.cons _ y _ (nil _)) ..) : vector_scope. - (** In 8.4, the statement of admitted lemmas did not depend on the section variables. *) Unset Keep Admitted Variables. diff --git a/theories/Compat/Coq85.v b/theories/Compat/Coq85.v index 54aeeaa114..64ba6b1e30 100644 --- a/theories/Compat/Coq85.v +++ b/theories/Compat/Coq85.v @@ -12,6 +12,10 @@ are likely needed to make them behave like Coq 8.5. *) Require Export Coq.Compat.Coq86. +(** We use some deprecated options in this file, so we disable the + corresponding warning, to silence the build of this file. *) +Local Set Warnings "-deprecated-option". + (* In 8.5, "intros [|]", taken e.g. on a goal "A\/B->C", does not behave as "intros [H|H]" but leave instead hypotheses quantified in the goal, here producing subgoals A->C and B->C. *) @@ -23,20 +27,10 @@ Global Unset Shrink Abstract. Global Unset Shrink Obligations. Global Set Refolding Reduction. -(** In Coq 8.5, [] meant Vector, and [ ] meant list. Restore this - behavior, to allow user-defined [] to not override vector - notations. See https://coq.inria.fr/bugs/show_bug.cgi?id=4785. *) +(** The resolution algorithm for type classes has changed. *) +Global Set Typeclasses Legacy Resolution. +Global Set Typeclasses Limit Intros. +Global Unset Typeclasses Filtered Unification. -Require Coq.Lists.List. -Require Coq.Vectors.VectorDef. -Module Export Coq. -Module Export Vectors. -Module VectorDef. -Export Coq.Vectors.VectorDef. -Module VectorNotations. -Export Coq.Vectors.VectorDef.VectorNotations. -Notation "[]" := (VectorDef.nil _) : vector_scope. -End VectorNotations. -End VectorDef. -End Vectors. -End Coq. +(** Allow silently letting unification constraints float after a "." *) +Global Unset Solve Unification Constraints. diff --git a/theories/FSets/FMapList.v b/theories/FSets/FMapList.v index 13cb559b99..5acdb7eb7e 100644 --- a/theories/FSets/FMapList.v +++ b/theories/FSets/FMapList.v @@ -8,7 +8,7 @@ (** * Finite map library *) -(** This file proposes an implementation of the non-dependant interface +(** This file proposes an implementation of the non-dependent interface [FMapInterface.S] using lists of pairs ordered (increasing) with respect to left projection. *) diff --git a/theories/FSets/FMapWeakList.v b/theories/FSets/FMapWeakList.v index 0f11dd7a53..130cbee871 100644 --- a/theories/FSets/FMapWeakList.v +++ b/theories/FSets/FMapWeakList.v @@ -8,7 +8,7 @@ (** * Finite map library *) -(** This file proposes an implementation of the non-dependant interface +(** This file proposes an implementation of the non-dependent interface [FMapInterface.WS] using lists of pairs, unordered but without redundancy. *) Require Import FMapInterface. diff --git a/theories/FSets/FSetDecide.v b/theories/FSets/FSetDecide.v index ad067eb3d8..1db6a71e81 100644 --- a/theories/FSets/FSetDecide.v +++ b/theories/FSets/FSetDecide.v @@ -357,17 +357,8 @@ the above form: | _ => idtac end. - (** [if t then t1 else t2] executes [t] and, if it does not - fail, then [t1] will be applied to all subgoals - produced. If [t] fails, then [t2] is executed. *) - Tactic Notation - "if" tactic(t) - "then" tactic(t1) - "else" tactic(t2) := - first [ t; first [ t1 | fail 2 ] | t2 ]. - Ltac abstract_term t := - if (is_var t) then fail "no need to abstract a variable" + tryif (is_var t) then fail "no need to abstract a variable" else (let x := fresh "x" in set (x := t) in *; try clearbody x). Ltac abstract_elements := @@ -478,11 +469,11 @@ the above form: repeat ( match goal with | H : context [ @Logic.eq ?T ?x ?y ] |- _ => - if (change T with E.t in H) then fail - else if (change T with t in H) then fail + tryif (change T with E.t in H) then fail + else tryif (change T with t in H) then fail else clear H | H : ?P |- _ => - if prop (FSet_Prop P) holds by + tryif prop (FSet_Prop P) holds by (auto 100 with FSet_Prop) then fail else clear H @@ -747,7 +738,7 @@ the above form: | H: (In ?x ?r) -> False |- (E.eq ?y ?x) -> False => contradict H; fsetdec_body | H: ?P -> False |- ?Q -> False => - if prop (FSet_elt_Prop P) holds by + tryif prop (FSet_elt_Prop P) holds by (auto 100 with FSet_Prop) then (contradict H; fsetdec_body) else fsetdec_body diff --git a/theories/FSets/FSetList.v b/theories/FSets/FSetList.v index 1f36306c34..9c3ec71ae3 100644 --- a/theories/FSets/FSetList.v +++ b/theories/FSets/FSetList.v @@ -8,7 +8,7 @@ (** * Finite sets library *) -(** This file proposes an implementation of the non-dependant +(** This file proposes an implementation of the non-dependent interface [FSetInterface.S] using strictly ordered list. *) Require Export FSetInterface. diff --git a/theories/FSets/FSetWeakList.v b/theories/FSets/FSetWeakList.v index 2ea32e97cb..9dbea88495 100644 --- a/theories/FSets/FSetWeakList.v +++ b/theories/FSets/FSetWeakList.v @@ -8,7 +8,7 @@ (** * Finite sets library *) -(** This file proposes an implementation of the non-dependant +(** This file proposes an implementation of the non-dependent interface [FSetInterface.WS] using lists without redundancy. *) Require Import FSetInterface. diff --git a/theories/Init/Logic_Type.v b/theories/Init/Logic_Type.v index 4a5f2ad696..4536dfc0fd 100644 --- a/theories/Init/Logic_Type.v +++ b/theories/Init/Logic_Type.v @@ -64,7 +64,7 @@ Definition identity_rect_r : intros A x P H y H0; case identity_sym with (1 := H0); trivial. Defined. -Hint Immediate identity_sym not_identity_sym: core v62. +Hint Immediate identity_sym not_identity_sym: core. Notation refl_id := identity_refl (compat "8.3"). Notation sym_id := identity_sym (compat "8.3"). diff --git a/theories/Init/Peano.v b/theories/Init/Peano.v index 3749baf61c..6c4a63501d 100644 --- a/theories/Init/Peano.v +++ b/theories/Init/Peano.v @@ -33,7 +33,6 @@ Open Scope nat_scope. Definition eq_S := f_equal S. Definition f_equal_nat := f_equal (A:=nat). -Hint Resolve eq_S: v62. Hint Resolve f_equal_nat: core. (** The predecessor function *) @@ -41,7 +40,6 @@ Hint Resolve f_equal_nat: core. Notation pred := Nat.pred (compat "8.4"). Definition f_equal_pred := f_equal pred. -Hint Resolve f_equal_pred: v62. Theorem pred_Sn : forall n:nat, n = pred (S n). Proof. @@ -85,7 +83,6 @@ Notation plus := Nat.add (compat "8.4"). Infix "+" := Nat.add : nat_scope. Definition f_equal2_plus := f_equal2 plus. -Hint Resolve f_equal2_plus: v62. Definition f_equal2_nat := f_equal2 (A1:=nat) (A2:=nat). Hint Resolve f_equal2_nat: core. diff --git a/theories/Init/Specif.v b/theories/Init/Specif.v index d1038186e3..9fc00e80c1 100644 --- a/theories/Init/Specif.v +++ b/theories/Init/Specif.v @@ -299,7 +299,7 @@ Proof. apply (h2 h1). Defined. -Hint Resolve left right inleft inright: core v62. +Hint Resolve left right inleft inright: core. Hint Resolve exist exist2 existT existT2: core. (* Compatibility *) diff --git a/theories/Lists/List.v b/theories/Lists/List.v index fc94d7e254..30f1dec22c 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -27,6 +27,7 @@ Module ListNotations. Notation "[ ]" := nil (format "[ ]") : list_scope. Notation "[ x ]" := (cons x nil) : list_scope. Notation "[ x ; y ; .. ; z ]" := (cons x (cons y .. (cons z nil) ..)) : list_scope. +Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..) (compat "8.4") : list_scope. End ListNotations. Import ListNotations. @@ -339,11 +340,11 @@ Section Facts. End Facts. -Hint Resolve app_assoc app_assoc_reverse: datatypes v62. -Hint Resolve app_comm_cons app_cons_not_nil: datatypes v62. -Hint Immediate app_eq_nil: datatypes v62. -Hint Resolve app_eq_unit app_inj_tail: datatypes v62. -Hint Resolve in_eq in_cons in_inv in_nil in_app_or in_or_app: datatypes v62. +Hint Resolve app_assoc app_assoc_reverse: datatypes. +Hint Resolve app_comm_cons app_cons_not_nil: datatypes. +Hint Immediate app_eq_nil: datatypes. +Hint Resolve app_eq_unit app_inj_tail: datatypes. +Hint Resolve in_eq in_cons in_inv in_nil in_app_or in_or_app: datatypes. @@ -1543,7 +1544,7 @@ Section length_order. End length_order. Hint Resolve lel_refl lel_cons_cons lel_cons lel_nil lel_nil nil_cons: - datatypes v62. + datatypes. (******************************) @@ -1612,7 +1613,7 @@ Section SetIncl. End SetIncl. Hint Resolve incl_refl incl_tl incl_tran incl_appl incl_appr incl_cons - incl_app: datatypes v62. + incl_app: datatypes. (**************************************) @@ -2364,7 +2365,7 @@ Notation rev_acc := rev_append (only parsing). Notation rev_acc_rev := rev_append_rev (only parsing). Notation AllS := Forall (only parsing). (* was formerly in TheoryList *) -Hint Resolve app_nil_end : datatypes v62. +Hint Resolve app_nil_end : datatypes. (* end hide *) Section Repeat. diff --git a/theories/Lists/Streams.v b/theories/Lists/Streams.v index 7ec3d2503f..1c302b22f4 100644 --- a/theories/Lists/Streams.v +++ b/theories/Lists/Streams.v @@ -51,7 +51,7 @@ Lemma tl_nth_tl : Proof. simple induction n; simpl; auto. Qed. -Hint Resolve tl_nth_tl: datatypes v62. +Hint Resolve tl_nth_tl: datatypes. Lemma Str_nth_tl_plus : forall (n m:nat) (s:Stream), diff --git a/theories/Logic/Eqdep.v b/theories/Logic/Eqdep.v index f3a2783e1b..5ef86b8e77 100644 --- a/theories/Logic/Eqdep.v +++ b/theories/Logic/Eqdep.v @@ -33,5 +33,5 @@ Export EqdepTheory. (** Exported hints *) -Hint Resolve eq_dep_eq: eqdep v62. +Hint Resolve eq_dep_eq: eqdep. Hint Resolve inj_pair2 inj_pairT2: eqdep. diff --git a/theories/MSets/MSetDecide.v b/theories/MSets/MSetDecide.v index f2555791b2..9c622fd786 100644 --- a/theories/MSets/MSetDecide.v +++ b/theories/MSets/MSetDecide.v @@ -357,17 +357,8 @@ the above form: | _ => idtac end. - (** [if t then t1 else t2] executes [t] and, if it does not - fail, then [t1] will be applied to all subgoals - produced. If [t] fails, then [t2] is executed. *) - Tactic Notation - "if" tactic(t) - "then" tactic(t1) - "else" tactic(t2) := - first [ t; first [ t1 | fail 2 ] | t2 ]. - Ltac abstract_term t := - if (is_var t) then fail "no need to abstract a variable" + tryif (is_var t) then fail "no need to abstract a variable" else (let x := fresh "x" in set (x := t) in *; try clearbody x). Ltac abstract_elements := @@ -478,11 +469,11 @@ the above form: repeat ( match goal with | H : context [ @Logic.eq ?T ?x ?y ] |- _ => - if (change T with E.t in H) then fail - else if (change T with t in H) then fail + tryif (change T with E.t in H) then fail + else tryif (change T with t in H) then fail else clear H | H : ?P |- _ => - if prop (MSet_Prop P) holds by + tryif prop (MSet_Prop P) holds by (auto 100 with MSet_Prop) then fail else clear H @@ -747,7 +738,7 @@ the above form: | H: (In ?x ?r) -> False |- (E.eq ?y ?x) -> False => contradict H; fsetdec_body | H: ?P -> False |- ?Q -> False => - if prop (MSet_elt_Prop P) holds by + tryif prop (MSet_elt_Prop P) holds by (auto 100 with MSet_Prop) then (contradict H; fsetdec_body) else fsetdec_body diff --git a/theories/MSets/MSetList.v b/theories/MSets/MSetList.v index fb0d1ad9df..05c20eb8fa 100644 --- a/theories/MSets/MSetList.v +++ b/theories/MSets/MSetList.v @@ -8,7 +8,7 @@ (** * Finite sets library *) -(** This file proposes an implementation of the non-dependant +(** This file proposes an implementation of the non-dependent interface [MSetInterface.S] using strictly ordered list. *) Require Export MSetInterface OrdersFacts OrdersLists. diff --git a/theories/MSets/MSetWeakList.v b/theories/MSets/MSetWeakList.v index 372acd56ad..2ac57a932b 100644 --- a/theories/MSets/MSetWeakList.v +++ b/theories/MSets/MSetWeakList.v @@ -8,7 +8,7 @@ (** * Finite sets library *) -(** This file proposes an implementation of the non-dependant +(** This file proposes an implementation of the non-dependent interface [MSetWeakInterface.S] using lists without redundancy. *) Require Import MSetInterface. diff --git a/theories/Numbers/BigNumPrelude.v b/theories/Numbers/BigNumPrelude.v index 45a7527c97..bd8930872c 100644 --- a/theories/Numbers/BigNumPrelude.v +++ b/theories/Numbers/BigNumPrelude.v @@ -10,7 +10,7 @@ (** * BigNumPrelude *) -(** Auxillary functions & theorems used for arbitrary precision efficient +(** Auxiliary functions & theorems used for arbitrary precision efficient numbers. *) @@ -22,7 +22,7 @@ Require Export Zpow_facts. Declare ML Module "numbers_syntax_plugin". (* *** Nota Bene *** - All results that were general enough has been moved in ZArith. + All results that were general enough have been moved in ZArith. Only remain here specialized lemmas and compatibility elements. (P.L. 5/11/2007). *) diff --git a/theories/Reals/RIneq.v b/theories/Reals/RIneq.v index f26bac2bb4..379fee6f49 100644 --- a/theories/Reals/RIneq.v +++ b/theories/Reals/RIneq.v @@ -389,7 +389,7 @@ Lemma Rplus_ne : forall r, r + 0 = r /\ 0 + r = r. Proof. split; ring. Qed. -Hint Resolve Rplus_ne: real v62. +Hint Resolve Rplus_ne: real. (**********) @@ -425,7 +425,6 @@ Proof. apply (f_equal (fun v => v + r)). Qed. -(*i Old i*)Hint Resolve Rplus_eq_compat_l: v62. (**********) Lemma Rplus_eq_reg_l : forall r r1 r2, r + r1 = r + r2 -> r1 = r2. @@ -501,21 +500,21 @@ Lemma Rmult_0_r : forall r, r * 0 = 0. Proof. intro; ring. Qed. -Hint Resolve Rmult_0_r: real v62. +Hint Resolve Rmult_0_r: real. (**********) Lemma Rmult_0_l : forall r, 0 * r = 0. Proof. intro; ring. Qed. -Hint Resolve Rmult_0_l: real v62. +Hint Resolve Rmult_0_l: real. (**********) Lemma Rmult_ne : forall r, r * 1 = r /\ 1 * r = r. Proof. intro; split; ring. Qed. -Hint Resolve Rmult_ne: real v62. +Hint Resolve Rmult_ne: real. (**********) Lemma Rmult_1_r : forall r, r * 1 = r. @@ -530,7 +529,6 @@ Proof. auto with real. Qed. -(*i Old i*)Hint Resolve Rmult_eq_compat_l: v62. Lemma Rmult_eq_compat_r : forall r r1 r2, r1 = r2 -> r1 * r = r2 * r. Proof. @@ -646,7 +644,7 @@ Lemma Ropp_0 : -0 = 0. Proof. ring. Qed. -Hint Resolve Ropp_0: real v62. +Hint Resolve Ropp_0: real. (**********) Lemma Ropp_eq_0_compat : forall r, r = 0 -> - r = 0. diff --git a/theories/Reals/Raxioms.v b/theories/Reals/Raxioms.v index 9d55e4e639..9fbda92a2f 100644 --- a/theories/Reals/Raxioms.v +++ b/theories/Reals/Raxioms.v @@ -32,7 +32,7 @@ Hint Resolve Rplus_assoc: real. (**********) Axiom Rplus_opp_r : forall r:R, r + - r = 0. -Hint Resolve Rplus_opp_r: real v62. +Hint Resolve Rplus_opp_r: real. (**********) Axiom Rplus_0_l : forall r:R, 0 + r = r. @@ -44,11 +44,11 @@ Hint Resolve Rplus_0_l: real. (**********) Axiom Rmult_comm : forall r1 r2:R, r1 * r2 = r2 * r1. -Hint Resolve Rmult_comm: real v62. +Hint Resolve Rmult_comm: real. (**********) Axiom Rmult_assoc : forall r1 r2 r3:R, r1 * r2 * r3 = r1 * (r2 * r3). -Hint Resolve Rmult_assoc: real v62. +Hint Resolve Rmult_assoc: real. (**********) Axiom Rinv_l : forall r:R, r <> 0 -> / r * r = 1. @@ -69,7 +69,7 @@ Hint Resolve R1_neq_R0: real. (**********) Axiom Rmult_plus_distr_l : forall r1 r2 r3:R, r1 * (r2 + r3) = r1 * r2 + r1 * r3. -Hint Resolve Rmult_plus_distr_l: real v62. +Hint Resolve Rmult_plus_distr_l: real. (*********************************************************) (** * Order axioms *) diff --git a/theories/Relations/Relation_Definitions.v b/theories/Relations/Relation_Definitions.v index b6005b9d11..9c98879cea 100644 --- a/theories/Relations/Relation_Definitions.v +++ b/theories/Relations/Relation_Definitions.v @@ -66,10 +66,10 @@ Section Relation_Definition. End Relation_Definition. -Hint Unfold reflexive transitive antisymmetric symmetric: sets v62. +Hint Unfold reflexive transitive antisymmetric symmetric: sets. Hint Resolve Build_preorder Build_order Build_equivalence Build_PER preord_refl preord_trans ord_refl ord_trans ord_antisym equiv_refl - equiv_trans equiv_sym per_sym per_trans: sets v62. + equiv_trans equiv_sym per_sym per_trans: sets. -Hint Unfold inclusion same_relation commut: sets v62. +Hint Unfold inclusion same_relation commut: sets. diff --git a/theories/Relations/Relation_Operators.v b/theories/Relations/Relation_Operators.v index ffd682d62c..88239475c3 100644 --- a/theories/Relations/Relation_Operators.v +++ b/theories/Relations/Relation_Operators.v @@ -226,9 +226,9 @@ Section Lexicographic_Exponentiation. End Lexicographic_Exponentiation. -Hint Unfold transp union: sets v62. -Hint Resolve t_step rt_step rt_refl rst_step rst_refl: sets v62. -Hint Immediate rst_sym: sets v62. +Hint Unfold transp union: sets. +Hint Resolve t_step rt_step rt_refl rst_step rst_refl: sets. +Hint Immediate rst_sym: sets. (* begin hide *) (* Compatibility *) diff --git a/theories/Sets/Classical_sets.v b/theories/Sets/Classical_sets.v index 8a4bb9f424..837437a227 100644 --- a/theories/Sets/Classical_sets.v +++ b/theories/Sets/Classical_sets.v @@ -122,4 +122,4 @@ Section Ensembles_classical. End Ensembles_classical. Hint Resolve Strict_super_set_contains_new_element Subtract_intro - not_SIncl_empty: sets v62. + not_SIncl_empty: sets. diff --git a/theories/Sets/Constructive_sets.v b/theories/Sets/Constructive_sets.v index 8d2344f931..6291248eb5 100644 --- a/theories/Sets/Constructive_sets.v +++ b/theories/Sets/Constructive_sets.v @@ -141,4 +141,4 @@ End Ensembles_facts. Hint Resolve Singleton_inv Singleton_intro Add_intro1 Add_intro2 Intersection_inv Couple_inv Setminus_intro Strict_Included_intro Strict_Included_strict Noone_in_empty Inhabited_not_empty Add_not_Empty - not_Empty_Add Inhabited_add Included_Empty: sets v62. + not_Empty_Add Inhabited_add Included_Empty: sets. diff --git a/theories/Sets/Ensembles.v b/theories/Sets/Ensembles.v index 8f579214ad..0fefb354b2 100644 --- a/theories/Sets/Ensembles.v +++ b/theories/Sets/Ensembles.v @@ -90,9 +90,8 @@ Section Ensembles. End Ensembles. -Hint Unfold In Included Same_set Strict_Included Add Setminus Subtract: sets - v62. +Hint Unfold In Included Same_set Strict_Included Add Setminus Subtract: sets. Hint Resolve Union_introl Union_intror Intersection_intro In_singleton Couple_l Couple_r Triple_l Triple_m Triple_r Disjoint_intro - Extensionality_Ensembles: sets v62. + Extensionality_Ensembles: sets. diff --git a/theories/Sets/Finite_sets.v b/theories/Sets/Finite_sets.v index f38dd6fdf7..edbc1efec0 100644 --- a/theories/Sets/Finite_sets.v +++ b/theories/Sets/Finite_sets.v @@ -43,8 +43,8 @@ Section Ensembles_finis. End Ensembles_finis. -Hint Resolve Empty_is_finite Union_is_finite: sets v62. -Hint Resolve card_empty card_add: sets v62. +Hint Resolve Empty_is_finite Union_is_finite: sets. +Hint Resolve card_empty card_add: sets. Require Import Constructive_sets. diff --git a/theories/Sets/Image.v b/theories/Sets/Image.v index 34ea857d17..e74ef41e4b 100644 --- a/theories/Sets/Image.v +++ b/theories/Sets/Image.v @@ -200,4 +200,4 @@ Section Image. End Image. -Hint Resolve Im_def image_empty finite_image: sets v62. +Hint Resolve Im_def image_empty finite_image: sets. diff --git a/theories/Sets/Multiset.v b/theories/Sets/Multiset.v index ec38b8923f..42d0c76dcc 100644 --- a/theories/Sets/Multiset.v +++ b/theories/Sets/Multiset.v @@ -187,7 +187,7 @@ End multiset_defs. Unset Implicit Arguments. -Hint Unfold meq multiplicity: v62 datatypes. +Hint Unfold meq multiplicity: datatypes. Hint Resolve munion_empty_right munion_comm munion_ass meq_left meq_right - munion_empty_left: v62 datatypes. -Hint Immediate meq_sym: v62 datatypes. + munion_empty_left: datatypes. +Hint Immediate meq_sym: datatypes. diff --git a/theories/Sets/Partial_Order.v b/theories/Sets/Partial_Order.v index 3610ebce6e..335fec5b09 100644 --- a/theories/Sets/Partial_Order.v +++ b/theories/Sets/Partial_Order.v @@ -51,8 +51,8 @@ Section Partial_orders. End Partial_orders. -Hint Unfold Carrier_of Rel_of Strict_Rel_of: sets v62. -Hint Resolve Definition_of_covers: sets v62. +Hint Unfold Carrier_of Rel_of Strict_Rel_of: sets. +Hint Resolve Definition_of_covers: sets. Section Partial_order_facts. diff --git a/theories/Sets/Powerset.v b/theories/Sets/Powerset.v index d636e0468a..7c2435da04 100644 --- a/theories/Sets/Powerset.v +++ b/theories/Sets/Powerset.v @@ -175,14 +175,14 @@ Qed. End The_power_set_partial_order. -Hint Resolve Empty_set_minimal: sets v62. -Hint Resolve Power_set_Inhabited: sets v62. -Hint Resolve Inclusion_is_an_order: sets v62. -Hint Resolve Inclusion_is_transitive: sets v62. -Hint Resolve Union_minimal: sets v62. -Hint Resolve Union_increases_l: sets v62. -Hint Resolve Union_increases_r: sets v62. -Hint Resolve Intersection_decreases_l: sets v62. -Hint Resolve Intersection_decreases_r: sets v62. -Hint Resolve Empty_set_is_Bottom: sets v62. -Hint Resolve Strict_inclusion_is_transitive: sets v62. +Hint Resolve Empty_set_minimal: sets. +Hint Resolve Power_set_Inhabited: sets. +Hint Resolve Inclusion_is_an_order: sets. +Hint Resolve Inclusion_is_transitive: sets. +Hint Resolve Union_minimal: sets. +Hint Resolve Union_increases_l: sets. +Hint Resolve Union_increases_r: sets. +Hint Resolve Intersection_decreases_l: sets. +Hint Resolve Intersection_decreases_r: sets. +Hint Resolve Empty_set_is_Bottom: sets. +Hint Resolve Strict_inclusion_is_transitive: sets. diff --git a/theories/Sets/Powerset_Classical_facts.v b/theories/Sets/Powerset_Classical_facts.v index 09c90506bc..e802beac9a 100644 --- a/theories/Sets/Powerset_Classical_facts.v +++ b/theories/Sets/Powerset_Classical_facts.v @@ -90,7 +90,7 @@ Section Sets_as_an_algebra. apply Subtract_intro; auto with sets. red; intro H'1; apply H'; rewrite H'1; auto with sets. Qed. - Hint Resolve incl_soustr_add_r: sets v62. + Hint Resolve incl_soustr_add_r: sets. Lemma add_soustr_2 : forall (X:Ensemble U) (x:U), @@ -328,9 +328,9 @@ Section Sets_as_an_algebra. End Sets_as_an_algebra. -Hint Resolve incl_soustr_in: sets v62. -Hint Resolve incl_soustr: sets v62. -Hint Resolve incl_soustr_add_l: sets v62. -Hint Resolve incl_soustr_add_r: sets v62. -Hint Resolve add_soustr_1 add_soustr_2: sets v62. -Hint Resolve add_soustr_xy: sets v62. +Hint Resolve incl_soustr_in: sets. +Hint Resolve incl_soustr: sets. +Hint Resolve incl_soustr_add_l: sets. +Hint Resolve incl_soustr_add_r: sets. +Hint Resolve add_soustr_1 add_soustr_2: sets. +Hint Resolve add_soustr_xy: sets. diff --git a/theories/Sets/Powerset_facts.v b/theories/Sets/Powerset_facts.v index 63e84199d6..e9696a1cad 100644 --- a/theories/Sets/Powerset_facts.v +++ b/theories/Sets/Powerset_facts.v @@ -254,5 +254,5 @@ Section Sets_as_an_algebra. End Sets_as_an_algebra. Hint Resolve Empty_set_zero Empty_set_zero' Union_associative Union_add - singlx incl_add: sets v62. + singlx incl_add: sets. diff --git a/theories/Sets/Relations_1.v b/theories/Sets/Relations_1.v index de96fa560e..45fb8134c8 100644 --- a/theories/Sets/Relations_1.v +++ b/theories/Sets/Relations_1.v @@ -60,6 +60,6 @@ Section Relations_1. End Relations_1. Hint Unfold Reflexive Transitive Antisymmetric Symmetric contains - same_relation: sets v62. + same_relation: sets. Hint Resolve Definition_of_preorder Definition_of_order - Definition_of_equivalence Definition_of_PER: sets v62. + Definition_of_equivalence Definition_of_PER: sets. diff --git a/theories/Sets/Relations_2.v b/theories/Sets/Relations_2.v index f1026e31a1..1e0b83fe51 100644 --- a/theories/Sets/Relations_2.v +++ b/theories/Sets/Relations_2.v @@ -48,7 +48,7 @@ Definition Strongly_confluent : Prop := End Relations_2. -Hint Resolve Rstar_0: sets v62. -Hint Resolve Rstar1_0: sets v62. -Hint Resolve Rstar1_1: sets v62. -Hint Resolve Rplus_0: sets v62. +Hint Resolve Rstar_0: sets. +Hint Resolve Rstar1_0: sets. +Hint Resolve Rstar1_1: sets. +Hint Resolve Rplus_0: sets. diff --git a/theories/Sets/Relations_3.v b/theories/Sets/Relations_3.v index 92b2998855..c05b5ee76a 100644 --- a/theories/Sets/Relations_3.v +++ b/theories/Sets/Relations_3.v @@ -51,10 +51,10 @@ Section Relations_3. Definition Noetherian : Prop := forall x:U, noetherian x. End Relations_3. -Hint Unfold coherent: sets v62. -Hint Unfold locally_confluent: sets v62. -Hint Unfold confluent: sets v62. -Hint Unfold Confluent: sets v62. -Hint Resolve definition_of_noetherian: sets v62. -Hint Unfold Noetherian: sets v62. +Hint Unfold coherent: sets. +Hint Unfold locally_confluent: sets. +Hint Unfold confluent: sets. +Hint Unfold Confluent: sets. +Hint Resolve definition_of_noetherian: sets. +Hint Unfold Noetherian: sets. diff --git a/theories/Strings/Ascii.v b/theories/Strings/Ascii.v index 97cb746f37..55a533c55a 100644 --- a/theories/Strings/Ascii.v +++ b/theories/Strings/Ascii.v @@ -40,7 +40,7 @@ Defined. (** * Conversion between natural numbers modulo 256 and ascii characters *) -(** Auxillary function that turns a positive into an ascii by +(** Auxiliary function that turns a positive into an ascii by looking at the last 8 bits, ie z mod 2^8 *) Definition ascii_of_pos : positive -> ascii := diff --git a/theories/Structures/OrdersFacts.v b/theories/Structures/OrdersFacts.v index 6f8fc1b324..0115d8a544 100644 --- a/theories/Structures/OrdersFacts.v +++ b/theories/Structures/OrdersFacts.v @@ -434,14 +434,14 @@ Lemma eqb_compare x y : (x =? y) = match compare x y with Eq => true | _ => false end. Proof. apply eq_true_iff_eq. rewrite eqb_eq, <- compare_eq_iff. -destruct compare; now split. +now destruct compare. Qed. Lemma ltb_compare x y : (x <? y) = match compare x y with Lt => true | _ => false end. Proof. apply eq_true_iff_eq. rewrite ltb_lt, <- compare_lt_iff. -destruct compare; now split. +now destruct compare. Qed. Lemma leb_compare x y : diff --git a/theories/Vectors/VectorDef.v b/theories/Vectors/VectorDef.v index f49b340758..1f8b76cb62 100644 --- a/theories/Vectors/VectorDef.v +++ b/theories/Vectors/VectorDef.v @@ -295,11 +295,12 @@ End VECTORLIST. Module VectorNotations. Delimit Scope vector_scope with vector. Notation "[ ]" := [] (format "[ ]") : vector_scope. +Notation "[]" := [] (compat "8.5") : vector_scope. Notation "h :: t" := (h :: t) (at level 60, right associativity) : vector_scope. Notation "[ x ]" := (x :: []) : vector_scope. -Notation "[ x ; y ; .. ; z ]" := (cons _ x _ (cons _ y _ .. (cons _ z _ (nil _)) ..)) : vector_scope -. +Notation "[ x ; y ; .. ; z ]" := (cons _ x _ (cons _ y _ .. (cons _ z _ (nil _)) ..)) : vector_scope. +Notation "[ x ; .. ; y ]" := (cons _ x _ .. (cons _ y _ (nil _)) ..) (compat "8.4") : vector_scope. Notation "v [@ p ]" := (nth v p) (at level 1, format "v [@ p ]") : vector_scope. Open Scope vector_scope. End VectorNotations. diff --git a/theories/ZArith/Zwf.v b/theories/ZArith/Zwf.v index 1ac00bddd0..90754af3b4 100644 --- a/theories/ZArith/Zwf.v +++ b/theories/ZArith/Zwf.v @@ -56,7 +56,7 @@ Section wf_proof. End wf_proof. -Hint Resolve Zwf_well_founded: datatypes v62. +Hint Resolve Zwf_well_founded: datatypes. (** We also define the other family of relations: @@ -88,4 +88,4 @@ Section wf_proof_up. End wf_proof_up. -Hint Resolve Zwf_up_well_founded: datatypes v62. +Hint Resolve Zwf_up_well_founded: datatypes. diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index ac69a69a4a..b7dd5f2a14 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -390,7 +390,7 @@ let clean sds sps = let () = if !some_vfile then let () = print "cleanall:: clean\n" in - print "\trm -f $(patsubst %.v,.%.aux,$(VFILES))\n\n" in + print "\trm -f $(foreach f,$(VFILES:.v=),$(dir $(f)).$(notdir $(f)).aux)\n\n" in print "archclean::\n"; print "\trm -f *.cmx *.o\n"; List.iter @@ -887,7 +887,7 @@ let merlin targets (ml_inc,_,_) = print ".merlin:\n"; print "\t@echo 'FLG -rectypes' > .merlin\n" ; List.iter (fun c -> - printf "\t@echo \"B $(COQLIB) %s\" >> .merlin\n" c) + printf "\t@echo \"B $(COQLIB)%s\" >> .merlin\n" c) lib_dirs ; List.iter (fun (_,c) -> printf "\t@echo \"B %s\" >> .merlin\n" c; diff --git a/tools/coqc.ml b/tools/coqc.ml index ecbbfefac6..b12d48710f 100644 --- a/tools/coqc.ml +++ b/tools/coqc.ml @@ -94,7 +94,6 @@ let parse_args () = |"-silent"|"-m"|"-xml"|"-v7"|"-v8"|"-beautify"|"-strict-implicit" |"-dont-load-proofs"|"-load-proofs"|"-force-load-proofs" |"-impredicative-set"|"-vm"|"-native-compiler" - |"-verbose-compat-notations"|"-no-compat-notations" |"-indices-matter"|"-quick"|"-type-in-type" |"-async-proofs-always-delegate"|"-async-proofs-never-reopen-branch" as o) :: rem -> @@ -107,7 +106,7 @@ let parse_args () = |"-load-ml-source"|"-require"|"-load-ml-object" |"-init-file"|"-dump-glob"|"-compat"|"-coqlib"|"-top" |"-async-proofs-j" |"-async-proofs-private-flags" |"-async-proofs" |"-w" - |"-o" + |"-o"|"-profile-ltac-cutoff" as o) :: rem -> begin match rem with diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml index cc63c13d7b..0064aebdae 100644 --- a/tools/coqdep_common.ml +++ b/tools/coqdep_common.ml @@ -526,7 +526,6 @@ let rec add_directory recur add_file phys_dir log_dir = | FileRegular f -> add_file phys_dir log_dir f in - check_unix_dir (fun s -> eprintf "*** Warning: %s\n" s) phys_dir; if exists_dir phys_dir then process_directory f phys_dir else diff --git a/tools/gallina-db.el b/tools/gallina-db.el index baabebb13a..9664f69f8b 100644 --- a/tools/gallina-db.el +++ b/tools/gallina-db.el @@ -163,7 +163,7 @@ for DB structure." (defun coq-sort-menu-entries (menu) (sort menu - '(lambda (x y) (string< + (lambda (x y) (string< (downcase (elt x 0)) (downcase (elt y 0)))))) diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml index 180b836ea5..c8adf9465e 100644 --- a/toplevel/auto_ind_decl.ml +++ b/toplevel/auto_ind_decl.ml @@ -54,9 +54,10 @@ exception EqUnknown of string exception UndefinedCst of string exception InductiveWithProduct exception InductiveWithSort -exception ParameterWithoutEquality of constant +exception ParameterWithoutEquality of global_reference exception NonSingletonProp of inductive exception DecidabilityMutualNotSupported +exception NoDecidabilityCoInductive let dl = Loc.ghost @@ -181,7 +182,13 @@ let build_beq_scheme mode kn = let (c,a) = Reductionops.whd_betaiota_stack Evd.empty c in match kind_of_term c with | Rel x -> mkRel (x-nlist+ndx), Safe_typing.empty_private_constants - | Var x -> mkVar (id_of_string ("eq_"^(string_of_id x))), Safe_typing.empty_private_constants + | Var x -> + let eid = id_of_string ("eq_"^(string_of_id x)) in + let () = + try ignore (Environ.lookup_named eid env) + with Not_found -> raise (ParameterWithoutEquality (VarRef x)) + in + mkVar eid, Safe_typing.empty_private_constants | Cast (x,_,_) -> aux (applist (x,a)) | App _ -> assert false | Ind ((kn',i as ind'),u) (*FIXME: universes *) -> @@ -205,19 +212,19 @@ let build_beq_scheme mode kn = end | Sort _ -> raise InductiveWithSort | Prod _ -> raise InductiveWithProduct - | Lambda _-> raise (EqUnknown "Lambda") - | LetIn _ -> raise (EqUnknown "LetIn") + | Lambda _-> raise (EqUnknown "abstraction") + | LetIn _ -> raise (EqUnknown "let-in") | Const kn -> (match Environ.constant_opt_value_in env kn with - | None -> raise (ParameterWithoutEquality (fst kn)) + | None -> raise (ParameterWithoutEquality (ConstRef (fst kn))) | Some c -> aux (applist (c,a))) - | Proj _ -> raise (EqUnknown "Proj") - | Construct _ -> raise (EqUnknown "Construct") - | Case _ -> raise (EqUnknown "Case") - | CoFix _ -> raise (EqUnknown "CoFix") - | Fix _ -> raise (EqUnknown "Fix") - | Meta _ -> raise (EqUnknown "Meta") - | Evar _ -> raise (EqUnknown "Evar") + | Proj _ -> raise (EqUnknown "projection") + | Construct _ -> raise (EqUnknown "constructor") + | Case _ -> raise (EqUnknown "match") + | CoFix _ -> raise (EqUnknown "cofix") + | Fix _ -> raise (EqUnknown "fix") + | Meta _ -> raise (EqUnknown "meta-variable") + | Evar _ -> raise (EqUnknown "existential variable") in aux t in @@ -302,6 +309,8 @@ let build_beq_scheme mode kn = let kelim = Inductive.elim_sorts (mib,mib.mind_packets.(i)) in if not (Sorts.List.mem InSet kelim) then raise (NonSingletonProp (kn,i)); + if mib.mind_finite = Decl_kinds.CoFinite then + raise NoDecidabilityCoInductive; let fix = mkFix (((Array.make nb_ind 0),i),(names,types,cores)) in create_input fix), Evd.make_evar_universe_context (Global.env ()) None), diff --git a/toplevel/auto_ind_decl.mli b/toplevel/auto_ind_decl.mli index b6c66a1e84..60232ba8f4 100644 --- a/toplevel/auto_ind_decl.mli +++ b/toplevel/auto_ind_decl.mli @@ -21,9 +21,10 @@ exception EqUnknown of string exception UndefinedCst of string exception InductiveWithProduct exception InductiveWithSort -exception ParameterWithoutEquality of constant +exception ParameterWithoutEquality of Globnames.global_reference exception NonSingletonProp of inductive exception DecidabilityMutualNotSupported +exception NoDecidabilityCoInductive val beq_scheme_kind : mutual scheme_kind val build_beq_scheme : mutual_scheme_object_function diff --git a/toplevel/classes.ml b/toplevel/classes.ml index d6a6162f9f..1528cbb2f6 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -46,25 +46,34 @@ let set_typeclass_transparency c local b = let _ = Hook.set Typeclasses.add_instance_hint_hook - (fun inst path local pri poly -> + (fun inst path local info poly -> let inst' = match inst with IsConstr c -> Hints.IsConstr (c, Univ.ContextSet.empty) | IsGlobal gr -> Hints.IsGlobRef gr in - Flags.silently (fun () -> + let info = + let open Vernacexpr in + { info with hint_pattern = + Option.map + (Constrintern.intern_constr_pattern (Global.env())) + info.hint_pattern } in + Flags.silently (fun () -> Hints.add_hints local [typeclasses_db] (Hints.HintsResolveEntry - [pri, poly, false, Hints.PathHints path, inst'])) ()); + [info, poly, false, Hints.PathHints path, inst'])) ()); Hook.set Typeclasses.set_typeclass_transparency_hook set_typeclass_transparency; Hook.set Typeclasses.classes_transparent_state_hook (fun () -> Hints.Hint_db.transparent_state (Hints.searchtable_map typeclasses_db)) - + +open Vernacexpr + (** TODO: add subinstances *) -let existing_instance glob g pri = +let existing_instance glob g info = let c = global g in + let info = Option.default Hints.empty_hint_info info in let instance = Global.type_of_global_unsafe c in let _, r = decompose_prod_assum instance in match class_of_constr r with - | Some (_, ((tc,u), _)) -> add_instance (new_instance tc pri glob + | Some (_, ((tc,u), _)) -> add_instance (new_instance tc info glob (*FIXME*) (Flags.use_polymorphic_flag ()) c) | None -> user_err_loc (loc_of_reference g, "declare_instance", Pp.str "Constant does not build instances of a declared type class.") @@ -98,12 +107,12 @@ let id_of_class cl = open Pp -let instance_hook k pri global imps ?hook cst = +let instance_hook k info global imps ?hook cst = Impargs.maybe_declare_manual_implicits false cst ~enriching:false imps; - Typeclasses.declare_instance pri (not global) cst; + Typeclasses.declare_instance (Some info) (not global) cst; (match hook with Some h -> h cst | None -> ()) -let declare_instance_constant k pri global imps ?hook id pl poly evm term termtype = +let declare_instance_constant k info global imps ?hook id pl poly evm term termtype = let kind = IsDefinition Instance in let evm = let levels = Univ.LSet.union (Universes.universes_of_constr termtype) @@ -118,7 +127,7 @@ let declare_instance_constant k pri global imps ?hook id pl poly evm term termty let kn = Declare.declare_constant id cdecl in Declare.definition_message id; Universes.register_universe_binders (ConstRef kn) pl; - instance_hook k pri global imps ?hook (ConstRef kn); + instance_hook k info global imps ?hook (ConstRef kn); id let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) poly ctx (instid, bk, cl) props @@ -130,7 +139,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) p let evars = ref (Evd.from_ctx uctx) in let tclass, ids = match bk with - | Implicit -> + | Decl_kinds.Implicit -> Implicit_quantifiers.implicit_application Id.Set.empty ~allow_partial:false (fun avoid (clname, _) -> match clname with @@ -299,7 +308,7 @@ let new_instance ?(abstract=false) ?(global=false) ?(refine= !refine_instance) p let hook vis gr _ = let cst = match gr with ConstRef kn -> kn | _ -> assert false in Impargs.declare_manual_implicits false gr ~enriching:false [imps]; - Typeclasses.declare_instance pri (not global) (ConstRef cst) + Typeclasses.declare_instance (Some pri) (not global) (ConstRef cst) in let obls, constr, typ = match term with @@ -378,7 +387,7 @@ let context poly l = let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id decl in match class_of_constr t with | Some (rels, ((tc,_), args) as _cl) -> - add_instance (Typeclasses.new_instance tc None false (*FIXME*) + add_instance (Typeclasses.new_instance tc Hints.empty_hint_info false (*FIXME*) poly (ConstRef cst)); status (* declare_subclasses (ConstRef cst) cl *) diff --git a/toplevel/classes.mli b/toplevel/classes.mli index 7beb873e63..d2cb788eae 100644 --- a/toplevel/classes.mli +++ b/toplevel/classes.mli @@ -20,12 +20,12 @@ val mismatched_props : env -> constr_expr list -> Context.Rel.t -> 'a (** Instance declaration *) -val existing_instance : bool -> reference -> int option -> unit -(** globality, reference, priority *) +val existing_instance : bool -> reference -> Vernacexpr.hint_info_expr option -> unit +(** globality, reference, optional priority and pattern information *) val declare_instance_constant : typeclass -> - int option -> (** priority *) + Vernacexpr.hint_info_expr -> (** priority *) bool -> (** globality *) Impargs.manual_explicitation list -> (** implicits *) ?hook:(Globnames.global_reference -> unit) -> @@ -48,7 +48,7 @@ val new_instance : ?generalize:bool -> ?tac:unit Proofview.tactic -> ?hook:(Globnames.global_reference -> unit) -> - int option -> + Vernacexpr.hint_info_expr -> Id.t (** Setting opacity *) diff --git a/toplevel/command.ml b/toplevel/command.ml index 12c387dcf3..a9f2598e22 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -261,10 +261,7 @@ match local with let interp_assumption evdref env impls bl c = let c = prod_constr_expr c bl in - let ty, impls = interp_type_evars_impls env evdref ~impls c in - let evd, nf = nf_evars_and_universes !evdref in - let ctx = Evd.universe_context_set evd in - ((nf ty, ctx), impls) + interp_type_evars_impls env evdref ~impls c let declare_assumptions idl is_coe k (c,ctx) pl imps impl_is_on nl = let refs, status, _ = @@ -289,26 +286,32 @@ let do_assumptions_unbound_univs (_, poly, _ as kind) nl l = l [] else l in + (* We intepret all declarations in the same evar_map, i.e. as a telescope. *) let _,l = List.fold_map (fun (env,ienv) (is_coe,(idl,c)) -> - let (t,ctx),imps = interp_assumption evdref env ienv [] c in + let t,imps = interp_assumption evdref env ienv [] c in let env = push_named_context (List.map (fun (_,id) -> LocalAssum (id,t)) idl) env in let ienv = List.fold_right (fun (_,id) ienv -> let impls = compute_internalization_data env Variable t imps in Id.Map.add id impls ienv) idl ienv in - ((env,ienv),((is_coe,idl),t,(ctx,imps)))) + ((env,ienv),((is_coe,idl),t,imps))) (env,empty_internalization_env) l in let evd = solve_remaining_evars all_and_fail_flags env !evdref (Evd.empty,!evdref) in + (* The universe constraints come from the whole telescope. *) + let evd = Evd.nf_constraints evd in + let ctx = Evd.universe_context_set evd in let l = List.map (on_pi2 (nf_evar evd)) l in - snd (List.fold_left (fun (subst,status) ((is_coe,idl),t,(ctx,imps)) -> + pi2 (List.fold_left (fun (subst,status,ctx) ((is_coe,idl),t,imps) -> let t = replace_vars subst t in let (refs,status') = declare_assumptions idl is_coe kind (t,ctx) [] imps false nl in let subst' = List.map2 (fun (_,id) (c,u) -> (id,Universes.constr_of_global_univ (c,u))) idl refs in - (subst'@subst, status' && status)) ([],true) l) + (subst'@subst, status' && status, + (* The universe constraints are declared with the first declaration only. *) + Univ.ContextSet.empty)) ([],true,ctx) l) let do_assumptions_bound_univs coe kind nl id pl c = let env = Global.env () in @@ -537,11 +540,9 @@ let inductive_levels env evdref poly arities inds = in let duu = Sorts.univ_of_sort du in let evd = - if not (Univ.is_small_univ duu) && Evd.check_eq evd cu duu then - if is_flexible_sort evd duu then - if Evd.check_leq evd Univ.type0_univ duu then - evd - else Evd.set_eq_sort env evd (Prop Null) du + if not (Univ.is_small_univ duu) && Univ.Universe.equal cu duu then + if is_flexible_sort evd duu && not (Evd.check_leq evd Univ.type0_univ duu) then + Evd.set_eq_sort env evd (Prop Null) du else evd else Evd.set_eq_sort env evd (Type cu) du in @@ -1129,7 +1130,7 @@ let interp_recursive isfix fixl notations = () in (* Instantiate evars and check all are resolved *) - let evd = consider_remaining_unif_problems env_rec !evdref in + let evd = solve_unif_constraints_with_heuristics env_rec !evdref in let evd, nf = nf_evars_and_universes evd in let fixdefs = List.map (Option.map nf) fixdefs in let fixtypes = List.map nf fixtypes in diff --git a/toplevel/command.mli b/toplevel/command.mli index d353724294..616afb91f0 100644 --- a/toplevel/command.mli +++ b/toplevel/command.mli @@ -22,7 +22,7 @@ open Pfedit val do_universe : polymorphic -> Id.t Loc.located list -> unit val do_constraint : polymorphic -> - (Id.t Loc.located * Univ.constraint_type * Id.t Loc.located) list -> unit + (Misctypes.glob_level * Univ.constraint_type * Misctypes.glob_level) list -> unit (** {6 Hooks for Pcoq} *) diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 0d4807e163..e9771cfa40 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -13,7 +13,7 @@ open Flags open Vernac open Pcoq -let top_stderr x = msg_with !Pp_control.err_ft x +let top_stderr x = msg_with ~pp_tag:Ppstyle.pp_tag !Pp_control.err_ft x (* A buffer for the character read from a channel. We store the command * entered to be able to report errors without pretty-printing. *) @@ -23,7 +23,7 @@ type input_buffer = { mutable str : string; (* buffer of already read characters *) mutable len : int; (* number of chars in the buffer *) mutable bols : int list; (* offsets in str of beginning of lines *) - mutable tokens : Gram.parsable; (* stream of tokens *) + mutable tokens : Gram.coq_parsable; (* stream of tokens *) mutable start : int } (* stream count of the first char of the buffer *) (* Double the size of the buffer. *) @@ -34,7 +34,7 @@ let resize_buffer ibuf = ibuf.str <- nstr (* Delete all irrelevant lines of the input buffer. Keep the last line - in the buffer (useful when there are several commands on the same line. *) + in the buffer (useful when there are several commands on the same line). *) let resynch_buffer ibuf = match ibuf.bols with @@ -274,9 +274,9 @@ let rec discard_to_dot () = | End_of_input -> raise End_of_input | e when CErrors.noncritical e -> () -let read_sentence () = +let read_sentence input = try - let (loc, _ as r) = Vernac.parse_sentence (top_buffer.tokens, None) in + let (loc, _ as r) = Vernac.parse_sentence input in CWarnings.set_current_loc loc; r with reraise -> let reraise = CErrors.push reraise in @@ -298,7 +298,8 @@ let do_vernac () = if !print_emacs then top_stderr (str (top_buffer.prompt())); resynch_buffer top_buffer; try - Vernac.eval_expr (read_sentence ()) + let input = (top_buffer.tokens, None) in + Vernac.process_expr top_buffer.tokens (read_sentence input) with | End_of_input | CErrors.Quit -> top_stderr (fnl ()); raise CErrors.Quit @@ -307,7 +308,6 @@ let do_vernac () = else Feedback.msg_error (str"There is no ML toplevel.") | any -> let any = CErrors.push any in - Format.set_formatter_out_channel stdout; let msg = print_toplevel_error any ++ fnl () in pp_with ~pp_tag:Ppstyle.pp_tag !Pp_control.std_ft msg; Format.pp_print_flush !Pp_control.std_ft () @@ -348,5 +348,7 @@ let rec loop () = | any -> Feedback.msg_error (str"Anomaly: main loop exited with exception: " ++ str (Printexc.to_string any) ++ - fnl() ++ str"Please report."); + fnl() ++ + str"Please report" ++ + strbrk" at " ++ str Coq_config.wwwbugtracker ++ str "."); loop () diff --git a/toplevel/coqloop.mli b/toplevel/coqloop.mli index 00554da308..e40353e0f9 100644 --- a/toplevel/coqloop.mli +++ b/toplevel/coqloop.mli @@ -18,7 +18,7 @@ type input_buffer = { mutable str : string; (** buffer of already read characters *) mutable len : int; (** number of chars in the buffer *) mutable bols : int list; (** offsets in str of begining of lines *) - mutable tokens : Pcoq.Gram.parsable; (** stream of tokens *) + mutable tokens : Pcoq.Gram.coq_parsable; (** stream of tokens *) mutable start : int } (** stream count of the first char of the buffer *) (** The input buffer of stdin. *) diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 47d433d790..d9f8ed8815 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -61,8 +61,7 @@ let init_color () = match colors with | None -> (** Default colors *) - Ppstyle.init_color_output (); - Feedback.set_logger Feedback.color_terminal_logger + Feedback.init_color_output () | Some "" -> (** No color output *) () @@ -70,8 +69,7 @@ let init_color () = (** Overwrite all colors *) Ppstyle.clear_styles (); Ppstyle.parse_config s; - Ppstyle.init_color_output (); - Feedback.set_logger Feedback.color_terminal_logger + Feedback.init_color_output () end let toploop_init = ref begin fun x -> @@ -170,7 +168,7 @@ let load_vernacular () = List.iter (fun (s,b) -> let s = Loadpath.locate_file s in - if Flags.do_beautify () then + if !Flags.beautify then with_option beautify_file (Vernac.load_vernac b) s else Vernac.load_vernac b s) @@ -221,7 +219,7 @@ let add_compile verbose s = compile_list := (verbose,s) :: !compile_list let compile_file (v,f) = - if Flags.do_beautify () then + if !Flags.beautify then with_option beautify_file (Vernac.compile v) f else Vernac.compile v f @@ -230,11 +228,9 @@ let compile_files () = if !compile_list == [] then () else let init_state = States.freeze ~marshallable:`No in - let coqdoc_init_state = CLexer.location_table () in Feedback.(add_feeder debug_feeder); List.iter (fun vf -> States.unfreeze init_state; - CLexer.restore_location_table coqdoc_init_state; compile_file vf) (List.rev !compile_list) @@ -332,9 +328,6 @@ let error_missing_arg s = let filter_opts = ref false let exitcode () = if !filter_opts then 2 else 0 -let verb_compat_ntn = ref false -let no_compat_ntn = ref false - let print_where = ref false let print_config = ref false let print_tags = ref false @@ -531,7 +524,7 @@ let parse_args arglist = |"-control-channel" -> Spawned.control_channel := get_host_port opt (next()) |"-vio2vo" -> add_compile false (next ()); Flags.compilation_mode := Vio2Vo |"-toploop" -> set_toploop (next ()) - |"-w" | "-W" -> CWarnings.set_flags (next ()) + |"-w" | "-W" -> CWarnings.set_flags (CWarnings.normalize_flags_string (next ())) |"-o" -> Flags.compilation_output_name := Some (next()) (* Options with zero arg *) @@ -543,7 +536,7 @@ let parse_args arglist = Flags.async_proofs_never_reopen_branch := true; |"-batch" -> set_batch_mode () |"-test-mode" -> test_mode := true - |"-beautify" -> make_beautify true + |"-beautify" -> beautify := true |"-boot" -> boot := true; no_load_rc () |"-bt" -> Backtrace.record_backtrace true |"-color" -> set_color (next ()) @@ -555,10 +548,9 @@ let parse_args arglist = |"-ideslave" -> set_ideslave () |"-impredicative-set" -> set_impredicative_set () |"-indices-matter" -> Indtypes.enforce_indices_matter () - |"-just-parsing" -> Vernac.just_parsing := true + |"-just-parsing" -> warning "-just-parsing option has been removed in 8.6" |"-m"|"--memory" -> memory_stat := true |"-noinit"|"-nois" -> load_init := false - |"-no-compat-notations" -> no_compat_ntn := true |"-no-glob"|"-noglob" -> Dumpglob.noglob (); glob_opt := true |"-native-compiler" -> if Coq_config.no_native_compiler then @@ -576,7 +568,6 @@ let parse_args arglist = |"-unicode" -> add_require "Utf8_core" |"-v"|"--version" -> Usage.version (exitcode ()) |"--print-version" -> Usage.machine_readable_version (exitcode ()) - |"-verbose-compat-notations" -> verb_compat_ntn := true |"-where" -> print_where := true |"-xml" -> Flags.xml_export := true @@ -637,9 +628,6 @@ let init_toplevel arglist = inputstate (); Mltop.init_known_plugins (); engage (); - (* Be careful to set these variables after the inputstate *) - Syntax_def.set_verbose_compat_notations !verb_compat_ntn; -(* Syntax_def.set_compat_notations (not !no_compat_ntn); FIXME *) if (not !batch_mode || List.is_empty !compile_list) && Global.env_is_initial () then Option.iter Declaremods.start_library !toplevel_name; diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index ff4c18ad21..f98505c362 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -304,7 +304,8 @@ let explain_unification_error env sigma p1 p2 = function else [] | MetaOccurInBody evk -> [str "instance for " ++ quote (pr_existential_key sigma evk) ++ - strbrk " refers to a metavariable - please report your example"] + strbrk " refers to a metavariable - please report your example" ++ + strbrk "at " ++ str Coq_config.wwwbugtracker ++ str "."] | InstanceNotSameType (evk,env,t,u) -> let t, u = pr_explicit env sigma t u in [str "unable to find a well-typed instantiation for " ++ @@ -515,7 +516,8 @@ let explain_cant_find_case_type env sigma c = let c = Evarutil.nf_evar sigma c in let env = make_all_name_different env in let pe = pr_lconstr_env env sigma c in - str "Cannot infer type of pattern-matching on" ++ ws 1 ++ pe ++ str "." + str "Cannot infer the return type of pattern-matching on" ++ ws 1 ++ + pe ++ str "." let explain_occur_check env sigma ev rhs = let rhs = Evarutil.nf_evar sigma rhs in @@ -754,7 +756,7 @@ let pr_constraints printenv env sigma evars cstrs = let evs = prlist (fun (ev, evi) -> fnl () ++ pr_existential_key sigma ev ++ - str " : " ++ pr_lconstr_env env' sigma evi.evar_concl) l + str " : " ++ pr_lconstr_env env' sigma evi.evar_concl ++ fnl ()) l in h 0 (pe ++ evs ++ pr_evar_constraints cstrs) else diff --git a/toplevel/indschemes.ml b/toplevel/indschemes.ml index f9e6c207c3..101c2d9bfa 100644 --- a/toplevel/indschemes.ml +++ b/toplevel/indschemes.ml @@ -161,7 +161,7 @@ let try_declare_scheme what f internal names kn = let msg = match fst e with | ParameterWithoutEquality cst -> alarm what internal - (str "Boolean equality not found for parameter " ++ pr_con cst ++ + (str "Boolean equality not found for parameter " ++ Printer.pr_global cst ++ str".") | InductiveWithProduct -> alarm what internal @@ -186,6 +186,12 @@ let try_declare_scheme what f internal names kn = | DecidabilityMutualNotSupported -> alarm what internal (str "Decidability lemma for mutual inductive types not supported.") + | EqUnknown s -> + alarm what internal + (str "Found unsupported " ++ str s ++ str " while building Boolean equality.") + | NoDecidabilityCoInductive -> + alarm what internal + (str "Scheme Equality is only for inductive types.") | e when CErrors.noncritical e -> alarm what internal (str "Unexpected error during scheme creation: " ++ CErrors.print e) diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index a1edb7139e..008d5cf9f5 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -673,8 +673,13 @@ type syntax_extension = { synext_notgram : notation_grammar; synext_unparsing : unparsing list; synext_extra : (string * string) list; + synext_compat : Flags.compat_version option; } +let is_active_compat = function +| None -> true +| Some v -> 0 <= Flags.version_compare v !Flags.compat_version + type syntax_extension_obj = locality_flag * syntax_extension list let cache_one_syntax_extension se = @@ -685,13 +690,15 @@ let cache_one_syntax_extension se = let oldprec = Notation.level_of_notation ntn in if not (Notation.level_eq prec oldprec) then error_incompatible_level ntn oldprec prec with Not_found -> - (* Reserve the notation level *) - Notation.declare_notation_level ntn prec; - (* Declare the parsing rule *) - if not onlyprint then Egramcoq.extend_constr_grammar prec se.synext_notgram; - (* Declare the notation rule *) - Notation.declare_notation_rule ntn - ~extra:se.synext_extra (se.synext_unparsing, fst prec) se.synext_notgram + if is_active_compat se.synext_compat then begin + (* Reserve the notation level *) + Notation.declare_notation_level ntn prec; + (* Declare the parsing rule *) + if not onlyprint then Egramcoq.extend_constr_grammar prec se.synext_notgram; + (* Declare the notation rule *) + Notation.declare_notation_rule ntn + ~extra:se.synext_extra (se.synext_unparsing, fst prec) se.synext_notgram + end let cache_syntax_extension (_, (_, sy)) = List.iter cache_one_syntax_extension sy @@ -725,9 +732,10 @@ let inSyntaxExtension : syntax_extension_obj -> obj = let interp_modifiers modl = let onlyparsing = ref false in let onlyprinting = ref false in + let compat = ref None in let rec interp assoc level etyps format extra = function | [] -> - (assoc,level,etyps,!onlyparsing,!onlyprinting,format,extra) + (assoc,level,etyps,!onlyparsing,!onlyprinting,!compat,format,extra) | SetEntryType (s,typ) :: l -> let id = Id.of_string s in if Id.List.mem_assoc id etyps then @@ -749,12 +757,15 @@ let interp_modifiers modl = | SetAssoc a :: l -> if not (Option.is_empty assoc) then error"An associativity is given more than once."; interp (Some a) level etyps format extra l - | SetOnlyParsing _ :: l -> + | SetOnlyParsing :: l -> onlyparsing := true; interp assoc level etyps format extra l | SetOnlyPrinting :: l -> onlyprinting := true; interp assoc level etyps format extra l + | SetCompatVersion v :: l -> + compat := Some v; + interp assoc level etyps format extra l | SetFormat ("text",s) :: l -> if not (Option.is_empty format) then error "A format is given more than once."; interp assoc level etyps (Some s) extra l @@ -763,7 +774,7 @@ let interp_modifiers modl = in interp None None [] None [] modl let check_infix_modifiers modifiers = - let (_, _, t, _, _, _, _) = interp_modifiers modifiers in + let (_, _, t, _, _, _, _, _) = interp_modifiers modifiers in if not (List.is_empty t) then error "Explicit entry level or type unexpected in infix notation." @@ -775,20 +786,25 @@ let check_useless_entry_types recvars mainvars etyps = | _ -> () let not_a_syntax_modifier = function -| SetOnlyParsing _ -> true +| SetOnlyParsing -> true | SetOnlyPrinting -> true +| SetCompatVersion _ -> true | _ -> false let no_syntax_modifiers mods = List.for_all not_a_syntax_modifier mods let is_only_parsing mods = - let test = function SetOnlyParsing _ -> true | _ -> false in + let test = function SetOnlyParsing -> true | _ -> false in List.exists test mods let is_only_printing mods = let test = function SetOnlyPrinting -> true | _ -> false in List.exists test mods +let get_compat_version mods = + let test = function SetCompatVersion v -> Some v | _ -> None in + try Some (List.find_map test mods) with Not_found -> None + (* Compute precedences from modifiers (or find default ones) *) let set_entry_type etyps (x,typ) = @@ -874,12 +890,12 @@ let warn_non_reversible_notation = (fun () -> strbrk "This notation will not be used for printing as it is not reversible.") -let is_not_printable onlyparse noninjective = function +let is_not_printable onlyparse nonreversible = function | NVar _ -> if not onlyparse then warn_notation_bound_to_variable (); true | _ -> - if not onlyparse && noninjective then + if not onlyparse && nonreversible then (warn_non_reversible_notation (); true) else onlyparse @@ -966,7 +982,7 @@ let remove_curly_brackets l = in aux true l let compute_syntax_data df modifiers = - let (assoc,n,etyps,onlyparse,onlyprint,fmt,extra) = interp_modifiers modifiers in + let (assoc,n,etyps,onlyparse,onlyprint,compat,fmt,extra) = interp_modifiers modifiers in let assoc = match assoc with None -> (* default *) Some NonA | a -> a in let toks = split_notation_string df in let (recvars,mainvars,symbols) = analyze_notation_tokens toks in @@ -992,12 +1008,12 @@ let compute_syntax_data df modifiers = let sy_data = (n,sy_typs,symbols',fmt) in let sy_fulldata = (i_typs,ntn_for_grammar,prec,need_squash,sy_data) in let df' = ((Lib.library_dp(),Lib.current_dirpath true),df) in - let i_data = (onlyparse,onlyprint,recvars,mainvars,(ntn_for_interp,df')) in + let i_data = (onlyparse,onlyprint,compat,recvars,mainvars,(ntn_for_interp,df')) in (* Return relevant data for interpretation and for parsing/printing *) (msgs,i_data,i_typs,sy_fulldata,extra) let compute_pure_syntax_data df mods = - let (msgs,(onlyparse,onlyprint,_,_,_),_,sy_data,extra) = compute_syntax_data df mods in + let (msgs,(onlyparse,onlyprint,_,_,_,_),_,sy_data,extra) = compute_syntax_data df mods in let msgs = if onlyparse then (Feedback.msg_warning ?loc:None, @@ -1014,6 +1030,7 @@ type notation_obj = { notobj_interp : interpretation; notobj_onlyparse : bool; notobj_onlyprint : bool; + notobj_compat : Flags.compat_version option; notobj_notation : notation * notation_location; } @@ -1024,7 +1041,9 @@ let open_notation i (_, nobj) = let scope = nobj.notobj_scope in let (ntn, df) = nobj.notobj_notation in let pat = nobj.notobj_interp in - if Int.equal i 1 && not (Notation.exists_notation_in_scope scope ntn pat) then begin + let fresh = not (Notation.exists_notation_in_scope scope ntn pat) in + let active = is_active_compat nobj.notobj_compat in + if Int.equal i 1 && fresh && active then begin (* Declare the interpretation *) let onlyprint = nobj.notobj_onlyprint in let () = Notation.declare_notation_interpretation ntn scope pat df ~onlyprint in @@ -1074,7 +1093,10 @@ let contract_notation ntn = let rec aux ntn i = if i <= String.length ntn - 5 then let ntn' = - if String.is_sub "{ _ }" ntn i then + if String.is_sub "{ _ }" ntn i && + (i = 0 || ntn.[i-1] = ' ') && + (i = String.length ntn - 5 || ntn.[i+5] = ' ') + then String.sub ntn 0 i ^ "_" ^ String.sub ntn (i+5) (String.length ntn -i-5) else ntn in @@ -1094,7 +1116,9 @@ let recover_syntax ntn = synext_notation = ntn; synext_notgram = pa_rule; synext_unparsing = pp_rule; - synext_extra = pp_extra_rules } + synext_extra = pp_extra_rules; + synext_compat = None; + } with Not_found -> raise NoSyntaxRule @@ -1128,7 +1152,7 @@ let make_pp_rule (n,typs,symbols,fmt) = | None -> [UnpBox (PpHOVB 0, make_hunks typs symbols n)] | Some fmt -> hunks_of_format (n, List.split typs) (symbols, parse_format fmt) -let make_syntax_rules (i_typs,ntn,prec,need_squash,sy_data) extra onlyprint = +let make_syntax_rules (i_typs,ntn,prec,need_squash,sy_data) extra onlyprint compat = let pa_rule = make_pa_rule i_typs sy_data ntn onlyprint in let pp_rule = make_pp_rule sy_data in let sy = { @@ -1137,6 +1161,7 @@ let make_syntax_rules (i_typs,ntn,prec,need_squash,sy_data) extra onlyprint = synext_notgram = pa_rule; synext_unparsing = pp_rule; synext_extra = extra; + synext_compat = compat; } in (* By construction, the rule for "{ _ }" is declared, but we need to redeclare it because the file where it is declared needs not be open @@ -1153,19 +1178,18 @@ let to_map l = let add_notation_in_scope local df c mods scope = let (msgs,i_data,i_typs,sy_data,extra) = compute_syntax_data df mods in (* Prepare the interpretation *) - let (onlyparse, onlyprint, recvars,mainvars, df') = i_data in + let (onlyparse, onlyprint, compat, recvars,mainvars, df') = i_data in (* Prepare the parsing and printing rules *) - let sy_rules = make_syntax_rules sy_data extra onlyprint in + let sy_rules = make_syntax_rules sy_data extra onlyprint compat in let i_vars = make_internalization_vars recvars mainvars i_typs in let nenv = { ninterp_var_type = to_map i_vars; ninterp_rec_vars = to_map recvars; - ninterp_only_parse = false; } in - let (acvars, ac) = interp_notation_constr nenv c in + let (acvars, ac, reversible) = interp_notation_constr nenv c in let interp = make_interpretation_vars recvars acvars in let map (x, _) = try Some (x, Id.Map.find x interp) with Not_found -> None in - let onlyparse = is_not_printable onlyparse nenv.ninterp_only_parse ac in + let onlyparse = is_not_printable onlyparse (not reversible) ac in let notation = { notobj_local = local; notobj_scope = scope; @@ -1173,6 +1197,7 @@ let add_notation_in_scope local df c mods scope = (** Order is important here! *) notobj_onlyparse = onlyparse; notobj_onlyprint = onlyprint; + notobj_compat = compat; notobj_notation = df'; } in (* Ready to change the global state *) @@ -1181,7 +1206,7 @@ let add_notation_in_scope local df c mods scope = Lib.add_anonymous_leaf (inNotation notation); df' -let add_notation_interpretation_core local df ?(impls=empty_internalization_env) c scope onlyparse onlyprint = +let add_notation_interpretation_core local df ?(impls=empty_internalization_env) c scope onlyparse onlyprint compat = let dfs = split_notation_string df in let (recvars,mainvars,symbs) = analyze_notation_tokens dfs in (* Recover types of variables and pa/pp rules; redeclare them if needed *) @@ -1199,12 +1224,11 @@ let add_notation_interpretation_core local df ?(impls=empty_internalization_env) let nenv = { ninterp_var_type = to_map i_vars; ninterp_rec_vars = to_map recvars; - ninterp_only_parse = false; } in - let (acvars, ac) = interp_notation_constr ~impls nenv c in + let (acvars, ac, reversible) = interp_notation_constr ~impls nenv c in let interp = make_interpretation_vars recvars acvars in let map (x, _) = try Some (x, Id.Map.find x interp) with Not_found -> None in - let onlyparse = is_not_printable onlyparse nenv.ninterp_only_parse ac in + let onlyparse = is_not_printable onlyparse (not reversible) ac in let notation = { notobj_local = local; notobj_scope = scope; @@ -1212,6 +1236,7 @@ let add_notation_interpretation_core local df ?(impls=empty_internalization_env) (** Order is important here! *) notobj_onlyparse = onlyparse; notobj_onlyprint = onlyprint; + notobj_compat = compat; notobj_notation = df'; } in Lib.add_anonymous_leaf (inNotation notation); @@ -1221,19 +1246,19 @@ let add_notation_interpretation_core local df ?(impls=empty_internalization_env) let add_syntax_extension local ((loc,df),mods) = let msgs, sy_data, extra, onlyprint = compute_pure_syntax_data df mods in - let sy_rules = make_syntax_rules sy_data extra onlyprint in + let sy_rules = make_syntax_rules sy_data extra onlyprint None in Flags.if_verbose (List.iter (fun (f,x) -> f x)) msgs; Lib.add_anonymous_leaf (inSyntaxExtension(local,sy_rules)) (* Notations with only interpretation *) let add_notation_interpretation ((loc,df),c,sc) = - let df' = add_notation_interpretation_core false df c sc false false in + let df' = add_notation_interpretation_core false df c sc false false None in Dumpglob.dump_notation (loc,df') sc true let set_notation_for_interpretation impls ((_,df),c,sc) = (try ignore - (silently (fun () -> add_notation_interpretation_core false df ~impls c sc false false) ()); + (silently (fun () -> add_notation_interpretation_core false df ~impls c sc false false None) ()); with NoSyntaxRule -> error "Parsing rule for this notation has to be previously declared."); Option.iter (fun sc -> Notation.open_close_scope (false,true,sc)) sc @@ -1246,7 +1271,8 @@ let add_notation local c ((loc,df),modifiers) sc = (* No syntax data: try to rely on a previously declared rule *) let onlyparse = is_only_parsing modifiers in let onlyprint = is_only_printing modifiers in - try add_notation_interpretation_core local df c sc onlyparse onlyprint + let compat = get_compat_version modifiers in + try add_notation_interpretation_core local df c sc onlyparse onlyprint compat with NoSyntaxRule -> (* Try to determine a default syntax rule *) add_notation_in_scope local df c modifiers sc @@ -1339,10 +1365,9 @@ let add_syntactic_definition ident (vars,c) local onlyparse = let nenv = { ninterp_var_type = i_vars; ninterp_rec_vars = Id.Map.empty; - ninterp_only_parse = false; } in - let nvars, pat = interp_notation_constr nenv c in - let () = nonprintable := nenv.ninterp_only_parse in + let nvars, pat, reversible = interp_notation_constr nenv c in + let () = nonprintable := not reversible in let map id = let (_,sc,_) = Id.Map.find id nvars in (id, sc) in List.map map vars, pat in diff --git a/toplevel/mltop.ml b/toplevel/mltop.ml index 0a5b92270f..b6690fe47b 100644 --- a/toplevel/mltop.ml +++ b/toplevel/mltop.ml @@ -411,7 +411,7 @@ let inMLModule : ml_module_object -> obj = let declare_ml_modules local l = let l = List.map mod_of_name l in - Lib.add_anonymous_leaf (inMLModule {mlocal=local; mnames=l}) + Lib.add_anonymous_leaf ~cache_first:false (inMLModule {mlocal=local; mnames=l}) let print_ml_path () = let l = !coq_mlpath_copy in diff --git a/toplevel/record.ml b/toplevel/record.ml index 71d070776d..8d35e5a3da 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -108,7 +108,8 @@ let typecheck_params_and_fields def id pl t ps nots fs = List.iter (function LocalRawDef (b, _) -> error default_binder_kind b | LocalRawAssum (ls, bk, ce) -> List.iter (error bk) ls - | LocalPattern _ -> assert false) ps + | LocalPattern (loc,_,_) -> + Loc.raise loc (Stream.Error "pattern with quote not allowed in record parameters.")) ps in let impls_env, ((env1,newps), imps) = interp_context_evars env0 evars ps in let t', template = match t with @@ -517,15 +518,9 @@ let add_inductive_class ind = let k = let ctx = oneind.mind_arity_ctxt in let inst = Univ.UContext.instance mind.mind_universes in - let map = function - | LocalDef _ -> None - | LocalAssum (_, t) -> Some (lazy t) - in - let args = List.map_filter map ctx in - let ty = Inductive.type_of_inductive_knowing_parameters + let ty = Inductive.type_of_inductive (push_rel_context ctx (Global.env ())) ((mind,oneind),inst) - (Array.of_list args) in { cl_impl = IndRef ind; cl_context = List.map (const None) ctx, ctx; @@ -556,8 +551,10 @@ let definition_structure (kind,poly,finite,(is_coe,((loc,idstruc),pl)),ps,cfs,id | Vernacexpr.DefExpr ((_,Name id),_,_) -> id::acc | _ -> acc in let allnames = idstruc::(List.fold_left extract_name [] fs) in - if not (List.distinct_f Id.compare allnames) - then error "Two objects have the same name"; + let () = match List.duplicates Id.equal allnames with + | [] -> () + | id :: _ -> errorlabstrm "" (str "Two objects have the same name" ++ spc () ++ quote (Id.print id)) + in let isnot_class = match kind with Class false -> false | _ -> true in if isnot_class && List.exists (fun opt -> not (Option.is_empty opt)) priorities then error "Priorities only allowed for type class substructures"; @@ -567,8 +564,9 @@ let definition_structure (kind,poly,finite,(is_coe,((loc,idstruc),pl)),ps,cfs,id typecheck_params_and_fields (kind = Class true) idstruc pl s ps notations fs) () in let sign = structure_signature (fields@params) in let gr = match kind with - | Class def -> - let gr = declare_class finite def poly ctx (loc,idstruc) idbuild + | Class def -> + let priorities = List.map (fun id -> {hint_priority = id; hint_pattern = None}) priorities in + let gr = declare_class finite def poly ctx (loc,idstruc) idbuild implpars params arity template implfs fields is_coe coers priorities sign in gr | _ -> diff --git a/toplevel/record.mli b/toplevel/record.mli index b094255634..c50e577860 100644 --- a/toplevel/record.mli +++ b/toplevel/record.mli @@ -38,7 +38,8 @@ val declare_structure : inductive val definition_structure : - inductive_kind * Decl_kinds.polymorphic * Decl_kinds.recursivity_kind * plident with_coercion * local_binder list * + inductive_kind * Decl_kinds.polymorphic * Decl_kinds.recursivity_kind * + plident with_coercion * local_binder list * (local_decl_expr with_instance with_priority with_notation) list * Id.t * constr_expr option -> global_reference diff --git a/toplevel/search.ml b/toplevel/search.ml index e670b59b79..ff3c7a4f42 100644 --- a/toplevel/search.ml +++ b/toplevel/search.ml @@ -29,17 +29,6 @@ query, separated by a newline. This type of output is useful for editors (like emacs), to generate a list of completion candidates without having to parse thorugh the types of all symbols. *) -let search_output_name_only = ref false - -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "output-name-only search"; - optkey = ["Search";"Output";"Name";"Only"]; - optread = (fun () -> !search_output_name_only); - optwrite = (:=) search_output_name_only } - type glob_search_about_item = | GlobSearchSubPattern of constr_pattern | GlobSearchString of string @@ -118,18 +107,6 @@ let generic_search glnumopt fn = | Some glnum -> iter_hypothesis glnum fn); iter_declarations fn -(** Standard display *) -let plain_display accu ref env c = - let pr = pr_global ref in - if !search_output_name_only then - accu := pr :: !accu - else begin - let pc = pr_lconstr_env env Evd.empty c in - accu := hov 2 (pr ++ str":" ++ spc () ++ pc) :: !accu - end - -let format_display l = prlist_with_sep fnl (fun x -> x) (List.rev l) - (** Filters *) (** This function tries to see whether the conclusion matches a pattern. *) @@ -155,8 +132,9 @@ let full_name_of_reference ref = DirPath.to_string dir ^ "." ^ Id.to_string id (** Whether a reference is blacklisted *) -let blacklist_filter ref env typ = +let blacklist_filter_aux () = let l = SearchBlacklist.elements () in + fun ref env typ -> let name = full_name_of_reference ref in let is_not_bl str = not (String.string_contains ~where:name ~what:str) in List.for_all is_not_bl l @@ -180,19 +158,17 @@ let search_about_filter query gr env typ = match query with (** SearchPattern *) -let search_pattern gopt pat mods = - let ans = ref [] in +let search_pattern gopt pat mods pr_search = + let blacklist_filter = blacklist_filter_aux () in let filter ref env typ = - let f_module = module_filter mods ref env typ in - let f_blacklist = blacklist_filter ref env typ in - let f_pattern () = pattern_filter pat ref env typ in - f_module && f_pattern () && f_blacklist + module_filter mods ref env typ && + pattern_filter pat ref env typ && + blacklist_filter ref env typ in let iter ref env typ = - if filter ref env typ then plain_display ans ref env typ + if filter ref env typ then pr_search ref env typ in - let () = generic_search gopt iter in - format_display !ans + generic_search gopt iter (** SearchRewrite *) @@ -204,57 +180,50 @@ let rewrite_pat1 pat = let rewrite_pat2 pat = PApp (PRef eq, [| PMeta None; PMeta None; pat |]) -let search_rewrite gopt pat mods = +let search_rewrite gopt pat mods pr_search = let pat1 = rewrite_pat1 pat in let pat2 = rewrite_pat2 pat in - let ans = ref [] in + let blacklist_filter = blacklist_filter_aux () in let filter ref env typ = - let f_module = module_filter mods ref env typ in - let f_blacklist = blacklist_filter ref env typ in - let f_pattern () = - pattern_filter pat1 ref env typ || - pattern_filter pat2 ref env typ - in - f_module && f_pattern () && f_blacklist + module_filter mods ref env typ && + (pattern_filter pat1 ref env typ || + pattern_filter pat2 ref env typ) && + blacklist_filter ref env typ in let iter ref env typ = - if filter ref env typ then plain_display ans ref env typ + if filter ref env typ then pr_search ref env typ in - let () = generic_search gopt iter in - format_display !ans + generic_search gopt iter (** Search *) -let search_by_head gopt pat mods = - let ans = ref [] in +let search_by_head gopt pat mods pr_search = + let blacklist_filter = blacklist_filter_aux () in let filter ref env typ = - let f_module = module_filter mods ref env typ in - let f_blacklist = blacklist_filter ref env typ in - let f_pattern () = head_filter pat ref env typ in - f_module && f_pattern () && f_blacklist + module_filter mods ref env typ && + head_filter pat ref env typ && + blacklist_filter ref env typ in let iter ref env typ = - if filter ref env typ then plain_display ans ref env typ + if filter ref env typ then pr_search ref env typ in - let () = generic_search gopt iter in - format_display !ans + generic_search gopt iter (** SearchAbout *) -let search_about gopt items mods = - let ans = ref [] in +let search_about gopt items mods pr_search = + let blacklist_filter = blacklist_filter_aux () in let filter ref env typ = let eqb b1 b2 = if b1 then b2 else not b2 in - let f_module = module_filter mods ref env typ in - let f_about (b, i) = eqb b (search_about_filter i ref env typ) in - let f_blacklist = blacklist_filter ref env typ in - f_module && List.for_all f_about items && f_blacklist + module_filter mods ref env typ && + List.for_all + (fun (b,i) -> eqb b (search_about_filter i ref env typ)) items && + blacklist_filter ref env typ in let iter ref env typ = - if filter ref env typ then plain_display ans ref env typ + if filter ref env typ then pr_search ref env typ in - let () = generic_search gopt iter in - format_display !ans + generic_search gopt iter type search_constraint = | Name_Pattern of Str.regexp @@ -287,6 +256,7 @@ let interface_search = let (name, tpe, subtpe, mods, blacklist) = extract_flags [] [] [] [] false flags in + let blacklist_filter = blacklist_filter_aux () in let filter_function ref env constr = let id = Names.Id.to_string (Nametab.basename_of_global ref) in let path = Libnames.dirpath (Nametab.path_of_global ref) in @@ -305,13 +275,11 @@ let interface_search = let match_module (mdl, flag) = toggle (Libnames.is_dirpath_prefix_of mdl path) flag in - let in_blacklist = - blacklist || (blacklist_filter ref env constr) - in List.for_all match_name name && List.for_all match_type tpe && List.for_all match_subtype subtpe && - List.for_all match_module mods && in_blacklist + List.for_all match_module mods && + (blacklist || blacklist_filter ref env constr) in let ans = ref [] in let print_function ref env constr = @@ -342,3 +310,6 @@ let interface_search = in let () = generic_search glnum iter in !ans + +let blacklist_filter ref env typ = + blacklist_filter_aux () ref env typ diff --git a/toplevel/search.mli b/toplevel/search.mli index 9f209a17e7..ba3d48efcc 100644 --- a/toplevel/search.mli +++ b/toplevel/search.mli @@ -39,11 +39,14 @@ val search_about_filter : glob_search_about_item -> filter_function goal and the global environment for things matching [pattern] and satisfying module exclude/include clauses of [modinout]. *) -val search_by_head : int option -> constr_pattern -> DirPath.t list * bool -> std_ppcmds -val search_rewrite : int option -> constr_pattern -> DirPath.t list * bool -> std_ppcmds -val search_pattern : int option -> constr_pattern -> DirPath.t list * bool -> std_ppcmds +val search_by_head : int option -> constr_pattern -> DirPath.t list * bool + -> display_function -> unit +val search_rewrite : int option -> constr_pattern -> DirPath.t list * bool + -> display_function -> unit +val search_pattern : int option -> constr_pattern -> DirPath.t list * bool + -> display_function -> unit val search_about : int option -> (bool * glob_search_about_item) list - -> DirPath.t list * bool -> std_ppcmds + -> DirPath.t list * bool -> display_function -> unit type search_constraint = (** Whether the name satisfies a regexp (uses Ocaml Str syntax) *) diff --git a/toplevel/usage.ml b/toplevel/usage.ml index 8f77aea440..38ceacf5ec 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -36,8 +36,6 @@ let print_usage_channel co command = \n -noinit start without loading the Init library\ \n -nois (idem)\ \n -compat X.Y provides compatibility support for Coq version X.Y\ -\n -verbose-compat-notations be warned when using compatibility notations\ -\n -no-compat-notations get an error when using compatibility notations\ \n\ \n -load-ml-object f load ML object file f\ \n -load-ml-source f load ML file f\ @@ -61,8 +59,8 @@ let print_usage_channel co command = \n -v print Coq version and exit\ \n -list-tags print highlight color tags known by Coq and exit\ \n\ -\n -quiet unset display of extra information (implies -w none)\ -\n -w (all|none) configure display of warnings\ +\n -quiet unset display of extra information (implies -w \"-all\")\ +\n -w (w1,..,wn) configure display of warnings\ \n -color (yes|no|auto) configure color output\ \n\ \n -q skip loading of rcfile\ @@ -82,7 +80,7 @@ let print_usage_channel co command = \n the directory $COQ_XML_LIBRARY_ROOT (if set) or to\ \n stdout (if unset)\ \n -time display the time taken by each command\ -\n -profile-ltac display the time taken by each (sub)tactic\ +\n -profile-ltac display the time taken by each (sub)tactic\ \n -m, --memory display total heap size at program exit\ \n (use environment variable\ \n OCAML_GC_STATS=\"/tmp/gclog.txt\"\ diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index 55f3a31a34..bfdae85d50 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -18,6 +18,8 @@ open Vernacexpr Use the module Coqtoplevel, which catches these exceptions (the exceptions are explained only at the toplevel). *) +let user_error loc s = CErrors.user_err_loc (loc,"_",str s) + (* Navigation commands are allowed in a coqtop session but not in a .v file *) let rec is_navigation_vernac = function @@ -42,6 +44,14 @@ let is_reset = function | VernacResetInitial | VernacResetName _ -> true | _ -> false +let checknav_simple loc cmd = + if is_navigation_vernac cmd && not (is_reset cmd) then + user_error loc "Navigation commands forbidden in files." + +let checknav_deep loc ast = + if is_deep_navigation_vernac ast then + user_error loc "Navigation commands forbidden in nested commands." + (* When doing Load on a file, two behaviors are possible: - either the history stack is grown by only one command, @@ -70,8 +80,6 @@ let disable_drop = function | Drop -> CErrors.error "Drop is forbidden." | e -> e -let user_error loc s = CErrors.user_err_loc (loc,"_",str s) - (* Opening and closing a channel. Open it twice when verbose: the first channel is used to read the commands, and the second one to print them. Note: we could use only one thanks to seek_in, but seeking on and on in @@ -81,7 +89,7 @@ let open_file_twice_if verbosely longfname = let in_chan = open_utf8_file_in longfname in let verb_ch = if verbosely then Some (open_utf8_file_in longfname) else None in - let po = Pcoq.Gram.parsable (Stream.of_channel in_chan) in + let po = Pcoq.Gram.parsable ~file:longfname (Stream.of_channel in_chan) in (in_chan, longfname, (po, verb_ch)) let close_input in_chan (_,verb) = @@ -114,45 +122,39 @@ let parse_sentence = Flags.with_option Flags.we_are_parsing (* vernac parses the given stream, executes interpfun on the syntax tree it * parses, and is verbose on "primitives" commands if verbosely is true *) -let just_parsing = ref false let chan_beautify = ref stdout let beautify_suffix = ".beautified" -let set_formatter_translator() = - let ch = !chan_beautify in +let set_formatter_translator ch = let out s b e = output ch s b e in Format.set_formatter_output_functions out (fun () -> flush ch); Format.set_max_boxes max_int -let pr_new_syntax loc ocom = +let pr_new_syntax_in_context loc chan_beautify ocom = let loc = Loc.unloc loc in - if !beautify_file then set_formatter_translator(); + if !beautify_file then set_formatter_translator chan_beautify; let fs = States.freeze ~marshallable:`No in - let com = match ocom with - | Some com -> Ppvernac.pr_vernac com - | None -> mt() in - if !beautify_file then - Feedback.msg_notice (hov 0 (comment (fst loc) ++ com ++ comment (snd loc))) - else - Feedback.msg_info (hov 4 (str"New Syntax:" ++ fnl() ++ (hov 0 com))); - States.unfreeze fs; - Format.set_formatter_out_channel stdout - -let save_translator_coqdoc () = - (* translator state *) - let ch = !chan_beautify in - let cl = !Pp.comments in - let cs = CLexer.com_state() in - (* end translator state *) - let coqdocstate = CLexer.location_table () in - ch,cl,cs,coqdocstate - -let restore_translator_coqdoc (ch,cl,cs,coqdocstate) = - if !Flags.beautify_file then close_out !chan_beautify; - chan_beautify := ch; - Pp.comments := cl; - CLexer.restore_com_state cs; - CLexer.restore_location_table coqdocstate + (* The content of this is not supposed to fail, but if ever *) + try + (* Side-effect: order matters *) + let before = comment (CLexer.extract_comments (fst loc)) in + let com = match ocom with + | Some com -> Ppvernac.pr_vernac com + | None -> mt() in + let after = comment (CLexer.extract_comments (snd loc)) in + if !beautify_file then + Pp.msg_with !Pp_control.std_ft (hov 0 (before ++ com ++ after)) + else + Feedback.msg_info (hov 4 (str"New Syntax:" ++ fnl() ++ (hov 0 com))); + States.unfreeze fs; + Format.set_formatter_out_channel stdout + with any -> + States.unfreeze fs; + Format.set_formatter_out_channel stdout + +let pr_new_syntax po loc chan_beautify ocom = + (* Reinstall the context of parsing which includes the bindings of comments to locations *) + Pcoq.Gram.with_parsable po (pr_new_syntax_in_context chan_beautify loc) ocom (* For coqtop -time, we display the position in the file, and a glimpse of the executed command *) @@ -179,78 +181,55 @@ let pp_cmd_header loc com = and take control of the console. *) let print_cmd_header loc com = - Pp.pp_with !Pp_control.std_ft (pp_cmd_header loc com); + Pp.pp_with ~pp_tag:Ppstyle.pp_tag !Pp_control.std_ft (pp_cmd_header loc com); Format.pp_print_flush !Pp_control.std_ft () -let rec vernac_com checknav (loc,com) = +let rec interp_vernac po chan_beautify checknav (loc,com) = let interp = function | VernacLoad (verbosely, fname) -> 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 f = Loadpath.locate_file fname in - let st = save_translator_coqdoc () in - let old_lexer_file = CLexer.get_current_file () in - CLexer.set_current_file f; - if !Flags.beautify_file then - begin - chan_beautify := open_out (f^beautify_suffix); - Pp.comments := [] - end; - begin - try - Flags.silently (read_vernac_file verbosely) f; - restore_translator_coqdoc st; - CLexer.set_current_file old_lexer_file; - with reraise -> - let reraise = CErrors.push reraise in - restore_translator_coqdoc st; - CLexer.set_current_file old_lexer_file; - iraise reraise - end - - | v when !just_parsing -> () + load_vernac verbosely f | v -> Stm.interp (Flags.is_verbose()) (loc,v) in try checknav loc com; - if do_beautify () then pr_new_syntax loc (Some com); + if !beautify then pr_new_syntax po chan_beautify loc (Some com); (* XXX: This is not 100% correct if called from an IDE context *) if !Flags.time then print_cmd_header loc com; let com = if !Flags.time then VernacTime (loc,com) else com in - let a = CLexer.com_state () in - interp com; - CLexer.restore_com_state a + interp com with reraise -> let (reraise, info) = CErrors.push reraise in - Format.set_formatter_out_channel stdout; let loc' = Option.default Loc.ghost (Loc.get_loc info) in if Loc.is_ghost loc' then iraise (reraise, Loc.add_loc info loc) else iraise (reraise, info) -and read_vernac_file verbosely s = - let checknav loc cmd = - if is_navigation_vernac cmd && not (is_reset cmd) then - user_error loc "Navigation commands forbidden in files" - in - let (in_chan, fname, input) = open_file_twice_if verbosely s in +(* Load a vernac file. CErrors are annotated with file and location *) +and load_vernac verbosely file = + let chan_beautify = + if !Flags.beautify_file then open_out (file^beautify_suffix) else stdout in + let (in_chan, fname, input) = open_file_twice_if verbosely file in try (* we go out of the following infinite loop when a End_of_input is * raised, which means that we raised the end of the file being loaded *) while true do - let loc_ast = parse_sentence input in + let loc_ast = Flags.silently parse_sentence input in CWarnings.set_current_loc (fst loc_ast); - vernac_com checknav loc_ast; + Flags.silently (interp_vernac (fst input) chan_beautify checknav_simple) loc_ast; done with any -> (* whatever the exception *) let (e, info) = CErrors.push any in - Format.set_formatter_out_channel stdout; close_input in_chan input; (* we must close the file first *) match e with | End_of_input -> - if do_beautify () then - pr_new_syntax (Loc.make_loc (max_int,max_int)) None + if !beautify then + pr_new_syntax (fst input) chan_beautify (Loc.make_loc (max_int,max_int)) None; + if !Flags.beautify_file then close_out chan_beautify; | reraise -> + if !Flags.beautify_file then close_out chan_beautify; iraise (disable_drop e, info) (** [eval_expr : ?preserving:bool -> Loc.t * Vernacexpr.vernac_expr -> unit] @@ -260,32 +239,12 @@ and read_vernac_file verbosely s = of a new state label). An example of state-preserving command is one coming from the query panel of Coqide. *) -let checknav loc ast = - if is_deep_navigation_vernac ast then - user_error loc "Navigation commands forbidden in nested commands" - -let eval_expr loc_ast = vernac_com checknav loc_ast +let process_expr po loc_ast = interp_vernac po stdout checknav_deep loc_ast (* XML output hooks *) let (f_xml_start_library, xml_start_library) = Hook.make ~default:ignore () let (f_xml_end_library, xml_end_library) = Hook.make ~default:ignore () -(* Load a vernac file. CErrors are annotated with file and location *) -let load_vernac verb file = - chan_beautify := - if !Flags.beautify_file then open_out (file^beautify_suffix) else stdout; - let old_lexer_file = CLexer.get_current_file () in - try - CLexer.set_current_file file; - Flags.silently (read_vernac_file verb) file; - if !Flags.beautify_file then close_out !chan_beautify; - CLexer.set_current_file old_lexer_file; - with any -> - let (e, info) = CErrors.push any in - if !Flags.beautify_file then close_out !chan_beautify; - CLexer.set_current_file old_lexer_file; - iraise (disable_drop e, info) - let warn_file_no_extension = CWarnings.create ~name:"file-no-extension" ~category:"filesystem" (fun (f,ext) -> diff --git a/toplevel/vernac.mli b/toplevel/vernac.mli index 7bfddd9470..0d9f5871a3 100644 --- a/toplevel/vernac.mli +++ b/toplevel/vernac.mli @@ -11,17 +11,14 @@ (** Read a vernac command on the specified input (parse only). Raises [End_of_file] if EOF (or Ctrl-D) is reached. *) -val parse_sentence : Pcoq.Gram.parsable * in_channel option -> +val parse_sentence : Pcoq.Gram.coq_parsable * in_channel option -> Loc.t * Vernacexpr.vernac_expr -(** Reads and executes vernac commands from a stream. - The boolean [just_parsing] disables interpretation of commands. *) +(** Reads and executes vernac commands from a stream. *) exception End_of_input -val just_parsing : bool ref - -val eval_expr : Loc.t * Vernacexpr.vernac_expr -> unit +val process_expr : Pcoq.Gram.coq_parsable -> Loc.t * Vernacexpr.vernac_expr -> unit (** Set XML hooks *) val xml_start_library : (unit -> unit) Hook.t diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 382a716298..6736d83293 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -448,7 +448,27 @@ let vernac_notation locality local = (***********) (* Gallina *) -let start_proof_and_print k l hook = start_proof_com k l hook +let start_proof_and_print k l hook = + let inference_hook = + if Flags.is_program_mode () then + let hook env sigma ev = + let tac = !Obligations.default_tactic in + let evi = Evd.find sigma ev in + let env = Evd.evar_filtered_env evi in + try + let concl = Evarutil.nf_evars_universes sigma evi.Evd.evar_concl in + if Evarutil.has_undefined_evars sigma concl then raise Exit; + let c, _, ctx = + Pfedit.build_by_tactic env (Evd.evar_universe_context sigma) + concl (Tacticals.New.tclCOMPLETE tac) + in Evd.set_universe_context sigma ctx, c + with Logic_monad.TacticFailure e when Logic.catchable_exception e -> + error "The statement obligations could not be resolved \ + automatically, write a statement definition first." + in Some hook + else None + in + start_proof_com ?inference_hook k l hook let no_hook = Lemmas.mk_hook (fun _ _ -> ()) @@ -550,23 +570,23 @@ let vernac_inductive poly lo finite indl = | _ -> () (* dumping is done by vernac_record (called below) *) ) indl; match indl with - | [ ( _ , _ , _ ,Record, Constructors _ ),_ ] -> - CErrors.error "The Record keyword cannot be used to define a variant type. Use Variant instead." + | [ ( _ , _ , _ ,(Record|Structure), Constructors _ ),_ ] -> + CErrors.error "The Record keyword is for types defined using the syntax { ... }." | [ (_ , _ , _ ,Variant, RecordDecl _),_ ] -> - CErrors.error "The Variant keyword cannot be used to define a record type. Use Record instead." + CErrors.error "The Variant keyword does not support syntax { ... }." | [ ( id , bl , c , b, RecordDecl (oc,fs) ), [] ] -> - vernac_record (match b with Class true -> Class false | _ -> b) + vernac_record (match b with Class _ -> Class false | _ -> b) poly finite id bl c oc fs - | [ ( id , bl , c , Class true, Constructors [l]), _ ] -> + | [ ( id , bl , c , Class _, Constructors [l]), [] ] -> let f = let (coe, ((loc, id), ce)) = l in let coe' = if coe then Some true else None in (((coe', AssumExpr ((loc, Name id), ce)), None), []) in vernac_record (Class true) poly finite id bl c None [f] - | [ ( id , bl , c , Class true, _), _ ] -> - CErrors.error "Definitional classes must have a single method" - | [ ( id , bl , c , Class false, Constructors _), _ ] -> + | [ ( _ , _, _, Class _, Constructors _), [] ] -> CErrors.error "Inductive classes not supported" + | [ ( id , bl , c , Class _, _), _ :: _ ] -> + CErrors.error "where clause not supported for classes" | [ ( _ , _ , _ , _, RecordDecl _ ) , _ ] -> CErrors.error "where clause not supported for (co)inductive records" | _ -> let unpack = function @@ -821,9 +841,9 @@ let vernac_instance abst locality poly sup inst props pri = let vernac_context poly l = if not (Classes.context poly l) then Feedback.feedback Feedback.AddedAxiom -let vernac_declare_instances locality ids pri = +let vernac_declare_instances locality insts = let glob = not (make_section_locality locality) in - List.iter (fun id -> Classes.existing_instance glob id pri) ids + List.iter (fun (id, info) -> Classes.existing_instance glob id (Some info)) insts let vernac_declare_class id = Record.declare_existing_class (Nametab.global id) @@ -953,148 +973,262 @@ let vernac_declare_implicits locality r l = let warn_arguments_assert = CWarnings.create ~name:"arguments-assert" ~category:"vernacular" (fun sr -> - strbrk "This command is just asserting the number and names of arguments of " ++ + strbrk "This command is just asserting the names of arguments of " ++ pr_global sr ++ strbrk". If this is what you want add " ++ strbrk "': assert' to silence the warning. If you want " ++ strbrk "to clear implicit arguments add ': clear implicits'. " ++ strbrk "If you want to clear notation scopes add ': clear scopes'") - - -let vernac_declare_arguments locality r l nargs flags = - let extra_scope_flag = List.mem `ExtraScopes flags in - let names = List.map (List.map (fun (id, _,_,_,_) -> id)) l in - let names, rest = List.hd names, List.tl names in - let scopes = List.map (List.map (fun (_,_, s, _,_) -> s)) l in - if List.exists (fun na -> not (List.equal Name.equal na names)) rest then - error "All arguments lists must declare the same names."; - if not (List.distinct_f Name.compare (List.filter ((!=) Anonymous) names)) - then error "Arguments names must be distinct."; - let sr = smart_global r in + +(* [nargs_for_red] is the number of arguments required to trigger reduction, + [args] is the main list of arguments statuses, + [more_implicits] is a list of extra lists of implicit statuses *) +let vernac_arguments locality reference args more_implicits nargs_for_red flags = + let assert_flag = List.mem `Assert flags in + let rename_flag = List.mem `Rename flags in + let clear_scopes_flag = List.mem `ClearScopes flags in + let extra_scopes_flag = List.mem `ExtraScopes flags in + let clear_implicits_flag = List.mem `ClearImplicits flags in + let default_implicits_flag = List.mem `DefaultImplicits flags in + let never_unfold_flag = List.mem `ReductionNeverUnfold flags in + + let err_incompat x y = + error ("Options \""^x^"\" and \""^y^"\" are incompatible.") in + + if assert_flag && rename_flag then + err_incompat "assert" "rename"; + if Option.has_some nargs_for_red && never_unfold_flag then + err_incompat "simpl never" "/"; + if never_unfold_flag && List.mem `ReductionDontExposeCase flags then + err_incompat "simpl never" "simpl nomatch"; + if clear_scopes_flag && extra_scopes_flag then + err_incompat "clear scopes" "extra scopes"; + if clear_implicits_flag && default_implicits_flag then + err_incompat "clear implicits" "default implicits"; + + let sr = smart_global reference in let inf_names = let ty = Global.type_of_global_unsafe sr in - Impargs.compute_implicits_names (Global.env ()) ty in - let rec check li ld ls = match li, ld, ls with - | [], [], [] -> () - | [], Anonymous::ld, (Some _)::ls when extra_scope_flag -> check li ld ls - | [], _::_, (Some _)::ls when extra_scope_flag -> - error "Extra notation scopes can be set on anonymous arguments only" - | [], x::_, _ -> errorlabstrm "vernac_declare_arguments" - (str "Extra argument " ++ pr_name x ++ str ".") - | l, [], _ -> errorlabstrm "vernac_declare_arguments" - (str "The following arguments are not declared: " ++ - prlist_with_sep pr_comma pr_name l ++ str ".") - | _::li, _::ld, _::ls -> check li ld ls - | _ -> assert false in - let () = match l with - | [[]] when List.exists ((<>) `Assert) flags -> () - | _ -> - List.iter2 (check inf_names) (names :: rest) scopes + Impargs.compute_implicits_names (Global.env ()) ty in - (* we take extra scopes apart, and we check they are consistent *) - let l, scopes = - let scopes, rest = List.hd scopes, List.tl scopes in - if List.exists (List.exists ((!=) None)) rest then - error "Notation scopes can be given only once"; - if not extra_scope_flag then l, scopes else - let l, _ = List.split (List.map (List.chop (List.length inf_names)) l) in - l, scopes in - (* we interpret _ as the inferred names *) - let l = match l with - | [[]] -> l - | _ -> - let name_anons = function - | (Anonymous, a,b,c,d), Name id -> Name id, a,b,c,d - | x, _ -> x in - List.map (fun ns -> List.map name_anons (List.combine ns inf_names)) l in - let names_decl = List.map (List.map (fun (id, _,_,_,_) -> id)) l in - let renamed_arg = ref None in - let set_renamed a b = - if Option.is_empty !renamed_arg && not (Id.equal a b) then renamed_arg := Some(b,a) in - let some_renaming_specified = - try - let names = Arguments_renaming.arguments_names sr in - not (List.equal (List.equal Name.equal) names names_decl) - with Not_found -> false in - let some_renaming_specified, implicits = - match l with - | [[]] -> false, [[]] + let prev_names = + try Arguments_renaming.arguments_names sr with Not_found -> inf_names + in + let num_args = List.length inf_names in + assert (Int.equal num_args (List.length prev_names)); + + let names_of args = List.map (fun a -> a.name) args in + + (* Checks *) + + let err_extra_args names = + errorlabstrm "vernac_declare_arguments" + (strbrk "Extra arguments: " ++ + prlist_with_sep pr_comma pr_name names ++ str ".") + in + let err_missing_args names = + errorlabstrm "vernac_declare_arguments" + (strbrk "The following arguments are not declared: " ++ + prlist_with_sep pr_comma pr_name names ++ str ".") + in + + let rec check_extra_args extra_args = + match extra_args with + | [] -> () + | { notation_scope = None } :: _ -> err_extra_args (names_of extra_args) + | { name = Anonymous; notation_scope = Some _ } :: args -> + check_extra_args args | _ -> - List.fold_map (fun sr il -> - let sr', impl = List.fold_map (fun b -> function - | (Anonymous, _,_, true, max), Name id -> assert false - | (Name x, _,_, true, _), Anonymous -> - errorlabstrm "vernac_declare_arguments" - (str "Argument " ++ pr_id x ++ str " cannot be declared implicit.") - | (Name iid, _,_, true, max), Name id -> - set_renamed iid id; - b || not (Id.equal iid id), Some (ExplByName id, max, false) - | (Name iid, _,_, _, _), Name id -> - set_renamed iid id; - b || not (Id.equal iid id), None - | _ -> b, None) - sr (List.combine il inf_names) in - sr || sr', List.map_filter (fun x -> x) impl) - some_renaming_specified l in - if some_renaming_specified then - if not (List.mem `Rename flags) then - errorlabstrm "vernac_declare_arguments" - (str "To rename arguments the \"rename\" flag must be specified." ++ - match !renamed_arg with - | None -> mt () - | Some (o,n) -> - str "\nArgument " ++ pr_id o ++ str " renamed to " ++ pr_id n ++ str ".") - else - Arguments_renaming.rename_arguments - (make_section_locality locality) sr names_decl; - (* All other infos are in the first item of l *) - let l = List.hd l in - let some_implicits_specified = match implicits with - | [[]] -> false | _ -> true in - let scopes = List.map (function - | None -> None - | Some (o, k) -> - try ignore (Notation.find_scope k); Some k - with UserError _ -> - Some (Notation.find_delimiters_scope o k)) scopes + error "Extra notation scopes can be set on anonymous and explicit arguments only." + in + + let args, scopes = + let scopes = List.map (fun { notation_scope = s } -> s) args in + if List.length args > num_args then + let args, extra_args = List.chop num_args args in + if extra_scopes_flag then + (check_extra_args extra_args; (args, scopes)) + else err_extra_args (names_of extra_args) + else args, scopes in - let some_scopes_specified = List.exists ((!=) None) scopes in + + if Option.cata (fun n -> n > num_args) false nargs_for_red then + error "The \"/\" modifier should be put before any extra scope."; + + let scopes_specified = List.exists Option.has_some scopes in + + if scopes_specified && clear_scopes_flag then + error "The \"clear scopes\" flag is incompatible with scope annotations."; + + let names = List.map (fun { name } -> name) args in + let names = names :: List.map (List.map fst) more_implicits in + + let rename_flag_required = ref false in + let example_renaming = ref None in + let save_example_renaming renaming = + rename_flag_required := !rename_flag_required + || not (Name.equal (fst renaming) Anonymous); + if Option.is_empty !example_renaming then + example_renaming := Some renaming + in + + let rec names_union names1 names2 = + match names1, names2 with + | [], [] -> [] + | _ :: _, [] -> names1 + | [], _ :: _ -> names2 + | (Name _ as name) :: names1, Anonymous :: names2 + | Anonymous :: names1, (Name _ as name) :: names2 -> + name :: names_union names1 names2 + | name1 :: names1, name2 :: names2 -> + if Name.equal name1 name2 then + name1 :: names_union names1 names2 + else error "Argument lists should agree on the names they provide." + in + + let names = List.fold_left names_union [] names in + + let rec rename prev_names names = + match prev_names, names with + | [], [] -> [] + | [], _ :: _ -> err_extra_args names + | _ :: _, [] when assert_flag -> + (* Error messages are expressed in terms of original names, not + renamed ones. *) + err_missing_args (List.lastn (List.length prev_names) inf_names) + | _ :: _, [] -> prev_names + | prev :: prev_names, Anonymous :: names -> + prev :: rename prev_names names + | prev :: prev_names, (Name id as name) :: names -> + if not (Name.equal prev name) then save_example_renaming (prev,name); + name :: rename prev_names names + in + + let names = rename prev_names names in + let renaming_specified = Option.has_some !example_renaming in + + if !rename_flag_required && not rename_flag then + errorlabstrm "vernac_declare_arguments" + (strbrk "To rename arguments the \"rename\" flag must be specified." + ++ spc () ++ + match !example_renaming with + | None -> mt () + | Some (o,n) -> + str "Argument " ++ pr_name o ++ + str " renamed to " ++ pr_name n ++ str "."); + + let duplicate_names = + List.duplicates Name.equal (List.filter ((!=) Anonymous) names) + in + if not (List.is_empty duplicate_names) then begin + let duplicates = prlist_with_sep pr_comma pr_name duplicate_names in + errorlabstrm "_" (strbrk "Some argument names are duplicated: " ++ duplicates) + end; + + (* Parts of this code are overly complicated because the implicit arguments + API is completely crazy: positions (ExplByPos) are elaborated to + names. This is broken by design, since not all arguments have names. So + even though we eventually want to map only positions to implicit statuses, + we have to check whether the corresponding arguments have names, not to + trigger an error in the impargs code. Even better, the names we have to + check are not the current ones (after previous renamings), but the original + ones (inferred from the type). *) + + let implicits = + List.map (fun { name; implicit_status = i } -> (name,i)) args + in + let implicits = implicits :: more_implicits in + + let open Vernacexpr in + let rec build_implicits inf_names implicits = + match inf_names, implicits with + | _, [] -> [] + | _ :: inf_names, (_, NotImplicit) :: implicits -> + build_implicits inf_names implicits + + (* With the current impargs API, it is impossible to make an originally + anonymous argument implicit *) + | Anonymous :: _, (name, _) :: _ -> + errorlabstrm "vernac_declare_arguments" + (strbrk"Argument "++ pr_name name ++ + strbrk " cannot be declared implicit.") + + | Name id :: inf_names, (name, impl) :: implicits -> + let max = impl = MaximallyImplicit in + (ExplByName id,max,false) :: build_implicits inf_names implicits + + | _ -> assert false (* already checked in [names_union] *) + in + + let implicits = List.map (build_implicits inf_names) implicits in + let implicits_specified = match implicits with [[]] -> false | _ -> true in + + if implicits_specified && clear_implicits_flag then + error "The \"clear implicits\" flag is incompatible with implicit annotations"; + + if implicits_specified && default_implicits_flag then + error "The \"default implicits\" flag is incompatible with implicit annotations"; + let rargs = Util.List.map_filter (function (n, true) -> Some n | _ -> None) - (Util.List.map_i (fun i (_, b, _,_,_) -> i, b) 0 l) in - if some_scopes_specified || List.mem `ClearScopes flags then - vernac_arguments_scope locality r scopes; - if not some_implicits_specified && List.mem `DefaultImplicits flags then - vernac_declare_implicits locality r [] - else if some_implicits_specified || List.mem `ClearImplicits flags then - vernac_declare_implicits locality r implicits; - if nargs >= 0 && nargs <= List.fold_left max ~-1 rargs then - error "The \"/\" option must be placed after the last \"!\"."; - let no_flags = List.is_empty flags in + (Util.List.map_i (fun i { recarg_like = b } -> i, b) 0 args) + in + let rec narrow = function | #Reductionops.ReductionBehaviour.flag as x :: tl -> x :: narrow tl - | [] -> [] | _ :: tl -> narrow tl in - let flags = narrow flags in - let some_simpl_flags_specified = - not (List.is_empty rargs) || nargs >= 0 || not (List.is_empty flags) in - if some_simpl_flags_specified then begin + | [] -> [] | _ :: tl -> narrow tl + in + let red_flags = narrow flags in + let red_modifiers_specified = + not (List.is_empty rargs) || Option.has_some nargs_for_red + || not (List.is_empty red_flags) + in + + if not (List.is_empty rargs) && never_unfold_flag then + err_incompat "simpl never" "!"; + + + (* Actions *) + + if renaming_specified then begin + let local = make_section_locality locality in + Arguments_renaming.rename_arguments local sr names + end; + + if scopes_specified || clear_scopes_flag then begin + let scopes = List.map (Option.map (fun (o,k) -> + try ignore (Notation.find_scope k); k + with UserError _ -> + Notation.find_delimiters_scope o k)) scopes + in + vernac_arguments_scope locality reference scopes + end; + + if implicits_specified || clear_implicits_flag then + vernac_declare_implicits locality reference implicits; + + if default_implicits_flag then + vernac_declare_implicits locality reference []; + + if red_modifiers_specified then begin match sr with | ConstRef _ as c -> Reductionops.ReductionBehaviour.set - (make_section_locality locality) c (rargs, nargs, flags) - | _ -> errorlabstrm "" (strbrk "Modifiers of the behavior of the simpl tactic are relevant for constants only.") + (make_section_locality locality) c + (rargs, Option.default ~-1 nargs_for_red, red_flags) + | _ -> errorlabstrm "" + (strbrk "Modifiers of the behavior of the simpl tactic "++ + strbrk "are relevant for constants only.") end; - if not (some_renaming_specified || - some_implicits_specified || - some_scopes_specified || - some_simpl_flags_specified) && - no_flags then - warn_arguments_assert sr + if not (renaming_specified || + implicits_specified || + scopes_specified || + red_modifiers_specified) && (List.is_empty flags) then + warn_arguments_assert sr let default_env () = { Notation_term.ninterp_var_type = Id.Map.empty; ninterp_rec_vars = Id.Map.empty; - ninterp_only_parse = false; } let vernac_reserve bl = @@ -1103,7 +1237,7 @@ let vernac_reserve bl = let sigma = Evd.from_env env in let t,ctx = Constrintern.interp_type env sigma c in let t = Detyping.detype false [] env (Evd.from_ctx ctx) t in - let t = Notation_ops.notation_constr_of_glob_constr (default_env ()) t in + let t,_ = Notation_ops.notation_constr_of_glob_constr (default_env ()) t in Reserve.declare_reserved_type idl t) in List.iter sb_decl bl @@ -1360,7 +1494,7 @@ let _ = optwrite = (fun b -> Constrintern.parsing_explicit := b) } let _ = - declare_string_option + declare_string_option ~preprocess:CWarnings.normalize_flags_string { optsync = true; optdepr = false; optname = "warnings display"; @@ -1397,6 +1531,9 @@ let vernac_set_option locality key = function | IntValue n -> set_int_option_value_gen locality key n | BoolValue b -> set_bool_option_value_gen locality key b +let vernac_set_append_option locality key s = + set_string_option_append_value_gen locality key s + let vernac_unset_option locality key = unset_option_value_gen locality key @@ -1436,7 +1573,7 @@ let get_current_context_of_args = function let vernac_check_may_eval redexp glopt rc = let (sigma, env) = get_current_context_of_args glopt in let sigma', c = interp_open_constr env sigma rc in - let sigma' = Evarconv.consider_remaining_unif_problems env sigma' in + let sigma' = Evarconv.solve_unif_constraints_with_heuristics env sigma' in Evarconv.check_problems_are_solved env sigma'; let sigma',nf = Evarutil.nf_evars_and_universes sigma' in let pl, uctx = Evd.universe_context sigma' in @@ -1604,6 +1741,28 @@ let interp_search_about_item env = errorlabstrm "interp_search_about_item" (str "Unable to interp \"" ++ str s ++ str "\" either as a reference or as an identifier component") +(* 05f22a5d6d5b8e3e80f1a37321708ce401834430 introduced the + `search_output_name_only` option to avoid excessive printing when + searching. + + The motivation was to make search usable for IDE completion, + however, it is still too slow due to the non-indexed nature of the + underlying search mechanism. + + In the future we should deprecate the option and provide a fast, + indexed name-searching interface. +*) +let search_output_name_only = ref false + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "output-name-only search"; + optkey = ["Search";"Output";"Name";"Only"]; + optread = (fun () -> !search_output_name_only); + optwrite = (:=) search_output_name_only } + let vernac_search s gopt r = let r = interp_search_restriction r in let env,gopt = @@ -1615,16 +1774,25 @@ let vernac_search s gopt r = | Some g -> snd (Pfedit.get_goal_context g) , Some g in let get_pattern c = snd (intern_constr_pattern env c) in - let open Feedback in + let pr_search ref env c = + let pr = pr_global ref in + let pp = if !search_output_name_only + then pr + else begin + let pc = pr_lconstr_env env Evd.empty c in + hov 2 (pr ++ str":" ++ spc () ++ pc) + end + in Feedback.msg_notice pp + in match s with | SearchPattern c -> - msg_notice (Search.search_pattern gopt (get_pattern c) r) + Search.search_pattern gopt (get_pattern c) r pr_search | SearchRewrite c -> - msg_notice (Search.search_rewrite gopt (get_pattern c) r) + Search.search_rewrite gopt (get_pattern c) r pr_search | SearchHead c -> - msg_notice (Search.search_by_head gopt (get_pattern c) r) + Search.search_by_head gopt (get_pattern c) r pr_search | SearchAbout sl -> - msg_notice (Search.search_about gopt (List.map (on_snd (interp_search_about_item env)) sl) r) + Search.search_about gopt (List.map (on_snd (interp_search_about_item env)) sl) r pr_search let vernac_locate = let open Feedback in function | LocateAny (AN qid) -> msg_notice (print_located_qualid qid) @@ -1741,6 +1909,10 @@ let vernac_check_guard () = exception End_of_input let vernac_load interp fname = + let interp x = + let proof_mode = Proof_global.get_default_proof_mode_name () in + Proof_global.activate_proof_mode proof_mode; + interp x in let parse_sentence = Flags.with_option Flags.we_are_parsing (fun po -> match Pcoq.Gram.entry_parse Pcoq.main_entry po with @@ -1752,7 +1924,7 @@ let vernac_load interp fname = let input = let longfname = Loadpath.locate_file fname in let in_chan = open_utf8_file_in longfname in - Pcoq.Gram.parsable (Stream.of_channel in_chan) in + Pcoq.Gram.parsable ~file:longfname (Stream.of_channel in_chan) in try while true do interp (snd (parse_sentence input)) done with End_of_input -> () @@ -1824,10 +1996,10 @@ let interp ?proof ~loc locality poly c = vernac_identity_coercion locality poly local id s t (* Type classes *) - | VernacInstance (abst, sup, inst, props, pri) -> - vernac_instance abst locality poly sup inst props pri + | VernacInstance (abst, sup, inst, props, info) -> + vernac_instance abst locality poly sup inst props info | VernacContext sup -> vernac_context poly sup - | VernacDeclareInstances (ids, pri) -> vernac_declare_instances locality ids pri + | VernacDeclareInstances insts -> vernac_declare_instances locality insts | VernacDeclareClass id -> vernac_declare_class id (* Solving *) @@ -1859,13 +2031,14 @@ let interp ?proof ~loc locality poly c = vernac_syntactic_definition locality id c local b | VernacDeclareImplicits (qid,l) -> vernac_declare_implicits locality qid l - | VernacArguments (qid, l, narg, flags) -> - vernac_declare_arguments locality qid l narg flags + | VernacArguments (qid, args, more_implicits, nargs, flags) -> + vernac_arguments locality qid args more_implicits nargs flags | VernacReserve bl -> vernac_reserve bl | VernacGeneralizable gen -> vernac_generalizable locality gen | VernacSetOpacity qidl -> vernac_set_opacity locality qidl | VernacSetStrategy l -> vernac_set_strategy locality l | VernacSetOption (key,v) -> vernac_set_option locality key v + | VernacSetAppendOption (key,v) -> vernac_set_append_option locality key v | VernacUnsetOption key -> vernac_unset_option locality key | VernacRemoveOption (key,v) -> vernac_remove_option key v | VernacAddOption (key,v) -> vernac_add_option key v @@ -1938,7 +2111,7 @@ let check_vernac_supports_locality c l = | VernacArgumentsScope _ | VernacDeclareImplicits _ | VernacArguments _ | VernacGeneralizable _ | VernacSetOpacity _ | VernacSetStrategy _ - | VernacSetOption _ | VernacUnsetOption _ + | VernacSetOption _ | VernacSetAppendOption _ | VernacUnsetOption _ | VernacDeclareReduction _ | VernacExtend _ | VernacInductive _) -> () @@ -1962,7 +2135,7 @@ let enforce_polymorphism = function | None -> Flags.is_universe_polymorphism () | Some b -> Flags.make_polymorphic_flag b; b -(** A global default timeout, controled by option "Set Default Timeout n". +(** 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 |