diff options
357 files changed, 6209 insertions, 4489 deletions
diff --git a/.gitignore b/.gitignore index 4127ac649c..56e1905981 100644 --- a/.gitignore +++ b/.gitignore @@ -44,7 +44,6 @@ TAGS .pc bin/ _build -plugins/*/*_mod.ml myocamlbuild_config.ml config/Makefile config/coq_config.ml @@ -112,24 +111,23 @@ tools/coqwc.ml tools/coqdep_lexer.ml tools/ocamllibdep.ml tools/coqdoc/cpretty.ml -lib/xml_lexer.ml +ide/xml_lexer.ml -# .ml4 files +# .ml4 / .mlp files g_*.ml ide/project_file.ml parsing/compat.ml grammar/q_util.ml -grammar/q_constr.ml grammar/tacextend.ml grammar/vernacextend.ml grammar/argextend.ml parsing/cLexer.ml -tactics/hipattern.ml ltac/coretactics.ml ltac/extratactics.ml ltac/extraargs.ml +ltac/profile_ltac_tactics.ml ide/coqide_main.ml # other auto-generated files @@ -140,6 +138,10 @@ tools/tolink.ml theories/Numbers/Natural/BigN/NMake_gen.v ide/index_urls.txt lia.cache +checker/names.ml +checker/names.mli +checker/esubst.ml +checker/esubst.mli # mlis documentation @@ -157,3 +159,4 @@ dev/myinclude /doc/refman/Reference-Manual.hoptind /doc/refman/Reference-Manual.optidx /doc/refman/Reference-Manual.optind +user-contrib @@ -18,6 +18,9 @@ Tactics - Every generic argument type declares a tactic scope of the form "name:(...)" where name is the name of the argument. This generalizes the constr: and ltac: instances. +- When in strict mode (i.e. in a Ltac definition) the "intro" tactic cannot use + a locally free identifier anymore. It must use e.g. the "fresh" primitive + instead (potential source of incompatibilities). Program @@ -28,13 +31,21 @@ Notations - "Bind Scope" can once again bind "Funclass" and "Sortclass". +Tools + +- coqc accepts a -o option to specify the output file name + Changes from V8.5pl1 to V8.5pl2 =============================== Bugfixes -- #4677: fix alpha-conversion in notations needing eta-expansion +- #4677: fix alpha-conversion in notations needing eta-expansion. - Fully preserve initial order of hypotheses in "Regular Subst Tactic" mode. +- #4644: a regression in unification. +- #4777: printing inefficiency with implicit arguments +- #4752: CoqIDE crash on files not ended by ".v". +- #4398: type_scope used consistently in "match goal". Changes from V8.5 to V8.5pl1 ============================ diff --git a/COMPATIBILITY b/COMPATIBILITY index ab29903b93..883b8576d2 100644 --- a/COMPATIBILITY +++ b/COMPATIBILITY @@ -1,6 +1,43 @@ Potential sources of incompatibilities between Coq V8.4 and V8.5 ---------------------------------------------------------------- +* List of typical changes to be done to adapt files from Coq 8.4 * +* to Coq 8.5 when not using compatibility option "-compat 8.4". * + +Symptom: "The reference omega was not found in the current environment". +Cause: "Require Omega" does not import the tactic "omega" any more +Possible solutions: +- use "Require Import OmegaTactic" (not compatible with 8.4) +- use "Require Import Omega" (compatible with 8.4) +- add definition "Ltac omega := Coq.omega.Omega.omega." + +Symptom: "intuition" cannot solve a goal (not working anymore on non standard connective) +Cause: "intuition" had an accidental non uniform behavior fixed on non standard connectives +Possible solutions: +- use "dintuition" instead; it is stronger than "intuition" and works + uniformly on non standard connectives, such as n-ary conjunctions or disjunctions + (not compatible with 8.4) +- do the script differently + +Symptom: The constructor foo (in type bar) expects n arguments. +Cause: parameters must now be given in patterns +Possible solutions: +- use option "Set Asymmetric Patterns" (compatible with 8.4) +- add "_" for the parameters (not compatible with 8.4) +- turn the parameters into implicit arguments (compatible with 8.4) + +Symptom: "NPeano.Nat.foo" not existing anymore +Possible solutions: +- use "Nat.foo" instead + +Symptom: typing problems with proj1_sig or similar +Cause: coercion from sig to sigT and similar coercions have been + removed so as to make the initial state easier to understand for + beginners +Solution: change proj1_sig into projT1 and similarly (compatible with 8.4) + +* Other detailed changes * + (see also file CHANGES) - options for *coq* compilation (see below for ocaml). @@ -30,7 +67,6 @@ Potential sources of incompatibilities between Coq V8.4 and V8.5 for more details: file CHANGES or section "Customization at launch time" of the reference manual. - - Universe Polymorphism. diff --git a/INSTALL.ide b/INSTALL.ide index b651e77db4..cb7ca325f7 100644 --- a/INSTALL.ide +++ b/INSTALL.ide @@ -22,7 +22,7 @@ Else, read the rest of this document to compile your own CoqIde. COMPILATION REQUIREMENTS -- OCaml >= 3.12.1 with native threads support. +- OCaml >= 4.01 with native threads support. - make world must succeed. - The graphical toolkit GTK+ 2.x. See http://www.gtk.org. The official supported version is at least 2.24.x. @@ -63,15 +63,10 @@ define findx $(shell find . $(FIND_VCS_CLAUSE) '(' -name $(1) ')' -exec $(2) {} \; | sed 's|^\./||') endef -# We now discriminate .ml4 files according to their need of grammar.cma -# or q_constr.cmo -USEGRAMMAR := '(\*.*camlp4deps.*grammar' - ## Files in the source tree LEXFILES := $(call find, '*.mll') -export MLLIBFILES := $(call find, '*.mllib') -export ML4BASEFILES := $(call findx, '*.ml4', grep -L -e $(USEGRAMMAR)) +export MLLIBFILES := $(call find, '*.mllib') $(call find, '*.mlpack') export ML4FILES := $(call find, '*.ml4') export CFILES := $(call find, '*.c') @@ -85,9 +80,7 @@ EXISTINGMLI := $(call find, '*.mli') ## Files that will be generated GENML4FILES:= $(ML4FILES:.ml4=.ml) -GENPLUGINSMOD:=$(filter plugins/%,$(MLLIBFILES:%.mllib=%_mod.ml)) -export GENMLFILES:=$(LEXFILES:.mll=.ml) $(GENPLUGINSMOD) \ - tools/tolink.ml kernel/copcodes.ml +export GENMLFILES:=$(LEXFILES:.mll=.ml) tools/tolink.ml kernel/copcodes.ml export GENHFILES:=kernel/byterun/coq_jumptbl.h export GENVFILES:=theories/Numbers/Natural/BigN/NMake_gen.v export GENFILES:=$(GENMLFILES) $(GENMLIFILES) $(GENHFILES) $(GENVFILES) @@ -150,10 +143,7 @@ endif MAKE_OPTS := --warn-undefined-variable --no-builtin-rules -GRAM_TARGETS := grammar/grammar.cma grammar/q_constr.cmo - submake: - $(MAKE) $(MAKE_OPTS) -f Makefile.build BUILDGRAMMAR=1 $(GRAM_TARGETS) $(MAKE) $(MAKE_OPTS) -f Makefile.build $(MAKECMDGOALS) noconfig: @@ -161,7 +151,7 @@ noconfig: # To speed-up things a bit, let's dissuade make to attempt rebuilding makefiles -Makefile Makefile.build Makefile.common config/Makefile : ; +Makefile $(wildcard Makefile.*) config/Makefile : ; ########################################################################### # Cleaning @@ -181,7 +171,7 @@ cruftclean: ml4clean indepclean: rm -f $(GENFILES) - rm -f $(COQTOPBYTE) $(CHICKENBYTE) $(FAKEIDE) + rm -f $(COQTOPBYTE) $(CHICKENBYTE) find . \( -name '*~' -o -name '*.cm[ioat]' -o -name '*.cmti' \) -delete rm -f */*.pp[iox] plugins/*/*.pp[iox] rm -rf $(SOURCEDOCDIR) @@ -214,8 +204,8 @@ archclean: clean-ide optclean voclean rm -f $(ALLSTDLIB).* optclean: - rm -f $(COQTOPEXE) $(COQMKTOP) $(COQC) $(CHICKEN) $(COQDEPBOOT) - rm -f $(TOOLS) $(CSDPCERT) + rm -f $(COQTOPEXE) $(COQMKTOP) $(CHICKEN) + rm -f $(TOOLS) $(PRIVATEBINARIES) $(CSDPCERT) find . -name '*.cmx' -o -name '*.cmxs' -o -name '*.cmxa' -o -name '*.[soa]' -o -name '*.so' | xargs rm -f clean-ide: @@ -244,6 +234,7 @@ distclean: clean cleanconfig cacheclean voclean: find theories plugins test-suite \( -name '*.vo' -o -name '*.glob' -o -name "*.cmxs" -o -name "*.native" -o -name "*.cmx" -o -name "*.cmi" -o -name "*.o" \) -delete + find theories plugins test-suite -name .coq-native -empty -delete devdocclean: find . -name '*.dep.ps' -o -name '*.dot' | xargs rm -f diff --git a/Makefile.build b/Makefile.build index 190a62d000..4eafe1d619 100644 --- a/Makefile.build +++ b/Makefile.build @@ -10,45 +10,48 @@ # some variables. ########################################################################### -# Starting rule +# Default starting rule ########################################################################### -# build the different subsystems: coq, coqide -world: revision coq coqide documentation +# build the different subsystems: -.PHONY: world +world: coq coqide documentation revision + +coq: coqlib coqbinaries tools printers + +.PHONY: world coq ########################################################################### # Includes ########################################################################### +# This list of ml files used to be in the main Makefile, we moved it here +# to avoid exhausting the variable env in Win32 +MLFILES := $(MLSTATICFILES) $(GENMLFILES) $(ML4FILES:.ml4=.ml) + include Makefile.common -include Makefile.doc +include Makefile.doc ## provides the 'documentation' rule +include Makefile.checker +include Makefile.ide ## provides the 'coqide' rule +include Makefile.install +include Makefile.dev ## provides the 'printers' and 'revision' rules -# In a first phase, we restrict to the basic .ml4 (the ones without grammar.cma) +# This include below will lauch the build of all .d. +# The - at front is for disabling warnings about currently missing ones. +# For creating the missing .d, make will recursively build things like +# coqdep_boot (for the .v.d files) or grammar.cma (for .ml4 -> .ml -> .ml.d). -ifdef BUILDGRAMMAR - MLFILES := $(MLSTATICFILES) $(GENMLFILES) $(ML4BASEFILES:.ml4=.ml) - CURFILES := $(MLFILES) $(MLIFILES) $(ML4BASEFILES) grammar/grammar.mllib -else - MLFILES := $(MLSTATICFILES) $(GENMLFILES) $(ML4FILES:.ml4=.ml) - CURFILES := $(MLFILES) $(MLIFILES) $(ML4FILES) $(MLLIBFILES) $(CFILES) $(VFILES) -endif +DEPENDENCIES := \ + $(addsuffix .d, $(MLFILES) $(MLIFILES) $(MLLIBFILES) $(CFILES) $(VFILES)) -CURDEPS:=$(addsuffix .d, $(CURFILES)) +-include $(DEPENDENCIES) # All dependency includes must be declared secondary, otherwise make will # delete them if it decided to build them by dependency instead of because # of include, and they will then be automatically deleted, leading to an # infinite loop. -.SECONDARY: $(CURDEPS) $(GENFILES) $(ML4FILES:.ml4=.ml) - -# This include below will lauch the build of all concerned .d. -# The - at front is for disabling warnings about currently missing ones. - --include $(CURDEPS) - +.SECONDARY: $(DEPENDENCIES) $(GENFILES) $(ML4FILES:.ml4=.ml) ########################################################################### # Compilation options @@ -62,7 +65,6 @@ NO_RECALC_DEPS= READABLE_ML4= # non-empty means .ml of .ml4 will be ascii instead of binary VALIDATE= COQ_XML= # is "-xml" when building XML library -VM= # is "-no-vm" to not use the vm" TIMED= # non-empty will activate a default time command # when compiling .v (see $(STDTIME) below) @@ -81,7 +83,7 @@ TIMECMD= # if you prefer a specific time command instead of $(STDTIME) STDTIME=/usr/bin/time -f "$* (user: %U mem: %M ko)" TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD)) -COQOPTS=$(COQ_XML) $(VM) $(NATIVECOMPUTE) +COQOPTS=$(COQ_XML) $(NATIVECOMPUTE) BOOTCOQC=$(TIMER) $(COQTOPEXE) -boot $(COQOPTS) -compile # The SHOW and HIDE variables control whether make will echo complete commands @@ -101,23 +103,42 @@ BYTEFLAGS=-thread $(CAMLDEBUG) $(USERFLAGS) OPTFLAGS=-thread $(CAMLDEBUGOPT) $(CAMLTIMEPROF) $(USERFLAGS) DEPFLAGS= $(LOCALINCLUDES) -I ide -I ide/utils +# On MacOS, the binaries are signed, except our private ones ifeq ($(shell which codesign > /dev/null 2>&1 && echo $(ARCH)),Darwin) -LINKMETADATA=-ccopt "-sectcreate __TEXT __info_plist config/Info-$(notdir $@).plist" -CODESIGN:=codesign -s - +LINKMETADATA=$(if $(filter $(PRIVATEBINARIES),$@),,-ccopt "-sectcreate __TEXT __info_plist config/Info-$(notdir $@).plist") +CODESIGN=$(if $(filter $(PRIVATEBINARIES),$@),true,codesign -s -) else LINKMETADATA= -CODESIGN:=true +CODESIGN=true endif +# Best OCaml compiler, used in a generic way + +ifeq ($(BEST),opt) +OPT:=opt +BESTOBJ:=.cmx +BESTLIB:=.cmxa +BESTDYN:=.cmxs +else +OPT:= +BESTOBJ:=.cmo +BESTLIB:=.cma +BESTDYN:=.cma +endif + +define bestobj +$(patsubst %.cma,%$(BESTLIB),$(patsubst %.cmo,%$(BESTOBJ),$(1))) +endef + define bestocaml $(if $(OPT),\ -$(if $(findstring $@,$(PRIVATEBINARIES)),\ - $(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) -o $@ $(1) $(addsuffix .cmxa,$(2)) $^ && $(STRIP) $@,\ - $(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) $(LINKMETADATA) -o $@ $(1) $(addsuffix .cmxa,$(2)) $^ && $(STRIP) $@ && $(CODESIGN) $@),\ +$(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) $(LINKMETADATA) -o $@ $(1) $(addsuffix .cmxa,$(2)) $^ && $(STRIP) $@ && $(CODESIGN) $@,\ $(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) $(CUSTOM) -o $@ $(1) $(addsuffix .cma,$(2)) $^) endef -CAMLP4DEPS=$(shell LC_ALL=C sed -n -e 's@^(\*.*camlp4deps: "\(.*\)".*@\1@p' $(1) \#)) +# Camlp4 / Camlp5 settings + +CAMLP4DEPS:=tools/compat5.cmo grammar/grammar.cma ifeq ($(CAMLP4),camlp5) CAMLP4USE=pa_extend.cmo q_MLast.cmo pa_macro.cmo -D$(CAMLVERSION) else @@ -139,7 +160,6 @@ else P4CMA:=camlp4lib.cma endif - ########################################################################### # Infrastructure for the rest of the Makefile ########################################################################### @@ -180,13 +200,11 @@ endif TOTARGET = > "$@" || (RV=$$?; rm -f "$@"; exit $${RV}) ########################################################################### -# Compilation option for .c files +# Compilation of .c files ########################################################################### CINCLUDES= -I $(CAMLHLIB) -# libcoqrun.a, dllcoqrun.so - # NB: We used to do a ranlib after ocamlmklib, but it seems that # ocamlmklib is already doing it @@ -194,7 +212,6 @@ $(LIBCOQRUN): kernel/byterun/coq_jumptbl.h $(BYTERUN) cd $(dir $(LIBCOQRUN)) && \ $(OCAMLFIND) ocamlmklib -oc $(COQRUN) $(foreach u,$(BYTERUN),$(notdir $(u))) -#coq_jumptbl.h is required only if you have GCC 2.0 or later kernel/byterun/coq_jumptbl.h : kernel/byterun/coq_instruct.h sed -n -e '/^ /s/ \([A-Z]\)/ \&\&coq_lbl_\1/gp' \ -e '/^}/q' $< $(TOTARGET) @@ -203,29 +220,96 @@ kernel/copcodes.ml: kernel/byterun/coq_instruct.h sed -n -e '/^enum/p' -e 's/,//g' -e '/^ /p' $< | \ awk -f kernel/make-opcodes $(TOTARGET) +%.o: %.c + $(SHOW)'OCAMLC $<' + $(HIDE)cd $(dir $<) && $(OCAMLC) -ccopt "$(CFLAGS)" -c $(notdir $<) + +%_stubs.c.d: $(D_DEPEND_BEFORE_SRC) %_stubs.c $(D_DEPEND_AFTER_SRC) + $(SHOW)'CCDEP $<' + $(HIDE)echo "$@ $(@:.c.d=.o): $(@:.c.d=.c)" > $@ + +%.c.d: $(D_DEPEND_BEFORE_SRC) %.c $(D_DEPEND_AFTER_SRC) $(GENHFILES) + $(SHOW)'CCDEP $<' + $(HIDE)$(OCAMLC) -ccopt "-MM -MQ $@ -MQ $(<:.c=.o) -isystem $(CAMLHLIB)" $< $(TOTARGET) + ########################################################################### -# Main targets (coqmktop, coqtop.opt, coqtop.byte) +# grammar/grammar.cma ########################################################################### -.PHONY: coqbinaries coq coqlib coqlight states +## In this part, we compile grammar/grammar.cma +## without relying on .d dependency files, for bootstraping the creation +## and inclusion of these .d files -coqbinaries: ${COQBINARIES} ${CSDPCERT} ${FAKEIDE} +## Explicit dependencies for grammar stuff -coq: coqlib tools coqbinaries +GRAMBASEDEPS := grammar/gramCompat.cmo grammar/q_util.cmi +GRAMCMO := grammar/gramCompat.cmo grammar/q_util.cmo \ + grammar/argextend.cmo grammar/tacextend.cmo grammar/vernacextend.cmo -coqlib: theories plugins +grammar/q_util.cmi : grammar/gramCompat.cmo +grammar/argextend.cmo : $(GRAMBASEDEPS) +grammar/q_util.cmo : $(GRAMBASEDEPS) +grammar/tacextend.cmo : $(GRAMBASEDEPS) grammar/argextend.cmo +grammar/vernacextend.cmo : $(GRAMBASEDEPS) grammar/tacextend.cmo \ + grammar/argextend.cmo + +## Ocaml compiler with the right options and -I for grammar + +GRAMC := $(OCAMLFIND) ocamlc $(CAMLFLAGS) $(CAMLDEBUG) $(USERFLAGS) \ + -I $(MYCAMLP4LIB) -I grammar + +## Specific rules for grammar.cma -coqlight: theories-light tools coqbinaries +grammar/grammar.cma : $(GRAMCMO) + $(SHOW)'Testing $@' + @touch grammar/test.mlp + $(HIDE)$(GRAMC) -pp '$(CAMLP4O) -I $(MYCAMLP4LIB) $^ -impl' -impl grammar/test.mlp -o grammar/test + @rm -f grammar/test.* grammar/test + $(SHOW)'OCAMLC -a $@' + $(HIDE)$(GRAMC) $^ -linkall -a -o $@ -states: theories/Init/Prelude.vo +## Support of Camlp5 and Camlp5 + +# NB: compatibility modules for camlp4: +# - tools/compat5.cmo changes GEXTEND into EXTEND. Safe, always loaded +# - tools/compat5b.cmo changes EXTEND into EXTEND Gram. Interact badly with +# syntax such that VERNAC EXTEND, we only load it in grammar/ + +ifeq ($(CAMLP4),camlp4) + COMPATCMO:=tools/compat5.cmo tools/compat5b.cmo + GRAMP4USE:=$(COMPATCMO) -D$(CAMLVERSION) + GRAMPP:=$(CAMLP4O) -I $(MYCAMLP4LIB) $(GRAMP4USE) $(CAMLP4COMPAT) -impl +else + COMPATCMO:= + GRAMP4USE:=$(COMPATCMO) pa_extend.cmo q_MLast.cmo pa_macro.cmo -D$(CAMLVERSION) + GRAMPP:=$(CAMLP4O) -I $(MYCAMLP4LIB) $(GRAMP4USE) $(CAMLP4COMPAT) -impl +endif + +## Rules for standard .mlp and .mli files in grammar/ + +grammar/%.cmo: grammar/%.mlp | $(COMPATCMO) + $(SHOW)'OCAMLC -c -pp $<' + $(HIDE)$(GRAMC) -c -pp '$(GRAMPP)' -impl $< + +grammar/%.cmi: grammar/%.mli + $(SHOW)'OCAMLC -c $<' + $(HIDE)$(GRAMC) -c $< + + +########################################################################### +# Main targets (coqmktop, coqtop.opt, coqtop.byte) +########################################################################### + +.PHONY: coqbinaries + +coqbinaries: $(COQMKTOP) $(COQTOPEXE) $(COQTOPBYTE) \ + $(CHICKEN) $(CHICKENBYTE) $(CSDPCERT) $(FAKEIDE) -miniopt: $(COQTOPEXE) pluginsopt -minibyte: $(COQTOPBYTE) pluginsbyte ifeq ($(BEST),opt) $(COQTOPEXE): $(COQMKTOP) $(LINKCMX) $(LIBCOQRUN) $(TOPLOOPCMA:.cma=.cmxs) $(SHOW)'COQMKTOP -o $@' - $(HIDE)$(COQMKTOP) -boot -opt $(OPTFLAGS) $(LINKMETADATA) -thread -o $@ + $(HIDE)$(COQMKTOP) -boot -opt $(OPTFLAGS) $(LINKMETADATA) -o $@ $(STRIP) $@ $(CODESIGN) $@ else @@ -235,28 +319,13 @@ endif $(COQTOPBYTE): $(COQMKTOP) $(LINKCMO) $(LIBCOQRUN) $(TOPLOOPCMA) $(SHOW)'COQMKTOP -o $@' - $(HIDE)$(COQMKTOP) -boot -top $(BYTEFLAGS) -thread -o $@ + $(HIDE)$(COQMKTOP) -boot -top $(BYTEFLAGS) -o $@ -LOCALCHKLIBS:=$(addprefix -I , $(CHKSRCDIRS) ) -CHKLIBS:=$(LOCALCHKLIBS) -I $(MYCAMLP4LIB) - -ifeq ($(BEST),opt) -$(CHICKEN): checker/check.cmxa checker/main.ml - $(SHOW)'OCAMLOPT -o $@' - $(HIDE)$(OCAMLOPT) $(CHKLIBS) $(OPTFLAGS) $(LINKMETADATA) -thread -o $@ $(SYSCMXA) $^ - $(STRIP) $@ - $(CODESIGN) $@ -else -$(CHICKEN): $(CHICKENBYTE) - cp $< $@ -endif +# coqmktop -$(CHICKENBYTE): checker/check.cma checker/main.ml - $(SHOW)'OCAMLC -o $@' - $(HIDE)$(OCAMLC) $(CHKLIBS) $(BYTEFLAGS) $(CUSTOM) -thread -o $@ $(SYSCMA) $^ +COQMKTOPCMO:=lib/clib.cma lib/errors.cmo tools/tolink.cmo tools/coqmktop.cmo -# coqmktop -$(COQMKTOP): $(patsubst %.cma,%$(BESTLIB),$(COQMKTOPCMO:.cmo=$(BESTOBJ))) +$(COQMKTOP): $(call bestobj, $(COQMKTOPCMO)) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml, $(OSDEPLIBS), $(SYSMOD)) @@ -267,217 +336,114 @@ tools/tolink.ml: Makefile.build Makefile.common $(HIDE)echo "let core_objs = \""$(OBJSMOD)"\"" >> $@ # coqc -$(COQC): $(patsubst %.cma,%$(BESTLIB),$(COQCCMO:.cmo=$(BESTOBJ))) + +COQCCMO:=lib/clib.cma lib/errors.cmo toplevel/usage.cmo tools/coqc.cmo + +$(COQC): $(call bestobj, $(COQCCMO)) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml, $(OSDEPLIBS), $(SYSMOD)) -# target for libraries +########################################################################### +# other tools +########################################################################### -%.cma: | %.mllib.d - $(SHOW)'OCAMLC -a -o $@' - $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -a -o $@ $^ +.PHONY: +tools: $(TOOLS) $(OCAMLLIBDEP) $(COQDEPBOOT) -%.cmxa: | %.mllib.d - $(SHOW)'OCAMLOPT -a -o $@' - $(HIDE)$(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) -a -o $@ $^ +# coqdep_boot : a basic version of coqdep, with almost no dependencies. -# For the checker, different flags may be used +# Here it is important to mention .ml files instead of .cmo in order +# to avoid using implicit rules : at the time coqdep_boot is being built, +# some .ml.d files may still be missing or not taken in account yet by make. -checker/check.cma: | md5chk checker/check.mllib.d - $(SHOW)'OCAMLC -a -o $@' - $(HIDE)$(OCAMLC) $(CHKLIBS) $(BYTEFLAGS) -a -o $@ $^ +COQDEPBOOTSRC := \ + lib/minisys.ml \ + tools/coqdep_lexer.mli tools/coqdep_lexer.ml \ + tools/coqdep_common.mli tools/coqdep_common.ml \ + tools/coqdep_boot.ml -checker/check.cmxa: | md5chk checker/check.mllib.d - $(SHOW)'OCAMLOPT -a -o $@' - $(HIDE)$(OCAMLOPT) $(CHKLIBS) $(OPTFLAGS) -a -o $@ $^ +$(COQDEPBOOT): $(COQDEPBOOTSRC) + $(SHOW)'OCAMLBEST -o $@' + $(HIDE)$(call bestocaml, -I tools, unix) -########################################################################### -# Csdp to micromega special targets -########################################################################### +# Same for ocamllibdep -plugins/micromega/csdpcert$(EXE): $(CSDPCERTCMO:.cmo=$(BESTOBJ)) \ - $(addsuffix $(BESTLIB), lib/clib) +$(OCAMLLIBDEP): tools/ocamllibdep.ml $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml,,nums unix clib) - -########################################################################### -# CoqIde special targets -########################################################################### + $(HIDE)$(call bestocaml, -I tools, unix) -.PHONY: coqide coqide-binaries coqide-no coqide-byte coqide-opt coqide-files +# The full coqdep (unused by this build, but distributed by make install) -# target to build CoqIde -coqide: coqide-files coqide-binaries theories/Init/Prelude.vo +COQDEPCMO:=lib/clib.cma lib/errors.cmo lib/minisys.cmo lib/system.cmo \ + tools/coqdep_lexer.cmo tools/coqdep_common.cmo tools/coqdep.cmo -COQIDEFLAGS=$(addprefix -I , $(IDESRCDIRS)) $(COQIDEINCLUDES) +$(COQDEP): $(call bestobj, $(COQDEPCMO)) + $(SHOW)'OCAMLBEST -o $@' + $(HIDE)$(call bestocaml, $(OSDEPLIBS), $(SYSMOD)) -.SUFFIXES:.vo +$(GALLINA): $(call bestobj, tools/gallina_lexer.cmo tools/gallina.cmo) + $(SHOW)'OCAMLBEST -o $@' + $(HIDE)$(call bestocaml,,) -IDEFILES=$(wildcard ide/*.lang) ide/coq_style.xml ide/coq.png ide/MacOS/default_accel_map +COQMAKEFILECMO:=lib/clib.cma ide/project_file.cmo tools/coq_makefile.cmo -coqide-binaries: coqide-$(HASCOQIDE) ide-toploop -coqide-no: -coqide-byte: $(COQIDEBYTE) $(COQIDE) -coqide-opt: $(COQIDEBYTE) $(COQIDE) -coqide-files: $(IDEFILES) -ifeq ($(BEST),opt) -ide-toploop: $(IDETOPLOOPCMA) $(IDETOPLOOPCMA:.cma=.cmxs) -else -ide-toploop: $(IDETOPLOOPCMA) -endif +$(COQMAKEFILE): $(call bestobj,$(COQMAKEFILECMO)) + $(SHOW)'OCAMLBEST -o $@' + $(HIDE)$(call bestocaml,,str unix threads) -ifeq ($(HASCOQIDE),opt) -$(COQIDE): $(LINKIDEOPT) - $(SHOW)'OCAMLOPT -o $@' - $(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -o $@ unix.cmxa threads.cmxa lablgtk.cmxa \ - lablgtksourceview2.cmxa str.cmxa $(IDEFLAGS:.cma=.cmxa) $^ - $(STRIP) $@ -else -$(COQIDE): $(COQIDEBYTE) - cp $< $@ -endif +$(COQTEX): $(call bestobj, tools/coq_tex.cmo) + $(SHOW)'OCAMLBEST -o $@' + $(HIDE)$(call bestocaml,,str) -$(COQIDEBYTE): $(LINKIDE) - $(SHOW)'OCAMLC -o $@' - $(HIDE)$(OCAMLC) $(COQIDEFLAGS) $(BYTEFLAGS) -o $@ unix.cma threads.cma lablgtk.cma \ - lablgtksourceview2.cma str.cma $(IDEFLAGS) $(IDECDEPSFLAGS) $^ +$(COQWC): $(call bestobj, tools/coqwc.cmo) + $(SHOW)'OCAMLBEST -o $@' + $(HIDE)$(call bestocaml,,) -# install targets +COQDOCCMO:=lib/clib.cma $(addprefix tools/coqdoc/, \ + cdglobals.cmo alpha.cmo index.cmo tokens.cmo output.cmo cpretty.cmo main.cmo ) -.PHONY: install-coqide install-ide-bin install-ide-toploop install-ide-files install-ide-info install-ide-devfiles +$(COQDOC): $(call bestobj, $(COQDOCCMO)) + $(SHOW)'OCAMLBEST -o $@' + $(HIDE)$(call bestocaml,,str unix) -ifeq ($(HASCOQIDE),no) -install-coqide: install-ide-toploop -else -install-coqide: install-ide-bin install-ide-toploop install-ide-files install-ide-info install-ide-devfiles -endif +$(COQWORKMGR): $(call bestobj, lib/clib.cma stm/coqworkmgrApi.cmo tools/coqworkmgr.cmo) + $(SHOW)'OCAMLBEST -o $@' + $(HIDE)$(call bestocaml,, $(SYSMOD)) -install-ide-bin: - $(MKDIR) $(FULLBINDIR) - $(INSTALLBIN) $(COQIDE) $(FULLBINDIR) +# fake_ide : for debugging or test-suite purpose, a fake ide simulating +# a connection to coqtop -ideslave -install-ide-toploop: - $(MKDIR) $(FULLCOQLIB)/toploop - $(INSTALLBIN) $(IDETOPLOOPCMA) $(FULLCOQLIB)/toploop/ -ifeq ($(BEST),opt) - $(INSTALLBIN) $(IDETOPLOOPCMA:.cma=.cmxs) $(FULLCOQLIB)/toploop/ -endif +FAKEIDECMO:= lib/clib.cma lib/errors.cmo lib/spawn.cmo ide/document.cmo \ + ide/serialize.cmo ide/xml_lexer.cmo ide/xml_parser.cmo ide/xml_printer.cmo \ + ide/xmlprotocol.cmo tools/fake_ide.cmo -install-ide-devfiles: - $(MKDIR) $(FULLCOQLIB) - $(INSTALLSH) $(FULLCOQLIB) $(IDECMA) \ - $(foreach lib,$(IDECMA:.cma=_MLLIB_DEPENDENCIES),$(addsuffix .cmi,$($(lib)))) -ifeq ($(BEST),opt) - $(INSTALLSH) $(FULLCOQLIB) $(IDECMA:.cma=.cmxa) $(IDECMA:.cma=.a) -endif +$(FAKEIDE): $(call bestobj, $(FAKEIDECMO)) | $(IDETOPLOOPCMA:.cma=$(BESTDYN)) + $(SHOW)'OCAMLBEST -o $@' + $(HIDE)$(call bestocaml,-I ide,str unix threads) -install-ide-files: #Please update $(COQIDEAPP)/Contents/Resources/ at the same time - $(MKDIR) $(FULLDATADIR) - $(INSTALLLIB) ide/coq.png ide/*.lang ide/coq_style.xml $(FULLDATADIR) - $(MKDIR) $(FULLCONFIGDIR) - if [ $(IDEINT) = QUARTZ ] ; then $(INSTALLLIB) ide/mac_default_accel_map $(FULLCONFIGDIR)/coqide.keys ; fi +# votour: a small vo explorer (based on the checker) -install-ide-info: - $(MKDIR) $(FULLDOCDIR) - $(INSTALLLIB) ide/FAQ $(FULLDOCDIR)/FAQ-CoqIde +bin/votour: $(call bestobj, lib/cObj.cmo checker/analyze.cmo checker/values.cmo) checker/votour.ml + $(SHOW)'OCAMLBEST -o $@' + $(HIDE)$(call bestocaml, -I checker,) ########################################################################### -# CoqIde MacOS special targets +# Csdp to micromega special targets ########################################################################### -.PHONY: $(COQIDEAPP)/Contents - -$(COQIDEAPP)/Contents: - rm -rdf $@ - $(MKDIR) $@ - sed -e "s/VERSION/$(VERSION4MACOS)/g" ide/MacOS/Info.plist.template > $@/Info.plist - $(MKDIR) "$@/MacOS" - -$(COQIDEINAPP): ide/macos_prehook.cmx $(LINKIDEOPT) | $(COQIDEAPP)/Contents - $(SHOW)'OCAMLOPT -o $@' - $(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -o $@ \ - unix.cmxa lablgtk.cmxa lablgtksourceview2.cmxa str.cmxa \ - threads.cmxa $(IDEFLAGS:.cma=.cmxa) $^ - $(STRIP) $@ +CSDPCERTCMO:=lib/clib.cma $(addprefix plugins/micromega/, \ + mutils.cmo micromega.cmo \ + sos_types.cmo sos_lib.cmo sos.cmo csdpcert.cmo ) -$(COQIDEAPP)/Contents/Resources/share: $(COQIDEAPP)/Contents - $(MKDIR) $@/coq/ - $(INSTALLLIB) ide/coq.png ide/*.lang ide/coq_style.xml $@/coq/ - $(MKDIR) $@/gtksourceview-2.0/{language-specs,styles} - $(INSTALLLIB) "$(GTKSHARE)/"gtksourceview-2.0/language-specs/{def.lang,language2.rng} $@/gtksourceview-2.0/language-specs/ - $(INSTALLLIB) "$(GTKSHARE)/"gtksourceview-2.0/styles/{styles.rng,classic.xml} $@/gtksourceview-2.0/styles/ - cp -R "$(GTKSHARE)/"locale $@ - cp -R "$(GTKSHARE)/"icons $@ - cp -R "$(GTKSHARE)/"themes $@ - -$(COQIDEAPP)/Contents/Resources/loaders: $(COQIDEAPP)/Contents - $(MKDIR) $@ - $(INSTALLLIB) $$("$(GTKBIN)/gdk-pixbuf-query-loaders" | sed -n -e '5 s!.*= \(.*\)$$!\1!p')/libpixbufloader-png.so $@ - -$(COQIDEAPP)/Contents/Resources/immodules: $(COQIDEAPP)/Contents - $(MKDIR) $@ - $(INSTALLLIB) "$(GTKLIBS)/gtk-2.0/2.10.0/immodules/"*.so $@ - - -$(COQIDEAPP)/Contents/Resources/etc: $(COQIDEAPP)/Contents/Resources/lib - $(MKDIR) $@/xdg/coq - $(INSTALLLIB) ide/MacOS/default_accel_map $@/xdg/coq/coqide.keys - $(MKDIR) $@/gtk-2.0 - { "$(GTKBIN)/gdk-pixbuf-query-loaders" $@/../loaders/*.so |\ - sed -e "s!/.*\(/loaders/.*.so\)!@executable_path/../Resources/\1!"; } \ - > $@/gtk-2.0/gdk-pixbuf.loaders - { "$(GTKBIN)/gtk-query-immodules-2.0" $@/../immodules/*.so |\ - sed -e "s!/.*\(/immodules/.*.so\)!@executable_path/../Resources/\1!" |\ - sed -e "s!/.*\(/share/locale\)!@executable_path/../Resources/\1!"; } \ - > $@/gtk-2.0/gtk-immodules.loaders - $(MKDIR) $@/pango - echo "[Pango]" > $@/pango/pangorc - -$(COQIDEAPP)/Contents/Resources/lib: $(COQIDEAPP)/Contents/Resources/immodules $(COQIDEAPP)/Contents/Resources/loaders $(COQIDEAPP)/Contents $(COQIDEINAPP) - $(MKDIR) $@ - $(INSTALLLIB) $(GTKLIBS)/charset.alias $@/ - $(MKDIR) $@/pango/1.8.0/modules - $(INSTALLLIB) "$(GTKLIBS)/pango/1.8.0/modules/"*.so $@/pango/1.8.0/modules/ - { "$(GTKBIN)/pango-querymodules" $@/pango/1.8.0/modules/*.so |\ - sed -e "s!/.*\(/pango/1.8.0/modules/.*.so\)!@executable_path/../Resources/lib\1!"; } \ - > $@/pango/1.8.0/modules.cache - - for i in $$(otool -L $(COQIDEINAPP) |sed -n -e "\@$(GTKLIBS)@ s/[^/]*\(\/[^ ]*\) .*$$/\1/p"); \ - do cp $$i $@/; \ - ide/MacOS/relatify_with-respect-to_.sh $@/$$(basename $$i) $(GTKLIBS) $@; \ - done - for i in $@/../loaders/*.so $@/../immodules/*.so $@/pango/1.8.0/modules/*.so; \ - do \ - for j in $$(otool -L $$i | sed -n -e "\@$(GTKLIBS)@ s/[^/]*\(\/[^ ]*\) .*$$/\1/p"); \ - do cp $$j $@/; ide/MacOS/relatify_with-respect-to_.sh $@/$$(basename $$j) $(GTKLIBS) $@; done; \ - ide/MacOS/relatify_with-respect-to_.sh $$i $(GTKLIBS) $@; \ - done - EXTRAWORK=1; \ - while [ $${EXTRAWORK} -eq 1 ]; \ - do EXTRAWORK=0; \ - for i in $@/*.dylib; \ - do for j in $$(otool -L $$i | sed -n -e "\@$(GTKLIBS)@ s/[^/]*\(\/[^ ]*\) .*$$/\1/p"); \ - do EXTRAWORK=1; cp $$j $@/; ide/MacOS/relatify_with-respect-to_.sh $@/$$(basename $$j) $(GTKLIBS) $@; done; \ - done; \ - done - ide/MacOS/relatify_with-respect-to_.sh $(COQIDEINAPP) $(GTKLIBS) $@ - -$(COQIDEAPP)/Contents/Resources:$(COQIDEAPP)/Contents/Resources/etc $(COQIDEAPP)/Contents/Resources/share - $(INSTALLLIB) ide/MacOS/*.icns $@ - -$(COQIDEAPP):$(COQIDEAPP)/Contents/Resources - $(CODESIGN) $@ +$(CSDPCERT): $(call bestobj, $(CSDPCERTCMO)) + $(SHOW)'OCAMLBEST -o $@' + $(HIDE)$(call bestocaml,,nums unix) ########################################################################### # tests ########################################################################### -.PHONY: validate check test-suite $(ALLSTDLIB).v md5chk - -md5chk: - $(SHOW)'MD5SUM cic.mli' - $(HIDE)if grep -q `$(MD5SUM) checker/cic.mli` checker/values.ml; \ - then true; else echo "Error: outdated checker/values.ml"; false; fi +.PHONY: validate check test-suite $(ALLSTDLIB).v VALIDOPTS=$(if $(VERBOSE),,-silent) -o -m @@ -498,169 +464,10 @@ test-suite: world $(ALLSTDLIB).v $(MAKE) $(MAKE_TSOPTS) all $(MAKE) $(MAKE_TSOPTS) report -################################################################## -# partial targets: 1) core ML parts -################################################################## - -.PHONY: lib kernel byterun library proofs tactics interp parsing pretyping -.PHONY: engine highparsing stm toplevel ltac - -lib: lib/clib.cma lib/lib.cma -kernel: kernel/kernel.cma -byterun: $(BYTERUN) -library: library/library.cma -engine: engine/engine.cma -proofs: proofs/proofs.cma -tactics: tactics/tactics.cma -interp: interp/interp.cma -parsing: parsing/parsing.cma -pretyping: pretyping/pretyping.cma -highparsing: parsing/highparsing.cma -stm: stm/stm.cma -toplevel: toplevel/toplevel.cma -ltac: ltac/ltac.cma - ########################################################################### -# 2) theories and plugins files +### Special rules (Camlp5 / Camlp4) ########################################################################### -.PHONY: init theories theories-light -.PHONY: logic arith bool narith zarith qarith lists strings sets -.PHONY: fsets relations wellfounded reals setoids sorting numbers noreal -.PHONY: msets mmaps compat - -init: $(INITVO) - -theories: $(THEORIESVO) -theories-light: $(THEORIESLIGHTVO) - -logic: $(LOGICVO) -arith: $(ARITHVO) -bool: $(BOOLVO) -narith: $(NARITHVO) -zarith: $(ZARITHVO) -qarith: $(QARITHVO) -lists: $(LISTSVO) -strings: $(STRINGSVO) -sets: $(SETSVO) -fsets: $(FSETSVO) -relations: $(RELATIONSVO) -wellfounded: $(WELLFOUNDEDVO) -reals: $(REALSVO) -setoids: $(SETOIDSVO) -sorting: $(SORTINGVO) -numbers: $(NUMBERSVO) -unicode: $(UNICODEVO) -classes: $(CLASSESVO) -program: $(PROGRAMVO) -structures: $(STRUCTURESVO) -vectors: $(VECTORSVO) -msets: $(MSETSVO) -compat: $(COMPATVO) - -noreal: unicode logic arith bool zarith qarith lists sets fsets \ - relations wellfounded setoids sorting - -########################################################################### -# 3) plugins -########################################################################### - -.PHONY: plugins omega micromega setoid_ring nsatz extraction -.PHONY: fourier funind cc rtauto btauto pluginsopt pluginsbyte - -plugins: $(PLUGINSVO) -omega: $(OMEGAVO) $(OMEGACMA) $(ROMEGAVO) $(ROMEGACMA) -micromega: $(MICROMEGAVO) $(MICROMEGACMA) $(CSDPCERT) -setoid_ring: $(RINGVO) $(RINGCMA) -nsatz: $(NSATZVO) $(NSATZCMA) -extraction: $(EXTRACTIONCMA) -fourier: $(FOURIERVO) $(FOURIERCMA) -funind: $(FUNINDCMA) $(FUNINDVO) -cc: $(CCVO) $(CCCMA) -rtauto: $(RTAUTOVO) $(RTAUTOCMA) -btauto: $(BTAUTOVO) $(BTAUTOCMA) - -pluginsopt: $(PLUGINSOPT) -pluginsbyte: $(PLUGINS) - -########################################################################### -# rules to make theories and plugins -########################################################################### - -theories/Init/%.vo theories/Init/%.glob: theories/Init/%.v $(VO_TOOLS_DEP) | theories/Init/%.v.d - $(SHOW)'COQC $(COQ_XML) -noinit $<' - $(HIDE)rm -f theories/Init/$*.glob - $(HIDE)$(BOOTCOQC) $< $(COQ_XML) -noinit -R theories Coq - -theories/Numbers/Natural/BigN/NMake_gen.v: theories/Numbers/Natural/BigN/NMake_gen.ml - $(OCAML) $< $(TOTARGET) - -########################################################################### -# tools -########################################################################### - -.PHONY: printers tools - -printers: $(DEBUGPRINTERS) - -tools: $(TOOLS) $(DEBUGPRINTERS) $(OCAMLLIBDEP) - -# coqdep_boot : a basic version of coqdep, with almost no dependencies. - -# Here it is important to mention .ml files instead of .cmo in order -# to avoid using implicit rules and hence .ml.d files that would need -# coqdep_boot. - -OCAMLLIBDEPSRC:= tools/ocamllibdep.ml - -$(OCAMLLIBDEP): $(OCAMLLIBDEPSRC) - $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml, -I tools, unix) - -# the full coqdep - -$(COQDEP): $(patsubst %.cma,%$(BESTLIB),$(COQDEPCMO:.cmo=$(BESTOBJ))) - $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml, $(OSDEPLIBS), $(SYSMOD)) - -$(GALLINA): $(addsuffix $(BESTOBJ), tools/gallina_lexer tools/gallina) - $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml,,) - -$(COQMAKEFILE): $(patsubst %.cma,%$(BESTLIB),$(COQMAKEFILECMO:.cmo=$(BESTOBJ))) - $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml,,str unix threads) - -$(COQTEX): tools/coq_tex$(BESTOBJ) - $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml,,str) - -$(COQWC): tools/coqwc$(BESTOBJ) - $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml,,) - -$(COQDOC): $(patsubst %.cma,%$(BESTLIB),$(COQDOCCMO:.cmo=$(BESTOBJ))) - $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml,,str unix) - -$(COQWORKMGR): $(addsuffix $(BESTOBJ), stm/coqworkmgrApi tools/coqworkmgr) \ - $(addsuffix $(BESTLIB), lib/clib) - $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml,, $(SYSMOD) clib) - -# fake_ide : for debugging or test-suite purpose, a fake ide simulating -# a connection to coqtop -ideslave - -$(FAKEIDE): lib/clib$(BESTLIB) lib/xml_lexer$(BESTOBJ) lib/xml_parser$(BESTOBJ) lib/xml_printer$(BESTOBJ) lib/errors$(BESTOBJ) lib/spawn$(BESTOBJ) ide/document$(BESTOBJ) ide/xmlprotocol$(BESTOBJ) tools/fake_ide$(BESTOBJ) | $(IDETOPLOOPCMA:.cma=$(BESTDYN)) - $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml,-I ide,str unix threads) - -# votour: a small vo explorer (based on the checker) - -bin/votour: lib/cObj$(BESTOBJ) checker/analyze$(BESTOBJ) checker/values$(BESTOBJ) checker/votour.ml - $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml, -I checker,) - # Special rule for the compatibility-with-camlp5 extension for camlp4 ifeq ($(CAMLP4),camlp4) @@ -671,315 +478,51 @@ tools/compat5b.cmo: tools/compat5b.mlp else tools/compat5.cmo: tools/compat5.ml $(OCAMLC) -c $< -tools/compat5b.cmo: tools/compat5b.ml - $(OCAMLC) -c $< endif ########################################################################### -# Documentation : cf Makefile.doc +# Default rules for compiling ML code ########################################################################### -documentation: doc-$(WITHDOC) -doc-all: doc -doc-no: - -.PHONY: documentation doc-all doc-no +# Target for libraries .cma and .cmxa -########################################################################### -# Installation -########################################################################### - -ifeq ($(LOCAL),true) -install: - @echo "Nothing to install in a local build!" -else -install: install-coq install-coqide install-doc-$(WITHDOC) -endif +# The dependency over the .mllib is somewhat artificial, since +# ocamlc -a won't use this file, hence the $(filter-out ...) below. +# But this ensures that the .cm(x)a is rebuilt when needed, +# (especially when removing a module in the .mllib). +# We used to have a "order-only" dependency over .mllib.d here, +# but the -include mechanism should already ensure that we have +# up-to-date dependencies. -install-doc-all: install-doc -install-doc-no: - -.PHONY: install install-doc-all install-doc-no - -#These variables are intended to be set by the caller to make -#COQINSTALLPREFIX= -#OLDROOT= - - # Can be changed for a local installation (to make packages). - # You must NOT put a "/" at the end (Cygnus for win32 does not like "//"). - -ifdef COQINSTALLPREFIX -FULLBINDIR=$(BINDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%) -FULLCOQLIB=$(COQLIBINSTALL:"$(OLDROOT)%="$(COQINSTALLPREFIX)%) -FULLCONFIGDIR=$(CONFIGDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%) -FULLDATADIR=$(DATADIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%) -FULLMANDIR=$(MANDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%) -FULLEMACSLIB=$(EMACSLIB:"$(OLDROOT)%="$(COQINSTALLPREFIX)%) -FULLCOQDOCDIR=$(COQDOCDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%) -FULLDOCDIR=$(DOCDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%) -else -FULLBINDIR=$(BINDIR) -FULLCOQLIB=$(COQLIBINSTALL) -FULLCONFIGDIR=$(CONFIGDIR) -FULLDATADIR=$(DATADIR) -FULLMANDIR=$(MANDIR) -FULLEMACSLIB=$(EMACSLIB) -FULLCOQDOCDIR=$(COQDOCDIR) -FULLDOCDIR=$(DOCDIR) -endif - -.PHONY: install-coq install-coqlight install-binaries install-byte install-opt -.PHONY: install-tools install-library install-library-light install-devfiles -.PHONY: install-coq-info install-coq-manpages install-emacs install-latex - -install-coq: install-binaries install-library install-coq-info install-devfiles -install-coqlight: install-binaries install-library-light - -install-binaries: install-tools - $(MKDIR) $(FULLBINDIR) - $(INSTALLBIN) $(COQC) $(COQTOPBYTE) $(COQTOPEXE) $(CHICKEN) $(FULLBINDIR) - $(MKDIR) $(FULLCOQLIB)/toploop - $(INSTALLBIN) $(TOPLOOPCMA) $(FULLCOQLIB)/toploop/ -ifeq ($(BEST),opt) - $(INSTALLBIN) $(TOPLOOPCMA:.cma=.cmxs) $(FULLCOQLIB)/toploop/ -endif - - -install-tools: - $(MKDIR) $(FULLBINDIR) - # recopie des fichiers de style pour coqide - $(MKDIR) $(FULLCOQLIB)/tools/coqdoc - touch $(FULLCOQLIB)/tools/coqdoc/coqdoc.sty $(FULLCOQLIB)/tools/coqdoc/coqdoc.css # to have the mode according to umask (bug #1715) - $(INSTALLLIB) tools/coqdoc/coqdoc.css tools/coqdoc/coqdoc.sty $(FULLCOQLIB)/tools/coqdoc - $(INSTALLBIN) $(TOOLS) $(FULLBINDIR) - -# The list of .cmi to install, including the ones obtained -# from .mli without .ml, and the ones obtained from .ml without .mli - -INSTALLCMI = $(sort \ - $(filter-out checker/% ide/% tools/%, $(MLIFILES:.mli=.cmi)) \ - $(foreach lib,$(CORECMA) $(PLUGINSCMA), $(addsuffix .cmi,$($(lib:.cma=_MLLIB_DEPENDENCIES))))) - -install-devfiles: - $(MKDIR) $(FULLBINDIR) - $(INSTALLBIN) $(COQMKTOP) $(FULLBINDIR) - $(MKDIR) $(FULLCOQLIB) - $(INSTALLSH) $(FULLCOQLIB) $(LINKCMO) $(GRAMMARCMA) - $(INSTALLSH) $(FULLCOQLIB) $(INSTALLCMI) -ifeq ($(BEST),opt) - $(INSTALLSH) $(FULLCOQLIB) $(LINKCMX) $(CORECMA:.cma=.a) $(STATICPLUGINS:.cma=.a) -endif - -install-library: - $(MKDIR) $(FULLCOQLIB) - $(INSTALLSH) $(FULLCOQLIB) $(LIBFILES) $(PLUGINS) - $(MKDIR) $(FULLCOQLIB)/user-contrib -ifndef CUSTOM - $(INSTALLLIB) $(DLLCOQRUN) $(FULLCOQLIB) -endif -ifeq ($(BEST),opt) - $(INSTALLLIB) $(LIBCOQRUN) $(FULLCOQLIB) - $(INSTALLSH) $(FULLCOQLIB) $(PLUGINSOPT) -endif -# csdpcert is not meant to be directly called by the user; we install -# it with libraries - -$(MKDIR) $(FULLCOQLIB)/plugins/micromega - $(INSTALLBIN) $(CSDPCERT) $(FULLCOQLIB)/plugins/micromega - rm -f $(FULLCOQLIB)/revision - -$(INSTALLLIB) revision $(FULLCOQLIB) - -install-library-light: - $(MKDIR) $(FULLCOQLIB) - $(INSTALLSH) $(FULLCOQLIB) $(LIBFILESLIGHT) $(INITPLUGINS) - rm -f $(FULLCOQLIB)/revision - -$(INSTALLLIB) revision $(FULLCOQLIB) -ifndef CUSTOM - $(INSTALLLIB) $(DLLCOQRUN) $(FULLCOQLIB) -endif -ifeq ($(BEST),opt) - $(INSTALLLIB) $(LIBCOQRUN) $(FULLCOQLIB) - $(INSTALLSH) $(FULLCOQLIB) $(INITPLUGINSOPT) -endif - -install-coq-info: install-coq-manpages install-emacs install-latex - -install-coq-manpages: - $(MKDIR) $(FULLMANDIR)/man1 - $(INSTALLLIB) $(MANPAGES) $(FULLMANDIR)/man1 - -install-emacs: - $(MKDIR) $(FULLEMACSLIB) - $(INSTALLLIB) tools/gallina-db.el tools/coq-font-lock.el tools/gallina-syntax.el tools/gallina.el tools/coq-inferior.el $(FULLEMACSLIB) - -# command to update TeX' kpathsea database -#UPDATETEX = $(MKTEXLSR) /usr/share/texmf /var/spool/texmf $(BASETEXDIR) > /dev/null - -install-latex: - $(MKDIR) $(FULLCOQDOCDIR) - $(INSTALLLIB) tools/coqdoc/coqdoc.sty $(FULLCOQDOCDIR) -# -$(UPDATETEX) - -########################################################################### -# Documentation of the source code (using ocamldoc) -########################################################################### - -.PHONY: source-doc mli-doc ml-doc - -source-doc: mli-doc $(OCAMLDOCDIR)/coq.pdf - -$(OCAMLDOCDIR)/coq.tex: $(DOCMLIS:.mli=.cmi) - $(SHOW)'OCAMLDOC -latex -o $@' - $(HIDE)$(OCAMLFIND) ocamldoc -latex -rectypes -I $(MYCAMLP4LIB) $(MLINCLUDES)\ - $(DOCMLIS) -noheader -t "Coq mlis documentation" \ - -intro $(OCAMLDOCDIR)/docintro -o $@.tmp - $(SHOW)'OCAMLDOC utf8 fix' - $(HIDE)$(OCAMLDOCDIR)/fix-ocamldoc-utf8 $@.tmp - $(HIDE)cat $(OCAMLDOCDIR)/header.tex $@.tmp > $@ - rm $@.tmp - -mli-doc: $(DOCMLIS:.mli=.cmi) - $(SHOW)'OCAMLDOC -html' - $(HIDE)$(OCAMLFIND) ocamldoc -charset utf-8 -html -rectypes -I +threads -I $(MYCAMLP4LIB) $(MLINCLUDES) \ - $(DOCMLIS) -d $(OCAMLDOCDIR)/html -colorize-code \ - -t "Coq mlis documentation" -intro $(OCAMLDOCDIR)/docintro \ - -css-style style.css - -ml-dot: $(MLFILES) - $(OCAMLFIND) ocamldoc -dot -dot-reduce -rectypes -I +threads -I $(CAMLLIB) -I $(MYCAMLP4LIB) $(MLINCLUDES) \ - $(filter $(addsuffix /%.ml,$(CORESRCDIRS)),$(MLFILES)) -o $(OCAMLDOCDIR)/coq.dot - -%_dep.png: %.dot - $(DOT) -Tpng $< -o $@ - -%_types.dot: %.mli - $(OCAMLFIND) ocamldoc -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -dot-types -o $@ $< - -OCAMLDOC_MLLIBD = $(OCAMLFIND) ocamldoc -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -o $@ \ - $(foreach lib,$(|:.mllib.d=_MLLIB_DEPENDENCIES),$(addsuffix .ml,$($(lib)))) - -%.dot: | %.mllib.d - $(OCAMLDOC_MLLIBD) - -ml-doc: - $(OCAMLFIND) ocamldoc -charset utf-8 -html -rectypes -I +threads $(MLINCLUDES) $(COQIDEFLAGS) -d $(OCAMLDOCDIR) $(MLSTATICFILES) - -parsing/parsing.dot : | parsing/parsing.mllib.d parsing/highparsing.mllib.d - $(OCAMLDOC_MLLIBD) - -grammar/grammar.dot : | grammar/grammar.mllib.d - $(OCAMLDOC_MLLIBD) - -tactics/tactics.dot: | tactics/tactics.mllib.d ltac/ltac.mllib.d - $(OCAMLDOC_MLLIBD) - -%.dot: %.mli - $(OCAMLFIND) ocamldoc -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -o $@ $< - -$(OCAMLDOCDIR)/%.pdf: $(OCAMLDOCDIR)/%.tex - $(SHOW)'PDFLATEX $*.tex' - $(HIDE)(cd $(OCAMLDOCDIR) ; pdflatex -interaction=batchmode $*.tex && pdflatex -interaction=batchmode $*.tex) - $(HIDE)(cd doc/tools/; show_latex_messages -no-overfull ../../$(OCAMLDOCDIR)/$*.log) - -########################################################################### -### Special rules -########################################################################### +%.cma: %.mllib + $(SHOW)'OCAMLC -a -o $@' + $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -a -o $@ $(filter-out %.mllib, $^) -dev/printers.cma: | dev/printers.mllib.d - $(SHOW)'Testing $@' - $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -thread $(SYSCMA) $(P4CMA) $^ -o test-printer - @rm -f test-printer - $(SHOW)'OCAMLC -a $@' - $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -thread $(SYSCMA) $(P4CMA) $^ -linkall -a -o $@ +%.cmxa: %.mllib + $(SHOW)'OCAMLOPT -a -o $@' + $(HIDE)$(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) -a -o $@ $(filter-out %.mllib, $^) -grammar/grammar.cma: | grammar/grammar.mllib.d - $(SHOW)'Testing $@' - @touch test.ml4 - $(HIDE)$(CAMLP4O) $(CAMLP4FLAGS) $^ -impl test.ml4 -o test.ml - $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) test.ml -o test-grammar - @rm -f test-grammar test.* - $(SHOW)'OCAMLC -a $@' - $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) $^ -linkall -a -o $@ +# For plugin packs : -ide/coqide_main.ml: ide/coqide_main.ml4 config/Makefile # no camlp4deps here - $(SHOW)'CAMLP4O $<' - $(HIDE)$(CAMLP4O) $(CAMLP4FLAGS) $(PR_O) $(CAMLP4USE) -D$(IDEINT) -impl $< -o $@ - -# pretty printing of the revision number when compiling a checked out -# source tree -.PHONY: revision - -revision: - $(SHOW)'CHECK revision' - $(HIDE)rm -f revision.new -ifeq ($(CHECKEDOUT),svn) - $(HIDE)set -e; \ - if test -x "`which svn`"; then \ - export LC_ALL=C;\ - svn info . | sed -ne '/URL/s/.*\/\([^\/]\{1,\}\)/\1/p' > revision.new; \ - svn info . | sed -ne '/Revision/s/Revision: \([0-9]\{1,\}\)/\1/p'>> revision.new; \ - fi -endif -ifeq ($(CHECKEDOUT),gnuarch) - $(HIDE)set -e; \ - if test -x "`which tla`"; then \ - LANG=C; export LANG; \ - tla tree-version > revision.new ; \ - tla tree-revision | sed -ne 's|.*--||p' >> revision.new ; \ - fi -endif -ifeq ($(CHECKEDOUT),git) - $(HIDE)set -e; \ - if test -x "`which git`"; then \ - LANG=C; export LANG; \ - GIT_BRANCH=$$(git branch -a | sed -ne '/^\* /s/^\* \(.*\)/\1/p'); \ - GIT_HOST=$$(hostname); \ - GIT_PATH=$$(pwd); \ - (echo "$${GIT_HOST}:$${GIT_PATH},$${GIT_BRANCH}") > revision.new; \ - (echo "$$(git log -1 --pretty='format:%H')") >> revision.new; \ - fi -endif - $(HIDE)set -e; \ - if test -e revision.new; then \ - if test -e revision; then \ - if test "`cat revision`" = "`cat revision.new`" ; then \ - rm -f revision.new; \ - else \ - mv -f revision.new revision; \ - fi; \ - else \ - mv -f revision.new revision; \ - fi \ - fi +%.cmo: %.mlpack + $(SHOW)'OCAMLC -pack -o $@' + $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -pack -o $@ $(filter-out %.mlpack, $^) -########################################################################### -# Default rules -########################################################################### - -## Three flavor of flags: checker/* ide/* and normal files +%.cmx: %.mlpack + $(SHOW)'OCAMLOPT -pack -o $@' + $(HIDE)$(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) -pack -o $@ $(filter-out %.mlpack, $^) COND_BYTEFLAGS= \ - $(if $(filter checker/%,$<), $(CHKLIBS) -thread, \ - $(if $(filter ide/%,$<), $(COQIDEFLAGS), \ - $(if $(filter tools/fake_ide% tools/coq_makefile%,$<), -I ide,) $(MLINCLUDES) -thread)) $(BYTEFLAGS) + $(if $(filter tools/fake_ide% tools/coq_makefile%,$<), -I ide,) $(MLINCLUDES) $(BYTEFLAGS) COND_OPTFLAGS= \ - $(if $(filter checker/%,$<), $(CHKLIBS) -thread, \ - $(if $(filter ide/%,$<), $(COQIDEFLAGS), \ - $(if $(filter tools/fake_ide% tools/coq_makefile%,$<), -I ide,) $(MLINCLUDES) -thread)) $(OPTFLAGS) - -%.o: %.c - $(SHOW)'OCAMLC $<' - $(HIDE)cd $(dir $<) && $(OCAMLC) -ccopt "$(CFLAGS)" -c $(notdir $<) - -%.o: %.rc - $(SHOW)'WINDRES $<' - $(HIDE)i686-w64-mingw32-windres -i $< -o $@ + $(if $(filter tools/fake_ide% tools/coq_makefile%,$<), -I ide,) $(MLINCLUDES) $(OPTFLAGS) -%.cmi: %.mli | %.mli.d +%.cmi: %.mli $(SHOW)'OCAMLC $<' $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -c $< -%.cmo: %.ml | %.ml.d +%.cmo: %.ml $(SHOW)'OCAMLC $<' $(HIDE)$(OCAMLC) $(COND_BYTEFLAGS) -c $< @@ -1004,17 +547,21 @@ $(MLWITHOUTMLI:.ml=.cmx): %.cmx: %.cmi # for .ml with .mli this is already the $(MLWITHOUTMLI:.ml=.cmi): %.cmi: %.cmo -%.cmx: %.ml | %.ml.d +# NB: the *_FORPACK variables are generated in *.mlpack.d by ocamllibdep +# The only exceptions are the sources of the csdpcert binary. +# To avoid warnings, we set them manually here: +plugins/micromega/sos_lib_FORPACK:= +plugins/micromega/sos_FORPACK:= +plugins/micromega/sos_print_FORPACK:= +plugins/micromega/csdpcert_FORPACK:= + +plugins/%.cmx: plugins/%.ml $(SHOW)'OCAMLOPT $<' - $(HIDE)$(OCAMLOPT) $(COND_OPTFLAGS) $(HACKMLI) -c $< + $(HIDE)$(OCAMLOPT) $(COND_OPTFLAGS) $(HACKMLI) $($(@:.cmx=_FORPACK)) -c $< -%.cmxs: %.cmxa - $(SHOW)'OCAMLOPT -shared -o $@' -ifeq ($(HASNATDYNLINK),os5fixme) - $(HIDE)dev/ocamlopt_shared_os5fix.sh "$(OCAMLOPT)" $@ -else - $(HIDE)$(OCAMLOPT) -linkall -shared -o $@ $< -endif +%.cmx: %.ml + $(SHOW)'OCAMLOPT $<' + $(HIDE)$(OCAMLOPT) $(COND_OPTFLAGS) $(HACKMLI) -c $< %.cmxs: %.cmx $(SHOW)'OCAMLOPT -shared -o $@' @@ -1024,105 +571,84 @@ endif $(SHOW)'OCAMLLEX $<' $(HIDE)$(OCAMLLEX) -o $@ "$*.mll" -plugins/%_mod.ml: plugins/%.mllib - $(SHOW)'ECHO... > $@' - $(HIDE)sed -e "s/\([^ ]\{1,\}\)/let _=Mltop.add_known_module\"\1\" /g" $< > $@ - $(HIDE)echo "let _=Mltop.add_known_module\"$(notdir $*)\"" >> $@ - -# NB: compatibility modules for camlp4: -# - tools/compat5.cmo changes GEXTEND into EXTEND. Safe, always loaded -# - tools/compat5b.cmo changes EXTEND into EXTEND Gram. Interact badly with -# syntax such that VERNAC EXTEND, we only load it for a few files via camlp4deps - -%.ml: %.ml4 | %.ml4.d tools/compat5.cmo tools/compat5b.cmo +%.ml: %.ml4 | $(CAMLP4DEPS) $(SHOW)'CAMLP4O $<' - $(HIDE)$(CAMLP4O) $(CAMLP4FLAGS) $(PR_O) tools/compat5.cmo \ - $(call CAMLP4DEPS,$<) $(CAMLP4USE) $(CAMLP4COMPAT) -impl $< -o $@ + $(HIDE)$(CAMLP4O) $(CAMLP4FLAGS) $(PR_O) \ + $(CAMLP4DEPS) $(CAMLP4USE) $(CAMLP4COMPAT) -impl $< -o $@ -%.vo %.glob: %.v theories/Init/Prelude.vo $(VO_TOOLS_DEP) | %.v.d - $(SHOW)'COQC $<' - $(HIDE)rm -f $*.glob - $(HIDE)$(BOOTCOQC) $< -ifdef VALIDATE - $(SHOW)'COQCHK $(call vo_to_mod,$@)' - $(HIDE)$(CHICKEN) -boot -silent -norec $(call vo_to_mod,$@) \ - || ( RV=$$?; rm -f "$@"; exit $${RV} ) -endif ########################################################################### -# Dependencies +# Dependencies of ML code ########################################################################### -# .ml4.d contains the dependencies to generate the .ml from the .ml4 -# NOT to generate object code. - -%.ml4.d: $(D_DEPEND_BEFORE_SRC) %.ml4 - $(SHOW)'CAMLP4DEPS $<' - $(HIDE)echo "$*.ml: $(if $(NO_RECOMPILE_ML4),$(ORDER_ONLY_SEP)) $(call CAMLP4DEPS,$<)" $(TOTARGET) - -# Since OCaml 3.12.1, we could use again ocamldep directly, thanks to -# the option -ml-synonym - -OCAMLDEP_NG = $(OCAMLFIND) ocamldep -slash -ml-synonym .ml4 - -checker/%.ml.d: $(D_DEPEND_BEFORE_SRC) checker/%.ml $(D_DEPEND_AFTER_SRC) $(GENFILES) - $(SHOW)'OCAMLDEP $<' - $(HIDE)$(OCAMLDEP_NG) $(LOCALCHKLIBS) "$<" $(TOTARGET) - -checker/%.mli.d: $(D_DEPEND_BEFORE_SRC) checker/%.mli $(D_DEPEND_AFTER_SRC) $(GENFILES) - $(SHOW)'OCAMLDEP $<' - $(HIDE)$(OCAMLDEP_NG) $(LOCALCHKLIBS) "$<" $(TOTARGET) +# Ocamldep is now used directly again (thanks to -ml-synonym in OCaml >= 3.12) +OCAMLDEP = $(OCAMLFIND) ocamldep -slash -ml-synonym .ml4 -ml-synonym .mlpack %.ml.d: $(D_DEPEND_BEFORE_SRC) %.ml $(D_DEPEND_AFTER_SRC) $(GENFILES) $(SHOW)'OCAMLDEP $<' - $(HIDE)$(OCAMLDEP_NG) $(DEPFLAGS) "$<" $(TOTARGET) + $(HIDE)$(OCAMLDEP) $(DEPFLAGS) "$<" $(TOTARGET) %.mli.d: $(D_DEPEND_BEFORE_SRC) %.mli $(D_DEPEND_AFTER_SRC) $(GENFILES) $(SHOW)'OCAMLDEP $<' - $(HIDE)$(OCAMLDEP_NG) $(DEPFLAGS) "$<" $(TOTARGET) + $(HIDE)$(OCAMLDEP) $(DEPFLAGS) "$<" $(TOTARGET) -checker/%.mllib.d: $(D_DEPEND_BEFORE_SRC) checker/%.mllib $(D_DEPEND_AFTER_SRC) $(OCAMLLIBDEP) $(GENFILES) +%.mllib.d: $(D_DEPEND_BEFORE_SRC) %.mllib $(D_DEPEND_AFTER_SRC) $(OCAMLLIBDEP) $(GENFILES) $(SHOW)'OCAMLLIBDEP $<' - $(HIDE)$(OCAMLLIBDEP) $(LOCALCHKLIBS) "$<" $(TOTARGET) + $(HIDE)$(OCAMLLIBDEP) $(DEPFLAGS) "$<" $(TOTARGET) -dev/%.mllib.d: $(D_DEPEND_BEFORE_SRC) dev/%.mllib $(D_DEPEND_AFTER_SRC) $(OCAMLLIBDEP) $(GENFILES) - $(SHOW)'OCAMLLIBDEP $<' - $(HIDE)$(OCAMLLIBDEP) $(DEPFLAGS) -I dev "$<" $(TOTARGET) - -%.mllib.d: $(D_DEPEND_BEFORE_SRC) %.mllib $(D_DEPEND_AFTER_SRC) $(OCAMLLIBDEP) $(GENFILES) +%.mlpack.d: $(D_DEPEND_BEFORE_SRC) %.mlpack $(D_DEPEND_AFTER_SRC) $(OCAMLLIBDEP) $(GENFILES) $(SHOW)'OCAMLLIBDEP $<' $(HIDE)$(OCAMLLIBDEP) $(DEPFLAGS) "$<" $(TOTARGET) -%.v.d: $(D_DEPEND_BEFORE_SRC) %.v $(D_DEPEND_AFTER_SRC) $(COQDEP) $(GENVFILES) - $(SHOW)'COQDEP $<' - $(HIDE)$(COQDEP) -boot $(DEPNATDYN) "$<" $(TOTARGET) +########################################################################### +# Compilation of .v files +########################################################################### -%_stubs.c.d: $(D_DEPEND_BEFORE_SRC) %_stubs.c $(D_DEPEND_AFTER_SRC) - $(SHOW)'CCDEP $<' - $(HIDE)echo "$@ $(@:.c.d=.o): $(@:.c.d=.c)" > $@ +# NB: for make world, no need to mention explicitly the .cmxs of the plugins, +# since they are all mentioned in at least one Declare ML Module in some .v -%.c.d: $(D_DEPEND_BEFORE_SRC) %.c $(D_DEPEND_AFTER_SRC) $(GENHFILES) - $(SHOW)'CCDEP $<' - $(HIDE)$(OCAMLC) -ccopt "-MM -MQ $@ -MQ $(<:.c=.o) -isystem $(CAMLHLIB)" $< $(TOTARGET) +coqlib: theories plugins -########################################################################### -# this sets up developper supporting stuff -########################################################################### +theories: $(THEORIESVO) +plugins: $(PLUGINSVO) -.PHONY: devel otags -devel: $(DEBUGPRINTERS) +.PHONY: coqlib theories plugins -otags: - otags $(MLIFILES) $(MLSTATICFILES) \ - $(foreach i,$(ML4FILES),-pc -pa tools/compat5.cmo -pa op -pa g -pa m -pa rq $(patsubst %,-pa %,$(call CAMLP4DEPS,$i)) -impl $i) +# One of the .v files is macro-generated +theories/Numbers/Natural/BigN/NMake_gen.v: theories/Numbers/Natural/BigN/NMake_gen.ml + $(OCAML) $< $(TOTARGET) + +# The .vo files in Init are built with the -noinit option + +theories/Init/%.vo theories/Init/%.glob: theories/Init/%.v $(VO_TOOLS_DEP) + $(SHOW)'COQC $(COQ_XML) -noinit $<' + $(HIDE)rm -f theories/Init/$*.glob + $(HIDE)$(BOOTCOQC) $< $(COQ_XML) -noinit -R theories Coq + +# The general rule for building .vo files : + +%.vo %.glob: %.v theories/Init/Prelude.vo $(VO_TOOLS_DEP) + $(SHOW)'COQC $<' + $(HIDE)rm -f $*.glob + $(HIDE)$(BOOTCOQC) $< +ifdef VALIDATE + $(SHOW)'COQCHK $(call vo_to_mod,$@)' + $(HIDE)$(CHICKEN) -boot -silent -norec $(call vo_to_mod,$@) \ + || ( RV=$$?; rm -f "$@"; exit $${RV} ) +endif + +# Dependencies of .v files + +%.v.d: $(D_DEPEND_BEFORE_SRC) %.v $(D_DEPEND_AFTER_SRC) $(COQDEPBOOT) $(GENVFILES) + $(SHOW)'COQDEP $<' + $(HIDE)$(COQDEPBOOT) -boot $(DEPNATDYN) "$<" $(TOTARGET) ########################################################################### # To speed-up things a bit, let's dissuade make to attempt rebuilding makefiles -Makefile Makefile.build Makefile.common config/Makefile : ; - +Makefile $(wildcard Makefile.*) config/Makefile : ; # For emacs: # Local Variables: diff --git a/Makefile.checker b/Makefile.checker new file mode 100644 index 0000000000..3ea0baced6 --- /dev/null +++ b/Makefile.checker @@ -0,0 +1,86 @@ +####################################################################### +# v # The Coq Proof Assistant / The Coq Development Team # +# <O___,, # INRIA-Rocquencourt & LRI-CNRS-Orsay # +# \VV/ ############################################################# +# // # This file is distributed under the terms of the # +# # GNU Lesser General Public License Version 2.1 # +####################################################################### + +## Makefile rules for building Coqchk + +## NB: For the moment, the build system of Coqchk is part of +## the one of Coq. In particular, this Makefile.checker is included in +## Makefile.build. Please ensure that the rules define here are +## indeed specific to files of the form checker/* + +# The binaries + +CHICKENBYTE:=bin/coqchk.byte$(EXE) +CHICKEN:=bin/coqchk$(EXE) + +# The sources + +CHKLIBS:= -I config -I lib -I checker + +## NB: currently, both $(OPTFLAGS) and $(BYTEFLAGS) contain -thread + +# The rules + +ifeq ($(BEST),opt) +$(CHICKEN): checker/check.cmxa checker/main.ml + $(SHOW)'OCAMLOPT -o $@' + $(HIDE)$(OCAMLOPT) $(SYSCMXA) $(CHKLIBS) $(OPTFLAGS) $(LINKMETADATA) -o $@ $^ + $(STRIP) $@ + $(CODESIGN) $@ +else +$(CHICKEN): $(CHICKENBYTE) + cp $< $@ +endif + +$(CHICKENBYTE): checker/check.cma checker/main.ml + $(SHOW)'OCAMLC -o $@' + $(HIDE)$(OCAMLC) $(SYSCMA) $(CHKLIBS) $(BYTEFLAGS) $(CUSTOM) -o $@ $^ + +checker/check.cma: checker/check.mllib | md5chk + $(SHOW)'OCAMLC -a -o $@' + $(HIDE)$(OCAMLC) $(CHKLIBS) $(BYTEFLAGS) -a -o $@ $(filter-out %.mllib, $^) + +checker/check.cmxa: checker/check.mllib | md5chk + $(SHOW)'OCAMLOPT -a -o $@' + $(HIDE)$(OCAMLOPT) $(CHKLIBS) $(OPTFLAGS) -a -o $@ $(filter-out %.mllib, $^) + +checker/%.ml.d: checker/%.ml + $(SHOW)'OCAMLDEP $<' + $(HIDE)$(OCAMLFIND) ocamldep -slash $(CHKLIBS) "$<" $(TOTARGET) + +checker/%.mli.d: checker/%.mli + $(SHOW)'OCAMLDEP $<' + $(HIDE)$(OCAMLFIND) ocamldep -slash $(CHKLIBS) "$<" $(TOTARGET) + +checker/%.mllib.d: checker/%.mllib | $(OCAMLLIBDEP) + $(SHOW)'OCAMLLIBDEP $<' + $(HIDE)$(OCAMLLIBDEP) $(CHKLIBS) "$<" $(TOTARGET) + +checker/%.cmi: checker/%.mli + $(SHOW)'OCAMLC $<' + $(HIDE)$(OCAMLC) $(CHKLIBS) $(BYTEFLAGS) -c $< + +checker/%.cmo: checker/%.ml + $(SHOW)'OCAMLC $<' + $(HIDE)$(OCAMLC) $(CHKLIBS) $(BYTEFLAGS) -c $< + +checker/%.cmx: checker/%.ml + $(SHOW)'OCAMLOPT $<' + $(HIDE)$(OCAMLOPT) $(CHKLIBS) $(OPTFLAGS) $(HACKMLI) -c $< + +md5chk: + $(SHOW)'MD5SUM cic.mli' + $(HIDE)if grep -q `$(MD5SUM) checker/cic.mli` checker/values.ml; \ + then true; else echo "Error: outdated checker/values.ml"; false; fi + +.PHONY: md5chk + +# For emacs: +# Local Variables: +# mode: makefile +# End: diff --git a/Makefile.common b/Makefile.common index 3e2bfcb3aa..4742bb51e8 100644 --- a/Makefile.common +++ b/Makefile.common @@ -14,19 +14,32 @@ COQMKTOP:=bin/coqmktop$(EXE) -COQC:=bin/coqc$(EXE) - COQTOPBYTE:=bin/coqtop.byte$(EXE) COQTOPEXE:=bin/coqtop$(EXE) -CHICKENBYTE:=bin/coqchk.byte$(EXE) -CHICKEN:=bin/coqchk$(EXE) +COQDEP:=bin/coqdep$(EXE) +COQMAKEFILE:=bin/coq_makefile$(EXE) +GALLINA:=bin/gallina$(EXE) +COQTEX:=bin/coq-tex$(EXE) +COQWC:=bin/coqwc$(EXE) +COQDOC:=bin/coqdoc$(EXE) +COQC:=bin/coqc$(EXE) +COQWORKMGR:=bin/coqworkmgr$(EXE) -ifeq ($(CAMLP4),camlp4) -CAMLP4MOD:=camlp4lib -else -CAMLP4MOD:=gramlib -endif +TOOLS:=$(COQDEP) $(COQMAKEFILE) $(GALLINA) $(COQTEX) $(COQWC) $(COQDOC) $(COQC)\ + $(COQWORKMGR) + +COQDEPBOOT:=bin/coqdep_boot$(EXE) +OCAMLLIBDEP:=bin/ocamllibdep$(EXE) +FAKEIDE:=bin/fake_ide$(EXE) + +PRIVATEBINARIES:=$(FAKEIDE) $(OCAMLLIBDEP) $(COQDEPBOOT) + +CSDPCERT:=plugins/micromega/csdpcert$(EXE) + +########################################################################### +# Object and Source files +########################################################################### ifeq ($(HASNATDYNLINK)-$(BEST),true-opt) DEPNATDYN:= @@ -39,31 +52,10 @@ INSTALLLIB:=install -m 644 INSTALLSH:=./install.sh MKDIR:=install -d -COQIDEBYTE:=bin/coqide.byte$(EXE) -COQIDE:=bin/coqide$(EXE) -COQIDEAPP:=bin/CoqIDE_$(VERSION).app -COQIDEINAPP:=$(COQIDEAPP)/Contents/MacOS/coqide - -ifeq ($(BEST),opt) -OPT:=opt -else -OPT:= -endif - -BESTOBJ:=$(if $(OPT),.cmx,.cmo) -BESTLIB:=$(if $(OPT),.cmxa,.cma) -BESTDYN:=$(if $(OPT),.cmxs,.cma) - -COQBINARIES:= $(COQMKTOP) \ - $(COQTOPBYTE) $(COQTOPEXE) \ - $(CHICKENBYTE) $(CHICKEN) - -CSDPCERT:=plugins/micromega/csdpcert$(EXE) - CORESRCDIRS:=\ config lib kernel kernel/byterun library \ proofs tactics pretyping interp stm \ - toplevel parsing printing grammar intf engine ltac + toplevel parsing printing intf engine ltac PLUGINS:=\ omega romega micromega quote \ @@ -76,83 +68,6 @@ SRCDIRS:=\ tools tools/coqdoc \ $(addprefix plugins/, $(PLUGINS)) -IDESRCDIRS:= $(CORESRCDIRS) ide ide/utils - -# Order is relevant here because kernel and checker contain files -# with the same name -CHKSRCDIRS:= checker lib config kernel parsing - -########################################################################### -# Tools -########################################################################### - -COQDEP:=bin/coqdep$(EXE) -OCAMLLIBDEP:=bin/ocamllibdep$(EXE) -COQMAKEFILE:=bin/coq_makefile$(EXE) -GALLINA:=bin/gallina$(EXE) -COQTEX:=bin/coq-tex$(EXE) -COQWC:=bin/coqwc$(EXE) -COQDOC:=bin/coqdoc$(EXE) -FAKEIDE:=bin/fake_ide$(EXE) -COQWORKMGR:=bin/coqworkmgr$(EXE) - -TOOLS:=$(COQDEP) $(COQMAKEFILE) $(GALLINA) $(COQTEX) $(COQWC) $(COQDOC) $(COQC)\ - $(COQWORKMGR) - -PRIVATEBINARIES:=$(FAKEIDE) $(OCAMLLIBDEP) - -########################################################################### -# Documentation -########################################################################### - -LATEX:=latex -BIBTEX:=BIBINPUTS=.: bibtex -min-crossrefs=10 -MAKEINDEX:=makeindex -PDFLATEX:=pdflatex -DVIPS:=dvips -FIG2DEV:=fig2dev -CONVERT:=convert -HEVEA:=hevea -HACHA:=hacha -HEVEAOPTS:=-fix -exec xxdate.exe -HEVEALIB:=/usr/local/lib/hevea:/usr/lib/hevea -HTMLSTYLE:=simple -export TEXINPUTS:=$(HEVEALIB): -COQTEXOPTS:=-boot -n 72 -sl -small - -DOCCOMMON:=doc/common/version.tex doc/common/title.tex doc/common/macros.tex - -REFMANCOQTEXFILES:=$(addprefix doc/refman/, \ - RefMan-gal.v.tex RefMan-ext.v.tex \ - RefMan-mod.v.tex RefMan-tac.v.tex \ - RefMan-cic.v.tex RefMan-lib.v.tex \ - RefMan-tacex.v.tex RefMan-syn.v.tex \ - RefMan-oth.v.tex RefMan-ltac.v.tex \ - RefMan-decl.v.tex RefMan-pro.v.tex RefMan-sch.v.tex \ - Cases.v.tex Coercion.v.tex CanonicalStructures.v.tex Extraction.v.tex \ - Program.v.tex Omega.v.tex Micromega.v.tex Polynom.v.tex Nsatz.v.tex \ - Setoid.v.tex Classes.v.tex Universes.v.tex \ - Misc.v.tex) - -REFMANTEXFILES:=$(addprefix doc/refman/, \ - headers.sty Reference-Manual.tex \ - RefMan-pre.tex RefMan-int.tex RefMan-com.tex \ - RefMan-uti.tex RefMan-ide.tex RefMan-add.tex RefMan-modr.tex \ - AsyncProofs.tex ) \ - $(REFMANCOQTEXFILES) \ - -REFMANEPSFILES:=doc/refman/coqide.eps doc/refman/coqide-queries.eps - -REFMANFILES:=$(REFMANTEXFILES) $(DOCCOMMON) $(REFMANEPSFILES) doc/refman/biblio.bib - -REFMANPNGFILES:=$(REFMANEPSFILES:.eps=.png) - - - -########################################################################### -# Object and Source files -########################################################################### - COQRUN := coqrun LIBCOQRUN:=kernel/byterun/lib$(COQRUN).a DLLCOQRUN:=$(dir $(LIBCOQRUN))dll$(COQRUN)$(DLLEXT) @@ -174,28 +89,36 @@ TOPLOOPCMA:=stm/proofworkertop.cma stm/tacworkertop.cma stm/queryworkertop.cma GRAMMARCMA:=tools/compat5.cmo grammar/grammar.cma -OMEGACMA:=plugins/omega/omega_plugin.cma -ROMEGACMA:=plugins/romega/romega_plugin.cma -MICROMEGACMA:=plugins/micromega/micromega_plugin.cma -QUOTECMA:=plugins/quote/quote_plugin.cma -RINGCMA:=plugins/setoid_ring/newring_plugin.cma -NSATZCMA:=plugins/nsatz/nsatz_plugin.cma -FOURIERCMA:=plugins/fourier/fourier_plugin.cma -EXTRACTIONCMA:=plugins/extraction/extraction_plugin.cma -FUNINDCMA:=plugins/funind/recdef_plugin.cma -FOCMA:=plugins/firstorder/ground_plugin.cma -CCCMA:=plugins/cc/cc_plugin.cma -BTAUTOCMA:=plugins/btauto/btauto_plugin.cma -RTAUTOCMA:=plugins/rtauto/rtauto_plugin.cma -NATSYNTAXCMA:=plugins/syntax/nat_syntax_plugin.cma +# modules known by the toplevel of Coq + +OBJSMOD:=$(shell cat $(CORECMA:.cma=.mllib)) + +########################################################################### +# plugins object files +########################################################################### + +OMEGACMA:=plugins/omega/omega_plugin.cmo +ROMEGACMA:=plugins/romega/romega_plugin.cmo +MICROMEGACMA:=plugins/micromega/micromega_plugin.cmo +QUOTECMA:=plugins/quote/quote_plugin.cmo +RINGCMA:=plugins/setoid_ring/newring_plugin.cmo +NSATZCMA:=plugins/nsatz/nsatz_plugin.cmo +FOURIERCMA:=plugins/fourier/fourier_plugin.cmo +EXTRACTIONCMA:=plugins/extraction/extraction_plugin.cmo +FUNINDCMA:=plugins/funind/recdef_plugin.cmo +FOCMA:=plugins/firstorder/ground_plugin.cmo +CCCMA:=plugins/cc/cc_plugin.cmo +BTAUTOCMA:=plugins/btauto/btauto_plugin.cmo +RTAUTOCMA:=plugins/rtauto/rtauto_plugin.cmo +NATSYNTAXCMA:=plugins/syntax/nat_syntax_plugin.cmo OTHERSYNTAXCMA:=$(addprefix plugins/syntax/, \ - z_syntax_plugin.cma \ - numbers_syntax_plugin.cma \ - r_syntax_plugin.cma \ - ascii_syntax_plugin.cma \ - string_syntax_plugin.cma ) -DECLMODECMA:=plugins/decl_mode/decl_mode_plugin.cma -DERIVECMA:=plugins/derive/derive_plugin.cma + z_syntax_plugin.cmo \ + numbers_syntax_plugin.cmo \ + r_syntax_plugin.cmo \ + ascii_syntax_plugin.cmo \ + string_syntax_plugin.cmo ) +DECLMODECMA:=plugins/decl_mode/decl_mode_plugin.cmo +DERIVECMA:=plugins/derive/derive_plugin.cmo PLUGINSCMA:=$(OMEGACMA) $(ROMEGACMA) $(MICROMEGACMA) $(DECLMODECMA) \ $(QUOTECMA) $(RINGCMA) \ @@ -208,17 +131,17 @@ ifneq ($(HASNATDYNLINK),false) STATICPLUGINS:= INITPLUGINS:=$(EXTRACTIONCMA) $(FOCMA) $(CCCMA) \ $(FUNINDCMA) $(NATSYNTAXCMA) - INITPLUGINSOPT:=$(INITPLUGINS:.cma=.cmxs) + INITPLUGINSOPT:=$(INITPLUGINS:.cmo=.cmxs) PLUGINS:=$(PLUGINSCMA) - PLUGINSOPT:=$(PLUGINSCMA:.cma=.cmxs) + PLUGINSOPT:=$(PLUGINSCMA:.cmo=.cmxs) else ifeq ($(BEST),byte) STATICPLUGINS:= INITPLUGINS:=$(EXTRACTIONCMA) $(FOCMA) $(CCCMA) \ $(FUNINDCMA) $(NATSYNTAXCMA) - INITPLUGINSOPT:=$(INITPLUGINS:.cma=.cmxs) + INITPLUGINSOPT:=$(INITPLUGINS:.cmo=.cmxs) PLUGINS:=$(PLUGINSCMA) - PLUGINSOPT:=$(PLUGINSCMA:.cma=.cmxs) + PLUGINSOPT:=$(PLUGINSCMA:.cmo=.cmxs) else STATICPLUGINS:=$(PLUGINSCMA) INITPLUGINS:= @@ -229,43 +152,7 @@ endif endif LINKCMO:=$(CORECMA) $(STATICPLUGINS) -LINKCMX:=$(CORECMA:.cma=.cmxa) $(STATICPLUGINS:.cma=.cmxa) - -IDEDEPS:=lib/clib.cma lib/xml_lexer.cmo lib/xml_parser.cmo lib/xml_printer.cmo lib/errors.cmo lib/spawn.cmo -IDECMA:=ide/ide.cma -IDETOPLOOPCMA=ide/coqidetop.cma - -LINKIDE:=$(IDEDEPS) $(IDECDEPS) $(IDECMA) ide/coqide_main.ml -LINKIDEOPT:=$(IDEOPTCDEPS) $(patsubst %.cma,%.cmxa,$(IDEDEPS:.cmo=.cmx)) $(IDECMA:.cma=.cmxa) ide/coqide_main.ml - -# modules known by the toplevel of Coq - -OBJSMOD:=$(shell cat $(CORECMA:.cma=.mllib)) - -IDEMOD:=$(shell cat ide/ide.mllib) - -# coqmktop, coqc - -COQENVCMO:=lib/clib.cma lib/errors.cmo - -COQMKTOPCMO:=$(COQENVCMO) tools/tolink.cmo tools/coqmktop.cmo - -COQCCMO:=$(COQENVCMO) toplevel/usage.cmo tools/coqc.cmo - -## Misc - -CSDPCERTCMO:=$(addprefix plugins/micromega/, \ - mutils.cmo micromega.cmo \ - sos_types.cmo sos_lib.cmo sos.cmo csdpcert.cmo ) - -DEBUGPRINTERS:=dev/top_printers.cmo dev/vm_printers.cmo dev/printers.cma - -COQDEPCMO:=$(COQENVCMO) lib/system.cmo tools/coqdep_lexer.cmo tools/coqdep_common.cmo tools/coqdep.cmo - -COQDOCCMO:=lib/clib.cma $(addprefix tools/coqdoc/, \ - cdglobals.cmo alpha.cmo index.cmo tokens.cmo output.cmo cpretty.cmo main.cmo ) - -COQMAKEFILECMO:=lib/clib.cma ide/project_file.cmo tools/coq_makefile.cmo +LINKCMX:=$(CORECMA:.cma=.cmxa) $(STATICPLUGINS:.cmo=.cmx) ########################################################################### # vo files @@ -273,127 +160,41 @@ COQMAKEFILECMO:=lib/clib.cma ide/project_file.cmo tools/coq_makefile.cmo ## we now retrieve the names of .vo file to compile in */vo.itarget files -cat_vo_itarget = $(addprefix $(1)/,$(shell cat $(1)/vo.itarget)) - -## Theories - -INITVO:=$(call cat_vo_itarget, theories/Init) -LOGICVO:=$(call cat_vo_itarget, theories/Logic) -STRUCTURESVO:=$(call cat_vo_itarget, theories/Structures) -ARITHVO:=$(call cat_vo_itarget, theories/Arith) -SORTINGVO:=$(call cat_vo_itarget, theories/Sorting) -BOOLVO:=$(call cat_vo_itarget, theories/Bool) -PARITHVO:=$(call cat_vo_itarget, theories/PArith) -NARITHVO:=$(call cat_vo_itarget, theories/NArith) -ZARITHVO:=$(call cat_vo_itarget, theories/ZArith) -QARITHVO:=$(call cat_vo_itarget, theories/QArith) -LISTSVO:=$(call cat_vo_itarget, theories/Lists) -VECTORSVO:=$(call cat_vo_itarget, theories/Vectors) -STRINGSVO:=$(call cat_vo_itarget, theories/Strings) -SETSVO:=$(call cat_vo_itarget, theories/Sets) -FSETSVO:=$(call cat_vo_itarget, theories/FSets) -MSETSVO:=$(call cat_vo_itarget, theories/MSets) -RELATIONSVO:=$(call cat_vo_itarget, theories/Relations) -WELLFOUNDEDVO:=$(call cat_vo_itarget, theories/Wellfounded) -REALSVO:=$(call cat_vo_itarget, theories/Reals) -NUMBERSVO:=$(call cat_vo_itarget, theories/Numbers) -SETOIDSVO:=$(call cat_vo_itarget, theories/Setoids) -UNICODEVO:=$(call cat_vo_itarget, theories/Unicode) -CLASSESVO:=$(call cat_vo_itarget, theories/Classes) -PROGRAMVO:=$(call cat_vo_itarget, theories/Program) -COMPATVO:=$(call cat_vo_itarget, theories/Compat) - -THEORIESVO:=\ - $(INITVO) $(LOGICVO) $(ARITHVO) $(BOOLVO) \ - $(UNICODEVO) $(CLASSESVO) $(PROGRAMVO) \ - $(RELATIONSVO) $(WELLFOUNDEDVO) $(SETOIDSVO) \ - $(LISTSVO) $(STRINGSVO) \ - $(PARITHVO) $(NARITHVO) $(ZARITHVO) \ - $(SETSVO) $(FSETSVO) $(MSETSVO) \ - $(REALSVO) $(SORTINGVO) $(QARITHVO) \ - $(NUMBERSVO) $(STRUCTURESVO) $(VECTORSVO) \ - $(COMPATVO) - -THEORIESLIGHTVO:= $(INITVO) $(LOGICVO) $(UNICODEVO) $(ARITHVO) - -## Plugins - -OMEGAVO:=$(call cat_vo_itarget, plugins/omega) -ROMEGAVO:=$(call cat_vo_itarget, plugins/romega) -MICROMEGAVO:=$(call cat_vo_itarget, plugins/micromega) -QUOTEVO:=$(call cat_vo_itarget, plugins/quote) -RINGVO:=$(call cat_vo_itarget, plugins/setoid_ring) -NSATZVO:=$(call cat_vo_itarget, plugins/nsatz) -FOURIERVO:=$(call cat_vo_itarget, plugins/fourier) -FUNINDVO:=$(call cat_vo_itarget, plugins/funind) -BTAUTOVO:=$(call cat_vo_itarget, plugins/btauto) -RTAUTOVO:=$(call cat_vo_itarget, plugins/rtauto) -EXTRACTIONVO:=$(call cat_vo_itarget, plugins/extraction) -CCVO:= -DERIVEVO:=$(call cat_vo_itarget, plugins/derive) - -PLUGINSVO:= $(OMEGAVO) $(ROMEGAVO) $(MICROMEGAVO) \ - $(FOURIERVO) $(CCVO) $(FUNINDVO) \ - $(RTAUTOVO) $(BTAUTOVO) $(RINGVO) $(QUOTEVO) \ - $(NSATZVO) $(EXTRACTIONVO) $(DERIVEVO) +THEORIESVO:= $(foreach f, $(wildcard theories/*/vo.itarget), \ + $(addprefix $(dir $(f)),$(shell cat $(f)))) + +PLUGINSVO:= $(foreach f, $(wildcard plugins/*/vo.itarget), \ + $(addprefix $(dir $(f)),$(shell cat $(f)))) ALLVO:= $(THEORIESVO) $(PLUGINSVO) VFILES:= $(ALLVO:.vo=.v) + +## More specific targets + +THEORIESLIGHTVO:= \ + $(filter theories/Init/% theories/Logic/% theories/Unicode/% theories/Arith/%, $(THEORIESVO)) + ALLSTDLIB := test-suite/misc/universes/all_stdlib # convert a (stdlib) filename into a module name: # remove .vo, replace theories and plugins by Coq, and replace slashes by dots vo_to_mod = $(subst /,.,$(patsubst theories/%,Coq.%,$(patsubst plugins/%,Coq.%,$(1:.vo=)))) +ALLMODS:=$(call vo_to_mod,$(ALLVO)) + + # Converting a stdlib filename into native compiler filenames # Used for install targets vo_to_cm = $(foreach vo,$(1),$(dir $(vo)).coq-native/$(subst /,_,$(patsubst theories/%,NCoq_%,$(patsubst plugins/%,NCoq_%,$(vo:.vo=.cm*))))) vo_to_obj = $(foreach vo,$(1),$(dir $(vo)).coq-native/$(subst /,_,$(patsubst theories/%,NCoq_%,$(patsubst plugins/%,NCoq_%,$(vo:.vo=.o))))) -ALLMODS:=$(call vo_to_mod,$(ALLVO)) - LIBFILES:=$(THEORIESVO) $(PLUGINSVO) $(call vo_to_cm,$(THEORIESVO)) \ $(call vo_to_cm,$(PLUGINSVO)) $(call vo_to_obj,$(THEORIESVO)) \ $(call vo_to_obj,$(PLUGINSVO)) \ $(PLUGINSVO:.vo=.v) $(THEORIESVO:.vo=.v) \ $(PLUGINSVO:.vo=.glob) $(THEORIESVO:.vo=.glob) -LIBFILESLIGHT:=$(THEORIESLIGHTVO) - -########################################################################### -# Miscellaneous -########################################################################### - -MANPAGES:=man/coq-tex.1 man/coqdep.1 man/gallina.1 \ - man/coqc.1 man/coqtop.1 man/coqtop.byte.1 man/coqtop.opt.1 \ - man/coqwc.1 man/coqdoc.1 man/coqide.1 \ - man/coq_makefile.1 man/coqmktop.1 man/coqchk.1 - -########################################################################### -# Source documentation -########################################################################### - -OCAMLDOCDIR=dev/ocamldoc - -DOCMLIS=$(wildcard ./lib/*.mli ./intf/*.mli ./kernel/*.mli ./library/*.mli \ - ./engine/*.mli ./pretyping/*.mli ./interp/*.mli printing/*.mli \ - ./parsing/*.mli ./proofs/*.mli \ - ./tactics/*.mli ./stm/*.mli ./toplevel/*.mli ./ltac/*.mli) - -# Defining options to generate dependencies graphs -DOT=dot -ODOCDOTOPTS=-dot -dot-reduce - -########################################################################### -# GTK for Coqide MacOS bundle -########################################################################### - -GTKSHARE=$(shell pkg-config --variable=prefix gtk+-2.0)/share -GTKBIN=$(shell pkg-config --variable=prefix gtk+-2.0)/bin -GTKLIBS=$(shell pkg-config --variable=libdir gtk+-2.0) - - # For emacs: # Local Variables: # mode: makefile diff --git a/Makefile.dev b/Makefile.dev new file mode 100644 index 0000000000..f35b861c12 --- /dev/null +++ b/Makefile.dev @@ -0,0 +1,223 @@ +####################################################################### +# v # The Coq Proof Assistant / The Coq Development Team # +# <O___,, # INRIA-Rocquencourt & LRI-CNRS-Orsay # +# \VV/ ############################################################# +# // # This file is distributed under the terms of the # +# # GNU Lesser General Public License Version 2.1 # +####################################################################### + +# Extra targets for developpers : +# debug printers, revision, partial targets ... + +######################### +# Debug printers in dev/ +######################### + +.PHONY: devel printers + +DEBUGPRINTERS:=dev/top_printers.cmo dev/vm_printers.cmo dev/printers.cma + +devel: printers +printers: $(DEBUGPRINTERS) + +dev/printers.cma: dev/printers.mllib + $(SHOW)'Testing $@' + $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) $(SYSCMA) $(P4CMA) $(filter-out %.mllib, $^) -o test-printer + @rm -f test-printer + $(SHOW)'OCAMLC -a $@' + $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) $(SYSCMA) $(P4CMA) $(filter-out %.mllib, $^) -linkall -a -o $@ + +dev/%.mllib.d: dev/%.mllib | $(OCAMLLIBDEP) $(GENFILES) + $(SHOW)'OCAMLLIBDEP $<' + $(HIDE)$(OCAMLLIBDEP) $(DEPFLAGS) -I dev "$<" $(TOTARGET) + +############ +# revision +############ + +# display the revision number when compiling a checked out source tree + +revision: + $(SHOW)'CHECK revision' + $(HIDE)rm -f revision.new +ifeq ($(CHECKEDOUT),svn) + $(HIDE)set -e; \ + if test -x "`which svn`"; then \ + export LC_ALL=C;\ + svn info . | sed -ne '/URL/s/.*\/\([^\/]\{1,\}\)/\1/p' > revision.new; \ + svn info . | sed -ne '/Revision/s/Revision: \([0-9]\{1,\}\)/\1/p'>> revision.new; \ + fi +endif +ifeq ($(CHECKEDOUT),gnuarch) + $(HIDE)set -e; \ + if test -x "`which tla`"; then \ + LANG=C; export LANG; \ + tla tree-version > revision.new ; \ + tla tree-revision | sed -ne 's|.*--||p' >> revision.new ; \ + fi +endif +ifeq ($(CHECKEDOUT),git) + $(HIDE)set -e; \ + if test -x "`which git`"; then \ + LANG=C; export LANG; \ + GIT_BRANCH=$$(git branch -a | sed -ne '/^\* /s/^\* \(.*\)/\1/p'); \ + GIT_HOST=$$(hostname); \ + GIT_PATH=$$(pwd); \ + (echo "$${GIT_HOST}:$${GIT_PATH},$${GIT_BRANCH}") > revision.new; \ + (echo "$$(git log -1 --pretty='format:%H')") >> revision.new; \ + fi +endif + $(HIDE)set -e; \ + if test -e revision.new; then \ + if test -e revision; then \ + if test "`cat revision`" = "`cat revision.new`" ; then \ + rm -f revision.new; \ + else \ + mv -f revision.new revision; \ + fi; \ + else \ + mv -f revision.new revision; \ + fi \ + fi + +.PHONY: revision + +################### +# Partial builds +################### + +# The following partial targets are normally not necessary +# for a complete build of coq, see instead 'make world' for that. +# But these partial targets could be quite handy for quick builds +# of specific components of Coq. + +############################### +### 1) general-purpose targets +############################### + +coqlight: theories-light tools coqbinaries + +states: theories/Init/Prelude.vo + +miniopt: $(COQTOPEXE) pluginsopt +minibyte: $(COQTOPBYTE) pluginsbyte + +pluginsopt: $(PLUGINSOPT) +pluginsbyte: $(PLUGINS) + +.PHONY: coqlight states miniopt minibyte pluginsopt pluginsbyte + +########################## +### 2) core ML components +########################## + +lib: lib/clib.cma lib/lib.cma +kernel: kernel/kernel.cma +byterun: $(BYTERUN) +library: library/library.cma +engine: engine/engine.cma +proofs: proofs/proofs.cma +tactics: tactics/tactics.cma +interp: interp/interp.cma +parsing: parsing/parsing.cma +pretyping: pretyping/pretyping.cma +highparsing: parsing/highparsing.cma +stm: stm/stm.cma +toplevel: toplevel/toplevel.cma +ltac: ltac/ltac.cma + +.PHONY: lib kernel byterun library proofs tactics interp parsing pretyping +.PHONY: engine highparsing stm toplevel ltac + +###################### +### 3) theories files +###################### + +init: $(filter theories/Init/%, $(THEORIESVO)) +logic: $(filter theories/Logic/%, %(THEORIESVO)) +arith: $(filter theories/Arith/%, $(THEORIESVO)) +bool: $(filter theories/Bool/%, $(THEORIESVO)) +parith: $(filter theories/PArith/%, $(THEORIESVO)) +narith: $(filter theories/NArith/%, $(THEORIESVO)) +zarith: $(filter theories/ZArith/%, $(THEORIESVO)) +qarith: $(filter theories/QArith/%, $(THEORIESVO)) +lists: $(filter theories/Lists/%, $(THEORIESVO)) +strings: $(filter theories/Strings/%, $(THEORIESVO)) +sets: $(filter theories/Sets/%, $(THEORIESVO)) +fsets: $(filter theories/FSets/%, $(THEORIESVO)) +relations: $(filter theories/Relations/%, $(THEORIESVO)) +wellfounded: $(filter theories/Wellfounded/%, $(THEORIESVO)) +reals: $(filter theories/Reals/%, $(THEORIESVO)) +setoids: $(filter theories/Setoids/%, $(THEORIESVO)) +sorting: $(filter theories/Sorting/%, $(THEORIESVO)) +numbers: $(filter theories/Numbers/%, $(THEORIESVO)) +unicode: $(filter theories/Unicode/%, $(THEORIESVO)) +classes: $(filter theories/Classes/%, $(THEORIESVO)) +program: $(filter theories/Program/%, $(THEORIESVO)) +structures: $(filter theories/Structures/%, $(THEORIESVO)) +vectors: $(filter theories/Vectors/%, $(THEORIESVO)) +msets: $(filter theories/MSets/%, $(THEORIESVO)) +compat: $(filter theories/Compat/%, $(THEORIESVO)) + +theories-light: $(THEORIESLIGHTVO) + +noreal: unicode logic arith bool zarith qarith lists sets fsets \ + relations wellfounded setoids sorting + +.PHONY: init theories-light noreal +.PHONY: logic arith bool narith zarith qarith lists strings sets +.PHONY: fsets relations wellfounded reals setoids sorting numbers +.PHONY: msets mmaps compat + +################ +### 4) plugins +################ + +OMEGAVO:=$(filter plugins/omega/%, $(PLUGINSVO)) +ROMEGAVO:=$(filter plugins/romega/%, $(PLUGINSVO)) +MICROMEGAVO:=$(filter plugins/micromega/%, $(PLUGINSVO)) +QUOTEVO:=$(filter plugins/quote/%, $(PLUGINSVO)) +RINGVO:=$(filter plugins/setoid_ring/%, $(PLUGINSVO)) +NSATZVO:=$(filter plugins/nsatz/%, $(PLUGINSVO)) +FOURIERVO:=$(filter plugins/fourier/%, $(PLUGINSVO)) +FUNINDVO:=$(filter plugins/funind/%, $(PLUGINSVO)) +BTAUTOVO:=$(filter plugins/btauto/%, $(PLUGINSVO)) +RTAUTOVO:=$(filter plugins/rtauto/%, $(PLUGINSVO)) +EXTRACTIONVO:=$(filter plugins/extraction/%, $(PLUGINSVO)) +CCVO:= +DERIVEVO:=$(filter plugins/derive/%, $(PLUGINSVO)) + +omega: $(OMEGAVO) $(OMEGACMA) $(ROMEGAVO) $(ROMEGACMA) +micromega: $(MICROMEGAVO) $(MICROMEGACMA) $(CSDPCERT) +setoid_ring: $(RINGVO) $(RINGCMA) +nsatz: $(NSATZVO) $(NSATZCMA) +extraction: $(EXTRACTIONCMA) +fourier: $(FOURIERVO) $(FOURIERCMA) +funind: $(FUNINDCMA) $(FUNINDVO) +cc: $(CCVO) $(CCCMA) +rtauto: $(RTAUTOVO) $(RTAUTOCMA) +btauto: $(BTAUTOVO) $(BTAUTOCMA) + +.PHONY: omega micromega setoid_ring nsatz extraction +.PHONY: fourier funind cc rtauto btauto + +################################# +### Misc other development rules +################################# + +# NOTA : otags only accepts camlp4 as preprocessor, so the following rule +# won't build tags of .ml4 when compiling with camlp5 + +otags: + otags $(MLIFILES) $(filter-out configure.ml, $(MLSTATICFILES)) \ + $(if $(filter camlp5,$(CAMLP4)), , \ + -pa op -pa g -pa m -pa rq $(addprefix -pa , $(CAMLP4DEPS)) \ + $(addprefix -impl , $(ML4FILES))) + +.PHONY: otags + + +# For emacs: +# Local Variables: +# mode: makefile +# End: diff --git a/Makefile.doc b/Makefile.doc index b7251ce579..6c345025aa 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -1,3 +1,11 @@ +####################################################################### +# v # The Coq Proof Assistant / The Coq Development Team # +# <O___,, # INRIA-Rocquencourt & LRI-CNRS-Orsay # +# \VV/ ############################################################# +# // # This file is distributed under the terms of the # +# # GNU Lesser General Public License Version 2.1 # +####################################################################### + # Makefile for the Coq documentation # To compile documentation, you need the following tools: @@ -5,6 +13,61 @@ # Pdf: pdflatex # Html: hevea (http://hevea.inria.fr) >= 1.05 +# The main entry point : + +documentation: doc-$(WITHDOC) ## see $(WITHDOC) in config/Makefile +doc-all: doc +doc-no: + +.PHONY: documentation doc-all doc-no + +###################################################################### +### Variables +###################################################################### + +LATEX:=latex +BIBTEX:=BIBINPUTS=.: bibtex -min-crossrefs=10 +MAKEINDEX:=makeindex +PDFLATEX:=pdflatex +DVIPS:=dvips +FIG2DEV:=fig2dev +CONVERT:=convert +HEVEA:=hevea +HACHA:=hacha +HEVEAOPTS:=-fix -exec xxdate.exe +HEVEALIB:=/usr/local/lib/hevea:/usr/lib/hevea +HTMLSTYLE:=simple +export TEXINPUTS:=$(HEVEALIB): +COQTEXOPTS:=-boot -n 72 -sl -small + +DOCCOMMON:=doc/common/version.tex doc/common/title.tex doc/common/macros.tex + +REFMANCOQTEXFILES:=$(addprefix doc/refman/, \ + RefMan-gal.v.tex RefMan-ext.v.tex \ + RefMan-mod.v.tex RefMan-tac.v.tex \ + RefMan-cic.v.tex RefMan-lib.v.tex \ + RefMan-tacex.v.tex RefMan-syn.v.tex \ + RefMan-oth.v.tex RefMan-ltac.v.tex \ + RefMan-decl.v.tex RefMan-pro.v.tex RefMan-sch.v.tex \ + Cases.v.tex Coercion.v.tex CanonicalStructures.v.tex Extraction.v.tex \ + Program.v.tex Omega.v.tex Micromega.v.tex Polynom.v.tex Nsatz.v.tex \ + Setoid.v.tex Classes.v.tex Universes.v.tex \ + Misc.v.tex) + +REFMANTEXFILES:=$(addprefix doc/refman/, \ + headers.sty Reference-Manual.tex \ + RefMan-pre.tex RefMan-int.tex RefMan-com.tex \ + RefMan-uti.tex RefMan-ide.tex RefMan-add.tex RefMan-modr.tex \ + AsyncProofs.tex ) \ + $(REFMANCOQTEXFILES) \ + +REFMANEPSFILES:=doc/refman/coqide.eps doc/refman/coqide-queries.eps + +REFMANFILES:=$(REFMANTEXFILES) $(DOCCOMMON) $(REFMANEPSFILES) doc/refman/biblio.bib + +REFMANPNGFILES:=$(REFMANEPSFILES:.eps=.png) + + ###################################################################### ### General rules ###################################################################### @@ -339,6 +402,80 @@ install-doc-index-urls: $(MKDIR) $(FULLDATADIR) $(INSTALLLIB) $(INDEXURLS) $(FULLDATADIR) + +########################################################################### +# Documentation of the source code (using ocamldoc) +########################################################################### + +OCAMLDOCDIR=dev/ocamldoc + +DOCMLIS=$(wildcard ./lib/*.mli ./intf/*.mli ./kernel/*.mli ./library/*.mli \ + ./engine/*.mli ./pretyping/*.mli ./interp/*.mli printing/*.mli \ + ./parsing/*.mli ./proofs/*.mli \ + ./tactics/*.mli ./stm/*.mli ./toplevel/*.mli ./ltac/*.mli) + +# Defining options to generate dependencies graphs +DOT=dot +ODOCDOTOPTS=-dot -dot-reduce + +.PHONY: source-doc mli-doc ml-doc + +source-doc: mli-doc $(OCAMLDOCDIR)/coq.pdf + +$(OCAMLDOCDIR)/coq.tex: $(DOCMLIS:.mli=.cmi) + $(SHOW)'OCAMLDOC -latex -o $@' + $(HIDE)$(OCAMLFIND) ocamldoc -latex -rectypes -I $(MYCAMLP4LIB) $(MLINCLUDES)\ + $(DOCMLIS) -noheader -t "Coq mlis documentation" \ + -intro $(OCAMLDOCDIR)/docintro -o $@.tmp + $(SHOW)'OCAMLDOC utf8 fix' + $(HIDE)$(OCAMLDOCDIR)/fix-ocamldoc-utf8 $@.tmp + $(HIDE)cat $(OCAMLDOCDIR)/header.tex $@.tmp > $@ + rm $@.tmp + +mli-doc: $(DOCMLIS:.mli=.cmi) + $(SHOW)'OCAMLDOC -html' + $(HIDE)$(OCAMLFIND) ocamldoc -charset utf-8 -html -rectypes -I +threads -I $(MYCAMLP4LIB) $(MLINCLUDES) \ + $(DOCMLIS) -d $(OCAMLDOCDIR)/html -colorize-code \ + -t "Coq mlis documentation" -intro $(OCAMLDOCDIR)/docintro \ + -css-style style.css + +ml-dot: $(MLFILES) + $(OCAMLFIND) ocamldoc -dot -dot-reduce -rectypes -I +threads -I $(CAMLLIB) -I $(MYCAMLP4LIB) $(MLINCLUDES) \ + $(filter $(addsuffix /%.ml,$(CORESRCDIRS)),$(MLFILES)) -o $(OCAMLDOCDIR)/coq.dot + +%_dep.png: %.dot + $(DOT) -Tpng $< -o $@ + +%_types.dot: %.mli + $(OCAMLFIND) ocamldoc -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -dot-types -o $@ $< + +OCAMLDOC_MLLIBD = $(OCAMLFIND) ocamldoc -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -o $@ \ + $(foreach lib,$(|:.mllib.d=_MLLIB_DEPENDENCIES),$(addsuffix .ml,$($(lib)))) + +%.dot: | %.mllib.d + $(OCAMLDOC_MLLIBD) + +ml-doc: + $(OCAMLFIND) ocamldoc -charset utf-8 -html -rectypes -I +threads $(MLINCLUDES) $(COQIDEFLAGS) -d $(OCAMLDOCDIR) $(MLSTATICFILES) + +parsing/parsing.dot : | parsing/parsing.mllib.d parsing/highparsing.mllib.d + $(OCAMLDOC_MLLIBD) + +grammar/grammar.dot : | grammar/grammar.mllib.d + $(OCAMLDOC_MLLIBD) + +tactics/tactics.dot: | tactics/tactics.mllib.d ltac/ltac.mllib.d + $(OCAMLDOC_MLLIBD) + +%.dot: %.mli + $(OCAMLFIND) ocamldoc -rectypes $(MLINCLUDES) $(ODOCDOTOPTS) -o $@ $< + +$(OCAMLDOCDIR)/%.pdf: $(OCAMLDOCDIR)/%.tex + $(SHOW)'PDFLATEX $*.tex' + $(HIDE)(cd $(OCAMLDOCDIR) ; pdflatex -interaction=batchmode $*.tex && pdflatex -interaction=batchmode $*.tex) + $(HIDE)(cd doc/tools/; show_latex_messages -no-overfull ../../$(OCAMLDOCDIR)/$*.log) + + # For emacs: # Local Variables: # mode: makefile diff --git a/Makefile.ide b/Makefile.ide new file mode 100644 index 0000000000..8d6b5de36f --- /dev/null +++ b/Makefile.ide @@ -0,0 +1,254 @@ +####################################################################### +# v # The Coq Proof Assistant / The Coq Development Team # +# <O___,, # INRIA-Rocquencourt & LRI-CNRS-Orsay # +# \VV/ ############################################################# +# // # This file is distributed under the terms of the # +# # GNU Lesser General Public License Version 2.1 # +####################################################################### + +## Makefile rules for building the CoqIDE interface + +## NB: For the moment, the build system of CoqIDE is part of +## the one of Coq. In particular, this Makefile.ide is included in +## Makefile.build. Please ensure that the rules define here are +## indeed specific to files of the form ide/* + +## Coqide-related variables set by ./configure in config/Makefile + +#COQIDEINCLUDES : something like -I +lablgtk2 +#HASCOQIDE : opt / byte / no +#IDEFLAGS : some extra cma, for instance +#IDEOPTCDEPS : on windows, ide/ide_win32_stubs.o ide/coq_icon.o +#IDECDEPS +#IDECDEPSFLAGS +#IDEINT : X11 / QUARTZ / WIN32 + +## CoqIDE Executable + +COQIDEBYTE:=bin/coqide.byte$(EXE) +COQIDE:=bin/coqide$(EXE) +COQIDEAPP:=bin/CoqIDE_$(VERSION).app +COQIDEINAPP:=$(COQIDEAPP)/Contents/MacOS/coqide + +## CoqIDE source directory and files + +# Note : for just building bin/coqide, we could only consider +# config, lib, ide and ide/utils. But the coqidetop plugin (the +# one that will be loaded by coqtop -ideslave) refers to some +# core modules of coq, for instance printing/*. + +IDESRCDIRS:= $(CORESRCDIRS) ide ide/utils + +COQIDEFLAGS=$(addprefix -I , $(IDESRCDIRS)) $(COQIDEINCLUDES) + +IDEDEPS:=lib/clib.cma lib/errors.cmo lib/spawn.cmo +IDECMA:=ide/ide.cma +IDETOPLOOPCMA=ide/coqidetop.cma + +LINKIDE:=$(IDEDEPS) $(IDECDEPS) $(IDECMA) ide/coqide_main.ml +LINKIDEOPT:=$(IDEOPTCDEPS) $(patsubst %.cma,%.cmxa,$(IDEDEPS:.cmo=.cmx)) $(IDECMA:.cma=.cmxa) ide/coqide_main.ml + +IDEFILES=$(wildcard ide/*.lang) ide/coq_style.xml ide/coq.png ide/MacOS/default_accel_map + +## GTK for Coqide MacOS bundle + +GTKSHARE=$(shell pkg-config --variable=prefix gtk+-2.0)/share +GTKBIN=$(shell pkg-config --variable=prefix gtk+-2.0)/bin +GTKLIBS=$(shell pkg-config --variable=libdir gtk+-2.0) + + +########################################################################### +# CoqIde special targets +########################################################################### + +.PHONY: coqide coqide-binaries coqide-no coqide-byte coqide-opt coqide-files + +# target to build CoqIde +coqide: coqide-files coqide-binaries theories/Init/Prelude.vo + +coqide-binaries: coqide-$(HASCOQIDE) ide-toploop +coqide-no: +coqide-byte: $(COQIDEBYTE) $(COQIDE) +coqide-opt: $(COQIDEBYTE) $(COQIDE) +coqide-files: $(IDEFILES) +ifeq ($(BEST),opt) +ide-toploop: $(IDETOPLOOPCMA) $(IDETOPLOOPCMA:.cma=.cmxs) +else +ide-toploop: $(IDETOPLOOPCMA) +endif + +ifeq ($(HASCOQIDE),opt) +$(COQIDE): $(LINKIDEOPT) + $(SHOW)'OCAMLOPT -o $@' + $(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -o $@ unix.cmxa threads.cmxa lablgtk.cmxa \ + lablgtksourceview2.cmxa str.cmxa $(IDEFLAGS:.cma=.cmxa) $^ + $(STRIP) $@ +else +$(COQIDE): $(COQIDEBYTE) + cp $< $@ +endif + +$(COQIDEBYTE): $(LINKIDE) + $(SHOW)'OCAMLC -o $@' + $(HIDE)$(OCAMLC) $(COQIDEFLAGS) $(BYTEFLAGS) -o $@ unix.cma threads.cma lablgtk.cma \ + lablgtksourceview2.cma str.cma $(IDEFLAGS) $(IDECDEPSFLAGS) $^ + +ide/coqide_main.ml: ide/coqide_main.ml4 config/Makefile # no camlp4deps here + $(SHOW)'CAMLP4O $<' + $(HIDE)$(CAMLP4O) $(CAMLP4FLAGS) $(PR_O) $(CAMLP4USE) -D$(IDEINT) -impl $< -o $@ + + +ide/%.cmi: ide/%.mli + $(SHOW)'OCAMLC $<' + $(HIDE)$(OCAMLC) $(COQIDEFLAGS) $(BYTEFLAGS) -c $< + +ide/%.cmo: ide/%.ml + $(SHOW)'OCAMLC $<' + $(HIDE)$(OCAMLC) $(COQIDEFLAGS) $(BYTEFLAGS) -c $< + +ide/%.cmx: ide/%.ml + $(SHOW)'OCAMLOPT $<' + $(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) $(HACKMLI) -c $< + + +#################### +## Install targets +#################### + +.PHONY: install-coqide install-ide-bin install-ide-toploop install-ide-files install-ide-info install-ide-devfiles + +ifeq ($(HASCOQIDE),no) +install-coqide: install-ide-toploop +else +install-coqide: install-ide-bin install-ide-toploop install-ide-files install-ide-info install-ide-devfiles +endif + +install-ide-bin: + $(MKDIR) $(FULLBINDIR) + $(INSTALLBIN) $(COQIDE) $(FULLBINDIR) + +install-ide-toploop: + $(MKDIR) $(FULLCOQLIB)/toploop + $(INSTALLBIN) $(IDETOPLOOPCMA) $(FULLCOQLIB)/toploop/ +ifeq ($(BEST),opt) + $(INSTALLBIN) $(IDETOPLOOPCMA:.cma=.cmxs) $(FULLCOQLIB)/toploop/ +endif + +install-ide-devfiles: + $(MKDIR) $(FULLCOQLIB) + $(INSTALLSH) $(FULLCOQLIB) $(IDECMA) \ + $(foreach lib,$(IDECMA:.cma=_MLLIB_DEPENDENCIES),$(addsuffix .cmi,$($(lib)))) +ifeq ($(BEST),opt) + $(INSTALLSH) $(FULLCOQLIB) $(IDECMA:.cma=.cmxa) $(IDECMA:.cma=.a) +endif + +install-ide-files: #Please update $(COQIDEAPP)/Contents/Resources/ at the same time + $(MKDIR) $(FULLDATADIR) + $(INSTALLLIB) ide/coq.png ide/*.lang ide/coq_style.xml $(FULLDATADIR) + $(MKDIR) $(FULLCONFIGDIR) + if [ $(IDEINT) = QUARTZ ] ; then $(INSTALLLIB) ide/mac_default_accel_map $(FULLCONFIGDIR)/coqide.keys ; fi + +install-ide-info: + $(MKDIR) $(FULLDOCDIR) + $(INSTALLLIB) ide/FAQ $(FULLDOCDIR)/FAQ-CoqIde + +########################################################################### +# CoqIde MacOS special targets +########################################################################### + +.PHONY: $(COQIDEAPP)/Contents + +$(COQIDEAPP)/Contents: + rm -rdf $@ + $(MKDIR) $@ + sed -e "s/VERSION/$(VERSION4MACOS)/g" ide/MacOS/Info.plist.template > $@/Info.plist + $(MKDIR) "$@/MacOS" + +$(COQIDEINAPP): ide/macos_prehook.cmx $(LINKIDEOPT) | $(COQIDEAPP)/Contents + $(SHOW)'OCAMLOPT -o $@' + $(HIDE)$(OCAMLOPT) $(COQIDEFLAGS) $(OPTFLAGS) -o $@ \ + unix.cmxa lablgtk.cmxa lablgtksourceview2.cmxa str.cmxa \ + threads.cmxa $(IDEFLAGS:.cma=.cmxa) $^ + $(STRIP) $@ + +$(COQIDEAPP)/Contents/Resources/share: $(COQIDEAPP)/Contents + $(MKDIR) $@/coq/ + $(INSTALLLIB) ide/coq.png ide/*.lang ide/coq_style.xml $@/coq/ + $(MKDIR) $@/gtksourceview-2.0/{language-specs,styles} + $(INSTALLLIB) "$(GTKSHARE)/"gtksourceview-2.0/language-specs/{def.lang,language2.rng} $@/gtksourceview-2.0/language-specs/ + $(INSTALLLIB) "$(GTKSHARE)/"gtksourceview-2.0/styles/{styles.rng,classic.xml} $@/gtksourceview-2.0/styles/ + cp -R "$(GTKSHARE)/"locale $@ + cp -R "$(GTKSHARE)/"icons $@ + cp -R "$(GTKSHARE)/"themes $@ + +$(COQIDEAPP)/Contents/Resources/loaders: $(COQIDEAPP)/Contents + $(MKDIR) $@ + $(INSTALLLIB) $$("$(GTKBIN)/gdk-pixbuf-query-loaders" | sed -n -e '5 s!.*= \(.*\)$$!\1!p')/libpixbufloader-png.so $@ + +$(COQIDEAPP)/Contents/Resources/immodules: $(COQIDEAPP)/Contents + $(MKDIR) $@ + $(INSTALLLIB) "$(GTKLIBS)/gtk-2.0/2.10.0/immodules/"*.so $@ + + +$(COQIDEAPP)/Contents/Resources/etc: $(COQIDEAPP)/Contents/Resources/lib + $(MKDIR) $@/xdg/coq + $(INSTALLLIB) ide/MacOS/default_accel_map $@/xdg/coq/coqide.keys + $(MKDIR) $@/gtk-2.0 + { "$(GTKBIN)/gdk-pixbuf-query-loaders" $@/../loaders/*.so |\ + sed -e "s!/.*\(/loaders/.*.so\)!@executable_path/../Resources/\1!"; } \ + > $@/gtk-2.0/gdk-pixbuf.loaders + { "$(GTKBIN)/gtk-query-immodules-2.0" $@/../immodules/*.so |\ + sed -e "s!/.*\(/immodules/.*.so\)!@executable_path/../Resources/\1!" |\ + sed -e "s!/.*\(/share/locale\)!@executable_path/../Resources/\1!"; } \ + > $@/gtk-2.0/gtk-immodules.loaders + $(MKDIR) $@/pango + echo "[Pango]" > $@/pango/pangorc + +$(COQIDEAPP)/Contents/Resources/lib: $(COQIDEAPP)/Contents/Resources/immodules $(COQIDEAPP)/Contents/Resources/loaders $(COQIDEAPP)/Contents $(COQIDEINAPP) + $(MKDIR) $@ + $(INSTALLLIB) $(GTKLIBS)/charset.alias $@/ + $(MKDIR) $@/pango/1.8.0/modules + $(INSTALLLIB) "$(GTKLIBS)/pango/1.8.0/modules/"*.so $@/pango/1.8.0/modules/ + { "$(GTKBIN)/pango-querymodules" $@/pango/1.8.0/modules/*.so |\ + sed -e "s!/.*\(/pango/1.8.0/modules/.*.so\)!@executable_path/../Resources/lib\1!"; } \ + > $@/pango/1.8.0/modules.cache + + for i in $$(otool -L $(COQIDEINAPP) |sed -n -e "\@$(GTKLIBS)@ s/[^/]*\(\/[^ ]*\) .*$$/\1/p"); \ + do cp $$i $@/; \ + ide/MacOS/relatify_with-respect-to_.sh $@/$$(basename $$i) $(GTKLIBS) $@; \ + done + for i in $@/../loaders/*.so $@/../immodules/*.so $@/pango/1.8.0/modules/*.so; \ + do \ + for j in $$(otool -L $$i | sed -n -e "\@$(GTKLIBS)@ s/[^/]*\(\/[^ ]*\) .*$$/\1/p"); \ + do cp $$j $@/; ide/MacOS/relatify_with-respect-to_.sh $@/$$(basename $$j) $(GTKLIBS) $@; done; \ + ide/MacOS/relatify_with-respect-to_.sh $$i $(GTKLIBS) $@; \ + done + EXTRAWORK=1; \ + while [ $${EXTRAWORK} -eq 1 ]; \ + do EXTRAWORK=0; \ + for i in $@/*.dylib; \ + do for j in $$(otool -L $$i | sed -n -e "\@$(GTKLIBS)@ s/[^/]*\(\/[^ ]*\) .*$$/\1/p"); \ + do EXTRAWORK=1; cp $$j $@/; ide/MacOS/relatify_with-respect-to_.sh $@/$$(basename $$j) $(GTKLIBS) $@; done; \ + done; \ + done + ide/MacOS/relatify_with-respect-to_.sh $(COQIDEINAPP) $(GTKLIBS) $@ + +$(COQIDEAPP)/Contents/Resources:$(COQIDEAPP)/Contents/Resources/etc $(COQIDEAPP)/Contents/Resources/share + $(INSTALLLIB) ide/MacOS/*.icns $@ + +$(COQIDEAPP):$(COQIDEAPP)/Contents/Resources + $(CODESIGN) $@ + +########################################################################### +# CoqIde for Windows special targets +########################################################################### + +%.o: %.rc + $(SHOW)'WINDRES $<' + $(HIDE)i686-w64-mingw32-windres -i $< -o $@ + + +# For emacs: +# Local Variables: +# mode: makefile +# End: diff --git a/Makefile.install b/Makefile.install new file mode 100644 index 0000000000..ed29bc1e7b --- /dev/null +++ b/Makefile.install @@ -0,0 +1,136 @@ +####################################################################### +# v # The Coq Proof Assistant / The Coq Development Team # +# <O___,, # INRIA-Rocquencourt & LRI-CNRS-Orsay # +# \VV/ ############################################################# +# // # This file is distributed under the terms of the # +# # GNU Lesser General Public License Version 2.1 # +####################################################################### + +# This makefile regroups installation rules +# It is included by Makefile.build + +ifeq ($(LOCAL),true) +install: + @echo "Nothing to install in a local build!" +else +install: install-coq install-coqide install-doc-$(WITHDOC) +endif + +install-doc-all: install-doc +install-doc-no: + +.PHONY: install install-doc-all install-doc-no + +#These variables are intended to be set by the caller to make +#COQINSTALLPREFIX= +#OLDROOT= + + # Can be changed for a local installation (to make packages). + # You must NOT put a "/" at the end (Cygnus for win32 does not like "//"). + +ifdef COQINSTALLPREFIX +FULLBINDIR=$(BINDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%) +FULLCOQLIB=$(COQLIBINSTALL:"$(OLDROOT)%="$(COQINSTALLPREFIX)%) +FULLCONFIGDIR=$(CONFIGDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%) +FULLDATADIR=$(DATADIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%) +FULLMANDIR=$(MANDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%) +FULLEMACSLIB=$(EMACSLIB:"$(OLDROOT)%="$(COQINSTALLPREFIX)%) +FULLCOQDOCDIR=$(COQDOCDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%) +FULLDOCDIR=$(DOCDIR:"$(OLDROOT)%="$(COQINSTALLPREFIX)%) +else +FULLBINDIR=$(BINDIR) +FULLCOQLIB=$(COQLIBINSTALL) +FULLCONFIGDIR=$(CONFIGDIR) +FULLDATADIR=$(DATADIR) +FULLMANDIR=$(MANDIR) +FULLEMACSLIB=$(EMACSLIB) +FULLCOQDOCDIR=$(COQDOCDIR) +FULLDOCDIR=$(DOCDIR) +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 + +install-coq: install-binaries install-library install-coq-info install-devfiles + +install-binaries: install-tools + $(MKDIR) $(FULLBINDIR) + $(INSTALLBIN) $(COQC) $(COQTOPBYTE) $(COQTOPEXE) $(CHICKEN) $(FULLBINDIR) + $(MKDIR) $(FULLCOQLIB)/toploop + $(INSTALLBIN) $(TOPLOOPCMA) $(FULLCOQLIB)/toploop/ +ifeq ($(BEST),opt) + $(INSTALLBIN) $(TOPLOOPCMA:.cma=.cmxs) $(FULLCOQLIB)/toploop/ +endif + + +install-tools: + $(MKDIR) $(FULLBINDIR) + # recopie des fichiers de style pour coqide + $(MKDIR) $(FULLCOQLIB)/tools/coqdoc + touch $(FULLCOQLIB)/tools/coqdoc/coqdoc.sty $(FULLCOQLIB)/tools/coqdoc/coqdoc.css # to have the mode according to umask (bug #1715) + $(INSTALLLIB) tools/coqdoc/coqdoc.css tools/coqdoc/coqdoc.sty $(FULLCOQLIB)/tools/coqdoc + $(INSTALLBIN) $(TOOLS) $(FULLBINDIR) + +# The list of .cmi to install, including the ones obtained +# from .mli without .ml, and the ones obtained from .ml without .mli + +INSTALLCMI = $(sort \ + $(filter-out checker/% ide/% tools/%, $(MLIFILES:.mli=.cmi)) \ + $(foreach lib,$(CORECMA) $(PLUGINSCMA), $(addsuffix .cmi,$($(lib:.cma=_MLLIB_DEPENDENCIES))))) + +install-devfiles: + $(MKDIR) $(FULLBINDIR) + $(INSTALLBIN) $(COQMKTOP) $(FULLBINDIR) + $(MKDIR) $(FULLCOQLIB) + $(INSTALLSH) $(FULLCOQLIB) $(LINKCMO) $(GRAMMARCMA) + $(INSTALLSH) $(FULLCOQLIB) $(INSTALLCMI) +ifeq ($(BEST),opt) + $(INSTALLSH) $(FULLCOQLIB) $(LINKCMX) $(CORECMA:.cma=.a) $(STATICPLUGINS:.cma=.a) +endif + +install-library: + $(MKDIR) $(FULLCOQLIB) + $(INSTALLSH) $(FULLCOQLIB) $(LIBFILES) $(PLUGINS) + $(MKDIR) $(FULLCOQLIB)/user-contrib +ifndef CUSTOM + $(INSTALLLIB) $(DLLCOQRUN) $(FULLCOQLIB) +endif +ifeq ($(BEST),opt) + $(INSTALLLIB) $(LIBCOQRUN) $(FULLCOQLIB) + $(INSTALLSH) $(FULLCOQLIB) $(PLUGINSOPT) +endif +# csdpcert is not meant to be directly called by the user; we install +# it with libraries + -$(MKDIR) $(FULLCOQLIB)/plugins/micromega + $(INSTALLBIN) $(CSDPCERT) $(FULLCOQLIB)/plugins/micromega + rm -f $(FULLCOQLIB)/revision + -$(INSTALLLIB) revision $(FULLCOQLIB) + +install-coq-info: install-coq-manpages install-emacs install-latex + +MANPAGES:=man/coq-tex.1 man/coqdep.1 man/gallina.1 \ + man/coqc.1 man/coqtop.1 man/coqtop.byte.1 man/coqtop.opt.1 \ + man/coqwc.1 man/coqdoc.1 man/coqide.1 \ + man/coq_makefile.1 man/coqmktop.1 man/coqchk.1 + +install-coq-manpages: + $(MKDIR) $(FULLMANDIR)/man1 + $(INSTALLLIB) $(MANPAGES) $(FULLMANDIR)/man1 + +install-emacs: + $(MKDIR) $(FULLEMACSLIB) + $(INSTALLLIB) tools/gallina-db.el tools/coq-font-lock.el tools/gallina-syntax.el tools/gallina.el tools/coq-inferior.el $(FULLEMACSLIB) + +# command to update TeX' kpathsea database +#UPDATETEX = $(MKTEXLSR) /usr/share/texmf /var/spool/texmf $(BASETEXDIR) > /dev/null + +install-latex: + $(MKDIR) $(FULLCOQDOCDIR) + $(INSTALLLIB) tools/coqdoc/coqdoc.sty $(FULLCOQDOCDIR) +# -$(UPDATETEX) + +# For emacs: +# Local Variables: +# mode: makefile +# End: diff --git a/_tags b/_tags deleted file mode 100644 index f805eeaa3f..0000000000 --- a/_tags +++ /dev/null @@ -1,76 +0,0 @@ - -## tags for binaries - -<tools/coqmktop.{native,byte}> : use_str, use_unix -<tools/coqc.{native,byte}> : use_str, use_unix -<tools/coqdep_boot.{native,byte}> : use_unix -<tools/coqdep.{native,byte}> : use_str, use_unix -<tools/coq_tex.{native,byte}> : use_str -<tools/coq_makefile.{native,byte}> : use_str, use_unix -<tools/coqdoc/main.{native,byte}> : use_str -<ide/coqide_main.{native,byte}> : use_str, use_unix, ide -<checker/main.{native,byte}> : use_str, use_unix, thread -<plugins/micromega/csdpcert.{native,byte}> : use_nums, use_unix -<tools/mkwinapp.{native,byte}> : use_unix -<tools/fake_ide.{native,byte}> : use_unix, use_str - -## tags for ide - -<ide/**/*.{ml,mli}>: ide - -## tags for grammar.cm* - -<grammar/grammar.{cma,cmxa}> : use_unix - -## tags for camlp4 files - -"parsing/g_constr.ml4": use_compat5 -"parsing/g_ltac.ml4": use_compat5 -"parsing/g_prim.ml4": use_compat5 -"parsing/g_proofs.ml4": use_compat5 -"parsing/g_tactic.ml4": use_compat5 -"parsing/g_vernac.ml4": use_compat5 -"parsing/g_xml.ml4": use_compat5 -"parsing/pcoq.ml4": use_compat5 -"parsing/g_obligations.ml4": use_grammar - -"grammar/argextend.ml4": use_compat5b -"grammar/q_constr.ml4": use_compat5b -"grammar/tacextend.ml4": use_compat5b -"grammar/vernacextend.ml4": use_compat5b - -<tactics/*.ml4>: use_grammar -"tactics/hipattern.ml4": use_constr - -<plugins/**/*.ml4>: use_grammar -"plugins/decl_mode/g_decl_mode.ml4": use_compat5 -"plugins/funind/g_indfun.ml4": use_compat5 - -## sub-directory inclusion - -# Note: "checker" is deliberately not included -# Note: same for "config" (we create a special coq_config.ml) - -"parsing": include -"ide": include -"ide/utils": include -"interp": include -"intf": include -"grammar": include -"kernel": include -"kernel/byterun": include -"lib": include -"library": include -"parsing": include -"plugins": include -"engine": include -"pretyping": include -"printing": include -"proofs": include -"tactics": include -"theories": include -"tools": include -"tools/coqdoc": include -"toplevel": include - -<plugins/**>: include diff --git a/build b/build deleted file mode 100755 index debf29cf43..0000000000 --- a/build +++ /dev/null @@ -1,32 +0,0 @@ -#!/bin/sh - -FLAGS="-j 2" -OCAMLBUILD=ocamlbuild -MYCFG=myocamlbuild_config.ml - -export CAML_LD_LIBRARY_PATH=`pwd`/_build/kernel/byterun - -check_config() { - if [ ! -f $MYCFG ]; then echo "please run ./configure first"; exit 1; fi -} - -ocb() { $OCAMLBUILD $FLAGS $*; } - -rule() { - check_config - case $1 in - clean) ocb -clean && rm -rf bin/*;; - all) ocb coq.otarget;; - win32) ocb coq-win32.otarget;; - *) ocb $1;; - esac; -} - -if [ $# -eq 0 ]; then - rule all -else - while [ $# -gt 0 ]; do - rule $1; - shift - done -fi diff --git a/checker/check.ml b/checker/check.ml index 3a5c91217d..da3cd03161 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -111,15 +111,14 @@ let check_one_lib admit (dir,m) = also check if it carries a validation certificate (yet to be implemented). *) if LibrarySet.mem dir admit then - (Flags.if_verbose ppnl + (Flags.if_verbose Feedback.msg_notice (str "Admitting library: " ++ pr_dirpath dir); Safe_typing.unsafe_import file md m.library_extra_univs dig) else - (Flags.if_verbose ppnl + (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 pp (fnl()); - pp_flush (); + Flags.if_verbose Feedback.msg_notice (fnl()); register_loaded_library m (*************************************************************************) @@ -173,7 +172,7 @@ let remove_load_path dir = let add_load_path (phys_path,coq_path) = if !Flags.debug then - ppnl (str "path: " ++ pr_dirpath coq_path ++ str " ->" ++ spc() ++ + Feedback.msg_notice (str "path: " ++ pr_dirpath coq_path ++ str " ->" ++ spc() ++ str phys_path); let phys_path = canonical_path_name phys_path in let physical, logical = !load_paths in @@ -188,7 +187,7 @@ let add_load_path (phys_path,coq_path) = begin (* Assume the user is concerned by library naming *) if dir <> default_root_prefix then - msg_warning + Feedback.msg_warning (str phys_path ++ strbrk " was previously bound to " ++ pr_dirpath dir ++ strbrk "; it is remapped to " ++ pr_dirpath coq_path); @@ -299,12 +298,12 @@ let name_clash_message dir mdir f = let depgraph = ref LibraryMap.empty let intern_from_file (dir, f) = - Flags.if_verbose pp (str"[intern "++str f++str" ..."); pp_flush (); + Flags.if_verbose Feedback.msg_notice(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 let (sd:Cic.summary_disk), _, digest = System.marshal_in_segment f ch in - let (md:Cic.library_disk), _, _ = System.marshal_in_segment f ch in + let (md:Cic.library_disk), _, digest = System.marshal_in_segment f ch in let (opaque_csts:'a option), _, udg = System.marshal_in_segment f ch in let (discharging:'a option), _, _ = System.marshal_in_segment f ch in let (tasks:'a option), _, _ = System.marshal_in_segment f ch in @@ -323,7 +322,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 - pp (str " (was a vio file) "); + Feedback.msg_notice(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")) @@ -334,12 +333,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 ppnl (str" done]"); pp_flush (); + Flags.if_verbose Feedback.msg_notice (str" done]"); 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 ppnl (str" failed!]"); raise e in + with e -> Flags.if_verbose Feedback.msg_notice (str" failed!]"); 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,_,_) -> @@ -407,11 +406,11 @@ let recheck_library ~norec ~admit ~check = let nochk = List.fold_right LibrarySet.remove (List.map fst (nrl@ml)) nochk in (* *) - Flags.if_verbose ppnl (fnl()++hv 2 (str "Ordered list:" ++ fnl() ++ + Flags.if_verbose Feedback.msg_notice (fnl()++hv 2 (str "Ordered list:" ++ fnl() ++ prlist (fun (dir,_) -> pr_dirpath dir ++ fnl()) needed)); List.iter (check_one_lib nochk) needed; - Flags.if_verbose ppnl (str"Modules were successfully checked") + Flags.if_verbose Feedback.msg_notice (str"Modules were successfully checked") open Printf diff --git a/checker/check.mllib b/checker/check.mllib index 900cfe0c82..2fa4d57977 100644 --- a/checker/check.mllib +++ b/checker/check.mllib @@ -22,21 +22,24 @@ CList CString Serialize Stateid -Feedback -Pp -Segmenttree -Unicodetable -Unicode CObj CArray CStack Util +Pp Ppstyle +Xml_datatype +Richpp +Feedback +Segmenttree +Unicodetable +Unicode Errors CEphemeron Future CUnix +Minisys System Profile RemoteCounter diff --git a/checker/check_stat.ml b/checker/check_stat.ml index 84f5684d48..a26c93a30d 100644 --- a/checker/check_stat.ml +++ b/checker/check_stat.ml @@ -57,12 +57,13 @@ let print_context env = env_modules=mods; env_modtypes=mtys}; env_stratification= {env_universes=univ; env_engagement=engt}} = env in - ppnl(hov 0 + Feedback.msg_notice + (hov 0 (fnl() ++ str"CONTEXT SUMMARY" ++ fnl() ++ str"===============" ++ fnl() ++ fnl() ++ str "* " ++ hov 0 (pr_engagement engt ++ fnl()) ++ fnl() ++ str "* " ++ hov 0 (pr_ax csts) ++ - fnl())); pp_flush() + fnl())); end let stats () = diff --git a/checker/checker.ml b/checker/checker.ml index 91a207a60c..9d76fb09e6 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -17,7 +17,7 @@ open Check let () = at_exit flush_all let fatal_error info anomaly = - flush_all (); pperrnl info; flush_all (); + flush_all (); Feedback.msg_error info; flush_all (); exit (if anomaly then 129 else 1) let coq_root = Id.of_string "Coq" @@ -67,12 +67,12 @@ let add_path ~unix_path:dir ~coq_root:coq_dirpath = Check.add_load_path (dir,coq_dirpath) end else - msg_warning (str "Cannot open " ++ str dir) + Feedback.msg_warning (str "Cannot open " ++ str dir) let convert_string d = try Id.of_string d with Errors.UserError _ -> - if_verbose msg_warning + if_verbose Feedback.msg_warning (str "Directory " ++ str d ++ str " cannot be used as a Coq identifier (skipped)"); raise Exit @@ -90,7 +90,7 @@ let add_rec_path ~unix_path ~coq_root = List.iter Check.add_load_path dirs; Check.add_load_path (unix_path, coq_root) else - msg_warning (str "Cannot open " ++ str unix_path) + Feedback.msg_warning (str "Cannot open " ++ str unix_path) (* By the option -include -I or -R of the command line *) let includes = ref [] @@ -123,7 +123,7 @@ let init_load_path () = add_rec_path ~unix_path:user_contrib ~coq_root:Check.default_root_prefix; (* then directories in XDG_DATA_DIRS and XDG_DATA_HOME *) List.iter (fun s -> add_rec_path ~unix_path:s ~coq_root:Check.default_root_prefix) - (xdg_dirs ~warn:(fun x -> msg_warning (str x))); + (xdg_dirs ~warn:(fun x -> Feedback.msg_warning (str x))); (* then directories in COQPATH *) List.iter (fun s -> add_rec_path ~unix_path:s ~coq_root:Check.default_root_prefix) coqpath; (* then current directory *) @@ -179,10 +179,7 @@ let print_usage_channel co command = output_string co command; output_string co "coqchk options are:\n"; output_string co -" -I dir -as coqdir map physical dir to logical coqdir\ -\n -I dir map directory dir to the empty logical path\ -\n -include dir (idem)\ -\n -R dir coqdir recursively map physical dir to logical coqdir\ +" -R dir coqdir map physical dir to logical coqdir\ \n\ \n -admit module load module and dependencies without checking\ \n -norec module check module but admit dependencies without checking\ @@ -288,7 +285,7 @@ let rec explain_exn = function Format.printf "@\nis not convertible with@\n"; Print.print_pure_constr a; Format.printf "@\n====== universes ====@\n"; - Pp.pp (Univ.pr_universes + Feedback.msg_notice (Univ.pr_universes (ctx.Environ.env_stratification.Environ.env_universes)); str "\nCantApplyBadType at argument " ++ int n | CantApplyNonFunctional _ -> str"CantApplyNonFunctional" diff --git a/checker/closure.ml b/checker/closure.ml index c2708e97d2..cef1d31a68 100644 --- a/checker/closure.ml +++ b/checker/closure.ml @@ -29,7 +29,7 @@ let reset () = beta := 0; delta := 0; zeta := 0; evar := 0; iota := 0; prune := 0 let stop() = - msg_debug (str "[Reds: beta=" ++ int !beta ++ str" delta=" ++ int !delta ++ + Feedback.msg_debug (str "[Reds: beta=" ++ int !beta ++ str" delta=" ++ int !delta ++ str" zeta=" ++ int !zeta ++ str" evar=" ++ int !evar ++ str" iota=" ++ int !iota ++ str" prune=" ++ int !prune ++ str"]") diff --git a/checker/declarations.ml b/checker/declarations.ml index 3ce3125337..1fe02c8b60 100644 --- a/checker/declarations.ml +++ b/checker/declarations.ml @@ -73,32 +73,32 @@ let solve_delta_kn resolve kn = | Equiv kn1 -> kn1 | Inline _ -> raise Not_found with Not_found -> - let mp,dir,l = repr_kn kn in + let mp,dir,l = KerName.repr kn in let new_mp = find_prefix resolve mp in if mp == new_mp then kn else - make_kn new_mp dir l + KerName.make new_mp dir l let gen_of_delta resolve x kn fix_can = let new_kn = solve_delta_kn resolve kn in if kn == new_kn then x else fix_can new_kn let constant_of_delta resolve con = - let kn = user_con con in - gen_of_delta resolve con kn (constant_of_kn_equiv kn) + let kn = Constant.user con in + gen_of_delta resolve con kn (Constant.make kn) let constant_of_delta2 resolve con = - let kn, kn' = canonical_con con, user_con con in - gen_of_delta resolve con kn (constant_of_kn_equiv kn') + let kn, kn' = Constant.canonical con, Constant.user con in + gen_of_delta resolve con kn (Constant.make kn') let mind_of_delta resolve mind = - let kn = user_mind mind in - gen_of_delta resolve mind kn (mind_of_kn_equiv kn) + let kn = MutInd.user mind in + gen_of_delta resolve mind kn (MutInd.make kn) let mind_of_delta2 resolve mind = - let kn, kn' = canonical_mind mind, user_mind mind in - gen_of_delta resolve mind kn (mind_of_kn_equiv kn') + let kn, kn' = MutInd.canonical mind, MutInd.user mind in + gen_of_delta resolve mind kn (MutInd.make kn') let find_inline_of_delta kn resolve = match Deltamap.find_kn kn resolve with @@ -106,7 +106,7 @@ let find_inline_of_delta kn resolve = | _ -> raise Not_found let constant_of_delta_with_inline resolve con = - let kn1,kn2 = canonical_con con,user_con con in + let kn1,kn2 = Constant.canonical con, Constant.user con in try find_inline_of_delta kn2 resolve with Not_found -> try find_inline_of_delta kn1 resolve @@ -137,17 +137,17 @@ let subst_mp sub mp = | Some (mp',_) -> mp' let subst_kn_delta sub kn = - let mp,dir,l = repr_kn kn in + let mp,dir,l = KerName.repr kn in match subst_mp0 sub mp with Some (mp',resolve) -> - solve_delta_kn resolve (make_kn mp' dir l) + solve_delta_kn resolve (KerName.make mp' dir l) | None -> kn let subst_kn sub kn = - let mp,dir,l = repr_kn kn in + let mp,dir,l = KerName.repr kn in match subst_mp0 sub mp with Some (mp',_) -> - make_kn mp' dir l + KerName.make mp' dir l | None -> kn exception No_subst @@ -165,14 +165,14 @@ let gen_subst_mp f sub mp1 mp2 = | Some (mp1',_), Some (mp2',resolve2) -> Canonical, (f mp1' mp2'), resolve2 let make_mind_equiv mpu mpc dir l = - let knu = make_kn mpu dir l in - if mpu == mpc then mind_of_kn knu - else mind_of_kn_equiv knu (make_kn mpc dir l) + let knu = KerName.make mpu dir l in + if mpu == mpc then MutInd.make1 knu + else MutInd.make knu (KerName.make mpc dir l) let subst_ind sub mind = - let kn1,kn2 = user_mind mind, canonical_mind mind in - let mp1,dir,l = repr_kn kn1 in - let mp2,_,_ = repr_kn kn2 in + let kn1,kn2 = MutInd.user mind, MutInd.canonical mind in + let mp1,dir,l = KerName.repr kn1 in + let mp2,_,_ = KerName.repr kn2 in let rebuild_mind mp1 mp2 = make_mind_equiv mp1 mp2 dir l in try let side,mind',resolve = gen_subst_mp rebuild_mind sub mp1 mp2 in @@ -182,14 +182,14 @@ let subst_ind sub mind = with No_subst -> mind let make_con_equiv mpu mpc dir l = - let knu = make_kn mpu dir l in - if mpu == mpc then constant_of_kn knu - else constant_of_kn_equiv knu (make_kn mpc dir l) + let knu = KerName.make mpu dir l in + if mpu == mpc then Constant.make1 knu + else Constant.make knu (KerName.make mpc dir l) let subst_con0 sub con u = - let kn1,kn2 = user_con con,canonical_con con in - let mp1,dir,l = repr_kn kn1 in - let mp2,_,_ = repr_kn kn2 in + let kn1,kn2 = Constant.user con, Constant.canonical con in + let mp1,dir,l = KerName.repr kn1 in + let mp2,_,_ = KerName.repr kn2 in let rebuild_con mp1 mp2 = make_con_equiv mp1 mp2 dir l in let dup con = con, Const (con, u) in let side,con',resolve = gen_subst_mp rebuild_con sub mp1 mp2 in @@ -304,7 +304,9 @@ let subset_prefixed_by mp resolver = match hint with | Inline _ -> rslv | Equiv _ -> - if mp_in_mp mp (modpath kn) then Deltamap.add_kn kn hint rslv else rslv + if mp_in_mp mp (KerName.modpath kn) + then Deltamap.add_kn kn hint rslv + else rslv in Deltamap.fold mp_prefix kn_prefix resolver empty_delta_resolver diff --git a/checker/environ.ml b/checker/environ.ml index 7040fdda46..9352f71ef7 100644 --- a/checker/environ.ml +++ b/checker/environ.ml @@ -112,7 +112,7 @@ let anomaly s = anomaly (Pp.str s) let add_constant kn cs env = if Cmap_env.mem kn env.env_globals.env_constants then Printf.ksprintf anomaly ("Constant %s is already defined") - (string_of_con kn); + (Constant.to_string kn); let new_constants = Cmap_env.add kn cs env.env_globals.env_constants in let new_globals = @@ -172,12 +172,14 @@ let lookup_projection p env = let scrape_mind env kn= try KNmap.find kn env.env_globals.env_inductives_eq - with - Not_found -> kn + with + Not_found -> kn let mind_equiv env (kn1,i1) (kn2,i2) = Int.equal i1 i2 && - KerName.equal (scrape_mind env (user_mind kn1)) (scrape_mind env (user_mind kn2)) + KerName.equal + (scrape_mind env (MutInd.user kn1)) + (scrape_mind env (MutInd.user kn2)) let lookup_mind kn env = @@ -186,9 +188,9 @@ let lookup_mind kn env = let add_mind kn mib env = if Mindmap_env.mem kn env.env_globals.env_inductives then Printf.ksprintf anomaly ("Inductive %s is already defined") - (string_of_mind kn); + (MutInd.to_string kn); let new_inds = Mindmap_env.add kn mib env.env_globals.env_inductives in - let kn1,kn2 = user_mind kn,canonical_mind kn in + let kn1,kn2 = MutInd.user kn, MutInd.canonical kn in let new_inds_eq = if KerName.equal kn1 kn2 then env.env_globals.env_inductives_eq else @@ -205,7 +207,7 @@ let add_mind kn mib env = let add_modtype ln mtb env = if MPmap.mem ln env.env_globals.env_modtypes then Printf.ksprintf anomaly ("Module type %s is already defined") - (string_of_mp ln); + (ModPath.to_string ln); let new_modtypes = MPmap.add ln mtb env.env_globals.env_modtypes in let new_globals = { env.env_globals with @@ -215,7 +217,7 @@ let add_modtype ln mtb env = let shallow_add_module mp mb env = if MPmap.mem mp env.env_globals.env_modules then Printf.ksprintf anomaly ("Module %s is already defined") - (string_of_mp mp); + (ModPath.to_string mp); let new_mods = MPmap.add mp mb env.env_globals.env_modules in let new_globals = { env.env_globals with @@ -225,7 +227,7 @@ let shallow_add_module mp mb env = let shallow_remove_module mp env = if not (MPmap.mem mp env.env_globals.env_modules) then Printf.ksprintf anomaly ("Module %s is unknown") - (string_of_mp mp); + (ModPath.to_string mp); let new_mods = MPmap.remove mp env.env_globals.env_modules in let new_globals = { env.env_globals with diff --git a/checker/indtypes.ml b/checker/indtypes.ml index 566df673c1..a667bb8a3e 100644 --- a/checker/indtypes.ml +++ b/checker/indtypes.ml @@ -32,11 +32,11 @@ let string_of_mp mp = if !Flags.debug then debug_string_of_mp mp else string_of_mp mp let prkn kn = - let (mp,_,l) = repr_kn kn in + let (mp,_,l) = KerName.repr kn in str(string_of_mp mp ^ "." ^ Label.to_string l) let prcon c = - let ck = canonical_con c in - let uk = user_con c in + let ck = Constant.canonical c in + let uk = Constant.user c in if KerName.equal ck uk then prkn uk else (prkn uk ++str"(="++prkn ck++str")") (* Same as noccur_between but may perform reductions. @@ -528,7 +528,7 @@ let check_positivity env_ar mind params nrecp inds = (************************************************************************) let check_inductive env kn mib = - Flags.if_verbose ppnl (str " checking ind: " ++ pr_mind kn); pp_flush (); + Flags.if_verbose Feedback.msg_notice (str " checking ind: " ++ MutInd.print kn); (* check mind_constraints: should be consistent with env *) let env = add_constraints (Univ.UContext.constraints mib.mind_universes) env in (* check mind_record : TODO ? check #constructor = 1 ? *) diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index 3ea5ed0d34..7f93e15609 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -18,7 +18,7 @@ let refresh_arity ar = let ctxt, hd = decompose_prod_assum ar in match hd with Sort (Type u) when not (Univ.is_univ_variable u) -> - let ul = Univ.Level.make empty_dirpath 1 in + let ul = Univ.Level.make DirPath.empty 1 in let u' = Univ.Universe.make ul in let cst = Univ.enforce_leq u u' Univ.empty_constraint in let ctx = Univ.ContextSet.make (Univ.LSet.singleton ul) cst in @@ -26,7 +26,7 @@ let refresh_arity ar = | _ -> ar, Univ.ContextSet.empty let check_constant_declaration env kn cb = - Flags.if_verbose ppnl (str " checking cst: " ++ prcon kn); pp_flush (); + Flags.if_verbose Feedback.msg_notice (str " checking cst: " ++ prcon kn); let env' = if cb.const_polymorphic then let inst = Univ.make_abstract_instance cb.const_universes in @@ -70,7 +70,7 @@ let check_constant_declaration env kn cb = let lookup_module mp env = try Environ.lookup_module mp env with Not_found -> - failwith ("Unknown module: "^string_of_mp mp) + failwith ("Unknown module: "^ModPath.to_string mp) let mk_mtb mp sign delta = { mod_mp = mp; diff --git a/checker/modops.ml b/checker/modops.ml index 9f43752620..442f999bb3 100644 --- a/checker/modops.ml +++ b/checker/modops.ml @@ -28,7 +28,7 @@ let error_not_match l _ = let error_no_such_label l = error ("No such label "^Label.to_string l) let error_no_such_label_sub l l1 = - let l1 = string_of_mp l1 in + let l1 = ModPath.to_string l1 in error ("The field "^ Label.to_string l^" is missing in "^l1^".") diff --git a/checker/print.ml b/checker/print.ml index 9cd8fda5dc..c0d1ac3688 100644 --- a/checker/print.ml +++ b/checker/print.ml @@ -10,7 +10,7 @@ open Format open Cic open Names -let print_instance i = Pp.pp (Univ.Instance.pr i) +let print_instance i = Feedback.msg_notice (Univ.Instance.pr i) let print_pure_constr csr = let rec term_display c = match c with @@ -108,7 +108,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("; Pp.pp (Univ.pr_uni u); print_string ")" + | Type u -> print_string "Type("; Feedback.msg_notice (Univ.pr_uni u); print_string ")" and name_display = function | Name id -> print_string (Id.to_string id) @@ -122,7 +122,7 @@ let print_pure_constr csr = | ("Coq"::_::l) -> l | l -> l in List.iter (fun x -> print_string x; print_string ".") ls;*) - print_string (debug_string_of_mind sp) + print_string (MutInd.debug_to_string sp) and sp_con_display sp = (* let dir,l = decode_kn sp in let ls = @@ -131,7 +131,7 @@ let print_pure_constr csr = | ("Coq"::_::l) -> l | l -> l in List.iter (fun x -> print_string x; print_string ".") ls;*) - print_string (debug_string_of_con sp) + print_string (Constant.debug_to_string sp) in try diff --git a/checker/safe_typing.ml b/checker/safe_typing.ml index 7f9ed92f95..1071e2f930 100644 --- a/checker/safe_typing.ml +++ b/checker/safe_typing.ml @@ -81,7 +81,7 @@ let stamp_library file digest = () warning is issued in case of mismatch *) let import file clib univs digest = let env = !genv in - check_imports msg_warning clib.comp_name env clib.comp_deps; + check_imports Feedback.msg_warning clib.comp_name env clib.comp_deps; check_engagement env clib.comp_enga; let mb = clib.comp_mod in Mod_checking.check_module @@ -93,7 +93,7 @@ let import file clib univs digest = (* When the module is admitted, digests *must* match *) let unsafe_import file clib univs digest = let env = !genv in - if !Flags.debug then check_imports msg_warning clib.comp_name env clib.comp_deps + if !Flags.debug then check_imports Feedback.msg_warning clib.comp_name env clib.comp_deps else check_imports (errorlabstrm"unsafe_import") clib.comp_name env clib.comp_deps; check_engagement env clib.comp_enga; full_add_module clib.comp_name clib.comp_mod univs digest diff --git a/checker/subtyping.ml b/checker/subtyping.ml index e41922573f..46d21f6ccb 100644 --- a/checker/subtyping.ml +++ b/checker/subtyping.ml @@ -103,7 +103,7 @@ let check_inductive env mp1 l info1 mib2 spec2 subst1 subst2= in let eq_projection_body p1 p2 = let check eq f = if not (eq (f p1) (f p2)) then error () in - check eq_mind (fun x -> x.proj_ind); + check MutInd.equal (fun x -> x.proj_ind); check (==) (fun x -> x.proj_npars); check (==) (fun x -> x.proj_arg); check (eq_constr) (fun x -> x.proj_type); diff --git a/checker/typeops.ml b/checker/typeops.ml index 64afd21b2a..da9842a8db 100644 --- a/checker/typeops.ml +++ b/checker/typeops.ml @@ -92,7 +92,7 @@ let judge_of_constant_knowing_parameters env (kn,u as cst) paramstyp = let _cb = try lookup_constant kn env with Not_found -> - failwith ("Cannot find constant: "^string_of_con kn) + failwith ("Cannot find constant: "^Constant.to_string kn) in let ty, cu = type_of_constant_knowing_parameters env cst paramstyp in let () = check_constraints cu env in @@ -178,7 +178,7 @@ let judge_of_inductive_knowing_parameters env (ind,u) (paramstyp:constr array) = let specif = try lookup_mind_specif env ind with Not_found -> - failwith ("Cannot find inductive: "^string_of_mind (fst ind)) + failwith ("Cannot find inductive: "^MutInd.to_string (fst ind)) in type_of_inductive_knowing_parameters env (specif,u) paramstyp @@ -192,7 +192,7 @@ let judge_of_constructor env (c,u) = let specif = try lookup_mind_specif env ind with Not_found -> - failwith ("Cannot find inductive: "^string_of_mind (fst ind)) + failwith ("Cannot find inductive: "^MutInd.to_string (fst ind)) in type_of_constructor (c,u) specif @@ -223,7 +223,7 @@ let judge_of_projection env p c ct = try find_rectype env ct with Not_found -> error_case_not_inductive env (c, ct) in - assert(eq_mind pb.proj_ind (fst ind)); + assert(MutInd.equal pb.proj_ind (fst ind)); let ty = subst_instance_constr u pb.proj_type in substl (c :: List.rev args) ty diff --git a/configure.ml b/configure.ml index 6adaa45db7..71502058fe 100644 --- a/configure.ml +++ b/configure.ml @@ -474,7 +474,7 @@ let caml_version_nums = "Is it installed properly?") let check_caml_version () = - if caml_version_nums >= [3;12;1] then + if caml_version_nums >= [4;1;0] then if caml_version_nums = [4;2;0] && not !Prefs.force_caml_version then die ("Your version of OCaml is 4.02.0 which suffers from a bug inducing\n" ^ "very slow compilation times. If you still want to use it, use \n" ^ @@ -486,7 +486,7 @@ let check_caml_version () = if !Prefs.force_caml_version then printf "*Warning* Your version of OCaml is outdated.\n" else - die "You need OCaml 3.12.1 or later." + die "You need OCaml 4.01 or later." let _ = check_caml_version () @@ -513,43 +513,32 @@ exception NoCamlp5 let check_camlp5 testcma = match !Prefs.camlp5dir with | Some dir -> - if Sys.file_exists (dir/testcma) then dir + if Sys.file_exists (dir/testcma) then + let camlp5o = + try which_camlpX "camlp5o" + with Not_found -> die "Error: cannot find Camlp5 binaries in path.\n" in + dir, camlp5o else let msg = sprintf "Cannot find camlp5 libraries in '%s' (%s not found)." dir testcma in die msg | None -> - let dir,_ = tryrun "camlp5" ["-where"] in - let dir2 = - if Sys.file_exists (camllib/"camlp5"/testcma) then - camllib/"camlp5" - else if Sys.file_exists (camllib/"site-lib"/"camlp5"/testcma) then - camllib/"site-lib"/"camlp5" - else "" - in - (* if the two values are different then camlp5 has been relocated - * and will not be able to find its own files, so we prefer the - * path where the files actually do exist *) - if dir2 = "" then - if dir = "" then - let () = printf "No Camlp5 installation found." in - let () = printf "Looking for Camlp4 instead...\n" in - raise NoCamlp5 - else dir - else dir2 - -let check_camlp5_version () = - try - let camlp5o = which_camlpX "camlp5o" in - let version_line, _ = run ~err:StdOut camlp5o ["-v"] in - let version = List.nth (string_split ' ' version_line) 2 in - match string_split '.' version with - | major::minor::_ when s2i major > 5 || (s2i major, s2i minor) >= (5,1) -> - printf "You have Camlp5 %s. Good!\n" version; camlp5o, version - | _ -> failwith "bad version" - with - | Not_found -> die "Error: cannot find Camlp5 binaries in path.\n" + try + let camlp5o = which_camlpX "camlp5o" in + let dir,_ = tryrun camlp5o ["-where"] in + dir, camlp5o + with Not_found -> + let () = printf "No Camlp5 installation found." in + let () = printf "Looking for Camlp4 instead...\n" in + raise NoCamlp5 + +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 + | major::minor::_ when s2i major > 5 || (s2i major, s2i minor) >= (5,1) -> + printf "You have Camlp5 %s. Good!\n" version; version | _ -> die "Error: unsupported Camlp5 (version < 5.01 or unrecognized).\n" let check_caml_version_for_camlp4 () = @@ -563,8 +552,8 @@ let config_camlpX () = try if not !Prefs.usecamlp5 then raise NoCamlp5; let camlp5mod = "gramlib" in - let camlp5libdir = check_camlp5 (camlp5mod^".cma") in - let camlp5o, camlp5_version = check_camlp5_version () in + let camlp5libdir, camlp5o = check_camlp5 (camlp5mod^".cma") in + let camlp5_version = check_camlp5_version camlp5o in "camlp5", camlp5o, Filename.dirname camlp5o, camlp5libdir, camlp5mod, camlp5_version with NoCamlp5 -> (* We now try to use Camlp4, either by explicit choice or @@ -1003,7 +992,7 @@ let write_dbg_wrapper f = let _ = write_dbg_wrapper "dev/ocamldebug-coq" -(** * Build the config/coq_config.ml file (+ link to myocamlbuild_config.ml) *) +(** * Build the config/coq_config.ml file *) let write_configml f = safe_remove f; @@ -1070,15 +1059,18 @@ let write_configml f = close_out o; Unix.chmod f 0o444 -let write_configml_my f f' = - write_configml f; - if os_type_win32 then - write_configml f' - else - (safe_remove f'; Unix.symlink f f') +let _ = write_configml "config/coq_config.ml" -let _ = write_configml_my "config/coq_config.ml" "myocamlbuild_config.ml" +(** * Symlinks or copies for the checker *) +let _ = + let prog, args, prf = + if arch = "win32" then "cp", [], "" + else "ln", ["-s"], "../" in + List.iter (fun file -> + ignore(run "rm" ["-f"; "checker/"^file]); + ignore(run ~fatal:true prog (args @ [prf^"kernel/"^file;"checker/"^file]))) + [ "esubst.ml"; "esubst.mli"; "names.ml"; "names.mli" ] (** * Build the config/Makefile file *) diff --git a/coq-win32.itarget b/coq-win32.itarget deleted file mode 100644 index 9e2c7a2b6b..0000000000 --- a/coq-win32.itarget +++ /dev/null @@ -1,2 +0,0 @@ -binariesopt -plugins/pluginsdyn.otarget diff --git a/coq.itarget b/coq.itarget deleted file mode 100644 index dd8b25905c..0000000000 --- a/coq.itarget +++ /dev/null @@ -1,8 +0,0 @@ -# NB: for the moment we start with bytecode compilation -# for early error detection in .ml -binariesbyte -plugins/pluginsbyte.otarget -binariesopt -plugins/pluginsopt.otarget -theories/theories.otarget -plugins/pluginsvo.otarget diff --git a/dev/doc/build-system.dev.txt b/dev/doc/build-system.dev.txt index af1120e97b..fefcb0937a 100644 --- a/dev/doc/build-system.dev.txt +++ b/dev/doc/build-system.dev.txt @@ -30,6 +30,11 @@ HISTORY: restricted set of .ml4 (see variable BUILDGRAMMAR). - then on the true target asked by the user. +* June 2016 (Pierre Letouzey) + The files in grammar/ are now self-contained, we could compile + grammar.cma (and q_constr.cmo) directly, no need for a separate + subcall to make nor awkward include-failed-and-retry. + --------------------------------------------------------------------------- @@ -59,29 +64,14 @@ Cons: Makefiles hierachy ------------------ -Le Makefile a été séparé en plusieurs fichiers : - -- Makefile: coquille vide qui lançant Makefile.build sauf pour - clean et quelques petites choses ne nécessitant par de calculs - de dépendances. -- Makefile.common : définitions des variables (essentiellement des - listes de fichiers) -- Makefile.build : contient les regles de compilation, ainsi que - le "include" des dépendances (restreintes ou non selon la variable - BUILDGRAMMAR). -- Makefile.doc : regles specifiques à la compilation de la documentation. - - -Parallélisation ---------------- +The Makefile is separated in several files : -Il y a actuellement un double appel interne à "make -f Makefile.build", -d'abord pour construire grammar.cma/q_constr.cmo, puis le reste. -Cela signifie que ce makefile est un petit peu moins parallélisable -que strictement possible en théorie: par exemple, certaines choses -faites lors du second make pourraient être faites en parallèle avec -le premier. En pratique, ce premier make va suffisemment vite pour -que cette limitation soit peu gênante. +- Makefile: wrapper that triggers a call to Makefile.build, except for + clean and a few other little things doable without dependency analysis. +- Makefile.common : variable definitions (mostly lists of files or + directories) +- Makefile.build : contains compilation rules, and the "include" of dependencies +- Makefile.doc : specific rules for compiling the documentation. FIND_VCS_CLAUSE diff --git a/dev/doc/build-system.txt b/dev/doc/build-system.txt index 31d9875ad1..4593a6ad5e 100644 --- a/dev/doc/build-system.txt +++ b/dev/doc/build-system.txt @@ -113,15 +113,20 @@ Targets for cleaning various parts: - docclean: clean documentation -.ml4 files ----------- +.ml4/.mlp files +--------------- -If a .ml4 file uses a grammar extension from Coq (such as grammar.cma -or q_constr.cmo), it must contain a line like: +There is now two kinds of preprocessed files : + - a .mlp do not need grammar.cma (they are in grammar/ and tools/compat5*.mlp) + - a .ml4 is now always preprocessed with grammar.cma (and q_constr.cmo), + except coqide_main.ml4 and its specific rule + +This classification replaces the old mechanism of declaring the use +of a grammar extension via a line of the form: (*i camlp4deps: "grammar.cma q_constr.cmo" i*) The use of (*i camlp4use: ... i*) to mention uses of standard -extension such as IFDEF has been discontinued, the Makefile now +extension such as IFDEF has also been discontinued, the Makefile now always calls camlp4 with pa_macros.cmo and a few others by default. For debugging a Coq grammar extension, it could be interesting diff --git a/dev/doc/changes.txt b/dev/doc/changes.txt index 2f631c6338..4135ddd2db 100644 --- a/dev/doc/changes.txt +++ b/dev/doc/changes.txt @@ -2,6 +2,73 @@ = CHANGES BETWEEN COQ V8.5 AND COQ V8.6 = ========================================= +** Notation_ops ** + +Use Glob_ops.glob_constr_eq instead of Notation_ops.eq_glob_constr. + +** Logging and Pretty Printing: ** + +* Printing functions have been removed from `Pp.mli`, which is now a + purely pretty-printing interface. Functions affected are: + +```` ocaml +val pp : std_ppcmds -> unit +val ppnl : std_ppcmds -> unit +val pperr : std_ppcmds -> unit +val pperrnl : std_ppcmds -> unit +val pperr_flush : unit -> unit +val pp_flush : unit -> unit +val flush_all : unit -> unit +val msg : std_ppcmds -> unit +val msgnl : std_ppcmds -> unit +val msgerr : std_ppcmds -> unit +val msgerrnl : std_ppcmds -> unit +val message : string -> unit +```` + + which are no more available. Users of `Pp.pp msg` should now use the + proper `Feedback.msg_*` function. Clients also have no control over + flushing, the back end takes care of it. + +* Feedback related functions and definitions have been moved to the + `Feedback` module. `message_level` has been renamed to + level. Functions moved from Pp to Feedback are: + +```` ocaml +val set_logger : logger -> unit +val std_logger : logger +val emacs_logger : logger +val feedback_logger : logger +```` + +* We now provide several loggers, `log_via_feedback` is removed in + favor of `set_logger feedback_logger`. Output functions are: + +```` ocaml +val with_output_to_file : string -> ('a -> 'b) -> 'a -> 'b +val msg_info : Pp.std_ppcmds -> unit +val msg_notice : Pp.std_ppcmds -> unit +val msg_warning : Pp.std_ppcmds -> unit +val msg_error : Pp.std_ppcmds -> unit +val msg_debug : Pp.std_ppcmds -> unit +```` + + with the `msg_*` functions being just an alias for `logger $Level`. + +* The main feedback functions are: + +```` ocaml +val set_feeder : (feedback -> unit) -> unit +val feedback : ?id:edit_or_state_id -> ?route:route_id -> feedback_content -> unit +val set_id_for_feedback : ?route:route_id -> edit_or_state_id -> unit +```` + Note that `feedback` doesn't take two parameters anymore. After + refactoring the following function has been removed: + +```` ocaml +val get_id_for_feedback : unit -> edit_or_state_id * route_id +```` + - The interface of the Context module was changed. Related types and functions were put in separate submodules. The mapping from old identifiers to new identifiers is the following: @@ -81,6 +148,38 @@ define_evar_* mostly used internally in the unification engine. - The Refine module was move out of Proofview. + Proofview.Refine.* ---> Refine.* + +- A statically monotonous evarmap type was introduced in Sigma. Not all the API + has been converted, so that the user may want to use compatibility functions + Sigma.to_evar_map and Sigma.Unsafe.of_evar_map or Sigma.Unsafe.of_pair when + needed. Code can be straightforwardly adapted in the following way: + + let (sigma, x1) = ... in + ... + let (sigma, xn) = ... in + (sigma, ans) + + should be turned into: + + open Sigma.Notations + + let Sigma (x1, sigma, p1) = ... in + ... + let Sigma (xn, sigma, pn) = ... in + Sigma (ans, sigma, p1 +> ... +> pn) + +- The Proofview.Goal.*enter family of functions now takes a polymorphic + continuation given as a record as an argument. + + Proofview.Goal.enter begin fun gl -> ... end + + should be turned into + + open Proofview.Notations + + Proofview.Goal.enter { enter = begin fun gl -> ... end } + ========================================= = CHANGES BETWEEN COQ V8.4 AND COQ V8.5 = ========================================= diff --git a/dev/doc/ocamlbuild.txt b/dev/doc/ocamlbuild.txt new file mode 100644 index 0000000000..efedbc506e --- /dev/null +++ b/dev/doc/ocamlbuild.txt @@ -0,0 +1,30 @@ +Ocamlbuild & Coq +---------------- + +A quick note in case someone else gets interested someday in compiling +Coq via ocamlbuild : such an experimental build system has existed +in the past (more or less maintained from 2009 to 2013), in addition +to the official build system via gnu make. But this build via +ocamlbuild has been severly broken since early 2014 (and don't work +in 8.5, for instance). This experiment has attracted very limited +interest from other developers over the years, and has been quite +cumbersome to maintain, so it is now officially discontinued. +If you want to have a look at the files of this build system +(especially myocamlbuild.ml), you can fetch : + - my last effort at repairing this build system (up to coqtop.native) : + https://github.com/letouzey/coq-wip/tree/ocamlbuild-partial-repair + - coq official v8.5 branch (recent but broken) + - coq v8.4 branch(less up-to-date, but works). + +For the record, the three main drawbacks of this experiments were: + - recurrent issues with circularities reported by ocamlbuild + (even though make was happy) during the evolution of Coq sources + - no proper support of parallel build + - quite slow re-traversal of already built things +See the two corresponding bug reports on Mantis, or +https://github.com/ocaml/ocamlbuild/issues/52 + +As an interesting feature, I successfully used this to cross-compile +Coq 8.4 from linux to win32 via mingw. + +Pierre Letouzey, june 2016 diff --git a/dev/doc/profiling.txt b/dev/doc/profiling.txt new file mode 100644 index 0000000000..9d2ebf0d4c --- /dev/null +++ b/dev/doc/profiling.txt @@ -0,0 +1,76 @@ +# How to profile Coq? + +I (Pierre-Marie Pédrot) mainly use two OCaml branches to profile Coq, whether I +want to profile time or memory consumption. AFAIK, this only works for Linux. + +## Time + +In Coq source folder: + +opam switch 4.02.1+fp +./configure -local -debug +make +perf record -g bin/coqtop -compile file.v +perf report -g fractal,callee --no-children + +To profile only part of a file, first load it using + +bin/coqtop -l file.v + +and plug into the process + +perf record -g -p PID + +## Memory + +You first need a few commits atop trunk for this to work. + +git remote add ppedrot https://github.com/ppedrot/coq.git +git fetch ppedrot +git checkout ppedrot/allocation-profiling +git rebase master + +Then: + +opam switch 4.00.1+alloc-profiling +./configure -local -debug +make + +Note that linking the coqtop binary takes quite an amount of time with this +branch, so do not worry too much. There are more recent branches of +alloc-profiling on mshinwell's repo which can be found at: + +https://github.com/mshinwell/opam-repo-dev + +### For memory dump: + +CAMLRUNPARAM=T,mj bin/coqtop -compile file.v + +In another terminal: + +pkill -SIGUSR1 $COQTOPPID +... +pkill -SIGUSR1 $COQTOPPID +dev/decode-major-heap.sh heap.$COQTOPPID.$N bin/coqtop + +where $COQTOPPID is coqtop pid and $N the index of the call to pkill. + +First column is the memory taken by the objects (in words), second one is the +number of objects and third is the place where the objects where allocated. + +### For complete memory graph: + +CAMLRUNPARAM=T,gr bin/coqtop -compile file.v + +In another terminal: + +pkill -SIGUSR1 $COQTOPPID +... +pkill -SIGUSR1 $COQTOPPID +ocaml dev/decodegraph.ml edge.$COQTOPPID.$N bin/coqtop > memory.dot +dot -Tpdf -o memory.pdf memory.dot + +where $COQTOPPID is coqtop pid and $N the index of the call to pkill. + +The pdf produced by the last command gives a compact graphical representation of +the various objects allocated. diff --git a/dev/nsis/coq.nsi b/dev/nsis/coq.nsi index e1052b1e1b..80da845174 100755 --- a/dev/nsis/coq.nsi +++ b/dev/nsis/coq.nsi @@ -83,6 +83,7 @@ FunctionEnd Section "Coq" Sec1 SetOutPath "$INSTDIR\" + File ${COQ_SRC_PATH}\LICENSE SetOutPath "$INSTDIR\bin" File ${COQ_SRC_PATH}\bin\*.exe diff --git a/dev/printers.mllib b/dev/printers.mllib index aa74cb5085..e39b780723 100644 --- a/dev/printers.mllib +++ b/dev/printers.mllib @@ -26,19 +26,21 @@ Control Loc Serialize Stateid -Feedback -Pp -Segmenttree -Unicodetable -Unicode CObj CArray CStack Util +Pp Ppstyle +Richpp +Feedback +Segmenttree +Unicodetable +Unicode Errors Bigint CUnix +Minisys System Envars Aux_file @@ -187,7 +189,6 @@ Logic Refiner Clenv Evar_refiner -Proof_errors Refine Proof Proof_global diff --git a/dev/top_printers.ml b/dev/top_printers.ml index f5599d793f..6074acea46 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -29,7 +29,8 @@ let _ = set_bool_option_value ["Printing";"Matching"] false let _ = Detyping.set_detype_anonymous (fun _ _ -> raise Not_found) (* std_ppcmds *) -let pppp x = pp x +let pp x = Feedback.msg_notice x +let pppp x = Feedback.msg_notice x (** Future printer *) @@ -315,7 +316,7 @@ let constr_display csr = | Anonymous -> "Anonymous" in - Pp.pp (str (term_display csr) ++fnl ()); Pp.pp_flush () + Feedback.msg_notice (str (term_display csr) ++fnl ()) open Format;; @@ -486,9 +487,7 @@ let ppist ist = (* Vernac-level debugging commands *) let in_current_context f c = - let (evmap,sign) = - try Pfedit.get_current_goal_context () - with e when Logic.catchable_exception e -> (Evd.empty, Global.env()) in + let (evmap,sign) = Pfedit.get_current_context () in f (fst (Constrintern.interp_constr sign evmap c))(*FIXME*) (* We expand the result of preprocessing to be independent of camlp4 @@ -515,7 +514,7 @@ let _ = (fun () -> in_current_context constr_display c) | _ -> failwith "Vernac extension: cannot occur") with - e -> Pp.pp (Errors.print e) + e -> Feedback.msg_notice (Errors.print e) let _ = extend_vernac_command_grammar ("PrintConstr", 0) None [GramTerminal "PrintConstr"; @@ -531,7 +530,7 @@ let _ = (fun () -> in_current_context print_pure_constr c) | _ -> failwith "Vernac extension: cannot occur") with - e -> Pp.pp (Errors.print e) + e -> Feedback.msg_notice (Errors.print e) let _ = extend_vernac_command_grammar ("PrintPureConstr", 0) None [GramTerminal "PrintPureConstr"; diff --git a/dev/vm_printers.ml b/dev/vm_printers.ml index 1c501df808..afa94a63e0 100644 --- a/dev/vm_printers.ml +++ b/dev/vm_printers.ml @@ -79,7 +79,7 @@ and ppwhd whd = | Vatom_stk(a,s) -> open_hbox();ppatom a;close_box(); print_string"@";ppstack s - | Vuniv_level lvl -> Pp.pp (Univ.Level.pr lvl) + | Vuniv_level lvl -> Feedback.msg_notice (Univ.Level.pr lvl) and ppvblock b = open_hbox(); diff --git a/doc/refman/AsyncProofs.tex b/doc/refman/AsyncProofs.tex index 7cf5004003..7ffe252253 100644 --- a/doc/refman/AsyncProofs.tex +++ b/doc/refman/AsyncProofs.tex @@ -46,6 +46,43 @@ proof does not begin with \texttt{Proof using}, the system records in an auxiliary file, produced along with the \texttt{.vo} file, the list of section variables used. +\section{Proof blocks and error resilience} + +Coq 8.6 introduces a mechanism for error resiliency: in interactive mode Coq +is able to completely check a document containing errors instead of bailing +out at the first failure. + +Two kind of errors are supported: errors occurring in vernacular commands and +errors occurring in proofs. + +To properly recover from a failing tactic, Coq needs to recognize the structure of +the proof in order to confine the error to a sub proof. Proof block detection +is performed by looking at the syntax of the proof script (i.e. also looking at indentation). +Coq comes with four kind of proof blocks, and an ML API to add new ones. + +\begin{description} +\item[curly] blocks are delimited by \texttt{\{} and \texttt{\}}, see \ref{Proof-handling} +\item[par] blocks are atomic, i.e. just one tactic introduced by the \texttt{par:} goal selector +\item[indent] blocks end with a tactic indented less than the previous one +\item[bullet] blocks are delimited by two equal bullet signs at the same indentation level +\end{description} + +\subsection{Caveats} + +When a vernacular command fails the subsequent error messages may be bogus, i.e. caused by +the first error. Error resiliency for vernacular commands can be switched off passing +\texttt{-async-proofs-command-error-resilience off} to CoqIDE. + +An incorrect proof block detection can result into an incorrect error recovery and +hence in bogus errors. Proof block detection cannot be precise for bullets or +any other non well parenthesized proof structure. Error resiliency can be +turned off or selectively activated for any set of block kind passing to +CoqIDE one of the following options: +\texttt{-async-proofs-tactic-error-resilience off}, +\texttt{-async-proofs-tactic-error-resilience all}, +\texttt{-async-proofs-tactic-error-resilience $blocktype_1$,..., $blocktype_n$}. +Valid proof block types are: ``curly'', ``par'', ``indent'', ``bullet''. + \subsubsection{Automatic suggestion of proof annotations} The command \texttt{Set Suggest Proof Using} makes Coq suggest, when a @@ -85,6 +122,9 @@ reduce the reactivity of the master process to user commands. To disable this feature, one can pass the \texttt{-async-proofs off} flag to CoqIDE. +Proofs that are known to take little time to process are not delegated to a +worker process. The threshold can be configure with \texttt{-async-proofs-delegation-threshold}. Default is 0.03 seconds. + \section{Batch mode} When Coq is used as a batch compiler by running \texttt{coqc} or diff --git a/doc/refman/CanonicalStructures.tex b/doc/refman/CanonicalStructures.tex index a3372c2965..275e1c2d55 100644 --- a/doc/refman/CanonicalStructures.tex +++ b/doc/refman/CanonicalStructures.tex @@ -4,7 +4,7 @@ \label{CS-full} \index{Canonical Structures!presentation} -This chapter explains the basics of Canonical Structure and how thy can be used +\noindent This chapter explains the basics of Canonical Structure and how they can be used to overload notations and build a hierarchy of algebraic structures. The examples are taken from~\cite{CSwcu}. We invite the interested reader to refer to this paper for all the details that are omitted here for brevity. diff --git a/doc/refman/RefMan-ltac.tex b/doc/refman/RefMan-ltac.tex index cc7e6b53bf..ffcb371346 100644 --- a/doc/refman/RefMan-ltac.tex +++ b/doc/refman/RefMan-ltac.tex @@ -78,7 +78,7 @@ For instance {\tt try repeat \tac$_1$ || \tac$_2$;\tac$_3$;[\tac$_{31}$|\dots|\tac$_{3n}$];\tac$_4$.} \end{quote} -is understood as +is understood as \begin{quote} {\tt (try (repeat (\tac$_1$ || \tac$_2$)));} \\ {\tt ((\tac$_3$;[\tac$_{31}$|\dots|\tac$_{3n}$]);\tac$_4$).} @@ -174,7 +174,7 @@ is understood as \\ {\messagetoken}\!\!\!\!\!\! & ::= & {\qstring} ~|~ {\ident} ~|~ {\integer} \\ \\ -\tacarg & ::= & +\tacarg & ::= & {\qualid}\\ & $|$ & {\tt ()} \\ & $|$ & {\tt ltac :} {\atom}\\ @@ -344,7 +344,7 @@ for $=1,...,n$. It fails if the number of focused goals is not exactly $n$. expects multiple goals, such as {\tt swap}, would act as if a single goal is focused. - \item {\tacexpr} {\tt ; [ } {\tacexpr}$_1$ {\tt |} $...$ {\tt |} {\tacexpr}$_n$ {\tt ]} + \item {\tacexpr} {\tt ; [ } {\tacexpr}$_1$ {\tt |} $...$ {\tt |} {\tacexpr}$_n$ {\tt ]} This variant of local tactic application is paired with a sequence. In this variant, $n$ must be the number of goals @@ -782,7 +782,7 @@ setting option {\tt Printing All}, see Section~\ref{SetPrintingAll}). \begin{coq_example} Ltac f x := match x with - context f [S ?X] => + context f [S ?X] => idtac X; (* To display the evaluation order *) assert (p := eq_refl 1 : X=1); (* To filter the case X=1 *) let x:= context f[O] in assert (x=O) (* To observe the context *) @@ -1026,7 +1026,7 @@ Reset Initial. \index{Tacticals!abstract@{\tt abstract}}} From the outside ``\texttt{abstract \tacexpr}'' is the same as -{\tt solve \tacexpr}. Internally it saves an auxiliary lemma called +{\tt solve \tacexpr}. Internally it saves an auxiliary lemma called {\ident}\texttt{\_subproof}\textit{n} where {\ident} is the name of the current goal and \textit{n} is chosen so that this is a fresh name. Such auxiliary lemma is inlined in the final proof term @@ -1116,6 +1116,8 @@ Defined {\ltac} functions can be displayed using the command {\tt Print Ltac {\qualid}.} \end{quote} +The command {\tt Print Ltac Signatures\comindex{Print Ltac Signatures}} displays a list of all user-defined tactics, with their arguments. + \section{Debugging {\ltac} tactics} \subsection[Info trace]{Info trace\comindex{Info}\optindex{Info Level}} @@ -1194,6 +1196,86 @@ s: & continue current evaluation without stopping\\ r $n$: & advance $n$ steps further\\ r {\qstring}: & advance up to the next call to ``{\tt idtac} {\qstring}''\\ \end{tabular} + +\subsection[Profiling {\ltac} tactics]{Profiling {\ltac} tactics\optindex{Ltac Profiling}\comindex{Show Ltac Profile}\comindex{Reset Ltac Profile}} + +It is possible to measure the time spent in invocations of primitive tactics as well as tactics defined in {\ltac} and their inner invocations. The primary use is the development of complex tactics, which can sometimes be so slow as to impede interactive usage. The reasons for the performence degradation can be intricate, like a slowly performing {\ltac} match or a sub-tactic whose performance only degrades in certain situations. The profiler generates a call tree and indicates the time spent in a tactic depending its calling context. Thus it allows to locate the part of a tactic definition that contains the performance bug. + +\begin{quote} +{\tt Set Ltac Profiling}. +\end{quote} +Enables the profiler + +\begin{quote} +{\tt Unset Ltac Profiling}. +\end{quote} +Disables the profiler + +\begin{quote} +{\tt Show Ltac Profile}. +\end{quote} +Prints the profile + +\begin{quote} +{\tt Show Ltac Profile} {\qstring}. +\end{quote} +Prints a profile for all tactics that start with {\qstring}. Append a period (.) to the string if you only want exactly that name. + +\begin{quote} +{\tt Reset Profile}. +\end{quote} +Resets the profile, that is, deletes all accumulated information + +\begin{coq_eval} +Reset Initial. +\end{coq_eval} +\begin{coq_example*} +Require Import Coq.omega.Omega. + +Ltac mytauto := tauto. +Ltac tac := intros; repeat split; omega || mytauto. + +Notation max x y := (x + (y - x)) (only parsing). +\end{coq_example*} +\begin{coq_example*} +Goal forall x y z A B C D E F G H I J K L M N O P Q R S T U V W X Y Z, + max x (max y z) = max (max x y) z /\ max x (max y z) = max (max x y) z + /\ (A /\ B /\ C /\ D /\ E /\ F /\ G /\ H /\ I /\ J /\ K /\ L /\ M /\ N /\ O /\ P /\ Q /\ R /\ S /\ T /\ U /\ V /\ W /\ X /\ Y /\ Z + -> Z /\ Y /\ X /\ W /\ V /\ U /\ T /\ S /\ R /\ Q /\ P /\ O /\ N /\ M /\ L /\ K /\ J /\ I /\ H /\ G /\ F /\ E /\ D /\ C /\ B /\ A). +Proof. +\end{coq_example*} +\begin{coq_example} + Set Ltac Profiling. + tac. +\end{coq_example} +{\let\textit\texttt% use tt mode for the output of ltacprof +\begin{coq_example} + Show Ltac Profile. +\end{coq_example} +\begin{coq_example} + Show Ltac Profile "omega". +\end{coq_example} +} +\begin{coq_example*} +Abort. +Unset Ltac Profiling. +\end{coq_example*} + +\tacindex{start ltac profiling}\tacindex{stop ltac profiling} +The following two tactics behave like {\tt idtac} but enable and disable the profiling. They allow you to exclude parts of a proof script from profiling. + +\begin{quote} +{\tt start ltac profiling}. +\end{quote} + +\begin{quote} +{\tt stop ltac profiling}. +\end{quote} + +You can also pass the {\tt -profile-ltac} command line option to {\tt coqc}, which performs a {\tt Set Ltac Profiling} at the beginning of each document, and a {\tt Show Ltac Profile} at the end. + +Note that the profiler currently does not handle backtracking into multi-success tactics, and issues a warning to this effect in many cases when such backtracking occurs. + \endinput \subsection{Permutation on closed lists} @@ -1227,7 +1309,7 @@ Another more complex example is the problem of permutation on closed lists. The aim is to show that a closed list is a permutation of another one. First, we define the permutation predicate as shown on Figure~\ref{permutpred}. - + \begin{figure}[p] \begin{center} \fbox{\begin{minipage}{0.95\textwidth} @@ -1553,7 +1635,7 @@ Figure~\ref{isoslem} gives examples of what can be solved by {\tt IsoProve}. \begin{center} \fbox{\begin{minipage}{0.95\textwidth} \begin{coq_example*} -Lemma isos_ex1 : +Lemma isos_ex1 : forall A B:Set, A * unit * B = B * (unit * A). Proof. intros; IsoProve. @@ -1573,7 +1655,7 @@ Qed. \label{isoslem} \end{figure} -%%% Local Variables: +%%% Local Variables: %%% mode: latex %%% TeX-master: "Reference-Manual" -%%% End: +%%% End: diff --git a/doc/refman/Universes.tex b/doc/refman/Universes.tex index a08cd1475a..36518e6fae 100644 --- a/doc/refman/Universes.tex +++ b/doc/refman/Universes.tex @@ -201,7 +201,8 @@ universes and explicitly instantiate polymorphic definitions. In the monorphic case, this command declares a new global universe named {\ident}. It supports the polymorphic flag only in sections, meaning the universe quantification will be discharged on each section definition -independently. +independently. One cannot mix polymorphic and monomorphic declarations +in the same section. \subsection{\tt Constraint {\ident} {\textit{ord}} {\ident}. \comindex{Constraint} @@ -212,6 +213,7 @@ The order relation can be one of $<$, $\le$ or $=$. If consistent, the constraint is then enforced in the global environment. Like \texttt{Universe}, it can be used with the \texttt{Polymorphic} prefix in sections only to declare constraints discharged at section closing time. +One cannot declare a global constraint on polymorphic universes. \begin{ErrMsgs} \item \errindex{Undeclared universe {\ident}}. diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index a12983ab84..fb45777e7f 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -21,6 +21,7 @@ through the <tt>Require Import</tt> command.</p> theories/Init/Peano.v theories/Init/Specif.v theories/Init/Tactics.v + theories/Init/Tauto.v theories/Init/Wf.v (theories/Init/Prelude.v) </dd> @@ -203,6 +204,7 @@ through the <tt>Require Import</tt> command.</p> (theories/QArith/QArith.v) theories/QArith/Qreals.v theories/QArith/Qcanon.v + theories/QArith/Qcabs.v theories/QArith/Qround.v theories/QArith/QOrderedType.v theories/QArith/Qminmax.v diff --git a/engine/evarutil.mli b/engine/evarutil.mli index ffff2c5dd9..111d0f3e8c 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -11,7 +11,7 @@ open Term open Evd open Environ -(** {5 This modules provides useful functions for unification modulo evars } *) +(** This module provides useful higher-level functions for evar manipulation. *) (** {6 Metas} *) diff --git a/engine/evd.mli b/engine/evd.mli index 3ae6e586c1..df491c27b4 100644 --- a/engine/evd.mli +++ b/engine/evd.mli @@ -12,7 +12,10 @@ open Names open Term open Environ -(** {5 Existential variables and unification states} +(** This file defines the pervasive unification state used everywhere in Coq + tactic engine. It is very low-level and most of the functions exported here + are irrelevant to the standard API user. Consider using {!Evarutil}, + {!Sigma} or {!Proofview} instead. A unification state (of type [evar_map]) is primarily a finite mapping from existential variables to records containing the type of the evar @@ -23,6 +26,8 @@ open Environ It also contains conversion constraints, debugging information and information about meta variables. *) +(** {5 Existential variables and unification states} *) + (** {6 Evars} *) type evar = existential_key @@ -343,7 +348,6 @@ val on_sig : 'a sigma -> (evar_map -> evar_map * 'b) -> 'a sigma * 'b module MonadR : Monad.S with type +'a t = evar_map -> evar_map * 'a module Monad : Monad.S with type +'a t = evar_map -> 'a * evar_map - (** {5 Meta machinery} These functions are almost deprecated. They were used before the diff --git a/engine/ftactic.mli b/engine/ftactic.mli index 19041f1698..5db373199e 100644 --- a/engine/ftactic.mli +++ b/engine/ftactic.mli @@ -8,7 +8,9 @@ open Proofview.Notations -(** Potentially focussing tactics *) +(** This module defines potentially focussing tactics. They are used by Ltac to + emulate the historical behaviour of always-focussed tactics while still + allowing to remain global when the goal is not needed. *) type +'a focus diff --git a/engine/geninterp.mli b/engine/geninterp.mli index 42e1e3784c..b70671a2d9 100644 --- a/engine/geninterp.mli +++ b/engine/geninterp.mli @@ -6,7 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(** Interpretation functions for generic arguments. *) +(** Interpretation functions for generic arguments and interpreted Ltac + values. *) open Names open Genarg diff --git a/engine/logic_monad.ml b/engine/logic_monad.ml index d67f1eee35..64be07b9c7 100644 --- a/engine/logic_monad.ml +++ b/engine/logic_monad.ml @@ -104,11 +104,11 @@ struct Util.iraise (Exception e, info) (** Use the current logger. The buffer is also flushed. *) - let print_debug s = make (fun _ -> Pp.msg_info s;Pp.pp_flush ()) - let print_info s = make (fun _ -> Pp.msg_info s;Pp.pp_flush ()) - let print_warning s = make (fun _ -> Pp.msg_warning s;Pp.pp_flush ()) - let print_error s = make (fun _ -> Pp.msg_error s;Pp.pp_flush ()) - let print_notice s = make (fun _ -> Pp.msg_notice s;Pp.pp_flush ()) + let print_debug s = make (fun _ -> Feedback.msg_info s) + let print_info s = make (fun _ -> Feedback.msg_info s) + let print_warning s = make (fun _ -> Feedback.msg_warning s) + let print_error s = make (fun _ -> Feedback.msg_error s) + let print_notice s = make (fun _ -> Feedback.msg_notice s) let run = fun x -> try x () with Exception e as src -> diff --git a/engine/logic_monad.mli b/engine/logic_monad.mli index c5160443b1..dd122cca0f 100644 --- a/engine/logic_monad.mli +++ b/engine/logic_monad.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(** This file defines the low-level monadic operations used by the +(** This file implements the low-level monadic operations used by the tactic monad. The monad is divided into two layers: a non-logical layer which consists in operations which will not (or cannot) be backtracked in case of failure (input/output or persistent state) diff --git a/engine/namegen.mli b/engine/namegen.mli index a2923fee99..e5c156b4e5 100644 --- a/engine/namegen.mli +++ b/engine/namegen.mli @@ -6,6 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(** This file features facilities to generate fresh names. *) + open Names open Term open Environ diff --git a/engine/proofview.ml b/engine/proofview.ml index 95e20bc25a..bcdd4da115 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -46,7 +46,7 @@ let compact el ({ solution } as pv) = evar_candidates = Option.map (List.map nf) ei.evar_candidates }) in let new_solution = Evd.raw_map_undefined apply_subst_einfo pruned_solution in let new_size = Evd.fold (fun _ _ i -> i+1) new_solution 0 in - msg_info (Pp.str (Printf.sprintf "Evars: %d -> %d\n" size new_size)); + Feedback.msg_info (Pp.str (Printf.sprintf "Evars: %d -> %d\n" size new_size)); new_el, { pv with solution = new_solution; } @@ -665,11 +665,12 @@ let with_shelf tac = (** [goodmod p m] computes the representative of [p] modulo [m] in the interval [[0,m-1]].*) let goodmod p m = - let p' = p mod m in - (* if [n] is negative [n mod l] is negative of absolute value less - than [l], so [(n mod l)+l] is the representative of [n] in the - interval [[0,l-1]].*) - if p' < 0 then p'+m else p' + if m = 0 then 0 else + let p' = p mod m in + (* if [n] is negative [n mod l] is negative of absolute value less + than [l], so [(n mod l)+l] is the representative of [n] in the + interval [[0,l-1]].*) + if p' < 0 then p'+m else p' let cycle n = let open Proof in @@ -856,7 +857,7 @@ let tclTIME s t = else str (msg ^ " after ") ++ int n ++ str (String.plural n " backtracking") in - msg_info(str "Tactic call" ++ pr_opt str s ++ str " ran for " ++ + Feedback.msg_info(str "Tactic call" ++ pr_opt str s ++ str " ran for " ++ System.fmt_time_difference t1 t2 ++ str " " ++ surround msg) in let rec aux n t = let open Proof in diff --git a/engine/proofview.mli b/engine/proofview.mli index 7996b7969c..93ba55c61f 100644 --- a/engine/proofview.mli +++ b/engine/proofview.mli @@ -303,6 +303,9 @@ val guard_no_unifiable : Names.Name.t list option tactic goals of p *) 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. *) val with_shelf : 'a tactic -> (Goal.goal list * 'a) tactic diff --git a/engine/proofview_monad.mli b/engine/proofview_monad.mli index 0aff0a7207..637414cce7 100644 --- a/engine/proofview_monad.mli +++ b/engine/proofview_monad.mli @@ -7,7 +7,8 @@ (************************************************************************) (** This file defines the datatypes used as internal states by the - tactic monad, and specialises the [Logic_monad] to these type. *) + tactic monad, and specialises the [Logic_monad] to these types. It should + not be used directly. Consider using {!Proofview} instead. *) (** {6 Traces} *) diff --git a/engine/sigma.mli b/engine/sigma.mli index 643bea4036..aaf603efd8 100644 --- a/engine/sigma.mli +++ b/engine/sigma.mli @@ -12,7 +12,9 @@ open Constr (** Monotonous state enforced by typing. This module allows to constrain uses of evarmaps in a monotonous fashion, - and in particular statically suppress evar leaks and the like. + and in particular statically suppress evar leaks and the like. To this + ends, it defines a type of indexed evarmaps whose phantom typing ensures + monotonous use. *) (** {5 Stages} *) @@ -32,7 +34,7 @@ val (+>) : ('a, 'b) le -> ('b, 'c) le -> ('a, 'c) le (** {5 Monotonous evarmaps} *) type 'r t -(** Stage-indexed evarmaps. *) +(** Stage-indexed evarmaps. This is just a plain evarmap with a phantom type. *) type ('a, 'r) sigma = Sigma : 'a * 's t * ('r, 's) le -> ('a, 'r) sigma (** Return values at a later stage *) diff --git a/engine/termops.mli b/engine/termops.mli index c2a4f33235..76a31037bc 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -6,6 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(** This file defines various utilities for term manipulation that are not + needed in the kernel. *) + open Pp open Names open Term diff --git a/engine/uState.mli b/engine/uState.mli index c5c454020c..0cdc6277a5 100644 --- a/engine/uState.mli +++ b/engine/uState.mli @@ -6,7 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(** Universe unification states *) +(** This file defines universe unification states which are part of evarmaps. + Most of the API below is reexported in {!Evd}. Consider using higher-level + primitives when needed. *) open Names diff --git a/grammar/argextend.ml4 b/grammar/argextend.mlp index 9be6c6bc4a..eaaa7f0256 100644 --- a/grammar/argextend.ml4 +++ b/grammar/argextend.mlp @@ -6,10 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4deps: "tools/compat5b.cmo" i*) - open Q_util -open Compat +open GramCompat let loc = CompatLoc.ghost let default_loc = <:expr< Loc.ghost >> diff --git a/grammar/gramCompat.mlp b/grammar/gramCompat.mlp new file mode 100644 index 0000000000..6246da7bb6 --- /dev/null +++ b/grammar/gramCompat.mlp @@ -0,0 +1,86 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Compatibility file depending on ocaml/camlp4 version *) + +(** Misc module emulation *) + +IFDEF CAMLP5 THEN + +module CompatLoc = struct + include Ploc + let ghost = dummy + let merge = encl +end + +ELSE + +module CompatLoc = Camlp4.PreCast.Loc + +END + +IFDEF CAMLP5 THEN + +module PcamlSig = struct end + +ELSE + +module PcamlSig = Camlp4.Sig +module Ast = Camlp4.PreCast.Ast +module Pcaml = Camlp4.PreCast.Syntax +module MLast = Ast + +END + +(** Compatibility with camlp5 strict mode *) +IFDEF CAMLP5 THEN + IFDEF STRICT THEN + let vala x = Ploc.VaVal x + ELSE + let vala x = x + END +ELSE + let vala x = x +END + +(** Fix a quotation difference in [str_item] *) + +let declare_str_items loc l = +IFDEF CAMLP5 THEN + MLast.StDcl (loc, vala l) (* correspond to <:str_item< declare $list:l'$ end >> *) +ELSE + Ast.stSem_of_list l +END + +(** Quotation difference for match clauses *) + +let default_patt loc = + (<:patt< _ >>, vala None, <:expr< failwith "Extension: cannot occur" >>) + +IFDEF CAMLP5 THEN + +let make_fun loc cl = + let l = cl @ [default_patt loc] in + MLast.ExFun (loc, vala l) (* correspond to <:expr< fun [ $list:l$ ] >> *) + +ELSE + +let make_fun loc cl = + let mk_when = function + | Some w -> w + | None -> Ast.ExNil loc + in + let mk_clause (patt,optwhen,expr) = + (* correspond to <:match_case< ... when ... -> ... >> *) + Ast.McArr (loc, patt, mk_when optwhen, expr) in + let init = mk_clause (default_patt loc) in + let add_clause x acc = Ast.McOr (loc, mk_clause x, acc) in + let l = List.fold_right add_clause cl init in + Ast.ExFun (loc,l) (* correspond to <:expr< fun [ $l$ ] >> *) + +END diff --git a/grammar/grammar.mllib b/grammar/grammar.mllib deleted file mode 100644 index 9b24c97974..0000000000 --- a/grammar/grammar.mllib +++ /dev/null @@ -1,13 +0,0 @@ -Coq_config - -Store -Exninfo -Loc - -Tok -Compat - -Q_util -Argextend -Tacextend -Vernacextend diff --git a/grammar/q_constr.ml4 b/grammar/q_constr.ml4 deleted file mode 100644 index 40db819494..0000000000 --- a/grammar/q_constr.ml4 +++ /dev/null @@ -1,120 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i camlp4deps: "tools/compat5b.cmo" i*) - -open Q_util -open Compat -open Pcaml -open PcamlSig (* necessary for camlp4 *) - -let loc = CompatLoc.ghost -let dloc = <:expr< Loc.ghost >> - -let apply_ref f l = - <:expr< - Glob_term.GApp ($dloc$, Glob_term.GRef ($dloc$, Lazy.force $f$, None), $mlexpr_of_list (fun x -> x) l$) - >> - -EXTEND - GLOBAL: expr; - expr: - [ [ "PATTERN"; "["; c = constr; "]" -> - <:expr< snd (Patternops.pattern_of_glob_constr $c$) >> ] ] - ; - sort: - [ [ "Set" -> Misctypes.GSet - | "Prop" -> Misctypes.GProp - | "Type" -> Misctypes.GType [] ] ] - ; - ident: - [ [ s = string -> <:expr< Names.Id.of_string $str:s$ >> ] ] - ; - name: - [ [ "_" -> <:expr< Anonymous >> | id = ident -> <:expr< Name $id$ >> ] ] - ; - string: - [ [ s = UIDENT -> s | s = LIDENT -> s ] ] - ; - constr: - [ "200" RIGHTA - [ LIDENT "forall"; id = ident; ":"; c1 = constr; ","; c2 = constr -> - <:expr< Glob_term.GProd ($dloc$,Name $id$,Decl_kinds.Explicit,$c1$,$c2$) >> - | "fun"; id = ident; ":"; c1 = constr; "=>"; c2 = constr -> - <:expr< Glob_term.GLambda ($dloc$,Name $id$,Decl_kinds.Explicit,$c1$,$c2$) >> - | "let"; id = ident; ":="; c1 = constr; "in"; c2 = constr -> - <:expr< Glob_term.RLetin ($dloc$,Name $id$,$c1$,$c2$) >> - (* fix todo *) - ] - | "100" RIGHTA - [ c1 = constr; ":"; c2 = SELF -> - <:expr< Glob_term.GCast($dloc$,$c1$,DEFAULTcast,$c2$) >> ] - | "90" RIGHTA - [ c1 = constr; "->"; c2 = SELF -> - <:expr< Glob_term.GProd ($dloc$,Anonymous,Decl_kinds.Explicit,$c1$,$c2$) >> ] - | "75" RIGHTA - [ "~"; c = constr -> - apply_ref <:expr< coq_not_ref >> [c] ] - | "70" RIGHTA - [ c1 = constr; "="; c2 = NEXT; ":>"; t = NEXT -> - apply_ref <:expr< coq_eq_ref >> [t;c1;c2] ] - | "10" LEFTA - [ f = constr; args = LIST1 NEXT -> - let args = mlexpr_of_list (fun x -> x) args in - <:expr< Glob_term.GApp ($dloc$,$f$,$args$) >> ] - | "0" - [ s = sort -> <:expr< Glob_term.GSort ($dloc$,s) >> - | id = ident -> <:expr< Glob_term.GVar ($dloc$,$id$) >> - | "_" -> <:expr< Glob_term.GHole ($dloc$,Evar_kinds.QuestionMark (Evar_kinds.Define False),Misctypes.IntroAnonymous,None) >> - | "?"; id = ident -> <:expr< Glob_term.GPatVar($dloc$,(False,$id$)) >> - | "{"; c1 = constr; "}"; "+"; "{"; c2 = constr; "}" -> - apply_ref <:expr< coq_sumbool_ref >> [c1;c2] - | "%"; e = string -> <:expr< Glob_term.GRef ($dloc$,Lazy.force $lid:e$, None) >> - | c = match_constr -> c - | "("; c = constr LEVEL "200"; ")" -> c ] ] - ; - match_constr: - [ [ "match"; c = constr LEVEL "100"; (ty,nal) = match_type; - "with"; OPT"|"; br = LIST0 eqn SEP "|"; "end" -> - let br = mlexpr_of_list (fun x -> x) br in - <:expr< Glob_term.GCases ($dloc$,$ty$,[($c$,$nal$)],$br$) >> - ] ] - ; - match_type: - [ [ "as"; id = ident; "in"; ind = LIDENT; nal = LIST0 name; - "return"; ty = constr LEVEL "100" -> - let nal = mlexpr_of_list (fun x -> x) nal in - <:expr< Some $ty$ >>, - <:expr< (Name $id$, Some ($dloc$,$lid:ind$,$nal$)) >> - | -> <:expr< None >>, <:expr< (Anonymous, None) >> ] ] - ; - eqn: - [ [ (lid,pl) = pattern; "=>"; rhs = constr -> - let lid = mlexpr_of_list (fun x -> x) lid in - <:expr< ($dloc$,$lid$,[$pl$],$rhs$) >> - ] ] - ; - pattern: - [ [ "%"; e = string; lip = LIST0 patvar -> - let lp = mlexpr_of_list (fun (_,x) -> x) lip in - let lid = List.flatten (List.map fst lip) in - lid, <:expr< Glob_term.PatCstr ($dloc$,$lid:e$,$lp$,Anonymous) >> - | p = patvar -> p - | "("; p = pattern; ")" -> p ] ] - ; - patvar: - [ [ "_" -> [], <:expr< Glob_term.PatVar ($dloc$,Anonymous) >> - | id = ident -> [id], <:expr< Glob_term.PatVar ($dloc$,Name $id$) >> - ] ] - ; - END;; - -(* Example -open Coqlib -let a = PATTERN [ match ?X with %path_of_S n => n | %path_of_O => ?X end ] -*) diff --git a/grammar/q_util.mli b/grammar/q_util.mli index 9b6f11827c..a5e36e47bc 100644 --- a/grammar/q_util.mli +++ b/grammar/q_util.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Compat (* necessary for camlp4 *) +open GramCompat (* necessary for camlp4 *) type argument_type = | ListArgType of argument_type diff --git a/grammar/q_util.ml4 b/grammar/q_util.mlp index a9a339241e..2d5c40894a 100644 --- a/grammar/q_util.ml4 +++ b/grammar/q_util.mlp @@ -8,7 +8,7 @@ (* This file defines standard combinators to build ml expressions *) -open Compat +open GramCompat type argument_type = | ListArgType of argument_type @@ -87,7 +87,7 @@ let coincide s pat off = while !break && !i < len do let c = Char.code s.[off + !i] in let d = Char.code pat.[!i] in - break := Int.equal c d; + break := c = d; incr i done; !break @@ -110,7 +110,7 @@ let rec parse_user_entry s sep = else if l > 4 && coincide s "_opt" (l-4) then let entry = parse_user_entry (String.sub s 0 (l-4)) "" in Uopt entry - else if Int.equal l 7 && coincide s "tactic" 0 && '5' >= s.[6] && s.[6] >= '0' then + else if l = 7 && coincide s "tactic" 0 && '5' >= s.[6] && s.[6] >= '0' then let n = Char.code s.[6] - 48 in Uentryl ("tactic", n) else diff --git a/grammar/tacextend.ml4 b/grammar/tacextend.mlp index 4c4ecaf732..ac6a7ac7f2 100644 --- a/grammar/tacextend.ml4 +++ b/grammar/tacextend.mlp @@ -6,13 +6,11 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4deps: "tools/compat5b.cmo" i*) - (** Implementation of the TACTIC EXTEND macro. *) open Q_util open Argextend -open Compat +open GramCompat let dloc = <:expr< Loc.ghost >> @@ -47,7 +45,7 @@ let make_clause (pt,_,e) = make_let false e pt) let make_fun_clauses loc s l = - let map c = Compat.make_fun loc [make_clause c] in + 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 ] >> @@ -102,7 +100,7 @@ let declare_tactic loc s c cl = match cl with whole-prof tactics like [shelve_unifiable]. *) <:expr< fun _ $lid:"ist"$ -> $tac$ >> | _ -> - let f = Compat.make_fun loc [patt, vala None, <:expr< fun $lid:"ist"$ -> $tac$ >>] in + let f = GramCompat.make_fun loc [patt, vala None, <:expr< fun $lid:"ist"$ -> $tac$ >>] in <:expr< Tacinterp.lift_constr_tac_to_ml_tac $vars$ $f$ >> in (** Arguments are not passed directly to the ML tactic in the TacML node, @@ -117,7 +115,7 @@ let declare_tactic loc s c cl = match cl with Tacenv.register_ml_tactic $se$ [|$tac$|]; Mltop.declare_cache_obj obj $plugin_name$; } with [ e when Errors.noncritical e -> - Pp.msg_warning + Feedback.msg_warning (Pp.app (Pp.str ("Exception in tactic extend " ^ $entry$ ^": ")) (Errors.print e)) ]; } >> @@ -135,7 +133,7 @@ let declare_tactic loc s c cl = match cl with Tacenv.register_ml_tactic $se$ (Array.of_list $make_fun_clauses loc s cl$); Mltop.declare_cache_obj $obj$ $plugin_name$; } with [ e when Errors.noncritical e -> - Pp.msg_warning + Feedback.msg_warning (Pp.app (Pp.str ("Exception in tactic extend " ^ $entry$ ^": ")) (Errors.print e)) ]; } >> diff --git a/grammar/vernacextend.ml4 b/grammar/vernacextend.mlp index 904662ea1c..ce04318894 100644 --- a/grammar/vernacextend.ml4 +++ b/grammar/vernacextend.mlp @@ -6,14 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4deps: "tools/compat5b.cmo" i*) - (** Implementation of the VERNAC EXTEND macro. *) open Q_util open Argextend open Tacextend -open Compat +open GramCompat type rule = { r_head : string option; @@ -93,13 +91,13 @@ let make_fun_clauses loc s l = | None -> false | Some () -> true in - let cl = Compat.make_fun loc [make_clause c] in + let cl = GramCompat.make_fun loc [make_clause c] in <:expr< ($mlexpr_of_bool depr$, $cl$)>> in mlexpr_of_list map l let make_fun_classifiers loc s c l = - let cl = List.map (fun x -> Compat.make_fun loc [make_clause_classifier c s x]) l in + let cl = List.map (fun x -> GramCompat.make_fun loc [make_clause_classifier c s x]) l in mlexpr_of_list (fun x -> x) cl let make_prod_item = function @@ -128,7 +126,7 @@ let declare_command loc s c nt cl = CList.iteri (fun i (depr, f) -> Vernacinterp.vinterp_add depr ($se$, i) f) $funcl$; CList.iteri (fun i f -> Vernac_classifier.declare_vernac_classifier ($se$, i) f) $classl$ } with [ e when Errors.noncritical e -> - Pp.msg_warning + Feedback.msg_warning (Pp.app (Pp.str ("Exception in vernac extend " ^ $se$ ^": ")) (Errors.print e)) ]; diff --git a/ide/coq.ml b/ide/coq.ml index fa0adf979c..61f002576b 100644 --- a/ide/coq.ml +++ b/ide/coq.ml @@ -290,23 +290,20 @@ let rec check_errors = function | `NVAL :: _ -> raise (TubeError "NVAL") | `OUT :: _ -> raise (TubeError "OUT") -let handle_intermediate_message handle xml = - let message = Pp.to_message xml in - let level = message.Pp.message_level in - let content = message.Pp.message_content in - let logger = match handle.waiting_for with - | Some (_, l) -> l +let handle_intermediate_message handle level content = + let logger = match handle.waiting_for with + | Some (_, l) -> l | None -> function - | Pp.Error -> fun s -> Minilib.log ~level:`ERROR (xml_to_string s) - | Pp.Info -> fun s -> Minilib.log ~level:`INFO (xml_to_string s) - | Pp.Notice -> fun s -> Minilib.log ~level:`NOTICE (xml_to_string s) - | Pp.Warning -> fun s -> Minilib.log ~level:`WARNING (xml_to_string s) - | Pp.Debug _ -> fun s -> Minilib.log ~level:`DEBUG (xml_to_string s) + | Feedback.Error -> fun s -> Minilib.log ~level:`ERROR (xml_to_string s) + | Feedback.Info -> fun s -> Minilib.log ~level:`INFO (xml_to_string s) + | Feedback.Notice -> fun s -> Minilib.log ~level:`NOTICE (xml_to_string s) + | Feedback.Warning -> fun s -> Minilib.log ~level:`WARNING (xml_to_string s) + | Feedback.Debug _ -> fun s -> Minilib.log ~level:`DEBUG (xml_to_string s) in - logger level (Richpp.richpp_of_xml content) + logger level content let handle_feedback feedback_processor xml = - let feedback = Feedback.to_feedback xml in + let feedback = Xmlprotocol.to_feedback xml in feedback_processor feedback let handle_final_answer handle xml = @@ -335,15 +332,18 @@ let unsafe_handle_input handle feedback_processor state conds ~read_all = let l_end = Lexing.lexeme_end lex in state.fragment <- String.sub s l_end (String.length s - l_end); state.lexerror <- None; - if Pp.is_message xml then begin - handle_intermediate_message handle xml; + match Xmlprotocol.is_message xml with + | Some (lvl, msg) -> + handle_intermediate_message handle lvl msg; loop () - end else if Feedback.is_feedback xml then begin - handle_feedback feedback_processor xml; - loop () - end else begin - ignore (handle_final_answer handle xml) - end + | None -> + if Xmlprotocol.is_feedback xml then begin + handle_feedback feedback_processor xml; + loop () + end else + begin + ignore (handle_final_answer handle xml) + end in try loop () with Xml_parser.Error _ as e -> @@ -357,7 +357,9 @@ let unsafe_handle_input handle feedback_processor state conds ~read_all = let print_exception = function | Xml_parser.Error e -> Xml_parser.error e - | Serialize.Marshal_error -> "Protocol violation" + | Serialize.Marshal_error(expected,actual) -> + "Protocol violation. Expected: " ^ expected ^ " Actual: " + ^ Xml_printer.to_string actual | e -> Printexc.to_string e let input_watch handle respawner feedback_processor = diff --git a/ide/coqOps.ml b/ide/coqOps.ml index b55786ddd0..6ffe771da3 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -519,7 +519,7 @@ object(self) self#position_error_tag_at_iter start phrase loc; buffer#place_cursor ~where:stop; messages#clear; - messages#push Pp.Error msg; + messages#push Feedback.Error msg; self#show_goals end else self#show_goals_aux ~move_insert:true () @@ -595,7 +595,8 @@ object(self) if Queue.is_empty queue then conclude topstack else match Queue.pop queue, topstack with | `Skip(start,stop), [] -> - logger Pp.Error (Richpp.richpp_of_string "You must close the proof with Qed or Admitted"); + + logger Feedback.Error (Richpp.richpp_of_string "You must close the proof with Qed or Admitted"); self#discard_command_queue queue; conclude [] | `Skip(start,stop), (_,s) :: topstack -> @@ -611,7 +612,7 @@ object(self) let handle_answer = function | Good (id, (Util.Inl (* NewTip *) (), msg)) -> Doc.assign_tip_id document id; - logger Pp.Notice (Richpp.richpp_of_string msg); + logger Feedback.Notice (Richpp.richpp_of_string msg); self#commit_queue_transaction sentence; loop id [] | Good (id, (Util.Inr (* Unfocus *) tip, msg)) -> @@ -619,7 +620,7 @@ object(self) let topstack, _ = Doc.context document in self#exit_focus; self#cleanup (Doc.cut_at document tip); - logger Pp.Notice (Richpp.richpp_of_string msg); + logger Feedback.Notice (Richpp.richpp_of_string msg); self#mark_as_needed sentence; if Queue.is_empty queue then loop tip [] else loop tip (List.rev topstack) @@ -638,7 +639,7 @@ object(self) let next = function | Good _ -> messages#clear; - messages#push Pp.Info (Richpp.richpp_of_string "All proof terms checked by the kernel"); + messages#push Feedback.Info (Richpp.richpp_of_string "All proof terms checked by the kernel"); Coq.return () | Fail x -> self#handle_failure x in Coq.bind (Coq.status ~logger:messages#push true) next @@ -740,8 +741,8 @@ object(self) self#cleanup (Doc.cut_at document to_id); conclusion () | Fail (safe_id, loc, msg) -> - if loc <> None then messages#push Pp.Error (Richpp.richpp_of_string "Fixme LOC"); - messages#push Pp.Error msg; +(* if loc <> None then messages#push Feedback.Error (Richpp.richpp_of_string "Fixme LOC"); *) + messages#push Feedback.Error msg; if Stateid.equal safe_id Stateid.dummy then self#show_goals else undo safe_id (Doc.focused document && Doc.is_in_focus document safe_id)) @@ -759,7 +760,7 @@ object(self) ?(move_insert=false) (safe_id, (loc : (int * int) option), msg) = messages#clear; - messages#push Pp.Error msg; + messages#push Feedback.Error msg; ignore(self#process_feedback ()); if Stateid.equal safe_id Stateid.dummy then Coq.lift (fun () -> ()) else diff --git a/ide/coqide.ml b/ide/coqide.ml index 1fe393d2b9..d1a799a773 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -677,12 +677,18 @@ let searchabout sn = let searchabout () = on_current_term searchabout +let doquery query sn = + sn.messages#clear; + Coq.try_grab sn.coqtop (sn.coqops#raw_coq_query query) ignore + let otherquery command sn = - let word = get_current_word sn in - if word <> "" then - let query = command ^ " " ^ word ^ "." in - sn.messages#clear; - Coq.try_grab sn.coqtop (sn.coqops#raw_coq_query query) ignore + Option.iter (fun query -> doquery (query ^ ".") sn) + begin try + let i = CString.string_index_from command 0 "..." in + let word = get_current_word sn in + if word = "" then None + else Some (CString.sub command 0 i ^ " " ^ word) + with Not_found -> Some command end let otherquery command = cb_on_current_term (otherquery command) @@ -783,7 +789,7 @@ let coqtop_arguments sn = let args = String.concat " " args in let msg = Printf.sprintf "Invalid arguments: %s" args in let () = sn.messages#clear in - sn.messages#push Pp.Error (Richpp.richpp_of_string msg) + sn.messages#push Feedback.Error (Richpp.richpp_of_string msg) else dialog#destroy () in let _ = entry#connect#activate ok_cb in @@ -859,12 +865,12 @@ let toggle_items menu_name l = in List.iter f l +let no_under = Util.String.map (fun x -> if x = '_' then '-' else x) + (** Create alphabetical menu items with elements in sub-items. [l] is a list of lists, one per initial letter *) let alpha_items menu_name item_name l = - let no_under = Util.String.map (fun x -> if x = '_' then '-' else x) - in let mk_item text = let text' = let last = String.length text - 1 in @@ -911,6 +917,16 @@ let template_item (text, offset, len, key) = in item name ~label ~callback:(cb_on_current_term callback) ~accel:(modifier^key) +(** Create menu items for pairs (query, shortcut key). *) +let user_queries_items menu_name item_name l = + let mk_item (query, key) = + let callback = Query.query query in + let accel = if not (CString.is_empty key) then + Some (modifier_for_queries#get^key) else None in + item (item_name^" "^(no_under query)) ~label:query ?accel ~callback menu_name + in + List.iter mk_item l + let emit_to_focus window sgn = let focussed_widget = GtkWindow.Window.get_focus window#as_window in let obj = Gobject.unsafe_cast focussed_widget in @@ -1100,16 +1116,22 @@ let build_ui () = ]; alpha_items templates_menu "Template" Coq_commands.commands; - let qitem s accel = item s ~label:("_"^s) ?accel ~callback:(Query.query s) in + let qitem s sc ?(dots = true) = + let query = if dots then s ^ "..." else s in + item s ~label:("_"^s) + ~accel:(modifier_for_queries#get^sc) + ~callback:(Query.query query) + in menu queries_menu [ item "Queries" ~label:"_Queries"; - qitem "Search" (Some "<Ctrl><Shift>K"); - qitem "Check" (Some "<Ctrl><Shift>C"); - qitem "Print" (Some "<Ctrl><Shift>P"); - qitem "About" (Some "<Ctrl><Shift>A"); - qitem "Locate" (Some "<Ctrl><Shift>L"); - qitem "Print Assumptions" (Some "<Ctrl><Shift>N"); + qitem "Search" "K" ~dots:false; + qitem "Check" "C"; + qitem "Print" "P"; + qitem "About" "A"; + qitem "Locate" "L"; + qitem "Print Assumptions" "N"; ]; + user_queries_items queries_menu "User-Query" user_queries#get; menu tools_menu [ item "Tools" ~label:"_Tools"; diff --git a/ide/coqide_ui.ml b/ide/coqide_ui.ml index edfe28b261..2ae18593ac 100644 --- a/ide/coqide_ui.ml +++ b/ide/coqide_ui.ml @@ -18,6 +18,15 @@ let list_items menu li = let () = List.iter (fun b -> Buffer.add_buffer res_buf (tactic_item b)) li in res_buf +let list_queries menu li = + let res_buf = Buffer.create 500 in + let query_item (q, _) = + let s = "<menuitem action='"^menu^" "^(no_under q)^"' />\n" in + Buffer.add_string res_buf s + in + let () = List.iter query_item li in + res_buf + let init () = let theui = Printf.sprintf "<ui> <menubar name='CoqIde MenuBar'> @@ -119,6 +128,8 @@ let init () = <menuitem action='About' /> <menuitem action='Locate' /> <menuitem action='Print Assumptions' /> + <separator /> + %s </menu> <menu name='Tools' action='Tools'> <menuitem action='Comment' /> @@ -162,5 +173,6 @@ let init () = (if Coq_config.gtk_platform <> `QUARTZ then "<menuitem action='Quit' />" else "") (Buffer.contents (list_items "Tactic" Coq_commands.tactics)) (Buffer.contents (list_items "Template" Coq_commands.commands)) + (Buffer.contents (list_queries "User-Query" Preferences.user_queries#get)) in ignore (ui_m#add_ui_from_string theui); diff --git a/ide/coqidetop.mllib b/ide/coqidetop.mllib index 92301dc30e..ed1fa465d2 100644 --- a/ide/coqidetop.mllib +++ b/ide/coqidetop.mllib @@ -1,2 +1,9 @@ +Xml_lexer +Xml_parser +Xml_printer +Serialize +Richprinter Xmlprotocol +Texmacspp +Document Ide_slave diff --git a/ide/ide.mllib b/ide/ide.mllib index 83b3142839..b2f32fcf7b 100644 --- a/ide/ide.mllib +++ b/ide/ide.mllib @@ -14,8 +14,13 @@ Config_lexer Utf8_convert Preferences Project_file -Ideutils +Serialize +Richprinter +Xml_lexer +Xml_parser +Xml_printer Xmlprotocol +Ideutils Coq Coq_lex Sentence diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index 9a3e85e47d..79affb36f5 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -98,11 +98,11 @@ 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 - msg_warning (strbrk"This will not work. Use CoqIDE display menu instead"); + Feedback.msg_warning (strbrk"This will not work. Use CoqIDE display menu instead"); if Vernac.is_navigation_vernac ast || is_undo ast then - msg_warning (strbrk "Rather use CoqIDE navigation instead"); + Feedback.msg_warning (strbrk "Rather use CoqIDE navigation instead"); if is_query ast then - msg_warning (strbrk "Query commands should not be inserted in scripts") + Feedback.msg_warning (strbrk "Query commands should not be inserted in scripts") (** Interpretation (cf. [Ide_intf.interp]) *) @@ -212,7 +212,7 @@ let export_pre_goals pgs = let goals () = Stm.finish (); let s = read_stdout () in - if not (String.is_empty s) then msg_info (str s); + if not (String.is_empty s) then Feedback.msg_info (str s); try let pfts = Proof_global.give_me_the_proof () in Some (export_pre_goals (Proof.map_structured_proof pfts process_goal)) @@ -222,7 +222,7 @@ let evars () = try Stm.finish (); let s = read_stdout () in - if not (String.is_empty s) then msg_info (str s); + if not (String.is_empty s) then Feedback.msg_info (str s); let pfts = Proof_global.give_me_the_proof () in let { Evd.it = all_goals ; sigma = sigma } = Proof.V82.subgoals pfts in let exl = Evar.Map.bindings (Evarutil.non_instantiated sigma) in @@ -255,7 +255,7 @@ let status force = Stm.finish (); if force then Stm.join (); let s = read_stdout () in - if not (String.is_empty s) then msg_info (str s); + if not (String.is_empty s) then Feedback.msg_info (str s); let path = let l = Names.DirPath.repr (Lib.cwd ()) in List.rev_map Names.Id.to_string l @@ -281,11 +281,33 @@ let export_coq_object t = { Interface.coq_object_object = t.Search.coq_object_object } +let pattern_of_string ?env s = + let env = + match env with + | None -> Global.env () + | Some e -> e + in + let constr = Pcoq.parse_string Pcoq.Constr.lconstr_pattern s in + let (_, pat) = Constrintern.intern_constr_pattern env constr in + pat + +let dirpath_of_string_list s = + let path = String.concat "." s in + let m = Pcoq.parse_string Pcoq.Constr.global path in + let (_, qid) = Libnames.qualid_of_reference m in + let id = + try Nametab.full_name_module qid + with Not_found -> + Errors.errorlabstrm "Search.interface_search" + (str "Module " ++ str path ++ str " not found.") + in + id + let import_search_constraint = function - | Interface.Name_Pattern s -> Search.Name_Pattern s - | Interface.Type_Pattern s -> Search.Type_Pattern s - | Interface.SubType_Pattern s -> Search.SubType_Pattern s - | Interface.In_Module ms -> Search.In_Module ms + | Interface.Name_Pattern s -> Search.Name_Pattern (Str.regexp s) + | Interface.Type_Pattern s -> Search.Type_Pattern (pattern_of_string s) + | Interface.SubType_Pattern s -> Search.SubType_Pattern (pattern_of_string s) + | Interface.In_Module ms -> Search.In_Module (dirpath_of_string_list ms) | Interface.Include_Blacklist -> Search.Include_Blacklist let search flags = @@ -361,8 +383,6 @@ let init = match file with | None -> Stm.get_current_state () | Some file -> - if not (Filename.check_suffix file ".v") then - error "A file with suffix .v is expected."; let dir = Filename.dirname file in let open Loadpath in let open CUnix in let initial_id, _ = @@ -393,6 +413,15 @@ let interp ((_raw, verbose), s) = let quit = ref false +(** Serializes the output of Stm.get_ast *) +let print_ast id = + match Stm.get_ast id with + | Some (expr, loc) -> begin + try Texmacspp.tmpp expr loc + with e -> Xml_datatype.PCData ("ERROR " ^ Printexc.to_string e) + end + | None -> Xml_datatype.PCData "ERROR" + (** Grouping all call handlers together + error handling *) let eval_call xml_oc log c = @@ -423,7 +452,7 @@ let eval_call xml_oc log c = Interface.interp = interruptible interp; Interface.handle_exn = handle_exn; Interface.stop_worker = Stm.stop_worker; - Interface.print_ast = Stm.print_ast; + Interface.print_ast = print_ast; Interface.annotate = interruptible annotate; } in Xmlprotocol.abstract_eval_call handler c @@ -444,16 +473,12 @@ let print_xml = let slave_logger xml_oc level message = (* convert the message into XML *) let msg = hov 0 message in - let message = { - Pp.message_level = level; - Pp.message_content = (Richpp.repr (Richpp.richpp_of_pp msg)); - } in - let () = pr_debug (Printf.sprintf "-> %S" (string_of_ppcmds msg)) in - let xml = Pp.of_message message in + let () = pr_debug (Printf.sprintf "-> %S" (string_of_ppcmds msg)) in + let xml = Xmlprotocol.of_message level (Richpp.richpp_of_pp message) in print_xml xml_oc xml let slave_feeder xml_oc msg = - let xml = Feedback.of_feedback msg in + let xml = Xmlprotocol.of_feedback msg in print_xml xml_oc xml (** The main loop *) @@ -471,8 +496,8 @@ let loop () = CThread.thread_friendly_read in_ch s ~off:0 ~len) in let xml_ic = Xml_parser.make (Xml_parser.SLexbuf in_lb) in let () = Xml_parser.check_eof xml_ic false in - set_logger (slave_logger xml_oc); - set_feeder (slave_feeder xml_oc); + Feedback.set_logger (slave_logger xml_oc); + Feedback.set_feeder (slave_feeder xml_oc); (* We'll handle goal fetching and display in our own way *) Vernacentries.enable_goal_printing := false; Vernacentries.qed_display_script := false; @@ -482,7 +507,7 @@ let loop () = (* pr_with_pid (Xml_printer.to_string_fmt xml_query); *) let Xmlprotocol.Unknown q = Xmlprotocol.to_call xml_query in let () = pr_debug_call q in - let r = eval_call xml_oc (slave_logger xml_oc Pp.Notice) q in + let r = eval_call xml_oc (slave_logger xml_oc Feedback.Notice) q in let () = pr_debug_answer q r in (* pr_with_pid (Xml_printer.to_string_fmt (Xmlprotocol.of_answer q r)); *) print_xml xml_oc (Xmlprotocol.of_answer q r); @@ -494,7 +519,7 @@ let loop () = | Xml_parser.Error (err, loc) -> pr_debug ("Syntax error in query: " ^ Xml_parser.error_msg err); exit 1 - | Serialize.Marshal_error -> + | Serialize.Marshal_error _ -> pr_debug "Incorrect query."; exit 1 | any -> diff --git a/ide/ideutils.ml b/ide/ideutils.ml index 508881cad8..00c3f88e56 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -297,15 +297,15 @@ let textview_width (view : #GText.view_skel) = let char_width = GPango.to_pixels metrics#approx_char_width in pixel_width / char_width -type logger = Pp.message_level -> Richpp.richpp -> unit +type logger = Feedback.level -> Richpp.richpp -> unit let default_logger level message = let level = match level with - | Pp.Debug _ -> `DEBUG - | Pp.Info -> `INFO - | Pp.Notice -> `NOTICE - | Pp.Warning -> `WARNING - | Pp.Error -> `ERROR + | Feedback.Debug _ -> `DEBUG + | Feedback.Info -> `INFO + | Feedback.Notice -> `NOTICE + | Feedback.Warning -> `WARNING + | Feedback.Error -> `ERROR in Minilib.log ~level (xml_to_string message) diff --git a/ide/ideutils.mli b/ide/ideutils.mli index 4e35a6f9fa..491e8e823d 100644 --- a/ide/ideutils.mli +++ b/ide/ideutils.mli @@ -69,7 +69,7 @@ val requote : string -> string val textview_width : #GText.view_skel -> int (** Returns an approximate value of the character width of a textview *) -type logger = Pp.message_level -> Richpp.richpp -> unit +type logger = Feedback.level -> Richpp.richpp -> unit val default_logger : logger (** Default logger. It logs messages that the casual user should not see. *) diff --git a/ide/preferences.ml b/ide/preferences.ml index c4dc55972b..3a33bbb1d8 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -144,6 +144,18 @@ object method into s = Some s end +let string_pair_list (sep : char) : (string * string) list repr = +object + val sep' = String.make 1 sep + method from = CList.map (fun (s1, s2) -> CString.concat sep' [s1; s2]) + method into l = + try + Some (CList.map (fun s -> + let split = CString.split sep s in + CList.nth split 0, CList.nth split 1) l) + with Failure _ -> None +end + let bool : bool repr = object method from s = [string_of_bool s] @@ -303,10 +315,14 @@ let modifier_for_tactics = let modifier_for_display = new preference ~name:["modifier_for_display"] ~init:"<Alt><Shift>" ~repr:Repr.(string) +let modifier_for_queries = + new preference ~name:["modifier_for_queries"] ~init:"<Control><Shift>" ~repr:Repr.(string) + let _ = attach_modifiers modifier_for_navigation "<Actions>/Navigation/" let _ = attach_modifiers modifier_for_templates "<Actions>/Templates/" let _ = attach_modifiers modifier_for_tactics "<Actions>/Tactics/" let _ = attach_modifiers modifier_for_display "<Actions>/View/" +let _ = attach_modifiers modifier_for_queries "<Actions>/Queries/" let modifiers_valid = new preference ~name:["modifiers_valid"] ~init:"<Alt><Control><Shift>" ~repr:Repr.(string) @@ -507,6 +523,9 @@ let highlight_current_line = let nanoPG = new preference ~name:["nanoPG"] ~init:false ~repr:Repr.(bool) +let user_queries = + new preference ~name:["user_queries"] ~init:[] ~repr:Repr.(string_pair_list '$') + class tag_button (box : Gtk.box Gtk.obj) = object (self) @@ -837,6 +856,9 @@ let configure ?(apply=(fun () -> ())) () = let modifier_for_display = pmodifiers "Modifiers for View Menu" modifier_for_display in + let modifier_for_queries = + pmodifiers "Modifiers for Queries Menu" modifier_for_queries + in let modifiers_valid = pmodifiers ~all:true "Allowed modifiers" modifiers_valid in @@ -908,6 +930,36 @@ let configure ?(apply=(fun () -> ())) () = let misc = [contextual_menus_on_goal;stop_before;reset_on_tab_switch; vertical_tabs;opposite_tabs] in + let add_user_query () = + let input_string l v = + match GToolbox.input_string ~title:l v with + | None -> "" + | Some s -> s + in + let q = input_string "User query" "Your query" in + let k = input_string "Shortcut key" "Shortcut (a single letter)" in + let q = CString.map (fun c -> if c = '$' then ' ' else c) q in + (* Anything that is not a simple letter will be ignored. *) + let k = + if Int.equal (CString.length k) 1 && Util.is_letter k.[0] then k + else "" in + let k = CString.uppercase k in + [q, k] + in + + let user_queries = + list + ~f:user_queries#set + (* Disallow same query, key or empty query. *) + ~eq:(fun (q1, k1) (q2, k2) -> k1 = k2 || q1 = "" || q2 = "" || q1 = q2) + ~add:add_user_query + ~titles:["User query"; "Shortcut key"] + "User queries" + (fun (q, s) -> [q; s]) + user_queries#get + + in + (* ATTENTION !!!!! L'onglet Fonts doit etre en premier pour eviter un bug !!!! (shame on Benjamin) *) let cmds = @@ -937,9 +989,10 @@ let configure ?(apply=(fun () -> ())) () = [automatic_tactics]); Section("Shortcuts", Some `PREFERENCES, [modifiers_valid; modifier_for_tactics; - modifier_for_templates; modifier_for_display; modifier_for_navigation]); + modifier_for_templates; modifier_for_display; modifier_for_navigation; + modifier_for_queries; user_queries]); Section("Misc", Some `ADD, - misc)] + misc)] in (* Format.printf "before edit: current.text_font = %s@." (Pango.Font.to_string current.text_font); diff --git a/ide/preferences.mli b/ide/preferences.mli index 1733091a58..426b0a328e 100644 --- a/ide/preferences.mli +++ b/ide/preferences.mli @@ -65,6 +65,7 @@ val modifier_for_navigation : string preference val modifier_for_templates : string preference val modifier_for_tactics : string preference val modifier_for_display : string preference +val modifier_for_queries : string preference val modifiers_valid : string preference val cmd_browse : string preference val cmd_editor : string preference @@ -95,6 +96,7 @@ val spaces_instead_of_tabs : bool preference val tab_length : int preference val highlight_current_line : bool preference val nanoPG : bool preference +val user_queries : (string * string) list preference val save_pref : unit -> unit val load_pref : unit -> unit diff --git a/ide/project_file.ml4 b/ide/project_file.ml4 index 081094e2b6..de0720e033 100644 --- a/ide/project_file.ml4 +++ b/ide/project_file.ml4 @@ -56,24 +56,24 @@ let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts) | ("-full"|"-opt") :: r -> process_cmd_line orig_dir (project_file,makefile,install,true) l r | "-impredicative-set" :: r -> - Pp.msg_warning (Pp.str "Please now use \"-arg -impredicative-set\" instead of \"-impredicative-set\" alone to be more uniform."); + Feedback.msg_warning (Pp.str "Please now use \"-arg -impredicative-set\" instead of \"-impredicative-set\" alone to be more uniform."); process_cmd_line orig_dir opts (Arg "-impredicative-set" :: l) r | "-no-install" :: r -> - Pp.msg_warning (Pp.(++) (Pp.str "Option -no-install is deprecated.") (Pp.(++) (Pp.spc ()) (Pp.str "Use \"-install none\" instead"))); + Feedback.msg_warning (Pp.(++) (Pp.str "Option -no-install is deprecated.") (Pp.(++) (Pp.spc ()) (Pp.str "Use \"-install none\" instead"))); process_cmd_line orig_dir (project_file,makefile,NoInstall,opt) l r | "-install" :: d :: r -> - if install <> UnspecInstall then Pp.msg_warning (Pp.str "-install sets more than once."); + if install <> UnspecInstall then Feedback.msg_warning (Pp.str "-install sets more than once."); let install = match d with | "user" -> UserInstall | "none" -> NoInstall | "global" -> TraditionalInstall - | _ -> Pp.msg_warning (Pp.(++) (Pp.str "invalid option '") (Pp.(++) (Pp.str d) (Pp.str "' passed to -install."))); + | _ -> Feedback.msg_warning (Pp.(++) (Pp.str "invalid option '") (Pp.(++) (Pp.str d) (Pp.str "' passed to -install."))); install in process_cmd_line orig_dir (project_file,makefile,install,opt) l r | "-custom" :: com :: dependencies :: file :: r -> - Pp.msg_warning (Pp.app + Feedback.msg_warning (Pp.app (Pp.str "Please now use \"-extra[-phony] result deps command\" instead of \"-custom command deps result\".") (Pp.pr_arg Pp.str "It follows makefile target declaration order and has a clearer semantic.") ); @@ -94,7 +94,7 @@ let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts) let file = CUnix.remove_path_dot (CUnix.correct_path file orig_dir) in let () = match project_file with | None -> () - | Some _ -> Pp.msg_warning (Pp.str + | Some _ -> Feedback.msg_warning (Pp.str "Several features will not work with multiple project files.") in let (opts',l') = process_cmd_line (Filename.dirname file) (Some file,makefile,install,opt) l (parse file) in @@ -109,7 +109,7 @@ let rec process_cmd_line orig_dir ((project_file,makefile,install,opt) as opts) let () = match makefile with |None -> () |Some f -> - Pp.msg_warning (Pp.(++) (Pp.str "Only one output file is genererated. ") (Pp.(++) (Pp.str f) (Pp.str " will not be."))) + Feedback.msg_warning (Pp.(++) (Pp.str "Only one output file is genererated. ") (Pp.(++) (Pp.str f) (Pp.str " will not be."))) in process_cmd_line orig_dir (project_file,Some file,install,opt) l r end | v :: "=" :: def :: r -> diff --git a/printing/richprinter.ml b/ide/richprinter.ml index 5f39f36eab..5f39f36eab 100644 --- a/printing/richprinter.ml +++ b/ide/richprinter.ml diff --git a/printing/richprinter.mli b/ide/richprinter.mli index c9e84e3eb4..c9e84e3eb4 100644 --- a/printing/richprinter.mli +++ b/ide/richprinter.mli diff --git a/lib/serialize.ml b/ide/serialize.ml index 685ec6049c..7b568501ed 100644 --- a/lib/serialize.ml +++ b/ide/serialize.ml @@ -8,7 +8,7 @@ open Xml_datatype -exception Marshal_error +exception Marshal_error of string * xml (** Utility functions *) @@ -19,30 +19,31 @@ let rec get_attr attr = function let massoc x l = try get_attr x l - with Not_found -> raise Marshal_error + with Not_found -> raise (Marshal_error("attribute " ^ x,PCData "not there")) let constructor t c args = Element (t, ["val", c], args) let do_match t mf = function | Element (s, attrs, args) when CString.equal s t -> let c = massoc "val" attrs in mf c args - | _ -> raise Marshal_error + | x -> raise (Marshal_error (t,x)) let singleton = function | [x] -> x - | _ -> raise Marshal_error + | l -> raise (Marshal_error + ("singleton",PCData ("list of length " ^ string_of_int (List.length l)))) let raw_string = function | [] -> "" | [PCData s] -> s - | _ -> raise Marshal_error + | x::_ -> raise (Marshal_error("raw string",x)) (** Base types *) let of_unit () = Element ("unit", [], []) let to_unit : xml -> unit = function | Element ("unit", [], []) -> () - | _ -> raise Marshal_error + | x -> raise (Marshal_error ("unit",x)) let of_bool (b : bool) : xml = if b then constructor "bool" "true" [] @@ -50,13 +51,13 @@ let of_bool (b : bool) : xml = let to_bool : xml -> bool = do_match "bool" (fun s _ -> match s with | "true" -> true | "false" -> false - | _ -> raise Marshal_error) + | x -> raise (Marshal_error("bool",PCData x))) let of_list (f : 'a -> xml) (l : 'a list) = Element ("list", [], List.map f l) let to_list (f : xml -> 'a) : xml -> 'a list = function | Element ("list", [], l) -> List.map f l - | _ -> raise Marshal_error + | x -> raise (Marshal_error("list",x)) let of_option (f : 'a -> xml) : 'a option -> xml = function | None -> Element ("option", ["val", "none"], []) @@ -64,24 +65,24 @@ let of_option (f : 'a -> xml) : 'a option -> xml = function let to_option (f : xml -> 'a) : xml -> 'a option = function | Element ("option", ["val", "none"], []) -> None | Element ("option", ["val", "some"], [x]) -> Some (f x) - | _ -> raise Marshal_error + | x -> raise (Marshal_error("option",x)) let of_string (s : string) : xml = Element ("string", [], [PCData s]) let to_string : xml -> string = function | Element ("string", [], l) -> raw_string l - | _ -> raise Marshal_error + | x -> raise (Marshal_error("string",x)) let of_int (i : int) : xml = Element ("int", [], [PCData (string_of_int i)]) let to_int : xml -> int = function | Element ("int", [], [PCData s]) -> - (try int_of_string s with Failure _ -> raise Marshal_error) - | _ -> raise Marshal_error + (try int_of_string s with Failure _ -> raise(Marshal_error("int",PCData s))) + | x -> raise (Marshal_error("int",x)) let of_pair (f : 'a -> xml) (g : 'b -> xml) (x : 'a * 'b) : xml = Element ("pair", [], [f (fst x); g (snd x)]) let to_pair (f : xml -> 'a) (g : xml -> 'b) : xml -> 'a * 'b = function | Element ("pair", [], [x; y]) -> (f x, g y) - | _ -> raise Marshal_error + | x -> raise (Marshal_error("pair",x)) let of_union (f : 'a -> xml) (g : 'b -> xml) : ('a,'b) CSig.union -> xml = function | CSig.Inl x -> Element ("union", ["val","in_l"], [f x]) @@ -89,7 +90,7 @@ let of_union (f : 'a -> xml) (g : 'b -> xml) : ('a,'b) CSig.union -> xml = funct let to_union (f : xml -> 'a) (g : xml -> 'b) : xml -> ('a,'b) CSig.union = function | Element ("union", ["val","in_l"], [x]) -> CSig.Inl (f x) | Element ("union", ["val","in_r"], [x]) -> CSig.Inr (g x) - | _ -> raise Marshal_error + | x -> raise (Marshal_error("union",x)) (** More elaborate types *) @@ -99,7 +100,7 @@ let to_edit_id = function let id = int_of_string i in assert (id <= 0 ); id - | _ -> raise Marshal_error + | x -> raise (Marshal_error("edit_id",x)) let of_loc loc = let start, stop = Loc.unloc loc in @@ -107,14 +108,14 @@ let of_loc loc = let to_loc xml = match xml with | Element ("loc", l,[]) -> + let start = massoc "start" l in + let stop = massoc "stop" l in (try - let start = massoc "start" l in - let stop = massoc "stop" l in Loc.make_loc (int_of_string start, int_of_string stop) - with Not_found | Invalid_argument _ -> raise Marshal_error) - | _ -> raise Marshal_error + with Not_found | Invalid_argument _ -> raise (Marshal_error("loc",PCData(start^":"^stop)))) + | x -> raise (Marshal_error("loc",x)) let of_xml x = Element ("xml", [], [x]) let to_xml xml = match xml with | Element ("xml", [], [x]) -> x -| _ -> raise Marshal_error +| x -> raise (Marshal_error("xml",x)) diff --git a/lib/serialize.mli b/ide/serialize.mli index d7c14e7e73..bf9e184ebb 100644 --- a/lib/serialize.mli +++ b/ide/serialize.mli @@ -8,7 +8,7 @@ open Xml_datatype -exception Marshal_error +exception Marshal_error of string * xml val massoc: string -> (string * string) list -> string val constructor: string -> string -> xml list -> xml diff --git a/stm/texmacspp.ml b/ide/texmacspp.ml index d1d6de9ae8..d1d6de9ae8 100644 --- a/stm/texmacspp.ml +++ b/ide/texmacspp.ml diff --git a/stm/texmacspp.mli b/ide/texmacspp.mli index 858847fb6a..858847fb6a 100644 --- a/stm/texmacspp.mli +++ b/ide/texmacspp.mli diff --git a/ide/wg_MessageView.ml b/ide/wg_MessageView.ml index 7728ad2360..758f383d6d 100644 --- a/ide/wg_MessageView.ml +++ b/ide/wg_MessageView.ml @@ -73,8 +73,8 @@ let message_view () : message_view = method push level msg = let tags = match level with - | Pp.Error -> [Tags.Message.error] - | Pp.Warning -> [Tags.Message.warning] + | Feedback.Error -> [Tags.Message.error] + | Feedback.Warning -> [Tags.Message.warning] | _ -> [] in let rec non_empty = function @@ -88,7 +88,7 @@ let message_view () : message_view = push#call (level, msg) end - method add msg = self#push Pp.Notice msg + method add msg = self#push Feedback.Notice msg method add_string s = self#add (Richpp.richpp_of_string s) diff --git a/ide/wg_Segment.ml b/ide/wg_Segment.ml index c2799e40b1..dbc1740ef6 100644 --- a/ide/wg_Segment.ml +++ b/ide/wg_Segment.ml @@ -60,6 +60,8 @@ object (self) val mutable default : color = `WHITE val mutable pixmap : GDraw.pixmap = GDraw.pixmap ~width:1 ~height:1 () val clicked = new GUtil.signal () + val mutable need_refresh = false + val refresh_timer = Ideutils.mktimer () initializer box#misc#set_size_request ~height (); @@ -88,13 +90,15 @@ object (self) let cb show = if show then self#misc#show () else self#misc#hide () in stick show_progress_bar self cb; (** Initial pixmap *) - draw#set_pixmap pixmap + draw#set_pixmap pixmap; + refresh_timer.Ideutils.run ~ms:300 + ~callback:(fun () -> if need_refresh then self#refresh (); true) method set_model md = model <- Some md; let changed_cb = function | `INSERT | `REMOVE -> - if self#misc#visible then self#refresh () + if self#misc#visible then need_refresh <- true | `SET (i, color) -> if self#misc#visible then self#fill_range color i (i + 1) in @@ -125,6 +129,7 @@ object (self) method private refresh () = match model with | None -> () | Some md -> + need_refresh <- false; pixmap#set_foreground default; pixmap#rectangle ~x:0 ~y:0 ~width ~height ~filled:true (); let make (k, cur, accu) v = match cur with diff --git a/lib/xml_lexer.mli b/ide/xml_lexer.mli index e61cb055f7..e61cb055f7 100644 --- a/lib/xml_lexer.mli +++ b/ide/xml_lexer.mli diff --git a/lib/xml_lexer.mll b/ide/xml_lexer.mll index 290f2c89ab..290f2c89ab 100644 --- a/lib/xml_lexer.mll +++ b/ide/xml_lexer.mll diff --git a/lib/xml_parser.ml b/ide/xml_parser.ml index 8db3f9e8ba..8db3f9e8ba 100644 --- a/lib/xml_parser.ml +++ b/ide/xml_parser.ml diff --git a/lib/xml_parser.mli b/ide/xml_parser.mli index ac2eab352f..ac2eab352f 100644 --- a/lib/xml_parser.mli +++ b/ide/xml_parser.mli diff --git a/lib/xml_printer.ml b/ide/xml_printer.ml index e7e4d0cebc..e7e4d0cebc 100644 --- a/lib/xml_printer.ml +++ b/ide/xml_printer.ml diff --git a/lib/xml_printer.mli b/ide/xml_printer.mli index f24f51fff5..f24f51fff5 100644 --- a/lib/xml_printer.mli +++ b/ide/xml_printer.mli diff --git a/ide/xmlprotocol.ml b/ide/xmlprotocol.ml index 232630e5b2..a55d19aa1b 100644 --- a/ide/xmlprotocol.ml +++ b/ide/xmlprotocol.ml @@ -39,7 +39,7 @@ let to_search_cst = do_match "search_cst" (fun s args -> match s with | "subtype_pattern" -> SubType_Pattern (to_string (singleton args)) | "in_module" -> In_Module (to_list to_string (singleton args)) | "include_blacklist" -> Include_Blacklist - | _ -> raise Marshal_error) + | x -> raise (Marshal_error("search",PCData x))) let of_coq_object f ans = let prefix = of_list of_string ans.coq_object_prefix in @@ -56,7 +56,7 @@ let to_coq_object f = function coq_object_qualid = qualid; coq_object_object = obj; } -| _ -> raise Marshal_error +| x -> raise (Marshal_error("coq_object",x)) let of_option_value = function | IntValue i -> constructor "option_value" "intvalue" [of_option of_int i] @@ -68,7 +68,7 @@ let to_option_value = do_match "option_value" (fun s args -> match s with | "boolvalue" -> BoolValue (to_bool (singleton args)) | "stringvalue" -> StringValue (to_string (singleton args)) | "stringoptvalue" -> StringOptValue (to_option to_string (singleton args)) - | _ -> raise Marshal_error) + | x -> raise (Marshal_error("*value",PCData x))) let of_option_state s = Element ("option_state", [], [ @@ -82,8 +82,20 @@ let to_option_state = function opt_depr = to_bool depr; opt_name = to_string name; opt_value = to_option_value value } - | _ -> raise Marshal_error + | x -> raise (Marshal_error("option_state",x)) +let to_stateid = function + | Element ("state_id",["val",i],[]) -> + let id = int_of_string i in + Stateid.of_int id + | _ -> raise (Invalid_argument "to_state_id") + +let of_stateid i = Element ("state_id",["val",string_of_int (Stateid.to_int i)],[]) + +let of_richpp x = Element ("richpp", [], [Richpp.repr x]) +let to_richpp xml = match xml with + | Element ("richpp", [], [x]) -> Richpp.richpp_of_xml x + | x -> raise Serialize.(Marshal_error("richpp",x)) let of_value f = function | Good x -> Element ("value", ["val", "good"], [f x]) @@ -91,8 +103,9 @@ let of_value f = function let loc = match loc with | None -> [] | Some (s, e) -> [("loc_s", string_of_int s); ("loc_e", string_of_int e)] in - let id = Stateid.to_xml id in - Element ("value", ["val", "fail"] @ loc, [id; Richpp.of_richpp msg]) + let id = of_stateid id in + Element ("value", ["val", "fail"] @ loc, [id; of_richpp msg]) + let to_value f = function | Element ("value", attrs, l) -> let ans = massoc "val" attrs in @@ -103,14 +116,14 @@ let to_value f = function let loc_s = int_of_string (Serialize.massoc "loc_s" attrs) in let loc_e = int_of_string (Serialize.massoc "loc_e" attrs) in Some (loc_s, loc_e) - with Marshal_error | Failure _ -> None + with Marshal_error _ | Failure _ -> None in - let (id, msg) = match l with [id; msg] -> (id, msg) | _ -> raise Marshal_error in - let id = Stateid.of_xml id in - let msg = Richpp.to_richpp msg in + let (id, msg) = match l with [id; msg] -> (id, msg) | _ -> raise (Marshal_error("val",PCData "no id attribute")) in + let id = to_stateid id in + let msg = to_richpp msg in Fail (id, loc, msg) - else raise Marshal_error -| _ -> raise Marshal_error + else raise (Marshal_error("good or fail",PCData ans)) +| x -> raise (Marshal_error("value",x)) let of_status s = let of_so = of_option of_string in @@ -126,25 +139,25 @@ let to_status = function status_proofname = to_option to_string name; status_allproofs = to_list to_string prfs; status_proofnum = to_int pnum; } - | _ -> raise Marshal_error + | x -> raise (Marshal_error("status",x)) let of_evar s = Element ("evar", [], [PCData s.evar_info]) let to_evar = function | Element ("evar", [], data) -> { evar_info = raw_string data; } - | _ -> raise Marshal_error + | x -> raise (Marshal_error("evar",x)) let of_goal g = - let hyp = of_list Richpp.of_richpp g.goal_hyp in - let ccl = Richpp.of_richpp g.goal_ccl in + let hyp = of_list of_richpp g.goal_hyp in + let ccl = of_richpp g.goal_ccl in let id = of_string g.goal_id in Element ("goal", [], [id; hyp; ccl]) let to_goal = function | Element ("goal", [], [id; hyp; ccl]) -> - let hyp = to_list Richpp.to_richpp hyp in - let ccl = Richpp.to_richpp ccl in + let hyp = to_list to_richpp hyp in + let ccl = to_richpp ccl in let id = to_string id in { goal_hyp = hyp; goal_ccl = ccl; goal_id = id; } - | _ -> raise Marshal_error + | x -> raise (Marshal_error("goal",x)) let of_goals g = let of_glist = of_list of_goal in @@ -162,7 +175,7 @@ let to_goals = function let given_up = to_list to_goal given_up in { fg_goals = fg; bg_goals = bg; shelved_goals = shelf; given_up_goals = given_up } - | _ -> raise Marshal_error + | x -> raise (Marshal_error("goals",x)) let of_coq_info info = let version = of_string info.coqtop_version in @@ -176,7 +189,7 @@ let to_coq_info = function protocol_version = to_string protocol; release_date = to_string release; compile_date = to_string compile; } - | _ -> raise Marshal_error + | x -> raise (Marshal_error("coq_info",x)) end include Xml_marshalling @@ -286,7 +299,7 @@ end = struct | Coq_object t -> (of_coq_object (convert t)) | Pair (t1,t2) -> (of_pair (convert t1) (convert t2)) | Union (t1,t2) -> (of_union (convert t1) (convert t2)) - | State_id -> Stateid.to_xml + | State_id -> of_stateid | Search_cst -> of_search_cst in convert ty @@ -309,7 +322,7 @@ end = struct | Coq_object t -> (to_coq_object (convert t)) | Pair (t1,t2) -> (to_pair (convert t1) (convert t2)) | Union (t1,t2) -> (to_union (convert t1) (convert t2)) - | State_id -> Stateid.of_xml + | State_id -> to_stateid | Search_cst -> to_search_cst in convert ty @@ -422,7 +435,7 @@ end = struct (pr_xml (of_bool true)) (pr_xml (of_bool false)); Printf.printf "%s:\n\n%s\n\n" (print_val_t String) (pr_xml (of_string "hello")); Printf.printf "%s:\n\n%s\n\n" (print_val_t Int) (pr_xml (of_int 256)); - Printf.printf "%s:\n\n%s\n\n" (print_val_t State_id) (pr_xml (Stateid.to_xml Stateid.initial)); + Printf.printf "%s:\n\n%s\n\n" (print_val_t State_id) (pr_xml (of_stateid Stateid.initial)); Printf.printf "%s:\n\n%s\n\n" (print_val_t (List Int)) (pr_xml (of_list of_int [3;4;5])); Printf.printf "%s:\n\n%s\n%s\n\n" (print_val_t (Option Int)) (pr_xml (of_option of_int (Some 3))) (pr_xml (of_option of_int None)); @@ -682,7 +695,7 @@ let to_call : xml -> unknown_call = | "StopWorker" -> Unknown (StopWorker (mkCallArg stop_worker_sty_t a)) | "PrintAst" -> Unknown (PrintAst (mkCallArg print_ast_sty_t a)) | "Annotate" -> Unknown (Annotate (mkCallArg annotate_sty_t a)) - | _ -> raise Marshal_error) + | x -> raise (Marshal_error("call",PCData x))) (** Debug printing *) @@ -750,4 +763,130 @@ let document to_string_fmt = (Fail (Stateid.initial,Some (15,34),Richpp.richpp_of_string "error message")))); document_type_encoding to_string_fmt +(* Moved from feedback.mli : This is IDE specific and we don't want to + pollute the core with it *) + +open Feedback + +let of_message_level = function + | Debug s -> + Serialize.constructor "message_level" "debug" [Xml_datatype.PCData s] + | Info -> Serialize.constructor "message_level" "info" [] + | Notice -> Serialize.constructor "message_level" "notice" [] + | Warning -> Serialize.constructor "message_level" "warning" [] + | Error -> Serialize.constructor "message_level" "error" [] +let to_message_level = + Serialize.do_match "message_level" (fun s args -> match s with + | "debug" -> Debug (Serialize.raw_string args) + | "info" -> Info + | "notice" -> Notice + | "warning" -> Warning + | "error" -> Error + | x -> raise Serialize.(Marshal_error("error level",PCData x))) + +let of_message lvl msg = + let lvl = of_message_level lvl in + let content = of_richpp msg in + Xml_datatype.Element ("message", [], [lvl; content]) +let to_message xml = match xml with + | Xml_datatype.Element ("message", [], [lvl; content]) -> + Message(to_message_level lvl, to_richpp content) + | x -> raise (Marshal_error("message",x)) + +let is_message = function + | Xml_datatype.Element ("message", [], [lvl; content]) -> + Some (to_message_level lvl, to_richpp content) + | _ -> None + +let to_feedback_content = do_match "feedback_content" (fun s a -> match s,a with + | "addedaxiom", _ -> AddedAxiom + | "processed", _ -> Processed + | "processingin", [where] -> ProcessingIn (to_string where) + | "incomplete", _ -> Incomplete + | "complete", _ -> Complete + | "globref", [loc; filepath; modpath; ident; ty] -> + GlobRef(to_loc loc, to_string filepath, + to_string modpath, to_string ident, to_string ty) + | "globdef", [loc; ident; secpath; ty] -> + GlobDef(to_loc loc, to_string ident, to_string secpath, to_string ty) + | "errormsg", [loc; s] -> ErrorMsg (to_loc loc, to_string s) + | "inprogress", [n] -> InProgress (to_int n) + | "workerstatus", [ns] -> + let n, s = to_pair to_string to_string ns in + WorkerStatus(n,s) + | "goals", [loc;s] -> Goals (to_loc loc, to_string s) + | "custom", [loc;name;x]-> Custom (to_loc loc, to_string name, x) + | "filedependency", [from; dep] -> + FileDependency (to_option to_string from, to_string dep) + | "fileloaded", [dirpath; filename] -> + FileLoaded (to_string dirpath, to_string filename) + | "message", [x] -> to_message x + | x,l -> raise (Marshal_error("feedback_content",PCData (x ^ " with attributes " ^ string_of_int (List.length l))))) + +let of_feedback_content = function + | AddedAxiom -> constructor "feedback_content" "addedaxiom" [] + | Processed -> constructor "feedback_content" "processed" [] + | ProcessingIn where -> + constructor "feedback_content" "processingin" [of_string where] + | Incomplete -> constructor "feedback_content" "incomplete" [] + | Complete -> constructor "feedback_content" "complete" [] + | GlobRef(loc, filepath, modpath, ident, ty) -> + constructor "feedback_content" "globref" [ + of_loc loc; + of_string filepath; + of_string modpath; + of_string ident; + of_string ty ] + | GlobDef(loc, ident, secpath, ty) -> + constructor "feedback_content" "globdef" [ + of_loc loc; + of_string ident; + of_string secpath; + of_string ty ] + | ErrorMsg(loc, s) -> + constructor "feedback_content" "errormsg" [of_loc loc; of_string s] + | InProgress n -> constructor "feedback_content" "inprogress" [of_int n] + | WorkerStatus(n,s) -> + constructor "feedback_content" "workerstatus" + [of_pair of_string of_string (n,s)] + | Goals (loc,s) -> + constructor "feedback_content" "goals" [of_loc loc;of_string s] + | Custom (loc, name, x) -> + constructor "feedback_content" "custom" [of_loc loc; of_string name; x] + | FileDependency (from, depends_on) -> + constructor "feedback_content" "filedependency" [ + of_option of_string from; + of_string depends_on] + | FileLoaded (dirpath, filename) -> + constructor "feedback_content" "fileloaded" [ + of_string dirpath; + of_string filename ] + | Message (l,m) -> constructor "feedback_content" "message" [ of_message l m ] + +let of_edit_or_state_id = function + | Edit id -> ["object","edit"], of_edit_id id + | State id -> ["object","state"], of_stateid id + +let of_feedback msg = + let content = of_feedback_content msg.contents in + let obj, id = of_edit_or_state_id msg.id in + let route = string_of_int msg.route in + Element ("feedback", obj @ ["route",route], [id;content]) + +let to_feedback xml = match xml with + | Element ("feedback", ["object","edit";"route",route], [id;content]) -> { + id = Edit(to_edit_id id); + route = int_of_string route; + contents = to_feedback_content content } + | Element ("feedback", ["object","state";"route",route], [id;content]) -> { + id = State(to_stateid id); + route = int_of_string route; + contents = to_feedback_content content } + | x -> raise (Marshal_error("feedback",x)) + +let is_feedback = function + | Element ("feedback", _, _) -> true + | _ -> false + (* vim: set foldmethod=marker: *) + diff --git a/ide/xmlprotocol.mli b/ide/xmlprotocol.mli index 265a50c47c..6bca8772ed 100644 --- a/ide/xmlprotocol.mli +++ b/ide/xmlprotocol.mli @@ -56,3 +56,17 @@ val document : (xml -> string) -> unit val pr_call : 'a call -> string val pr_value : 'a value -> string val pr_full_value : 'a call -> 'a value -> string + +(** * Serialization of rich documents *) +val of_richpp : Richpp.richpp -> Xml_datatype.xml +val to_richpp : Xml_datatype.xml -> Richpp.richpp + +(** * Serializaiton of feedback *) +val of_feedback : Feedback.feedback -> xml +val to_feedback : xml -> Feedback.feedback +val is_feedback : xml -> bool + +val is_message : xml -> (Feedback.level * Richpp.richpp) option +val of_message : Feedback.level -> Richpp.richpp -> xml +(* val to_message : xml -> Feedback.message *) + diff --git a/interp/constrextern.ml b/interp/constrextern.ml index 592f593330..57091ca898 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -175,6 +175,10 @@ let add_patt_for_params ind l = if !Flags.in_debugger then l else Util.List.addn (Inductiveops.inductive_nparamdecls ind) (CPatAtom (Loc.ghost,None)) l +let add_cpatt_for_params ind l = + if !Flags.in_debugger then l else + Util.List.addn (Inductiveops.inductive_nparamdecls ind) (PatVar (Loc.ghost,Anonymous)) l + let drop_implicits_in_patt cst nb_expl args = let impl_st = (implicits_of_global cst) in let impl_data = extract_impargs_data impl_st in @@ -299,7 +303,7 @@ let rec extern_cases_pattern_in_scope (scopes:local_scopes) vars pat = with No_match -> try if !Flags.raw_print || !print_no_symbol then raise No_match; - extern_symbol_pattern scopes vars pat + extern_notation_pattern scopes vars pat (uninterp_cases_pattern_notations pat) with No_match -> match pat with @@ -382,7 +386,7 @@ and apply_notation_to_pattern loc gr ((subst,substlist),(nb_to_drop,more_args)) in assert (List.is_empty substlist); mkPat loc qid (List.rev_append l1 l2') -and extern_symbol_pattern (tmp_scope,scopes as allscopes) vars t = function +and extern_notation_pattern (tmp_scope,scopes as allscopes) vars t = function | [] -> raise No_match | (keyrule,pat,n as _rule)::rules -> try @@ -395,9 +399,9 @@ and extern_symbol_pattern (tmp_scope,scopes as allscopes) vars t = function | PatVar (loc,Anonymous) -> CPatAtom (loc, None) | PatVar (loc,Name id) -> CPatAtom (loc, Some (Ident (loc,id))) with - No_match -> extern_symbol_pattern allscopes vars t rules + No_match -> extern_notation_pattern allscopes vars t rules -let rec extern_symbol_ind_pattern allscopes vars ind args = function +let rec extern_notation_ind_pattern allscopes vars ind args = function | [] -> raise No_match | (keyrule,pat,n as _rule)::rules -> try @@ -405,7 +409,7 @@ let rec extern_symbol_ind_pattern allscopes vars ind args = function apply_notation_to_pattern Loc.ghost (IndRef ind) (match_notation_constr_ind_pattern ind args pat) allscopes vars keyrule with - No_match -> extern_symbol_ind_pattern allscopes vars ind args rules + No_match -> extern_notation_ind_pattern allscopes vars ind args rules let extern_ind_pattern_in_scope (scopes:local_scopes) vars ind args = (* pboutill: There are letins in pat which is incompatible with notations and @@ -425,7 +429,7 @@ let extern_ind_pattern_in_scope (scopes:local_scopes) vars ind args = with No_match -> try if !Flags.raw_print || !print_no_symbol then raise No_match; - extern_symbol_ind_pattern scopes vars ind args + extern_notation_ind_pattern scopes vars ind args (uninterp_ind_pattern_notations ind) with No_match -> let c = extern_reference Loc.ghost vars (IndRef ind) in @@ -477,15 +481,15 @@ 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 && - is_significant_implicit a && - not (is_inferable_implicit inctx n imp)) + not (is_inferable_implicit inctx n imp) && + is_significant_implicit (Lazy.force a)) in if visible then - (a,Some (Loc.ghost, ExplByName (name_of_implicit imp))) :: tail + (Lazy.force a,Some (Loc.ghost, ExplByName (name_of_implicit imp))) :: tail else tail - | a::args, _::impl -> (a,None) :: exprec (q+1) (args,impl) - | args, [] -> List.map (fun a -> (a,None)) args (*In case of polymorphism*) + | a::args, _::impl -> (Lazy.force a,None) :: exprec (q+1) (args,impl) + | args, [] -> List.map (fun a -> (Lazy.force a,None)) args (*In case of polymorphism*) | [], (imp :: _) when is_status_implicit imp && maximal_insertion_of imp -> (* The non-explicit application cannot be parsed back with the same type *) raise Expl @@ -512,7 +516,7 @@ let explicitize loc inctx impl (cf,f) args = with Expl -> let f',us = match f with CRef (f,us) -> f,us | _ -> assert false in let ip = if !print_projections then ip else None in - CAppExpl (loc, (ip, f', us), args) + CAppExpl (loc, (ip, f', us), List.map Lazy.force args) let is_start_implicit = function | imp :: _ -> is_status_implicit imp && maximal_insertion_of imp @@ -534,19 +538,21 @@ let extern_app loc inctx impl (cf,f) us args = (!print_implicits && not !print_implicits_explicit_args)) && List.exists is_status_implicit impl) then + let args = List.map Lazy.force args in CAppExpl (loc, (is_projection (List.length args) cf,f,us), args) else explicitize loc inctx impl (cf,CRef (f,us)) args -let rec extern_args extern scopes env args subscopes = - match args with - | [] -> [] - | a::args -> - let argscopes, subscopes = match subscopes with - | [] -> (None,scopes), [] - | scopt::subscopes -> (scopt,scopes), subscopes in - extern argscopes env a :: extern_args extern scopes env args subscopes +let rec fill_arg_scopes args subscopes scopes = match args, subscopes with +| [], _ -> [] +| a :: args, scopt :: subscopes -> + (a, (scopt, scopes)) :: fill_arg_scopes args subscopes scopes +| a :: args, [] -> + (a, (None, scopes)) :: fill_arg_scopes args [] scopes +let extern_args extern env args = + let map (arg, argscopes) = lazy (extern argscopes env arg) in + List.map map args let match_coercion_app = function | GApp (loc,GRef (_,r,_),args) -> Some (loc, r, 0, args) @@ -622,7 +628,7 @@ let rec extern inctx scopes vars r = try let r'' = flatten_application r' in if !Flags.raw_print || !print_no_symbol then raise No_match; - extern_symbol scopes vars r'' (uninterp_notations r'') + extern_notation scopes vars r'' (uninterp_notations r'') with No_match -> match r' with | GRef (loc,ref,us) -> extern_global loc (select_stronger_impargs (implicits_of_global ref)) @@ -643,8 +649,7 @@ let rec extern inctx scopes vars r = (match f with | GRef (rloc,ref,us) -> let subscopes = find_arguments_scope ref in - let args = - extern_args (extern true) (snd scopes) vars args subscopes in + let args = fill_arg_scopes args subscopes (snd scopes) in begin try if !Flags.raw_print then raise Exit; @@ -679,12 +684,14 @@ let rec extern inctx scopes vars r = match args with | [] -> raise No_match (* we give up since the constructor is not complete *) - | head :: tail -> ip q locs' tail - ((extern_reference loc Id.Set.empty (ConstRef c), head) :: acc) + | (arg, scopes) :: tail -> + let head = extern true scopes vars arg in + ip q locs' tail ((extern_reference loc Id.Set.empty (ConstRef c), head) :: acc) in CRecord (loc, List.rev (ip projs locals args [])) with | Not_found | No_match | Exit -> + let args = extern_args (extern true) vars args in extern_app loc inctx (select_stronger_impargs (implicits_of_global ref)) (Some ref,extern_reference rloc vars ref) (extern_universes us) args @@ -692,7 +699,7 @@ let rec extern inctx scopes vars r = | _ -> explicitize loc inctx [] (None,sub_extern false scopes vars f) - (List.map (sub_extern true scopes vars) args)) + (List.map (fun c -> lazy (sub_extern true scopes vars c)) args)) | GLetIn (loc,na,t,c) -> CLetIn (loc,(loc,na),sub_extern false scopes vars t, @@ -730,9 +737,7 @@ let rec extern inctx scopes vars r = na', Option.map (fun (loc,ind,nal) -> let args = List.map (fun x -> PatVar (Loc.ghost, x)) nal in - let fullargs = - if !Flags.in_debugger then args else - Notation_ops.add_patterns_for_params ind args in + let fullargs = add_cpatt_for_params ind args in extern_ind_pattern_in_scope scopes vars ind fullargs ) x)) tml @@ -842,7 +847,7 @@ and extern_eqn inctx scopes vars (loc,ids,pl,c) = (loc,[loc,List.map (extern_cases_pattern_in_scope scopes vars) pl], extern inctx scopes vars c) -and extern_symbol (tmp_scope,scopes as allscopes) vars t = function +and extern_notation (tmp_scope,scopes as allscopes) vars t = function | [] -> raise No_match | (keyrule,pat,n as _rule)::rules -> let loc = Glob_ops.loc_of_glob_constr t in @@ -914,10 +919,11 @@ and extern_symbol (tmp_scope,scopes as allscopes) vars t = function if List.is_empty l then a else CApp (loc,(None,a),l) in if List.is_empty args then e else - let args = extern_args (extern true) scopes vars args argsscopes in + let args = fill_arg_scopes args argsscopes scopes in + let args = extern_args (extern true) vars args in explicitize loc false argsimpls (None,e) args with - No_match -> extern_symbol allscopes vars t rules + No_match -> extern_notation allscopes vars t rules and extern_recursion_order scopes vars = function GStructRec -> CStructRec diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 0de98242ae..50252a368f 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -526,7 +526,7 @@ let rec subst_iterator y t = function | GVar (_,id) as x -> if Id.equal id y then t else x | x -> map_glob_constr (subst_iterator y t) x -let subst_aconstr_in_glob_constr loc intern (_,ntnvars as lvar) subst infos c = +let instantiate_notation_constr loc intern (_,ntnvars as lvar) subst infos c = let (terms,termlists,binders) = subst in (* when called while defining a notation, avoid capturing the private binders of the expression by variables bound by the notation (see #3892) *) @@ -649,7 +649,7 @@ let intern_notation intern env lvar loc ntn fullargs = let terms = make_subst ids args in let termlists = make_subst idsl argslist in let binders = make_subst idsbl bll in - subst_aconstr_in_glob_constr loc intern lvar + instantiate_notation_constr loc intern lvar (terms, termlists, binders) (Id.Map.empty, env) c (**********************************************************************) @@ -759,7 +759,7 @@ let intern_qualid loc qid intern env lvar us args = let subst = (terms, Id.Map.empty, Id.Map.empty) in let infos = (Id.Map.empty, env) in let projapp = match c with NRef _ -> true | _ -> false in - let c = subst_aconstr_in_glob_constr loc intern lvar subst infos c in + let c = instantiate_notation_constr loc intern lvar subst infos c in let c = match us, c with | None, _ -> c | Some _, GRef (loc, ref, None) -> GRef (loc, ref, us) @@ -1069,7 +1069,7 @@ let alias_of als = match als.alias_ids with | id :: _ -> Name id let message_redundant_alias id1 id2 = - msg_warning + Feedback.msg_warning (str "Alias variable " ++ pr_id id1 ++ str " is merged with " ++ pr_id id2) (** {6 Expanding notations } diff --git a/interp/dumpglob.ml b/interp/dumpglob.ml index 85212b7aba..931fc1ca40 100644 --- a/interp/dumpglob.ml +++ b/interp/dumpglob.ml @@ -141,7 +141,7 @@ let interval loc = let dump_ref loc filepath modpath ident ty = match !glob_output with | Feedback -> - Pp.feedback (Feedback.GlobRef (loc, filepath, modpath, ident, ty)) + Feedback.feedback (Feedback.GlobRef (loc, filepath, modpath, ident, ty)) | NoGlob -> () | _ when not (Loc.is_ghost loc) -> let bl,el = interval loc in @@ -240,7 +240,7 @@ let dump_binding loc id = () let dump_def ty loc secpath id = if !glob_output = Feedback then - Pp.feedback (Feedback.GlobDef (loc, id, secpath, ty)) + Feedback.feedback (Feedback.GlobDef (loc, id, secpath, ty)) else let bl,el = interval loc in dump_string (Printf.sprintf "%s %d:%d %s %s\n" ty bl el secpath id) diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index 751b03a4a8..567150a5d6 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -310,7 +310,7 @@ let implicits_of_glob_constr ?(with_products=true) l = else let () = match bk with | Implicit -> - msg_warning (strbrk "Ignoring implicit status of product binder " ++ + Feedback.msg_warning (strbrk "Ignoring implicit status of product binder " ++ pr_name na ++ strbrk " and following binders") | _ -> () in [] diff --git a/interp/notation.ml b/interp/notation.ml index 0a65dfc096..b19fd9e1fe 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -184,7 +184,7 @@ let declare_delimiters scope key = | None -> scope_map := String.Map.add scope newsc !scope_map | Some oldkey when String.equal oldkey key -> () | Some oldkey -> - msg_warning + Feedback.msg_warning (str "Overwriting previous delimiting key " ++ str oldkey ++ str " in scope " ++ str scope); scope_map := String.Map.add scope newsc !scope_map end; @@ -192,7 +192,7 @@ let declare_delimiters scope key = let oldscope = String.Map.find key !delimiters_map in if String.equal oldscope scope then () else begin - msg_warning (str "Hiding binding of key " ++ str key ++ str " to " ++ str oldscope); + Feedback.msg_warning (str "Hiding binding of key " ++ str key ++ str " to " ++ str oldscope); delimiters_map := String.Map.add key scope !delimiters_map end with Not_found -> delimiters_map := String.Map.add key scope !delimiters_map @@ -201,7 +201,7 @@ let remove_delimiters scope = let sc = find_scope scope in let newsc = { sc with delimiters = None } in match sc.delimiters with - | None -> msg_warning (str "No bound key for scope " ++ str scope ++ str ".") + | None -> Feedback.msg_warning (str "No bound key for scope " ++ str scope ++ str ".") | Some key -> scope_map := String.Map.add scope newsc !scope_map; try @@ -388,7 +388,7 @@ let declare_notation_interpretation ntn scopt pat df = let which_scope = match scopt with | None -> mt () | Some _ -> str " in scope " ++ str scope in - msg_warning (str "Notation " ++ str ntn ++ str " was already used" ++ which_scope) + Feedback.msg_warning (str "Notation " ++ str ntn ++ str " was already used" ++ which_scope) in let sc = { sc with notations = String.Map.add ntn (pat,df) sc.notations } in let () = scope_map := String.Map.add scope sc !scope_map in diff --git a/interp/notation_ops.ml b/interp/notation_ops.ml index 5ceb25a8fd..b4cf6e9430 100644 --- a/interp/notation_ops.ml +++ b/interp/notation_ops.ml @@ -12,15 +12,103 @@ open Util open Names open Nameops open Globnames +open Decl_kinds open Misctypes open Glob_term open Glob_ops open Mod_subst open Notation_term -open Decl_kinds (**********************************************************************) -(* Re-interpret a notation as a glob_constr, taking care of binders *) +(* Utilities *) + +let on_true_do b f c = if b then (f c; b) else b + +let compare_glob_constr f add t1 t2 = match t1,t2 with + | GRef (_,r1,_), GRef (_,r2,_) -> eq_gr r1 r2 + | GVar (_,v1), GVar (_,v2) -> on_true_do (Id.equal v1 v2) add (Name v1) + | GApp (_,f1,l1), GApp (_,f2,l2) -> f f1 f2 && List.for_all2eq f l1 l2 + | GLambda (_,na1,bk1,ty1,c1), GLambda (_,na2,bk2,ty2,c2) + when Name.equal na1 na2 && Constrexpr_ops.binding_kind_eq bk1 bk2 -> + on_true_do (f ty1 ty2 && f c1 c2) add na1 + | GProd (_,na1,bk1,ty1,c1), GProd (_,na2,bk2,ty2,c2) + when Name.equal na1 na2 && Constrexpr_ops.binding_kind_eq bk1 bk2 -> + on_true_do (f ty1 ty2 && f c1 c2) add na1 + | GHole _, GHole _ -> true + | GSort (_,s1), GSort (_,s2) -> Miscops.glob_sort_eq s1 s2 + | GLetIn (_,na1,b1,c1), GLetIn (_,na2,b2,c2) when Name.equal na1 na2 -> + on_true_do (f b1 b2 && f c1 c2) add na1 + | (GCases _ | GRec _ + | GPatVar _ | GEvar _ | GLetTuple _ | GIf _ | GCast _),_ + | _,(GCases _ | GRec _ + | GPatVar _ | GEvar _ | GLetTuple _ | GIf _ | GCast _) + -> error "Unsupported construction in recursive notations." + | (GRef _ | GVar _ | GApp _ | GLambda _ | GProd _ + | GHole _ | GSort _ | GLetIn _), _ + -> false + +let rec eq_notation_constr t1 t2 = match t1, t2 with +| NRef gr1, NRef gr2 -> eq_gr gr1 gr2 +| NVar id1, NVar id2 -> Id.equal id1 id2 +| NApp (t1, a1), NApp (t2, a2) -> + eq_notation_constr t1 t2 && List.equal eq_notation_constr a1 a2 +| NHole (_, _, _), NHole (_, _, _) -> true (** FIXME? *) +| NList (i1, j1, t1, u1, b1), NList (i2, j2, t2, u2, b2) -> + Id.equal i1 i2 && Id.equal j1 j2 && eq_notation_constr t1 t2 && + eq_notation_constr u1 u2 && b1 == b2 +| NLambda (na1, t1, u1), NLambda (na2, t2, u2) -> + Name.equal na1 na2 && eq_notation_constr t1 t2 && eq_notation_constr u1 u2 +| NProd (na1, t1, u1), NProd (na2, t2, u2) -> + Name.equal na1 na2 && eq_notation_constr t1 t2 && eq_notation_constr u1 u2 +| NBinderList (i1, j1, t1, u1), NBinderList (i2, j2, t2, u2) -> + Id.equal i1 i2 && Id.equal j1 j2 && eq_notation_constr t1 t2 && + eq_notation_constr u1 u2 +| NLetIn (na1, t1, u1), NLetIn (na2, t2, u2) -> + Name.equal na1 na2 && eq_notation_constr t1 t2 && eq_notation_constr u1 u2 +| NCases (_, o1, r1, p1), NCases (_, o2, r2, p2) -> (** FIXME? *) + let eqpat (p1, t1) (p2, t2) = + List.equal cases_pattern_eq p1 p2 && + eq_notation_constr t1 t2 + in + let eqf (t1, (na1, o1)) (t2, (na2, o2)) = + let eq (i1, n1) (i2, n2) = eq_ind i1 i2 && List.equal Name.equal n1 n2 in + eq_notation_constr t1 t2 && Name.equal na1 na2 && Option.equal eq o1 o2 + in + Option.equal eq_notation_constr o1 o2 && + List.equal eqf r1 r2 && + List.equal eqpat p1 p2 +| NLetTuple (nas1, (na1, o1), t1, u1), NLetTuple (nas2, (na2, o2), t2, u2) -> + List.equal Name.equal nas1 nas2 && + Name.equal na1 na2 && + Option.equal eq_notation_constr o1 o2 && + eq_notation_constr t1 t2 && + eq_notation_constr u1 u2 +| NIf (t1, (na1, o1), u1, r1), NIf (t2, (na2, o2), u2, r2) -> + eq_notation_constr t1 t2 && + Name.equal na1 na2 && + Option.equal eq_notation_constr o1 o2 && + eq_notation_constr u1 u2 && + eq_notation_constr r1 r2 +| NRec (_, ids1, ts1, us1, rs1), NRec (_, ids2, ts2, us2, rs2) -> (** FIXME? *) + let eq (na1, o1, t1) (na2, o2, t2) = + Name.equal na1 na2 && + Option.equal eq_notation_constr o1 o2 && + eq_notation_constr t1 t2 + in + Array.equal Id.equal ids1 ids2 && + Array.equal (List.equal eq) ts1 ts2 && + Array.equal eq_notation_constr us1 us2 && + Array.equal eq_notation_constr rs1 rs2 +| NSort s1, NSort s2 -> + Miscops.glob_sort_eq s1 s2 +| NCast (t1, c1), NCast (t2, c2) -> + eq_notation_constr t1 t2 && cast_type_eq eq_notation_constr c1 c2 +| (NRef _ | NVar _ | NApp _ | NHole _ | NList _ | NLambda _ | NProd _ + | NBinderList _ | NLetIn _ | NCases _ | NLetTuple _ | NIf _ + | NRec _ | NSort _ | NCast _), _ -> false + +(**********************************************************************) +(* Re-interpret a notation as a glob_constr, taking care of binders *) let name_to_ident = function | Anonymous -> Errors.error "This expression should be a simple identifier." @@ -105,7 +193,6 @@ let glob_constr_of_notation_constr_with_binders loc g f e = function | NCast (c,k) -> GCast (loc,f e c,Miscops.map_cast_type (f e) k) | NSort x -> GSort (loc,x) | NHole (x, naming, arg) -> GHole (loc, x, naming, arg) - | NPatVar n -> GPatVar (loc,(false,n)) | NRef x -> GRef (loc,x,None) let glob_constr_of_notation_constr loc x = @@ -113,7 +200,7 @@ let glob_constr_of_notation_constr loc x = glob_constr_of_notation_constr_with_binders loc (fun () id -> ((),id)) aux () x in aux () x -(****************************************************************************) +(******************************************************************************) (* Translating a glob_constr into a notation, interpreting recursive patterns *) let add_id r id = r := (id :: pi1 !r, pi2 !r, pi3 !r) @@ -143,96 +230,6 @@ let split_at_recursive_part c = | GVar (_,v) when Id.equal v ldots_var -> (* Not enough context *) raise Not_found | _ -> outer_iterator, c -let on_true_do b f c = if b then (f c; b) else b - -let compare_glob_constr f add t1 t2 = match t1,t2 with - | GRef (_,r1,_), GRef (_,r2,_) -> eq_gr r1 r2 - | GVar (_,v1), GVar (_,v2) -> on_true_do (Id.equal v1 v2) add (Name v1) - | GApp (_,f1,l1), GApp (_,f2,l2) -> f f1 f2 && List.for_all2eq f l1 l2 - | GLambda (_,na1,bk1,ty1,c1), GLambda (_,na2,bk2,ty2,c2) - when Name.equal na1 na2 && Constrexpr_ops.binding_kind_eq bk1 bk2 -> - on_true_do (f ty1 ty2 && f c1 c2) add na1 - | GProd (_,na1,bk1,ty1,c1), GProd (_,na2,bk2,ty2,c2) - when Name.equal na1 na2 && Constrexpr_ops.binding_kind_eq bk1 bk2 -> - on_true_do (f ty1 ty2 && f c1 c2) add na1 - | GHole _, GHole _ -> true - | GSort (_,s1), GSort (_,s2) -> Miscops.glob_sort_eq s1 s2 - | GLetIn (_,na1,b1,c1), GLetIn (_,na2,b2,c2) when Name.equal na1 na2 -> - on_true_do (f b1 b2 && f c1 c2) add na1 - | (GCases _ | GRec _ - | GPatVar _ | GEvar _ | GLetTuple _ | GIf _ | GCast _),_ - | _,(GCases _ | GRec _ - | GPatVar _ | GEvar _ | GLetTuple _ | GIf _ | GCast _) - -> error "Unsupported construction in recursive notations." - | (GRef _ | GVar _ | GApp _ | GLambda _ | GProd _ - | GHole _ | GSort _ | GLetIn _), _ - -> false - -let rec eq_glob_constr t1 t2 = compare_glob_constr eq_glob_constr (fun _ -> ()) t1 t2 - -let rec eq_notation_constr t1 t2 = match t1, t2 with -| NRef gr1, NRef gr2 -> eq_gr gr1 gr2 -| NVar id1, NVar id2 -> Id.equal id1 id2 -| NApp (t1, a1), NApp (t2, a2) -> - eq_notation_constr t1 t2 && List.equal eq_notation_constr a1 a2 -| NHole (_, _, _), NHole (_, _, _) -> true (** FIXME? *) -| NList (i1, j1, t1, u1, b1), NList (i2, j2, t2, u2, b2) -> - Id.equal i1 i2 && Id.equal j1 j2 && eq_notation_constr t1 t2 && - eq_notation_constr u1 u2 && b1 == b2 -| NLambda (na1, t1, u1), NLambda (na2, t2, u2) -> - Name.equal na1 na2 && eq_notation_constr t1 t2 && eq_notation_constr u1 u2 -| NProd (na1, t1, u1), NProd (na2, t2, u2) -> - Name.equal na1 na2 && eq_notation_constr t1 t2 && eq_notation_constr u1 u2 -| NBinderList (i1, j1, t1, u1), NBinderList (i2, j2, t2, u2) -> - Id.equal i1 i2 && Id.equal j1 j2 && eq_notation_constr t1 t2 && - eq_notation_constr u1 u2 -| NLetIn (na1, t1, u1), NLetIn (na2, t2, u2) -> - Name.equal na1 na2 && eq_notation_constr t1 t2 && eq_notation_constr u1 u2 -| NCases (_, o1, r1, p1), NCases (_, o2, r2, p2) -> (** FIXME? *) - let eqpat (p1, t1) (p2, t2) = - List.equal cases_pattern_eq p1 p2 && - eq_notation_constr t1 t2 - in - let eqf (t1, (na1, o1)) (t2, (na2, o2)) = - let eq (i1, n1) (i2, n2) = eq_ind i1 i2 && List.equal Name.equal n1 n2 in - eq_notation_constr t1 t2 && Name.equal na1 na2 && Option.equal eq o1 o2 - in - Option.equal eq_notation_constr o1 o2 && - List.equal eqf r1 r2 && - List.equal eqpat p1 p2 -| NLetTuple (nas1, (na1, o1), t1, u1), NLetTuple (nas2, (na2, o2), t2, u2) -> - List.equal Name.equal nas1 nas2 && - Name.equal na1 na2 && - Option.equal eq_notation_constr o1 o2 && - eq_notation_constr t1 t2 && - eq_notation_constr u1 u2 -| NIf (t1, (na1, o1), u1, r1), NIf (t2, (na2, o2), u2, r2) -> - eq_notation_constr t1 t2 && - Name.equal na1 na2 && - Option.equal eq_notation_constr o1 o2 && - eq_notation_constr u1 u2 && - eq_notation_constr r1 r2 -| NRec (_, ids1, ts1, us1, rs1), NRec (_, ids2, ts2, us2, rs2) -> (** FIXME? *) - let eq (na1, o1, t1) (na2, o2, t2) = - Name.equal na1 na2 && - Option.equal eq_notation_constr o1 o2 && - eq_notation_constr t1 t2 - in - Array.equal Id.equal ids1 ids2 && - Array.equal (List.equal eq) ts1 ts2 && - Array.equal eq_notation_constr us1 us2 && - Array.equal eq_notation_constr rs1 rs2 -| NSort s1, NSort s2 -> - Miscops.glob_sort_eq s1 s2 -| NPatVar p1, NPatVar p2 -> - Id.equal p1 p2 -| NCast (t1, c1), NCast (t2, c2) -> - eq_notation_constr t1 t2 && cast_type_eq eq_notation_constr c1 c2 -| (NRef _ | NVar _ | NApp _ | NHole _ | NList _ | NLambda _ | NProd _ - | NBinderList _ | NLetIn _ | NCases _ | NLetTuple _ | NIf _ - | NRec _ | NSort _ | NPatVar _ | NCast _), _ -> false - - let subtract_loc loc1 loc2 = Loc.make_loc (fst (Loc.unloc loc1),fst (Loc.unloc loc2)-1) let check_is_hole id = function GHole _ -> () | t -> @@ -352,8 +349,7 @@ let notation_constr_and_vars_of_glob_constr a = | GSort (_,s) -> NSort s | GHole (_,w,naming,arg) -> NHole (w, naming, arg) | GRef (_,r,_) -> NRef r - | GPatVar (_,(_,n)) -> NPatVar n - | GEvar _ -> + | GEvar _ | GPatVar _ -> error "Existential variables not allowed in notations." in @@ -413,6 +409,7 @@ let notation_constr_of_glob_constr nenv a = let () = check_variables nenv found in a +(**********************************************************************) (* Substitution of kernel names, avoiding a list of bound identifiers *) let notation_constr_of_constr avoiding t = @@ -526,7 +523,7 @@ let rec subst_notation_constr subst bound raw = if dll' == dll && tl' == tl && bl' == bl then raw else NRec (fk,idl,dll',tl',bl') - | NPatVar _ | NSort _ -> raw + | NSort _ -> raw | NHole (knd, naming, solve) -> let nknd = match knd with @@ -548,7 +545,8 @@ let subst_interpretation subst (metas,pat) = let bound = List.map fst metas in (metas,subst_notation_constr subst bound pat) -(* Pattern-matching glob_constr and notation_constr *) +(**********************************************************************) +(* Pattern-matching a [glob_constr] against a [notation_constr] *) let abstract_return_type_context pi mklam tml rtno = Option.map (fun rtn -> @@ -782,7 +780,6 @@ let rec match_ inner u alp metas sigma a1 a2 = (* Matching compositionally *) | GVar (_,id1), NVar id2 when alpha_var id1 id2 (fst alp) -> sigma | GRef (_,r1,_), NRef r2 when (eq_gr r1 r2) -> sigma - | GPatVar (_,(_,n1)), NPatVar n2 when Id.equal n1 n2 -> sigma | GApp (loc,f1,l1), NApp (f2,l2) -> let n1 = List.length l1 and n2 = List.length l2 in let f1,l1,f2,l2 = diff --git a/interp/notation_ops.mli b/interp/notation_ops.mli index 280ccfd21f..576c5b943a 100644 --- a/interp/notation_ops.mli +++ b/interp/notation_ops.mli @@ -10,24 +10,28 @@ open Names open Notation_term open Glob_term -(** Utilities about [notation_constr] *) +(** {5 Utilities about [notation_constr]} *) -(** Translate a [glob_constr] into a notation given the list of variables - bound by the notation; also interpret recursive patterns *) +val eq_notation_constr : notation_constr -> notation_constr -> bool -val notation_constr_of_glob_constr : notation_interp_env -> - glob_constr -> notation_constr +(** Substitution of kernel names in interpretation data *) +val subst_interpretation : + Mod_subst.substitution -> interpretation -> interpretation + (** Name of the special identifier used to encode recursive notations *) + val ldots_var : Id.t -(** Equality of [glob_constr] (warning: only partially implemented) *) -(** FIXME: nothing to do here *) -val eq_glob_constr : glob_constr -> glob_constr -> bool +(** {5 Translation back and forth between [glob_constr] and [notation_constr] *) -val eq_notation_constr : notation_constr -> notation_constr -> bool +(** Translate a [glob_constr] into a notation given the list of variables + bound by the notation; also interpret recursive patterns *) + +val notation_constr_of_glob_constr : notation_interp_env -> + glob_constr -> notation_constr -(** Re-interpret a notation as a [glob_constr], taking care of binders *) +(** Re-interpret a notation as a [glob_constr], taking care of binders *) val glob_constr_of_notation_constr_with_binders : Loc.t -> ('a -> Name.t -> 'a * Name.t) -> @@ -36,6 +40,8 @@ val glob_constr_of_notation_constr_with_binders : Loc.t -> val glob_constr_of_notation_constr : Loc.t -> notation_constr -> glob_constr +(** {5 Matching a notation pattern against a [glob_constr] *) + (** [match_notation_constr] matches a [glob_constr] against a notation interpretation; raise [No_match] if the matching fails *) @@ -55,9 +61,5 @@ val match_notation_constr_ind_pattern : ((cases_pattern * subscopes) list * (cases_pattern list * subscopes) list) * (int * cases_pattern list) -(** Substitution of kernel names in interpretation data *) - -val subst_interpretation : - Mod_subst.substitution -> interpretation -> interpretation +(** {5 Matching a notation pattern against a [glob_constr] *) -val add_patterns_for_params : inductive -> cases_pattern list -> cases_pattern list diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml index db548ec326..891b64fa11 100644 --- a/interp/syntax_def.ml +++ b/interp/syntax_def.ml @@ -93,7 +93,7 @@ let is_verbose_compat () = let verbose_compat kn def = function | Some v when is_verbose_compat () && Flags.version_strictly_greater v -> let act = - if !verbose_compat_notations then msg_warning else errorlabstrm "" + if !verbose_compat_notations then Feedback.msg_warning else errorlabstrm "" in let pp_def = match def with | [], NRef r -> str " is " ++ pr_global_env Id.Set.empty r diff --git a/interp/topconstr.ml b/interp/topconstr.ml index 42538925a8..91099bbb19 100644 --- a/interp/topconstr.ml +++ b/interp/topconstr.ml @@ -132,7 +132,7 @@ let fold_constr_expr_with_binders g f n acc = function fold_local_binders g f n' (fold_local_binders g f n acc t lb) c lb) l acc | CCoFix (loc,_,_) -> - msg_warning (strbrk "Capture check in multiple binders not done"); acc + Feedback.msg_warning (strbrk "Capture check in multiple binders not done"); acc let free_vars_of_constr_expr c = let rec aux bdvars l = function diff --git a/intf/notation_term.mli b/intf/notation_term.mli index 39a36310d1..7c5d7657be 100644 --- a/intf/notation_term.mli +++ b/intf/notation_term.mli @@ -42,7 +42,6 @@ type notation_constr = (Name.t * notation_constr option * notation_constr) list array * notation_constr array * notation_constr array | NSort of glob_sort - | NPatVar of patvar | NCast of notation_constr * notation_constr cast_type (** Note concerning NList: first constr is iterator, second is terminator; diff --git a/intf/tacexpr.mli b/intf/tacexpr.mli index e06436d8a3..379dd59d39 100644 --- a/intf/tacexpr.mli +++ b/intf/tacexpr.mli @@ -139,8 +139,6 @@ type intro_pattern_naming = intro_pattern_naming_expr located type 'a gen_atomic_tactic_expr = (* Basic tactics *) | TacIntroPattern of 'dtrm intro_pattern_expr located list - | TacIntroMove of Id.t option * 'nam move_location - | TacExact of 'trm | TacApply of advanced_flag * evars_flag * 'trm with_bindings_arg list * ('nam * 'dtrm intro_pattern_expr located option) option | TacElim of evars_flag * 'trm with_bindings_arg * 'trm with_bindings option @@ -157,10 +155,6 @@ type 'a gen_atomic_tactic_expr = (* Derived basic tactics *) | TacInductionDestruct of rec_flag * evars_flag * ('trm,'dtrm,'nam) induction_clause_list - | TacDoubleInduction of quantified_hypothesis * quantified_hypothesis - - (* Context management *) - | TacRename of ('nam *'nam) list (* Conversion *) | TacReduce of ('trm,'cst,'pat) red_expr_gen * 'nam clause_expr diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index ae9328fcc0..6ce15a7c5a 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -454,7 +454,7 @@ type vernac_type = | VtStartProof of vernac_start | VtSideff of vernac_sideff_type | VtQed of vernac_qed_type - | VtProofStep of bool (* parallelize *) + | VtProofStep of proof_step | VtProofMode of string | VtQuery of vernac_part_of_script * report_with | VtStm of vernac_control * vernac_part_of_script @@ -476,6 +476,11 @@ and vernac_control = and opacity_guarantee = | GuaranteesOpacity (** Only generates opaque terms at [Qed] *) | Doesn'tGuaranteeOpacity (** May generate transparent terms even with [Qed].*) +and proof_step = { (* TODO: inline with OCaml 4.03 *) + parallel : bool; + proof_block_detection : proof_block_name option +} +and proof_block_name = string (* open type of delimiters *) type vernac_when = | VtNow | VtLater diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index bf383a33ac..df5fdce755 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -903,10 +903,12 @@ value coq_interprete Alloc_small(block, 2, ATOM_PROJ_TAG); Field(block, 0) = Field(coq_global_data, *pc); Field(block, 1) = accu; - /* Create accumulator */ - Alloc_small(accu, 2, Accu_tag); - Code_val(accu) = accumulate; - Field(accu, 1) = block; + accu = block; + /* Create accumulator */ + Alloc_small(block, 2, Accu_tag); + Code_val(block) = accumulate; + Field(block, 1) = accu; + accu = block; } else { accu = Field(accu, *pc++); } diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index 77eac9ee93..431c914c08 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -904,10 +904,10 @@ let compile fail_on_error ?universes:(universes=0) env c = in let fv = List.rev (!(reloc.in_env).fv_rev) in (if !Flags.dump_bytecode then - Pp.msg_debug (dump_bytecodes init_code !fun_code fv)) ; + Feedback.msg_debug (dump_bytecodes init_code !fun_code fv)) ; Some (init_code,!fun_code, Array.of_list fv) with TooLargeInductive tname -> - let fn = if fail_on_error then Errors.errorlabstrm "compile" else Pp.msg_warning in + let fn = if fail_on_error then Errors.errorlabstrm "compile" else Feedback.msg_warning in (Pp.(fn (str "Cannot compile code for virtual machine as it uses inductive " ++ Id.print tname ++ str str_max_constructors)); diff --git a/kernel/closure.ml b/kernel/closure.ml index bf3801e547..960bdb649a 100644 --- a/kernel/closure.ml +++ b/kernel/closure.ml @@ -45,7 +45,7 @@ let reset () = prune := 0 let stop() = - msg_debug (str "[Reds: beta=" ++ int !beta ++ str" delta=" ++ int !delta ++ + Feedback.msg_debug (str "[Reds: beta=" ++ int !beta ++ str" delta=" ++ int !delta ++ str " eta=" ++ int !eta ++ str" zeta=" ++ int !zeta ++ str" evar=" ++ int !evar ++ str" iota=" ++ int !iota ++ str" prune=" ++ int !prune ++ str"]") @@ -363,6 +363,7 @@ let set_norm v = v.norm <- Norm let is_val v = match v.norm with Norm -> true | _ -> false let mk_atom c = {norm=Norm;term=FAtom c} +let mk_red f = {norm=Red;term=f} (* Could issue a warning if no is still Red, pointing out that we loose sharing. *) diff --git a/kernel/closure.mli b/kernel/closure.mli index 07176cb7de..8e172290fb 100644 --- a/kernel/closure.mli +++ b/kernel/closure.mli @@ -164,6 +164,9 @@ val inject : constr -> fconstr (** mk_atom: prevents a term from being evaluated *) val mk_atom : constr -> fconstr +(** mk_red: makes a reducible term (used in newring) *) +val mk_red : fterm -> fconstr + val fterm_of : fconstr -> fterm val term_of_fconstr : fconstr -> constr val destFLambda : diff --git a/kernel/constr.mli b/kernel/constr.mli index f76b5ae4f0..42d298e3b9 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -6,6 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(** This file defines the most important datatype of Coq, namely kernel terms, + as well as a handful of generic manipulation functions. *) + open Names (** {6 Value under universe substitution } *) diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib index f7220c94a1..1e132e3ab2 100644 --- a/kernel/kernel.mllib +++ b/kernel/kernel.mllib @@ -15,7 +15,6 @@ Copcodes Cemitcodes Nativevalues Primitives -Nativeinstr Opaqueproof Declareops Retroknowledge diff --git a/kernel/names.ml b/kernel/names.ml index e8226d3d32..9abc9842a8 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -36,7 +36,7 @@ struct let check_soft ?(warn = true) x = let iter (fatal, x) = - if fatal then Errors.error x else if warn then Pp.msg_warning (str x) + if fatal then Errors.error x else if warn then Feedback.msg_warning (str x) in Option.iter iter (Unicode.ident_refutation x) diff --git a/kernel/names.mli b/kernel/names.mli index 1dfdd82903..feaedc775c 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -6,6 +6,20 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(** This file defines a lot of different notions of names used pervasively in + the kernel as well as in other places. The essential datatypes exported by + this API are: + + - Id.t is the type of identifiers, that is morally a subset of strings which + only contains Unicode characters of the Letter kind (and a few more). + - Name.t is an ad-hoc variant of Id.t option allowing to handle optionally + named objects. + - DirPath.t represents generic paths as sequences of identifiers. + - Label.t is an equivalent of Id.t made distinct for semantical purposes. + - ModPath.t are module paths. + - KerName.t are absolute names of objects in Coq. +*) + open Util (** {6 Identifiers } *) @@ -766,7 +780,7 @@ val mind_of_kn : KerName.t -> mutual_inductive (** @deprecated Same as [MutInd.make1] *) val mind_of_kn_equiv : KerName.t -> KerName.t -> mutual_inductive -(** @deprecated Same as [MutInd.make2] *) +(** @deprecated Same as [MutInd.make] *) val make_mind : ModPath.t -> DirPath.t -> Label.t -> mutual_inductive (** @deprecated Same as [MutInd.make3] *) diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index dabe905dee..44cf21cff0 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -1486,8 +1486,8 @@ let optimize_stk stk = (** Printing to ocaml **) (* Redefine a bunch of functions in module Names to generate names acceptable to OCaml. *) -let string_of_id s = Unicode.ascii_of_ident (string_of_id s) -let string_of_label l = Unicode.ascii_of_ident (string_of_label l) +let string_of_id s = Unicode.ascii_of_ident (Id.to_string s) +let string_of_label l = string_of_id (Label.to_id l) let string_of_dirpath = function | [] -> "_" @@ -1560,8 +1560,7 @@ let pp_gname fmt g = Format.fprintf fmt "%s" (string_of_gname g) let pp_lname fmt ln = - let s = Unicode.ascii_of_ident (string_of_name ln.lname) in - Format.fprintf fmt "x_%s_%i" s ln.luid + Format.fprintf fmt "x_%s_%i" (string_of_name ln.lname) ln.luid let pp_ldecls fmt ids = let len = Array.length ids in @@ -1864,7 +1863,7 @@ let compile_constant env sigma prefix ~interactive con cb = | Def t -> let t = Mod_subst.force_constr t in let code = lambda_of_constr env sigma t in - if !Flags.debug then Pp.msg_debug (Pp.str "Generated lambda code"); + if !Flags.debug then Feedback.msg_debug (Pp.str "Generated lambda code"); let is_lazy = is_lazy prefix t in let code = if is_lazy then mk_lazy code else code in let name = @@ -1879,11 +1878,11 @@ let compile_constant env sigma prefix ~interactive con cb = let (auxdefs,code) = compile_with_fv env sigma (Some univ) [] (Some l) code in (auxdefs,mkMLlam [|univ|] code) in - if !Flags.debug then Pp.msg_debug (Pp.str "Generated mllambda code"); + if !Flags.debug then Feedback.msg_debug (Pp.str "Generated mllambda code"); let code = optimize_stk (Glet(Gconstant ("",(con,u)),code)::auxdefs) in - if !Flags.debug then Pp.msg_debug (Pp.str "Optimized mllambda code"); + if !Flags.debug then Feedback.msg_debug (Pp.str "Optimized mllambda code"); code, name | _ -> let i = push_symbol (SymbConst con) in diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index 4ed926f1fe..a0ff9e123a 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -134,12 +134,12 @@ let native_conv_gen pb sigma env univs t1 t2 = match compile ml_filename code with | (true, fn) -> begin - if !Flags.debug then Pp.msg_debug (Pp.str "Running test..."); + if !Flags.debug then Feedback.msg_debug (Pp.str "Running test..."); let t0 = Sys.time () in call_linker ~fatal:true prefix fn (Some upds); let t1 = Sys.time () in let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in - if !Flags.debug then Pp.msg_debug (Pp.str time_info); + if !Flags.debug then Feedback.msg_debug (Pp.str time_info); (* TODO change 0 when we can have deBruijn *) fst (conv_val env pb 0 !rt1 !rt2 univs) end @@ -149,7 +149,7 @@ let native_conv_gen pb sigma env univs t1 t2 = let native_conv cv_pb sigma env t1 t2 = if Coq_config.no_native_compiler then begin let msg = "Native compiler is disabled, falling back to VM conversion test." in - Pp.msg_warning (Pp.str msg); + Feedback.msg_warning (Pp.str msg); vm_conv cv_pb env t1 t2 end else diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml index 4296b73abe..5b92e9554f 100644 --- a/kernel/nativelib.ml +++ b/kernel/nativelib.ml @@ -73,20 +73,20 @@ let call_compiler ml_filename = ::"-w"::"a" ::include_dirs @ ["-impl"; ml_filename] in - if !Flags.debug then Pp.msg_debug (Pp.str (ocamlfind () ^ " " ^ (String.concat " " args))); + if !Flags.debug then Feedback.msg_debug (Pp.str (ocamlfind () ^ " " ^ (String.concat " " args))); try let res = CUnix.sys_command (ocamlfind ()) args in let res = match res with | Unix.WEXITED 0 -> true | Unix.WEXITED n -> - Pp.(msg_warning (str "command exited with status " ++ int n)); false + Feedback.msg_warning Pp.(str "command exited with status " ++ int n); false | Unix.WSIGNALED n -> - Pp.(msg_warning (str "command killed by signal " ++ int n)); false + Feedback.msg_warning Pp.(str "command killed by signal " ++ int n); false | Unix.WSTOPPED n -> - Pp.(msg_warning (str "command stopped by signal " ++ int n)); false in + Feedback.msg_warning Pp.(str "command stopped by signal " ++ int n); false in res, link_filename with Unix.Unix_error (e,_,_) -> - Pp.(msg_warning (str (Unix.error_message e))); + Feedback.msg_warning Pp.(str (Unix.error_message e)); false, link_filename let compile fn code = @@ -120,7 +120,7 @@ let call_linker ?(fatal=true) prefix f upds = begin let msg = "Cannot find native compiler file " ^ f in if fatal then Errors.error msg - else if !Flags.debug then Pp.msg_debug (Pp.str msg) + else if !Flags.debug then Feedback.msg_debug (Pp.str msg) end else (try @@ -129,8 +129,8 @@ let call_linker ?(fatal=true) prefix f upds = with Dynlink.Error e as exn -> let exn = Errors.push exn in let msg = "Dynlink error, " ^ Dynlink.error_message e in - if fatal then (Pp.msg_error (Pp.str msg); iraise exn) - else if !Flags.debug then Pp.msg_debug (Pp.str msg)); + if fatal then (Feedback.msg_error (Pp.str msg); iraise exn) + else if !Flags.debug then Feedback.msg_debug (Pp.str msg)); match upds with Some upds -> update_locations upds | _ -> () let link_library ~prefix ~dirname ~basename = diff --git a/kernel/nativelibrary.ml b/kernel/nativelibrary.ml index 9d159be64c..246b00da40 100644 --- a/kernel/nativelibrary.ml +++ b/kernel/nativelibrary.ml @@ -29,13 +29,13 @@ and translate_field prefix mp env acc (l,x) = let con = make_con mp empty_dirpath l in (if !Flags.debug then let msg = Printf.sprintf "Compiling constant %s..." (Constant.to_string con) in - Pp.msg_debug (Pp.str msg)); + Feedback.msg_debug (Pp.str msg)); compile_constant_field (pre_env env) prefix con acc cb | SFBmind mb -> (if !Flags.debug then let id = mb.mind_packets.(0).mind_typename in let msg = Printf.sprintf "Compiling inductive %s..." (Id.to_string id) in - Pp.msg_debug (Pp.str msg)); + Feedback.msg_debug (Pp.str msg)); compile_mind_field prefix mp l acc mb | SFBmodule md -> let mp = md.mod_mp in @@ -43,7 +43,7 @@ and translate_field prefix mp env acc (l,x) = let msg = Printf.sprintf "Compiling module %s..." (ModPath.to_string mp) in - Pp.msg_debug (Pp.str msg)); + Feedback.msg_debug (Pp.str msg)); translate_mod prefix mp env md.mod_type acc | SFBmodtype mdtyp -> let mp = mdtyp.mod_mp in @@ -51,11 +51,11 @@ and translate_field prefix mp env acc (l,x) = let msg = Printf.sprintf "Compiling module type %s..." (ModPath.to_string mp) in - Pp.msg_debug (Pp.str msg)); + Feedback.msg_debug (Pp.str msg)); translate_mod prefix mp env mdtyp.mod_type acc let dump_library mp dp env mod_expr = - if !Flags.debug then Pp.msg_debug (Pp.str "Compiling library..."); + if !Flags.debug then Feedback.msg_debug (Pp.str "Compiling library..."); match mod_expr with | NoFunctor struc -> let env = add_structure mp struc empty_delta_resolver env in diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 5bf369441f..30a346c910 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -681,7 +681,7 @@ let vm_conv cv_pb env t1 t2 = try !vm_conv cv_pb env t1 t2 with Not_found | Invalid_argument _ -> - Pp.msg_warning (Pp.str "Bytecode compilation failed, falling back to standard conversion"); + Feedback.msg_warning (Pp.str "Bytecode compilation failed, falling back to standard conversion"); gen_conv cv_pb env t1 t2 let default_conv cv_pb ?(l2r=false) env t1 t2 = diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index 3839135a86..6bfd2457a8 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -167,8 +167,10 @@ let hcons_j j = { uj_val = hcons_constr j.uj_val; uj_type = hcons_constr j.uj_type} let feedback_completion_typecheck = - Option.iter (fun state_id -> Pp.feedback ~state_id Feedback.Complete) - + let open Feedback in + Option.iter (fun state_id -> + feedback ~id:(State state_id) Feedback.Complete) + let infer_declaration ~trust env kn dcl = match dcl with | ParameterEntry (ctx,poly,(t,uctx),nl) -> diff --git a/kernel/vconv.ml b/kernel/vconv.ml index 89e833254a..53db6f5bee 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -185,7 +185,7 @@ let vm_conv_gen cv_pb env univs t1 t2 = let v2 = val_of_constr env t2 in fst (conv_val env cv_pb (nb_rel env) v1 v2 univs) with Not_found | Invalid_argument _ -> - (Pp.msg_warning + (Feedback.msg_warning (Pp.str "Bytecode compilation failed, falling back to default conversion"); Reduction.generic_conv cv_pb ~l2r:false (fun _ -> None) full_transparent_state env univs t1 t2) diff --git a/lib/aux_file.ml b/lib/aux_file.ml index c814438dd7..096305b987 100644 --- a/lib/aux_file.ml +++ b/lib/aux_file.ml @@ -88,7 +88,7 @@ let load_aux_file_for vfile = | Sys_error s | Scanf.Scan_failure s | Failure s | Invalid_argument s -> Flags.if_verbose - Pp.msg_warning Pp.(str"Loading file "++str aux_fname++str": "++str s); + Feedback.msg_warning Pp.(str"Loading file "++str aux_fname++str": "++str s); empty_aux_file let set h loc k v = set h (Loc.unloc loc) k v diff --git a/lib/clib.mllib b/lib/clib.mllib index 3c1c5da33c..1e33173ee1 100644 --- a/lib/clib.mllib +++ b/lib/clib.mllib @@ -21,20 +21,16 @@ Control Loc CList CString -Serialize Deque CObj CArray CStack Util Stateid -Feedback Pp Ppstyle -Xml_lexer -Xml_parser -Xml_printer Richpp +Feedback CUnix Envars Aux_file diff --git a/lib/explore.ml b/lib/explore.ml index 587db11563..aa7bddf2b4 100644 --- a/lib/explore.ml +++ b/lib/explore.ml @@ -27,7 +27,7 @@ module Make = functor(S : SearchProblem) -> struct | [i] -> int i | i :: l -> pp_rec l ++ str "." ++ int i in - msg_debug (h 0 (pp_rec p) ++ pp) + Feedback.msg_debug (h 0 (pp_rec p) ++ pp) (*s Depth first search. *) diff --git a/lib/feedback.ml b/lib/feedback.ml index 1a90685de6..d6f580fd16 100644 --- a/lib/feedback.ml +++ b/lib/feedback.ml @@ -7,51 +7,14 @@ (************************************************************************) open Xml_datatype -open Serialize -type message_level = +type level = | Debug of string | Info | Notice | Warning | Error -type message = { - message_level : message_level; - message_content : xml; -} - -let of_message_level = function - | Debug s -> - Serialize.constructor "message_level" "debug" [Xml_datatype.PCData s] - | Info -> Serialize.constructor "message_level" "info" [] - | Notice -> Serialize.constructor "message_level" "notice" [] - | Warning -> Serialize.constructor "message_level" "warning" [] - | Error -> Serialize.constructor "message_level" "error" [] -let to_message_level = - Serialize.do_match "message_level" (fun s args -> match s with - | "debug" -> Debug (Serialize.raw_string args) - | "info" -> Info - | "notice" -> Notice - | "warning" -> Warning - | "error" -> Error - | _ -> raise Serialize.Marshal_error) - -let of_message msg = - let lvl = of_message_level msg.message_level in - let content = Serialize.of_xml msg.message_content in - Xml_datatype.Element ("message", [], [lvl; content]) -let to_message xml = match xml with - | Xml_datatype.Element ("message", [], [lvl; content]) -> { - message_level = to_message_level lvl; - message_content = Serialize.to_xml content } - | _ -> raise Serialize.Marshal_error - -let is_message = function - | Xml_datatype.Element ("message", _, _) -> true - | _ -> false - - type edit_id = int type state_id = Stateid.t type edit_or_state_id = Edit of edit_id | State of state_id @@ -71,8 +34,10 @@ type feedback_content = | GlobDef of Loc.t * string * string * string | FileDependency of string option * string | FileLoaded of string * string + (* Extra metadata *) | Custom of Loc.t * string * xml - | Message of message + (* Old generic messages *) + | Message of level * Richpp.richpp type feedback = { id : edit_or_state_id; @@ -80,92 +45,127 @@ type feedback = { route : route_id; } -let to_feedback_content = do_match "feedback_content" (fun s a -> match s,a with - | "addedaxiom", _ -> AddedAxiom - | "processed", _ -> Processed - | "processingin", [where] -> ProcessingIn (to_string where) - | "incomplete", _ -> Incomplete - | "complete", _ -> Complete - | "globref", [loc; filepath; modpath; ident; ty] -> - GlobRef(to_loc loc, to_string filepath, - to_string modpath, to_string ident, to_string ty) - | "globdef", [loc; ident; secpath; ty] -> - GlobDef(to_loc loc, to_string ident, to_string secpath, to_string ty) - | "errormsg", [loc; s] -> ErrorMsg (to_loc loc, to_string s) - | "inprogress", [n] -> InProgress (to_int n) - | "workerstatus", [ns] -> - let n, s = to_pair to_string to_string ns in - WorkerStatus(n,s) - | "goals", [loc;s] -> Goals (to_loc loc, to_string s) - | "custom", [loc;name;x]-> Custom (to_loc loc, to_string name, x) - | "filedependency", [from; dep] -> - FileDependency (to_option to_string from, to_string dep) - | "fileloaded", [dirpath; filename] -> - FileLoaded (to_string dirpath, to_string filename) - | "message", [m] -> Message (to_message m) - | _ -> raise Marshal_error) -let of_feedback_content = function - | AddedAxiom -> constructor "feedback_content" "addedaxiom" [] - | Processed -> constructor "feedback_content" "processed" [] - | ProcessingIn where -> - constructor "feedback_content" "processingin" [of_string where] - | Incomplete -> constructor "feedback_content" "incomplete" [] - | Complete -> constructor "feedback_content" "complete" [] - | GlobRef(loc, filepath, modpath, ident, ty) -> - constructor "feedback_content" "globref" [ - of_loc loc; - of_string filepath; - of_string modpath; - of_string ident; - of_string ty ] - | GlobDef(loc, ident, secpath, ty) -> - constructor "feedback_content" "globdef" [ - of_loc loc; - of_string ident; - of_string secpath; - of_string ty ] - | ErrorMsg(loc, s) -> - constructor "feedback_content" "errormsg" [of_loc loc; of_string s] - | InProgress n -> constructor "feedback_content" "inprogress" [of_int n] - | WorkerStatus(n,s) -> - constructor "feedback_content" "workerstatus" - [of_pair of_string of_string (n,s)] - | Goals (loc,s) -> - constructor "feedback_content" "goals" [of_loc loc;of_string s] - | Custom (loc, name, x) -> - constructor "feedback_content" "custom" [of_loc loc; of_string name; x] - | FileDependency (from, depends_on) -> - constructor "feedback_content" "filedependency" [ - of_option of_string from; - of_string depends_on] - | FileLoaded (dirpath, filename) -> - constructor "feedback_content" "fileloaded" [ - of_string dirpath; - of_string filename ] - | Message m -> constructor "feedback_content" "message" [ of_message m ] - -let of_edit_or_state_id = function - | Edit id -> ["object","edit"], of_edit_id id - | State id -> ["object","state"], Stateid.to_xml id - -let of_feedback msg = - let content = of_feedback_content msg.contents in - let obj, id = of_edit_or_state_id msg.id in - let route = string_of_int msg.route in - Element ("feedback", obj @ ["route",route], [id;content]) -let to_feedback xml = match xml with - | Element ("feedback", ["object","edit";"route",route], [id;content]) -> { - id = Edit(to_edit_id id); - route = int_of_string route; - contents = to_feedback_content content } - | Element ("feedback", ["object","state";"route",route], [id;content]) -> { - id = State(Stateid.of_xml id); - route = int_of_string route; - contents = to_feedback_content content } - | _ -> raise Marshal_error - -let is_feedback = function - | Element ("feedback", _, _) -> true - | _ -> false - let default_route = 0 + +(** Feedback and logging *) +open Pp +open Pp_control + +type logger = level -> std_ppcmds -> unit + +let msgnl_with fmt strm = msg_with fmt (strm ++ fnl ()) +let msgnl strm = msgnl_with !std_ft strm + +(* XXX: This is really painful! *) +module Emacs = struct + + (* Special chars for emacs, to detect warnings inside goal output *) + let emacs_quote_start = String.make 1 (Char.chr 254) + let emacs_quote_end = String.make 1 (Char.chr 255) + + let emacs_quote_err g = + hov 0 (str emacs_quote_start ++ g ++ str emacs_quote_end) + + let emacs_quote_info_start = "<infomsg>" + let emacs_quote_info_end = "</infomsg>" + + let emacs_quote_info g = + hov 0 (str emacs_quote_info_start++ brk(0,0) ++ g ++ brk(0,0) ++ str emacs_quote_info_end) + +end + +open Emacs + +let dbg_str = str "Debug:" ++ spc () +let info_str = mt () +let warn_str = str "Warning:" ++ spc () +let err_str = str "Error:" ++ spc () + +let make_body quoter info s = quoter (hov 0 (info ++ s)) + +(* Generic logger *) +let gen_logger dbg err level msg = match level with + | Debug _ -> msgnl (make_body dbg dbg_str msg) + | Info -> msgnl (make_body dbg info_str msg) + | Notice -> msgnl msg + | Warning -> Flags.if_warn (fun () -> + msgnl_with !err_ft (make_body err warn_str msg)) () + | Error -> msgnl_with !err_ft (make_body err err_str msg) + +(** Standard loggers *) +let std_logger = gen_logger (fun x -> x) (fun x -> x) + +(* Color logger *) +let color_terminal_logger level strm = + let msg = Ppstyle.color_msg in + match level with + | Debug _ -> msg ~header:("Debug", Ppstyle.debug_tag) !std_ft strm + | Info -> msg !std_ft strm + | Notice -> msg !std_ft strm + | Warning -> + let header = ("Warning", Ppstyle.warning_tag) in + Flags.if_warn (fun () -> msg ~header !err_ft strm) () + | Error -> msg ~header:("Error", Ppstyle.error_tag) !err_ft strm + +(* Rules for emacs: + - Debug/info: emacs_quote_info + - Warning/Error: emacs_quote_err + - Notice: unquoted + *) +let emacs_logger = gen_logger emacs_quote_info emacs_quote_err + +let logger = ref std_logger +let set_logger l = logger := l + +let msg_info x = !logger Info x +let msg_notice x = !logger Notice x +let msg_warning x = !logger Warning x +let msg_error x = !logger Error x +let msg_debug x = !logger (Debug "_") x + +(** Feeders *) +let feeder = ref ignore +let set_feeder f = feeder := f + +let feedback_id = ref (Edit 0) +let feedback_route = ref default_route + +let set_id_for_feedback ?(route=default_route) i = + feedback_id := i; feedback_route := route + +let feedback ?id ?route what = + !feeder { + contents = what; + route = Option.default !feedback_route route; + id = Option.default !feedback_id id; + } + +let feedback_logger lvl msg = + feedback ~route:!feedback_route ~id:!feedback_id + (Message (lvl, Richpp.richpp_of_pp msg)) + +(* Output to file *) +let ft_logger old_logger ft level mesg = + let id x = x in + match level with + | Debug _ -> msgnl_with ft (make_body id dbg_str mesg) + | Info -> msgnl_with ft (make_body id info_str mesg) + | Notice -> msgnl_with ft mesg + | Warning -> old_logger level mesg + | Error -> old_logger level mesg + +let with_output_to_file fname func input = + let old_logger = !logger in + let channel = open_out (String.concat "." [fname; "out"]) in + logger := ft_logger old_logger (Format.formatter_of_out_channel channel); + try + let output = func input in + logger := old_logger; + close_out channel; + output + with reraise -> + let reraise = Backtrace.add_backtrace reraise in + logger := old_logger; + close_out channel; + Exninfo.iraise reraise + diff --git a/lib/feedback.mli b/lib/feedback.mli index 0d8e20230d..50ffd22db9 100644 --- a/lib/feedback.mli +++ b/lib/feedback.mli @@ -9,27 +9,19 @@ open Xml_datatype (* Old plain messages (used to be in Pp) *) -type message_level = +type level = | Debug of string | Info | Notice | Warning | Error -type message = { - message_level : message_level; - message_content : xml; -} - -val of_message : message -> xml -val to_message : xml -> message -val is_message : xml -> bool - (** Coq "semantic" infos obtained during parsing/execution *) type edit_id = int type state_id = Stateid.t type edit_or_state_id = Edit of edit_id | State of state_id + type route_id = int val default_route : route_id @@ -54,15 +46,88 @@ type feedback_content = (* Extra metadata *) | Custom of Loc.t * string * xml (* Old generic messages *) - | Message of message + | Message of level * Richpp.richpp type feedback = { - id : edit_or_state_id; (* The document part concerned *) + id : edit_or_state_id; (* The document part concerned *) contents : feedback_content; (* The payload *) - route : route_id; (* Extra routing info *) + route : route_id; (* Extra routing info *) } -val of_feedback : feedback -> xml -val to_feedback : xml -> feedback -val is_feedback : xml -> bool +(** {6 Feedback sent, even asynchronously, to the user interface} *) + +(** Moved here from pp.ml *) + +(* Morally the parser gets a string and an edit_id, and gives back an AST. + * Feedbacks during the parsing phase are attached to this edit_id. + * The interpreter assignes an exec_id to the ast, and feedbacks happening + * during interpretation are attached to the exec_id. + * Only one among state_id and edit_id can be provided. *) + +(** A [logger] takes a level plus a pretty printing doc and logs it *) +type logger = level -> Pp.std_ppcmds -> unit + +(** [set_logger l] makes the [msg_*] to use [l] for logging *) +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! *) + +(** [feedback_logger] will produce feedback messages instead IO events *) +val feedback_logger : logger +val emacs_logger : logger + + +(** [set_feeder] A feeder processes the feedback, [ignore] by default *) +val set_feeder : (feedback -> unit) -> unit + +(** [feedback ?id ?route fb] produces feedback fb, with [route] and + [id] set appropiatedly, if absent, it will use the defaults set by + [set_id_for_feedback] *) +val feedback : + ?id:edit_or_state_id -> ?route:route_id -> feedback_content -> unit + +(** [set_id_for_feedback route id] Set the defaults for feedback *) +val set_id_for_feedback : ?route:route_id -> edit_or_state_id -> unit + +(** [with_output_to_file file f x] executes [f x] with logging + redirected to a file [file] *) +val with_output_to_file : string -> ('a -> 'b) -> 'a -> 'b + +(** {6 output functions} + +[msg_notice] do not put any decoration on output by default. If +possible don't mix it with goal output (prefer msg_info or +msg_warning) so that interfaces can dispatch outputs easily. Once all +interfaces use the xml-like protocol this constraint can be +relaxed. *) +(* Should we advertise these functions more? Should they be the ONLY + allowed way to output something? *) + +val msg_info : Pp.std_ppcmds -> unit +(** Message that displays information, usually in verbose mode, such as [Foobar + is defined] *) + +val msg_notice : Pp.std_ppcmds -> unit +(** Message that should be displayed, such as [Print Foo] or [Show Bar]. *) + +val msg_warning : Pp.std_ppcmds -> unit +(** Message indicating that something went wrong, but without serious + consequences. *) + +val msg_error : Pp.std_ppcmds -> unit +(** Message indicating that something went really wrong, though still + recoverable; otherwise an exception would have been raised. *) + +val msg_debug : Pp.std_ppcmds -> unit +(** For debugging purposes *) + + + diff --git a/lib/flags.ml b/lib/flags.ml index 9a209a2b3e..ba19c7a63b 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -69,11 +69,15 @@ let priority_of_string = function | "low" -> Low | "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_cmd_error_resilience = ref true let async_proofs_is_worker () = !async_proofs_worker_id <> "master" let async_proofs_is_master () = !async_proofs_mode = APon && !async_proofs_worker_id = "master" +let async_proofs_delegation_threshold = ref 0.03 let debug = ref false let in_debugger = ref false @@ -221,6 +225,7 @@ let native_compiler = ref false let print_mod_uid = ref false let tactic_context_compat = ref false +let profile_ltac = ref false let dump_bytecode = ref false let set_dump_bytecode = (:=) dump_bytecode diff --git a/lib/flags.mli b/lib/flags.mli index f52a14a303..8fe64d24fa 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -35,6 +35,10 @@ type priority = Low | High val async_proofs_worker_priority : priority ref val string_of_priority : priority -> string val priority_of_string : string -> priority +type tac_error_filter = [ `None | `Only of string list | `All ] +val async_proofs_tac_error_resilience : tac_error_filter ref +val async_proofs_cmd_error_resilience : bool ref +val async_proofs_delegation_threshold : float ref val debug : bool ref val in_debugger : bool ref @@ -144,6 +148,8 @@ val tactic_context_compat : bool ref (** Set to [true] to trigger the compatibility bugged context matching (old context vs. appcontext) is set. *) +val profile_ltac : bool ref + (** Dump the bytecode after compilation (for debugging purposes) *) val dump_bytecode : bool ref val set_dump_bytecode : bool -> unit diff --git a/lib/genarg.mli b/lib/genarg.mli index b8bb6af04a..d7ad9b93b4 100644 --- a/lib/genarg.mli +++ b/lib/genarg.mli @@ -6,6 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(** Generic arguments used by the extension mechanisms of several Coq ASTs. *) + (** The route of a generic argument, from parsing to evaluation. In the following diagram, "object" can be tactic_expr, constr, tactic_arg, etc. @@ -34,36 +36,10 @@ In the following diagram, "object" can be tactic_expr, constr, tactic_arg, etc. effective use {% \end{%}verbatim{% }%} -To distinguish between the uninterpreted (raw), globalized and +To distinguish between the uninterpreted, globalized and interpreted worlds, we annotate the type [generic_argument] by a -phantom argument which is either [constr_expr], [glob_constr] or -[constr]. +phantom argument. -Transformation for each type : -{% \begin{%}verbatim{% }%} -tag raw open type cooked closed type - -BoolArgType bool bool -IntArgType int int -IntOrVarArgType int or_var int -StringArgType string (parsed w/ "") string -PreIdentArgType string (parsed w/o "") (vernac only) -IdentArgType true identifier identifier -IdentArgType false identifier (pattern_ident) identifier -IntroPatternArgType intro_pattern_expr intro_pattern_expr -VarArgType identifier located identifier -RefArgType reference global_reference -QuantHypArgType quantified_hypothesis quantified_hypothesis -ConstrArgType constr_expr constr -ConstrMayEvalArgType constr_expr may_eval constr -OpenConstrArgType open_constr_expr open_constr -ConstrWithBindingsArgType constr_expr with_bindings constr with_bindings -BindingsArgType constr_expr bindings constr bindings -List0ArgType of argument_type -List1ArgType of argument_type -OptArgType of argument_type -ExtraArgType of string '_a '_b -{% \end{%}verbatim{% }%} *) (** {5 Generic types} *) @@ -77,14 +53,14 @@ sig val name : string -> any option end +(** Generic types. The first parameter is the OCaml lowest level, the second one + is the globalized level, and third one the internalized level. *) type (_, _, _) genarg_type = | ExtraArg : ('a, 'b, 'c) ArgT.tag -> ('a, 'b, 'c) genarg_type | ListArg : ('a, 'b, 'c) genarg_type -> ('a list, 'b list, 'c list) genarg_type | OptArg : ('a, 'b, 'c) genarg_type -> ('a option, 'b option, 'c option) genarg_type | PairArg : ('a1, 'b1, 'c1) genarg_type * ('a2, 'b2, 'c2) genarg_type -> ('a1 * 'a2, 'b1 * 'b2, 'c1 * 'c2) genarg_type -(** Generic types. ['raw] is the OCaml lowest level, ['glob] is the globalized - one, and ['top] the internalized one. *) type 'a uniform_genarg_type = ('a, 'a, 'a) genarg_type (** Alias for concision when the three types agree. *) @@ -99,21 +75,18 @@ val create_arg : string -> ('raw, 'glob, 'top) genarg_type (** {5 Specialized types} *) (** All of [rlevel], [glevel] and [tlevel] must be non convertible - to ensure the injectivity of the type inference from type - ['co generic_argument] to [('a,'co) abstract_argument_type]; - this guarantees that, for 'co fixed, the type of - out_gen is monomorphic over 'a, hence type-safe -*) + to ensure the injectivity of the GADT type inference. *) type rlevel = [ `rlevel ] type glevel = [ `glevel ] type tlevel = [ `tlevel ] +(** Generic types at a fixed level. The first parameter embeds the OCaml type + and the second one the level. *) type (_, _) abstract_argument_type = | Rawwit : ('a, 'b, 'c) genarg_type -> ('a, rlevel) abstract_argument_type | Glbwit : ('a, 'b, 'c) genarg_type -> ('b, glevel) abstract_argument_type | Topwit : ('a, 'b, 'c) genarg_type -> ('c, tlevel) abstract_argument_type -(** Type at level ['co] represented by an OCaml value of type ['a]. *) type 'a raw_abstract_argument_type = ('a, rlevel) abstract_argument_type (** Specialized type at raw level. *) @@ -207,9 +180,11 @@ sig end -(** {5 Basic generic type constructors} *) +(** {5 Compatibility layer} + +The functions below are aliases for generic_type constructors. -(** {6 Parameterized types} *) +*) val wit_list : ('a, 'b, 'c) genarg_type -> ('a list, 'b list, 'c list) genarg_type val wit_opt : ('a, 'b, 'c) genarg_type -> ('a option, 'b option, 'c option) genarg_type diff --git a/lib/lib.mllib b/lib/lib.mllib index 2be435f6ff..a6c09058dd 100644 --- a/lib/lib.mllib +++ b/lib/lib.mllib @@ -3,6 +3,7 @@ Bigint Segmenttree Unicodetable Unicode +Minisys System CThread Spawn diff --git a/lib/minisys.ml b/lib/minisys.ml new file mode 100644 index 0000000000..25e4d79c4e --- /dev/null +++ b/lib/minisys.ml @@ -0,0 +1,74 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Minisys regroups some code that used to be in System. + Unlike System, this module has no dependency and could + be used for initial compilation target such as coqdep_boot. + The functions here are still available in System thanks to + an include. For the signature, look at the top of system.mli +*) + +(** Dealing with directories *) + +type unix_path = string (* path in unix-style, with '/' separator *) + +type file_kind = + | FileDir of unix_path * (* basename of path: *) string + | FileRegular of string (* basename of file *) + +(* Copy of Filename.concat but assuming paths to always be POSIX *) + +let (//) dirname filename = + let l = String.length dirname in + if l = 0 || dirname.[l-1] = '/' + then dirname ^ filename + else dirname ^ "/" ^ filename + +(* Excluding directories; We avoid directories starting with . as well + as CVS and _darcs and any subdirs given via -exclude-dir *) + +let skipped_dirnames = ref ["CVS"; "_darcs"] + +let exclude_directory f = skipped_dirnames := f :: !skipped_dirnames + +let ok_dirname f = + not (f = "") && f.[0] != '.' && + not (List.mem f !skipped_dirnames) (*&& + (match Unicode.ident_refutation f with None -> true | _ -> false)*) + +(* Check directory can be opened *) + +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, ... *) + if ok_dirname name then + let path = if path = "." then name else path//name in + match try (Unix.stat path).Unix.st_kind with Unix.Unix_error _ -> Unix.S_BLK with + | Unix.S_DIR -> f (FileDir (path,name)) + | Unix.S_REG -> f (FileRegular name) + | _ -> () + +let readdir dir = try Sys.readdir dir with any -> [||] + +let process_directory f path = + Array.iter (apply_subdir f path) (readdir path) + +let process_subdirectories f path = + let f = function FileDir (path,base) -> f path base | FileRegular _ -> () in + process_directory f path @@ -64,13 +64,6 @@ end open Pp_control -(* This should not be used outside of this file. Use - Flags.print_emacs instead. This one is updated when reading - command line options. This was the only way to make [Pp] depend on - an option without creating a circularity: [Flags] -> [Util] -> - [Pp] -> [Flags] *) -let print_emacs = ref false - (* The different kinds of blocks are: \begin{description} \item[hbox:] Horizontal block no line breaking; @@ -339,175 +332,23 @@ let pp_dirs ?pp_tag ft = let () = Format.pp_print_flush ft () in Exninfo.iraise reraise - - -(* pretty print on stdout and stderr *) - -(* Special chars for emacs, to detect warnings inside goal output *) -let emacs_quote_start = String.make 1 (Char.chr 254) -let emacs_quote_end = String.make 1 (Char.chr 255) - -let emacs_quote_info_start = "<infomsg>" -let emacs_quote_info_end = "</infomsg>" - -let emacs_quote g = - if !print_emacs then hov 0 (str emacs_quote_start ++ g ++ str emacs_quote_end) - else hov 0 g - -let emacs_quote_info g = - if !print_emacs then hov 0 (str emacs_quote_info_start++ brk(0,0) ++ g ++ brk(0,0) ++ str emacs_quote_info_end) - else hov 0 g - - (* pretty printing functions WITHOUT FLUSH *) let pp_with ?pp_tag ft strm = pp_dirs ?pp_tag ft (Glue.atom (Ppdir_ppcmds strm)) -let ppnl_with ft strm = - pp_dirs ft (Glue.atom (Ppdir_ppcmds (strm ++ fnl ()))) - (* pretty printing functions WITH FLUSH *) let msg_with ft strm = pp_dirs ft (Glue.atom(Ppdir_ppcmds strm) ++ Glue.atom(Ppdir_print_flush)) -let msgnl_with ft strm = - pp_dirs ft (Glue.atom(Ppdir_ppcmds strm) ++ Glue.atom(Ppdir_print_newline)) - -(* pretty printing functions WITHOUT FLUSH *) -let pp x = pp_with !std_ft x -let ppnl x = ppnl_with !std_ft x -let pperr x = pp_with !err_ft x -let pperrnl x = ppnl_with !err_ft x -let message s = ppnl (str s) -let pp_flush x = Format.pp_print_flush !std_ft x -let pperr_flush x = Format.pp_print_flush !err_ft x -let flush_all () = - flush stderr; flush stdout; pp_flush (); pperr_flush () - -(* pretty printing functions WITH FLUSH *) -let msg x = msg_with !std_ft x -let msgnl x = msgnl_with !std_ft x -let msgerr x = msg_with !err_ft x -let msgerrnl x = msgnl_with !err_ft x - -(* Logging management *) - -type message_level = Feedback.message_level = - | Debug of string - | Info - | Notice - | Warning - | Error - -type message = Feedback.message = { - message_level : message_level; - message_content : Xml_datatype.xml; -} - -let of_message = Feedback.of_message -let to_message = Feedback.to_message -let is_message = Feedback.is_message - -type logger = message_level -> std_ppcmds -> unit - -let make_body info s = - emacs_quote (hov 0 (info ++ spc () ++ s)) - -let debugbody strm = emacs_quote_info (hov 0 (str "Debug:" ++ spc () ++ strm)) -let warnbody strm = make_body (str "Warning:") strm -let errorbody strm = make_body (str "Error:") strm -let infobody strm = emacs_quote_info strm - -let std_logger ~id:_ level msg = match level with -| Debug _ -> msgnl (debugbody msg) -| Info -> msgnl (hov 0 msg) -| Notice -> msgnl msg -| Warning -> Flags.if_warn (fun () -> msgnl_with !err_ft (warnbody msg)) () -| Error -> msgnl_with !err_ft (errorbody msg) - -let emacs_logger ~id:_ level mesg = match level with -| Debug _ -> msgnl (debugbody mesg) -| Info -> msgnl (infobody mesg) -| Notice -> msgnl mesg -| Warning -> Flags.if_warn (fun () -> msgnl_with !err_ft (warnbody mesg)) () -| Error -> msgnl_with !err_ft (errorbody mesg) - -let logger = ref std_logger - -let make_pp_emacs() = print_emacs:=true; logger:=emacs_logger -let make_pp_nonemacs() = print_emacs:=false; logger := std_logger - -let ft_logger old_logger ft ~id level mesg = match level with - | Debug _ -> msgnl_with ft (debugbody mesg) - | Info -> msgnl_with ft (infobody mesg) - | Notice -> msgnl_with ft mesg - | Warning -> old_logger ~id:id level mesg - | Error -> old_logger ~id:id level mesg - -let with_output_to_file fname func input = - let old_logger = !logger in - let channel = open_out (String.concat "." [fname; "out"]) in - logger := ft_logger old_logger (Format.formatter_of_out_channel channel); - try - let output = func input in - logger := old_logger; - close_out channel; - output - with reraise -> - let reraise = Backtrace.add_backtrace reraise in - logger := old_logger; - close_out channel; - Exninfo.iraise reraise - -let feedback_id = ref (Feedback.Edit 0) -let feedback_route = ref Feedback.default_route - (* If mixing some output and a goal display, please use msg_warning, so that interfaces (proofgeneral for example) can easily dispatch them to different windows. *) -let msg_info x = !logger ~id:!feedback_id Info x -let msg_notice x = !logger ~id:!feedback_id Notice x -let msg_warning x = !logger ~id:!feedback_id Warning x -let msg_error x = !logger ~id:!feedback_id Error x -let msg_debug x = !logger ~id:!feedback_id (Debug "_") x - -let set_logger l = logger := (fun ~id:_ lvl msg -> l lvl msg) - -let std_logger lvl msg = std_logger ~id:!feedback_id lvl msg - -(** Feedback *) - -let feeder = ref ignore -let set_id_for_feedback ?(route=Feedback.default_route) i = - feedback_id := i; feedback_route := route -let feedback ?state_id ?edit_id ?route what = - !feeder { - Feedback.contents = what; - Feedback.route = Option.default !feedback_route route; - Feedback.id = - match state_id, edit_id with - | Some id, _ -> Feedback.State id - | None, Some eid -> Feedback.Edit eid - | None, None -> !feedback_id; - } -let set_feeder f = feeder := f -let get_id_for_feedback () = !feedback_id, !feedback_route - -(** Utility *) - +(** Output to a string formatter *) let string_of_ppcmds c = - msg_with Format.str_formatter c; + Format.fprintf Format.str_formatter "@[%a@]" msg_with c; Format.flush_str_formatter () -let log_via_feedback printer = logger := (fun ~id lvl msg -> - !feeder { - Feedback.contents = Feedback.Message { - message_level = lvl; - message_content = printer msg }; - Feedback.route = !feedback_route; - Feedback.id = id }) - (* Copy paste from Util *) let pr_comma () = str "," ++ spc () @@ -597,3 +438,4 @@ let prvect_with_sep sep elem v = prvecti_with_sep sep (fun _ -> elem) v let prvect elem v = prvect_with_sep mt elem v let surround p = hov 1 (str"(" ++ p ++ str")") + diff --git a/lib/pp.mli b/lib/pp.mli index 04a60a7c8d..a18744c376 100644 --- a/lib/pp.mli +++ b/lib/pp.mli @@ -6,32 +6,24 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(** Modify pretty printing functions behavior for emacs ouput (special - chars inserted at some places). This function should called once in - module [Options], that's all. *) -val make_pp_emacs:unit -> unit -val make_pp_nonemacs:unit -> unit - -val with_output_to_file : string -> ('a -> 'b) -> 'a -> 'b - (** Pretty-printers. *) type std_ppcmds (** {6 Formatting commands} *) -val str : string -> std_ppcmds +val str : string -> std_ppcmds val stras : int * string -> std_ppcmds -val brk : int * int -> std_ppcmds -val tbrk : int * int -> std_ppcmds -val tab : unit -> std_ppcmds -val fnl : unit -> std_ppcmds -val pifb : unit -> std_ppcmds -val ws : int -> std_ppcmds -val mt : unit -> std_ppcmds -val ismt : std_ppcmds -> bool - -val comment : int -> std_ppcmds +val brk : int * int -> std_ppcmds +val tbrk : int * int -> std_ppcmds +val tab : unit -> std_ppcmds +val fnl : unit -> std_ppcmds +val pifb : unit -> std_ppcmds +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 (** {6 Manipulation commands} *) @@ -100,87 +92,10 @@ sig (** Project an object from a tag. *) end -type tag_handler = Tag.t -> Format.tag - val tag : Tag.t -> std_ppcmds -> std_ppcmds val open_tag : Tag.t -> std_ppcmds val close_tag : unit -> std_ppcmds -(** {6 Sending messages to the user} *) -type message_level = Feedback.message_level = - | Debug of string - | Info - | Notice - | Warning - | Error - -type message = Feedback.message = { - message_level : message_level; - message_content : Xml_datatype.xml; -} - -type logger = message_level -> std_ppcmds -> unit - -(** {6 output functions} - -[msg_notice] do not put any decoration on output by default. If -possible don't mix it with goal output (prefer msg_info or -msg_warning) so that interfaces can dispatch outputs easily. Once all -interfaces use the xml-like protocol this constraint can be -relaxed. *) -(* Should we advertise these functions more? Should they be the ONLY - allowed way to output something? *) - -val msg_info : std_ppcmds -> unit -(** Message that displays information, usually in verbose mode, such as [Foobar - is defined] *) - -val msg_notice : std_ppcmds -> unit -(** Message that should be displayed, such as [Print Foo] or [Show Bar]. *) - -val msg_warning : std_ppcmds -> unit -(** Message indicating that something went wrong, but without serious - consequences. *) - -val msg_error : std_ppcmds -> unit -(** Message indicating that something went really wrong, though still - recoverable; otherwise an exception would have been raised. *) - -val msg_debug : std_ppcmds -> unit -(** For debugging purposes *) - -val std_logger : logger -(** Standard logging function *) - -val set_logger : logger -> unit - -val log_via_feedback : (std_ppcmds -> Xml_datatype.xml) -> unit - -val of_message : message -> Xml_datatype.xml -val to_message : Xml_datatype.xml -> message -val is_message : Xml_datatype.xml -> bool - - -(** {6 Feedback sent, even asynchronously, to the user interface} *) - -(* This stuff should be available to most of the system, line msg_* above. - * But I'm unsure this is the right place, especially for the global edit_id. - * - * Morally the parser gets a string and an edit_id, and gives back an AST. - * Feedbacks during the parsing phase are attached to this edit_id. - * The interpreter assigns an exec_id to the ast, and feedbacks happening - * during interpretation are attached to the exec_id. - * Only one among state_id and edit_id can be provided. *) - -val feedback : - ?state_id:Feedback.state_id -> ?edit_id:Feedback.edit_id -> - ?route:Feedback.route_id -> Feedback.feedback_content -> unit - -val set_id_for_feedback : - ?route:Feedback.route_id -> Feedback.edit_or_state_id -> unit -val set_feeder : (Feedback.feedback -> unit) -> unit -val get_id_for_feedback : unit -> Feedback.edit_or_state_id * Feedback.route_id - (** {6 Utilities} *) val string_of_ppcmds : std_ppcmds -> string @@ -251,31 +166,13 @@ val surround : std_ppcmds -> std_ppcmds val pr_vertical_list : ('b -> std_ppcmds) -> 'b list -> std_ppcmds -(** {6 Low-level pretty-printing functions {% \emph{%}without flush{% }%}. } *) - -val pp_with : ?pp_tag:tag_handler -> Format.formatter -> std_ppcmds -> unit - -(** {6 Pretty-printing functions {% \emph{%}without flush{% }%} on [stdout] and [stderr]. } *) - -(** These functions are low-level interface to printing and should not be used - in usual code. Consider using the [msg_*] function family instead. *) +(** {6 Low-level pretty-printing functions with and without flush} *) -val pp : std_ppcmds -> unit -val ppnl : std_ppcmds -> unit -val pperr : std_ppcmds -> unit -val pperrnl : std_ppcmds -> unit -val pperr_flush : unit -> unit -val pp_flush : unit -> unit -val flush_all: unit -> unit - -(** {6 Deprecated functions} *) - -(** DEPRECATED. Do not use in newly written code. *) +(** FIXME: These ignore the logging settings and call [Format] directly *) +type tag_handler = Tag.t -> Format.tag -val msg_with : Format.formatter -> std_ppcmds -> unit +(** [msg_with fmt pp] Print [pp] to [fmt] and flush [fmt] *) +val msg_with : Format.formatter -> std_ppcmds -> unit -val msg : std_ppcmds -> unit -val msgnl : std_ppcmds -> unit -val msgerr : std_ppcmds -> unit -val msgerrnl : std_ppcmds -> unit -val message : string -> unit (** = pPNL *) +(** [msg_with 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 3ecaac0391..b068788c92 100644 --- a/lib/ppstyle.ml +++ b/lib/ppstyle.ml @@ -107,8 +107,11 @@ 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; @@ -116,34 +119,23 @@ let init_color_output () = Format.print_close_tag = ignore; } in let open Pp_control in - let () = Format.pp_set_mark_tags !std_ft true in - let () = Format.pp_set_mark_tags !err_ft true in - let () = Format.pp_set_formatter_tag_functions !std_ft tag_handler in - let () = Format.pp_set_formatter_tag_functions !err_ft tag_handler 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 ?header ft strm = let pptag = tag in let open Pp in - let msg ?header ft strm = - let strm = match header with + let strm = match header with | None -> hov 0 strm | Some (h, t) -> let tag = Pp.Tag.inj t pptag in let h = Pp.tag tag (str h ++ str ":") in hov 0 (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 (); - in - let logger level strm = match level with - | Debug _ -> msg ~header:("Debug", debug_tag) !std_ft strm - | Info -> msg !std_ft strm - | Notice -> msg !std_ft strm - | Warning -> - let header = ("Warning", warning_tag) in - Flags.if_warn (fun () -> msg ~header !err_ft strm) () - | Error -> msg ~header:("Error", error_tag) !err_ft strm in - let () = set_logger logger 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 97b5869f9b..1cd701ed4e 100644 --- a/lib/ppstyle.mli +++ b/lib/ppstyle.mli @@ -11,7 +11,8 @@ (** {5 Style tags} *) -type t +type t = string + (** Style tags *) val make : ?style:Terminal.style -> string list -> t @@ -46,12 +47,11 @@ val dump : unit -> (t * Terminal.style option) list (** {5 Setting color output} *) val init_color_output : unit -> unit -(** Once called, all tags defined here will use their current style when - printed. To this end, this function redefines the loggers used when sending - messages to the user. The program will in particular use the formatters - {!Pp_control.std_ft} and {!Pp_control.err_ft} to display those messages, - with additional syle information provided by this module. Be careful this is - not compatible with the Emacs mode! *) + +val color_msg : ?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 *) val pp_tag : Pp.tag_handler (** Returns the name of a style tag that is understandable by the formatters diff --git a/lib/richpp.ml b/lib/richpp.ml index fe3edd99ca..a98273edb2 100644 --- a/lib/richpp.ml +++ b/lib/richpp.ml @@ -194,7 +194,3 @@ let raw_print xml = let () = print xml in Buffer.contents buf -let of_richpp x = Element ("richpp", [], [x]) -let to_richpp xml = match xml with -| Element ("richpp", [], [x]) -> x -| _ -> raise Serialize.Marshal_error diff --git a/lib/richpp.mli b/lib/richpp.mli index 807d52aba4..287d265a8f 100644 --- a/lib/richpp.mli +++ b/lib/richpp.mli @@ -57,10 +57,7 @@ val richpp_of_string : string -> richpp val repr : richpp -> Xml_datatype.xml (** Observe the styled text as XML *) -(** {5 Serialization} *) - -val of_richpp : richpp -> Xml_datatype.xml -val to_richpp : Xml_datatype.xml -> richpp +(** {5 Debug/Compat} *) (** Represent the semi-structured document as a string, dropping any additional information. *) diff --git a/lib/stateid.ml b/lib/stateid.ml index 59cf206e2e..500581a39e 100644 --- a/lib/stateid.ml +++ b/lib/stateid.ml @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Xml_datatype - type t = int let initial = 1 let dummy = 0 @@ -15,20 +13,14 @@ let fresh, in_range = let cur = ref initial in (fun () -> incr cur; !cur), (fun id -> id >= 0 && id <= !cur) let to_string = string_of_int -let of_int id = assert(in_range id); id +let of_int id = + (* Coqide too to parse ids too, but cannot check if they are valid. + * Hence we check for validity only if we are an ide slave. *) + if !Flags.ide_slave then assert (in_range id); + id let to_int id = id let newer_than id1 id2 = id1 > id2 -let of_xml = function - | Element ("state_id",["val",i],[]) -> - let id = int_of_string i in - (* Coqide too to parse ids too, but cannot check if they are valid. - * Hence we check for validity only if we are an ide slave. *) - if !Flags.ide_slave then assert(in_range id); - id - | _ -> raise (Invalid_argument "to_state_id") -let to_xml i = Element ("state_id",["val",string_of_int i],[]) - let state_id_info : (t * t) Exninfo.t = Exninfo.make () let add exn ?(valid = initial) id = Exninfo.add exn state_id_info (valid, id) @@ -37,7 +29,13 @@ let get exn = Exninfo.get exn state_id_info let equal = Int.equal let compare = Int.compare -module Set = Set.Make(struct type t = int let compare = compare end) +module Self = struct + type t = int + let compare = compare + let equal = equal +end + +module Set = Set.Make(Self) type ('a,'b) request = { exn_info : t * t; diff --git a/lib/stateid.mli b/lib/stateid.mli index 2c12c30c3c..cd8fddf0ce 100644 --- a/lib/stateid.mli +++ b/lib/stateid.mli @@ -6,26 +6,23 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Xml_datatype - type t val equal : t -> t -> bool val compare : t -> t -> int -module Set : Set.S with type elt = t +module Self : Map.OrderedType with type t = t +module Set : Set.S with type elt = t and type t = Set.Make(Self).t val initial : t val dummy : t val fresh : unit -> t val to_string : t -> string + val of_int : int -> t val to_int : t -> int -val newer_than : t -> t -> bool -(* XML marshalling *) -val to_xml : t -> xml -val of_xml : xml -> t +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. diff --git a/lib/system.ml b/lib/system.ml index e54109a2f3..8b53a11d67 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -12,65 +12,7 @@ open Pp open Errors open Util -(** Dealing with directories *) - -type unix_path = string (* path in unix-style, with '/' separator *) - -type file_kind = - | FileDir of unix_path * (* basename of path: *) string - | FileRegular of string (* basename of file *) - -(* Copy of Filename.concat but assuming paths to always be POSIX *) - -let (//) dirname filename = - let l = String.length dirname in - if l = 0 || dirname.[l-1] = '/' - then dirname ^ filename - else dirname ^ "/" ^ filename - -(* Excluding directories; We avoid directories starting with . as well - as CVS and _darcs and any subdirs given via -exclude-dir *) - -let skipped_dirnames = ref ["CVS"; "_darcs"] - -let exclude_directory f = skipped_dirnames := f :: !skipped_dirnames - -let ok_dirname f = - not (f = "") && f.[0] != '.' && - not (List.mem f !skipped_dirnames) (*&& - (match Unicode.ident_refutation f with None -> true | _ -> false)*) - -(* Check directory can be opened *) - -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, ... *) - if ok_dirname name then - let path = if path = "." then name else path//name in - match try (Unix.stat path).Unix.st_kind with Unix.Unix_error _ -> Unix.S_BLK with - | Unix.S_DIR -> f (FileDir (path,name)) - | Unix.S_REG -> f (FileRegular name) - | _ -> () - -let readdir dir = try Sys.readdir dir with any -> [||] - -let process_directory f path = - Array.iter (apply_subdir f path) (readdir path) - -let process_subdirectories f path = - let f = function FileDir (path,base) -> f path base | FileRegular _ -> () in - process_directory f path +include Minisys (** Returns the list of all recursive subdirectories of [root] in depth-first search, with sons ordered as on the file system; @@ -88,9 +30,9 @@ let all_subdirs ~unix_path:root = | _ -> () in process_directory f path in - check_unix_dir (fun s -> msg_warning (str s)) root; + check_unix_dir (fun s -> Feedback.msg_warning (str s)) root; if exists_dir root then traverse root [] - else msg_warning (str ("Cannot open " ^ root)); + else Feedback.msg_warning (str ("Cannot open " ^ root)); List.rev !l (* Caching directory contents for efficient syntactic equality of file @@ -149,7 +91,7 @@ let where_in_path ?(warn=true) path filename = | (lpe, f) :: l' -> let () = match l' with | _ :: _ when warn -> - msg_warning + Feedback.msg_warning (str filename ++ str " has been found in" ++ spc () ++ hov 0 (str "[ " ++ hv 0 (prlist_with_sep (fun () -> str " " ++ pr_semicolon()) @@ -205,7 +147,7 @@ let is_in_system_path filename = let lpath = CUnix.path_to_list (Sys.getenv "PATH") in is_in_path lpath filename with Not_found -> - msg_warning (str "system variable PATH not found"); + Feedback.msg_warning (str "system variable PATH not found"); false let open_trapping_failure name = @@ -216,7 +158,7 @@ let open_trapping_failure name = let try_remove filename = try Sys.remove filename with e when Errors.noncritical e -> - msg_warning + Feedback.msg_warning (str"Could not remove file " ++ str filename ++ str" which is corrupted!") let error_corrupted file s = @@ -345,13 +287,13 @@ let with_time time f x = let y = f x in let tend = get_time() in let msg2 = if time then "" else " (successful)" in - msg_info (str msg ++ fmt_time_difference tstart tend ++ str msg2); + Feedback.msg_info (str msg ++ fmt_time_difference tstart tend ++ str msg2); y with e -> let tend = get_time() in let msg = if time then "" else "Finished failing transaction in " in let msg2 = if time then "" else " (failure)" in - msg_info (str msg ++ fmt_time_difference tstart tend ++ str msg2); + Feedback.msg_info (str msg ++ fmt_time_difference tstart tend ++ str msg2); raise e let process_id () = diff --git a/lib/unicode.ml b/lib/unicode.ml index 938e8f1a99..dc852d9819 100644 --- a/lib/unicode.ml +++ b/lib/unicode.ml @@ -240,14 +240,94 @@ let is_basic_ascii s = !ok let ascii_of_ident s = - if is_basic_ascii s then s else - let i = ref 0 and out = ref "" in - begin try while true do + let len = String.length s in + let has_UU i = + i+2 < len && s.[i]='_' && s.[i+1]='U' && s.[i+2]='U' + in + let i = ref 0 in + while !i < len && Char.code s.[!i] < 128 && not (has_UU !i) do + incr i + done; + if !i = len then s else + let out = Buffer.create (2*len) in + Buffer.add_substring out s 0 !i; + while !i < len do let j, n = next_utf8 s !i in - out := - if n >= 128 - then Printf.sprintf "%s__U%04x_" !out n - else Printf.sprintf "%s%c" !out s.[!i]; - i := !i + j - done with End_of_input -> () end; - !out + if n >= 128 then + (Printf.bprintf out "_UU%04x_" n; i := !i + j) + else if has_UU !i then + (Buffer.add_string out "_UUU"; i := !i + 3) + else + (Buffer.add_char out s.[!i]; incr i) + done; + Buffer.contents out + +(* Compute length of an UTF-8 encoded string + Rem 1 : utf8_length <= String.length (equal if pure ascii) + Rem 2 : if used for an iso8859_1 encoded string, the result is + wrong in very rare cases. Such a wrong case corresponds to any + sequence of a character in range 192..253 immediately followed by a + character in range 128..191 (typical case in french is "déçu" which + is counted 3 instead of 4); then no real harm to use always + utf8_length even if using an iso8859_1 encoding *) + +(** FIXME: duplicate code with Pp *) + +let utf8_length s = + let len = String.length s + and cnt = ref 0 + and nc = ref 0 + and p = ref 0 in + while !p < len do + begin + match s.[!p] with + | '\000'..'\127' -> nc := 0 (* ascii char *) + | '\128'..'\191' -> nc := 0 (* cannot start with a continuation byte *) + | '\192'..'\223' -> nc := 1 (* expect 1 continuation byte *) + | '\224'..'\239' -> nc := 2 (* expect 2 continuation bytes *) + | '\240'..'\247' -> nc := 3 (* expect 3 continuation bytes *) + | '\248'..'\251' -> nc := 4 (* expect 4 continuation bytes *) + | '\252'..'\253' -> nc := 5 (* expect 5 continuation bytes *) + | '\254'..'\255' -> nc := 0 (* invalid byte *) + end ; + incr p ; + while !p < len && !nc > 0 do + match s.[!p] with + | '\128'..'\191' (* next continuation byte *) -> incr p ; decr nc + | _ (* not a continuation byte *) -> nc := 0 + done ; + incr cnt + done ; + !cnt + +(* Variant of String.sub for UTF8 character positions *) +let utf8_sub s start_u len_u = + let len_b = String.length s + and end_u = start_u + len_u + and cnt = ref 0 + and nc = ref 0 + and p = ref 0 in + let start_b = ref len_b in + while !p < len_b && !cnt < end_u do + if !cnt <= start_u then start_b := !p ; + begin + match s.[!p] with + | '\000'..'\127' -> nc := 0 (* ascii char *) + | '\128'..'\191' -> nc := 0 (* cannot start with a continuation byte *) + | '\192'..'\223' -> nc := 1 (* expect 1 continuation byte *) + | '\224'..'\239' -> nc := 2 (* expect 2 continuation bytes *) + | '\240'..'\247' -> nc := 3 (* expect 3 continuation bytes *) + | '\248'..'\251' -> nc := 4 (* expect 4 continuation bytes *) + | '\252'..'\253' -> nc := 5 (* expect 5 continuation bytes *) + | '\254'..'\255' -> nc := 0 (* invalid byte *) + end ; + incr p ; + while !p < len_b && !nc > 0 do + match s.[!p] with + | '\128'..'\191' (* next continuation byte *) -> incr p ; decr nc + | _ (* not a continuation byte *) -> nc := 0 + done ; + incr cnt + done ; + let end_b = !p in + String.sub s !start_b (end_b - !start_b) diff --git a/lib/unicode.mli b/lib/unicode.mli index b8a11e2945..1f8bd44eee 100644 --- a/lib/unicode.mli +++ b/lib/unicode.mli @@ -27,15 +27,22 @@ val ident_refutation : string -> (bool * string) option @raise Assert_failure if the input string is empty. *) val lowercase_first_char : string -> string -(** Return [true] if all UTF-8 characters in the input string are just plain ASCII characters. - Returns [false] otherwise. *) +(** Return [true] if all UTF-8 characters in the input string are just plain + ASCII characters. Returns [false] otherwise. *) val is_basic_ascii : string -> bool -(** [ascii_of_ident s] maps UTF-8 string to a string composed solely from ASCII characters. - Those UTF-8 characters which do not have their ASCII counterparts are - translated to ["__Uxxxx_"] where {i xxxx} are four hexadecimal digits. - @raise Unsupported if the input string contains unsupported UTF-8 characters. *) +(** [ascii_of_ident s] maps UTF-8 string to a string composed solely from ASCII + characters. The non-ASCII characters are translated to ["_UUxxxx_"] where + {i xxxx} is the Unicode index of the character in hexadecimal (from four + to six hex digits). To avoid potential name clashes, any preexisting + substring ["_UU"] is turned into ["_UUU"]. *) val ascii_of_ident : string -> string (** Validate an UTF-8 string *) val is_utf8 : string -> bool + +(** Return the length of a valid UTF-8 string. *) +val utf8_length : string -> int + +(** Variant of {!String.sub} for UTF-8 strings. *) +val utf8_sub : string -> int -> int -> string diff --git a/library/declare.ml b/library/declare.ml index c59d190a0e..84284fd182 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -398,7 +398,7 @@ let declare_mind mie = let pr_rank i = pr_nth (i+1) let fixpoint_message indexes l = - Flags.if_verbose msg_info (match l with + Flags.if_verbose Feedback.msg_info (match l with | [] -> anomaly (Pp.str "no recursive definition") | [id] -> pr_id id ++ str " is recursively defined" ++ (match indexes with @@ -413,7 +413,7 @@ let fixpoint_message indexes l = | None -> mt ())) let cofixpoint_message l = - Flags.if_verbose msg_info (match l with + Flags.if_verbose Feedback.msg_info (match l with | [] -> anomaly (Pp.str "No corecursive definition.") | [id] -> pr_id id ++ str " is corecursively defined" | l -> hov 0 (prlist_with_sep pr_comma pr_id l ++ @@ -423,13 +423,13 @@ let recursive_message isfix i l = (if isfix then fixpoint_message i else cofixpoint_message) l let definition_message id = - Flags.if_verbose msg_info (pr_id id ++ str " is defined") + Flags.if_verbose Feedback.msg_info (pr_id id ++ str " is defined") let assumption_message id = (* Changing "assumed" to "declared", "assuming" referring more to the type of the object than to the name of the object (see discussion on coqdev: "Chapter 4 of the Reference Manual", 8/10/2015) *) - Flags.if_verbose msg_info (pr_id id ++ str " is declared") + Flags.if_verbose Feedback.msg_info (pr_id id ++ str " is declared") (** Global universe names, in a different summary *) @@ -440,8 +440,9 @@ let cache_universes (p, l) = let glob = Universes.global_universe_names () in let glob', ctx = List.fold_left (fun ((idl,lid),ctx) (id, lev) -> - ((Idmap.add id lev idl, Univ.LMap.add lev id lid), - Univ.ContextSet.add_universe lev ctx)) + ((Idmap.add id (p, lev) idl, + Univ.LMap.add lev id lid), + Univ.ContextSet.add_universe lev ctx)) (glob, Univ.ContextSet.empty) l in Global.push_context_set p ctx; @@ -457,6 +458,12 @@ let input_universes : universe_decl -> Libobject.obj = classify_function = (fun a -> Keep a) } let do_universe poly l = + let in_section = Lib.sections_are_opened () in + let () = + if poly && not in_section then + user_err_loc (Loc.ghost, "Constraint", + str"Cannot declare polymorphic universes outside sections") + in let l = List.map (fun (l, id) -> let lev = Universes.new_univ_level (Global.current_dirpath ()) in @@ -485,14 +492,30 @@ let input_constraints : constraint_decl -> Libobject.obj = 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) + fun (loc, id) -> + try 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 () = + if poly && not in_section then + user_err_loc (Loc.ghost, "Constraint", + str"Cannot declare polymorphic constraints outside sections") + in + let check_poly loc p loc' p' = + if poly then () + else if p || p' then + let loc = if p then loc else loc' in + user_err_loc (loc, "Constraint", + str "Cannot declare a global constraint on " ++ + str "a polymorphic universe, use " + ++ str "Polymorphic Constraint instead") in let constraints = List.fold_left (fun acc (l, d, r) -> - let lu = u_of_id l and ru = u_of_id r in - Univ.Constraint.add (lu, d, ru) acc) + let p, lu = u_of_id l and p', ru = u_of_id r in + check_poly (fst l) p (fst r) p'; + Univ.Constraint.add (lu, d, ru) acc) Univ.Constraint.empty l in Lib.add_anonymous_leaf (input_constraints (poly, constraints)) diff --git a/library/declaremods.ml b/library/declaremods.ml index f3f734aa09..dcd63c7691 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -897,7 +897,13 @@ let start_library dir = Lib.start_compilation dir mp; Lib.add_frozen_state () +let end_library_hook = ref ignore +let append_end_library_hook f = + let old_f = !end_library_hook in + end_library_hook := fun () -> old_f(); f () + let end_library ?except dir = + !end_library_hook(); let oname = Lib.end_compilation_checks dir in let mp,cenv,ast = Global.export ?except dir in let prefix, lib_stack = Lib.end_compilation oname in diff --git a/library/declaremods.mli b/library/declaremods.mli index 2b440c087a..3917fe8d64 100644 --- a/library/declaremods.mli +++ b/library/declaremods.mli @@ -90,6 +90,9 @@ val end_library : ?except:Future.UUIDSet.t -> library_name -> Safe_typing.compiled_library * library_objects * Safe_typing.native_library +(** append a function to be executed at end_library *) +val append_end_library_hook : (unit -> unit) -> unit + (** [really_import_module mp] opens the module [mp] (in a Caml sense). It modifies Nametab and performs the [open_object] function for every object of the module. Raises [Not_found] when [mp] is unknown diff --git a/library/goptions.ml b/library/goptions.ml index 5f6512e117..4aa3a2a21d 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -108,7 +108,8 @@ module MakeTable = (fun c -> t := MySet.remove c !t)) let print_table table_name printer table = - pp (str table_name ++ + Feedback.msg_notice + (str table_name ++ (hov 0 (if MySet.is_empty table then str " None" ++ fnl () else MySet.fold @@ -122,7 +123,7 @@ module MakeTable = method mem x = let y = A.encode x in let answer = MySet.mem y !t in - msg_info (A.member_message y answer) + Feedback.msg_info (A.member_message y answer) method print = print_table A.title A.printer !t end @@ -271,7 +272,7 @@ let declare_option cast uncast in let warn () = if depr then - msg_warning (str "Option " ++ str (nickname key) ++ str " is deprecated") + Feedback.msg_warning (str "Option " ++ str (nickname key) ++ str " is deprecated") in let cread () = cast (read ()) in let cwrite v = warn (); write (uncast v) in @@ -346,12 +347,12 @@ let set_int_option_value_gen locality = set_option_value locality check_int_value let set_bool_option_value_gen locality key v = try set_option_value locality check_bool_value key v - with UserError (_,s) -> msg_warning s + with UserError (_,s) -> Feedback.msg_warning s let set_string_option_value_gen locality = set_option_value locality check_string_value let unset_option_value_gen locality key = try set_option_value locality check_unset_value key () - with UserError (_,s) -> msg_warning s + with UserError (_,s) -> Feedback.msg_warning s let set_int_option_value = set_int_option_value_gen None let set_bool_option_value = set_bool_option_value_gen None @@ -375,9 +376,9 @@ let print_option_value key = let s = read () in match s with | BoolValue b -> - msg_info (str "The " ++ str name ++ str " mode is " ++ str (if b then "on" else "off")) + Feedback.msg_info (str "The " ++ str name ++ str " mode is " ++ str (if b then "on" else "off")) | _ -> - msg_info (str "Current value of " ++ str name ++ str " is " ++ msg_option_value (name, s)) + Feedback.msg_info (str "Current value of " ++ str name ++ str " is " ++ msg_option_value (name, s)) let get_tables () = let tables = !value_tab in diff --git a/library/libobject.ml b/library/libobject.ml index c566840e4b..b12d2038ae 100644 --- a/library/libobject.ml +++ b/library/libobject.ml @@ -133,7 +133,7 @@ let apply_dyn_fun deflt f lobj = Failure "local to_apply_dyn_fun" -> if not (!relax_flag || Hashtbl.mem missing_tab tag) then begin - Pp.msg_warning + Feedback.msg_warning (Pp.str ("Cannot find library functions for an object with tag " ^ tag ^ " (a plugin may be missing)")); Hashtbl.add missing_tab tag () diff --git a/library/library.ml b/library/library.ml index 34dbdfebac..bc7723f481 100644 --- a/library/library.ml +++ b/library/library.ml @@ -35,7 +35,7 @@ module Delayed : sig type 'a delayed -val in_delayed : string -> in_channel -> 'a delayed +val in_delayed : string -> in_channel -> 'a delayed * Digest.t val fetch_delayed : 'a delayed -> 'a end = @@ -50,7 +50,7 @@ type 'a delayed = { let in_delayed f ch = let pos = pos_in ch in let _, digest = System.skip_in_segment f ch in - { del_file = f; del_digest = digest; del_off = pos; } + ({ del_file = f; del_digest = digest; del_off = pos; }, digest) (** Fetching a table of opaque terms at position [pos] in file [f], expecting to find first a copy of [digest]. *) @@ -287,7 +287,7 @@ let locate_absolute_library dir = | [] -> raise LibNotFound | [file] -> file | [vo;vi] when Unix.((stat vo).st_mtime < (stat vi).st_mtime) -> - msg_warning (str"Loading " ++ str vi ++ str " instead of " ++ + Feedback.msg_warning (str"Loading " ++ str vi ++ str " instead of " ++ str vo ++ str " because it is more recent"); vi | [vo;vi] -> vo @@ -311,7 +311,7 @@ let locate_qualified_library ?root ?(warn = true) qid = | [lpath, file] -> lpath, file | [lpath_vo, vo; lpath_vi, vi] when Unix.((stat vo).st_mtime < (stat vi).st_mtime) -> - msg_warning (str"Loading " ++ str vi ++ str " instead of " ++ + Feedback.msg_warning (str"Loading " ++ str vi ++ str " instead of " ++ str vo ++ str " because it is more recent"); lpath_vi, vi | [lpath_vo, vo; _ ] -> lpath_vo, vo @@ -370,7 +370,7 @@ let access_table what tables dp i = | Fetched t -> t | ToFetch f -> let dir_path = Names.DirPath.to_string dp in - Flags.if_verbose msg_info (str"Fetching " ++ str what++str" from disk for " ++ str dir_path); + Flags.if_verbose Feedback.msg_info (str"Fetching " ++ str what++str" from disk for " ++ str dir_path); let t = try fetch_delayed f with Faulty f -> @@ -427,28 +427,28 @@ let mk_summary m = { let intern_from_file f = let ch = raw_intern_library f in let (lsd : seg_sum), _, digest_lsd = System.marshal_in_segment f ch in - let (lmd : seg_lib delayed) = in_delayed f ch in + let ((lmd : seg_lib delayed), digest_lmd) = in_delayed f ch in let (univs : seg_univ option), _, digest_u = System.marshal_in_segment f ch in let _ = System.skip_in_segment f ch in let _ = System.skip_in_segment f ch in - let (del_opaque : seg_proofs delayed) = in_delayed f ch in + let ((del_opaque : seg_proofs delayed),_) = in_delayed f ch in close_in ch; register_library_filename lsd.md_name f; add_opaque_table lsd.md_name (ToFetch del_opaque); let open Safe_typing in match univs with - | None -> mk_library lsd lmd (Dvo_or_vi digest_lsd) Univ.ContextSet.empty + | None -> mk_library lsd lmd (Dvo_or_vi digest_lmd) Univ.ContextSet.empty | Some (utab,uall,true) -> add_univ_table lsd.md_name (Fetched utab); - mk_library lsd lmd (Dvivo (digest_lsd,digest_u)) uall + mk_library lsd lmd (Dvivo (digest_lmd,digest_u)) uall | Some (utab,_,false) -> add_univ_table lsd.md_name (Fetched utab); - mk_library lsd lmd (Dvo_or_vi digest_lsd) Univ.ContextSet.empty + mk_library lsd lmd (Dvo_or_vi digest_lmd) Univ.ContextSet.empty module DPMap = Map.Make(DirPath) let rec intern_library (needed, contents) (dir, f) from = - Pp.feedback(Feedback.FileDependency (from, DirPath.to_string dir)); + Feedback.feedback(Feedback.FileDependency (from, DirPath.to_string dir)); (* Look if in the current logical environment *) try (find_library dir).libsum_digests, (needed, contents) with Not_found -> @@ -463,7 +463,7 @@ let rec intern_library (needed, contents) (dir, f) from = (str "The file " ++ str f ++ str " contains library" ++ spc () ++ pr_dirpath m.library_name ++ spc () ++ str "and not library" ++ spc() ++ pr_dirpath dir); - Pp.feedback(Feedback.FileLoaded(DirPath.to_string dir, f)); + Feedback.feedback (Feedback.FileLoaded(DirPath.to_string dir, f)); m.library_digests, intern_library_deps (needed, contents) dir m (Some f) and intern_library_deps libs dir m from = @@ -753,7 +753,7 @@ let save_library_to ?todo dir f otab = error "Could not compile the library to native code." with reraise -> let reraise = Errors.push reraise in - let () = msg_warning (str "Removed file " ++ str f') in + let () = Feedback.msg_warning (str "Removed file " ++ str f') in let () = close_out ch in let () = Sys.remove f' in iraise reraise diff --git a/library/loadpath.ml b/library/loadpath.ml index f8169576dd..33c0f41e17 100644 --- a/library/loadpath.ml +++ b/library/loadpath.ml @@ -72,7 +72,7 @@ let add_load_path phys_path coq_path ~implicit = let () = (* Do not warn when overriding the default "-I ." path *) if not (DirPath.equal old_path Nameops.default_root_prefix) then - msg_warning + Feedback.msg_warning (str phys_path ++ strbrk " was previously bound to " ++ pr_dirpath old_path ++ strbrk "; it is remapped to " ++ pr_dirpath coq_path) in diff --git a/library/nametab.ml b/library/nametab.ml index bbae98fc01..db902d625b 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -119,7 +119,7 @@ struct | Absolute (n,_) -> (* This is an absolute name, we must keep it otherwise it may become unaccessible forever *) - msg_warning (str ("Trying to mask the absolute name \"" + Feedback.msg_warning (str ("Trying to mask the absolute name \"" ^ U.to_string n ^ "\"!")); tree.path | Nothing @@ -155,7 +155,7 @@ let rec push_exactly uname o level tree = function | Absolute (n,_) -> (* This is an absolute name, we must keep it otherwise it may become unaccessible forever *) - msg_warning (str ("Trying to mask the absolute name \"" + Feedback.msg_warning (str ("Trying to mask the absolute name \"" ^ U.to_string n ^ "\"!")); tree.path | Nothing @@ -525,7 +525,7 @@ let shortest_qualid_of_tactic kn = let pr_global_env env ref = try pr_qualid (shortest_qualid_of_global env ref) with Not_found as e -> - if !Flags.debug then Pp.msg_debug (Pp.str "pr_global_env not found"); raise e + if !Flags.debug then Feedback.msg_debug (Pp.str "pr_global_env not found"); raise e let global_inductive r = match global r with diff --git a/library/universes.ml b/library/universes.ml index c4eb2afcbb..75cbd5604b 100644 --- a/library/universes.ml +++ b/library/universes.ml @@ -13,10 +13,11 @@ open Term open Environ open Univ open Globnames +open Decl_kinds (** Global universe names *) type universe_names = - Univ.universe_level Idmap.t * Id.t Univ.LMap.t + (polymorphic * Univ.universe_level) Idmap.t * Id.t Univ.LMap.t let global_universes = Summary.ref ~name:"Global universe names" diff --git a/library/universes.mli b/library/universes.mli index 53cf5f3844..a5740ec49f 100644 --- a/library/universes.mli +++ b/library/universes.mli @@ -19,7 +19,7 @@ val is_set_minimization : unit -> bool (** Global universe name <-> level mapping *) type universe_names = - Univ.universe_level Idmap.t * Id.t Univ.LMap.t + (Decl_kinds.polymorphic * Univ.universe_level) Idmap.t * Id.t Univ.LMap.t val global_universe_names : unit -> universe_names val set_global_universe_names : universe_names -> unit diff --git a/ltac/coretactics.ml4 b/ltac/coretactics.ml4 index ce28eacc09..9879cfc280 100644 --- a/ltac/coretactics.ml4 +++ b/ltac/coretactics.ml4 @@ -26,6 +26,10 @@ TACTIC EXTEND reflexivity [ "reflexivity" ] -> [ Tactics.intros_reflexivity ] END +TACTIC EXTEND exact + [ "exact" casted_constr(c) ] -> [ Tactics.exact_no_check c ] +END + TACTIC EXTEND assumption [ "assumption" ] -> [ Tactics.assumption ] END @@ -197,6 +201,19 @@ TACTIC EXTEND intros_until [ "intros" "until" quantified_hypothesis(h) ] -> [ Tactics.intros_until h ] END +TACTIC EXTEND intro +| [ "intro" ] -> [ Tactics.intro_move None MoveLast ] +| [ "intro" ident(id) ] -> [ Tactics.intro_move (Some id) MoveLast ] +| [ "intro" ident(id) "at" "top" ] -> [ Tactics.intro_move (Some id) MoveFirst ] +| [ "intro" ident(id) "at" "bottom" ] -> [ Tactics.intro_move (Some id) MoveLast ] +| [ "intro" ident(id) "after" hyp(h) ] -> [ Tactics.intro_move (Some id) (MoveAfter h) ] +| [ "intro" ident(id) "before" hyp(h) ] -> [ Tactics.intro_move (Some id) (MoveBefore h) ] +| [ "intro" "at" "top" ] -> [ Tactics.intro_move None MoveFirst ] +| [ "intro" "at" "bottom" ] -> [ Tactics.intro_move None MoveLast ] +| [ "intro" "after" hyp(h) ] -> [ Tactics.intro_move None (MoveAfter h) ] +| [ "intro" "before" hyp(h) ] -> [ Tactics.intro_move None (MoveBefore h) ] +END + (** Move *) TACTIC EXTEND move @@ -206,6 +223,12 @@ TACTIC EXTEND move | [ "move" hyp(id) "before" hyp(h) ] -> [ Tactics.move_hyp id (MoveBefore h) ] END +(** Rename *) + +TACTIC EXTEND rename +| [ "rename" ne_rename_list_sep(ids, ",") ] -> [ Tactics.rename_hyp ids ] +END + (** Revert *) TACTIC EXTEND revert @@ -222,6 +245,13 @@ TACTIC EXTEND simple_destruct [ "simple" "destruct" quantified_hypothesis(h) ] -> [ Tactics.simple_destruct h ] END +(** Double induction *) + +TACTIC EXTEND double_induction + [ "double" "induction" quantified_hypothesis(h1) quantified_hypothesis(h2) ] -> + [ Elim.h_double_induction h1 h2 ] +END + (* Admit *) TACTIC EXTEND admit @@ -280,7 +310,6 @@ let initial_atomic () = "hnf", TacReduce(Hnf,nocl); "simpl", TacReduce(Simpl (Redops.all_flags,None),nocl); "compute", TacReduce(Cbv Redops.all_flags,nocl); - "intro", TacIntroMove(None,MoveLast); "intros", TacIntroPattern []; ] in diff --git a/ltac/extraargs.ml4 b/ltac/extraargs.ml4 index 0bddcc9fdd..e6d0a9c69c 100644 --- a/ltac/extraargs.ml4 +++ b/ltac/extraargs.ml4 @@ -15,6 +15,7 @@ open Constrarg open Pcoq.Prim open Pcoq.Constr open Names +open Tacmach open Tacexpr open Taccoerce open Tacinterp @@ -175,6 +176,16 @@ ARGUMENT EXTEND lglob [ lconstr(c) ] -> [ c ] END +let interp_casted_constr ist gl c = + interp_constr_gen (Pretyping.OfType (pf_concl gl)) ist (pf_env gl) (project gl) c + +ARGUMENT EXTEND casted_constr + TYPED AS constr + PRINTED BY pr_gen + INTERPRETED BY interp_casted_constr + [ constr(c) ] -> [ c ] +END + type 'id gen_place= ('id * hyp_location_flag,unit) location type loc_place = Id.t Loc.located gen_place @@ -225,6 +236,14 @@ ARGUMENT EXTEND hloc END +let pr_rename _ _ _ (n, m) = Nameops.pr_id n ++ str " into " ++ Nameops.pr_id m + +ARGUMENT EXTEND rename + TYPED AS ident * ident + PRINTED BY pr_rename +| [ ident(n) "into" ident(m) ] -> [ (n, m) ] +END + (* Julien: Mise en commun des differentes version de replace with in by *) let pr_by_arg_tac _prc _prlc prtac opt_c = diff --git a/ltac/extraargs.mli b/ltac/extraargs.mli index 4d1d8ba7fe..0cf77935c2 100644 --- a/ltac/extraargs.mli +++ b/ltac/extraargs.mli @@ -16,6 +16,8 @@ val wit_orient : bool Genarg.uniform_genarg_type val orient : bool Pcoq.Gram.entry val pr_orient : bool -> Pp.std_ppcmds +val wit_rename : (Id.t * Id.t) Genarg.uniform_genarg_type + val occurrences : (int list or_var) Pcoq.Gram.entry val wit_occurrences : (int list or_var, int list or_var, int list) Genarg.genarg_type val pr_occurrences : int list or_var -> Pp.std_ppcmds @@ -38,6 +40,11 @@ val wit_lconstr : Tacexpr.glob_constr_and_expr, Constr.t) Genarg.genarg_type +val wit_casted_constr : + (constr_expr, + Tacexpr.glob_constr_and_expr, + Constr.t) Genarg.genarg_type + val glob : constr_expr Pcoq.Gram.entry val lglob : constr_expr Pcoq.Gram.entry diff --git a/ltac/extratactics.ml4 b/ltac/extratactics.ml4 index 451e0987b0..57fad85113 100644 --- a/ltac/extratactics.ml4 +++ b/ltac/extratactics.ml4 @@ -872,7 +872,7 @@ END;; mode. *) VERNAC COMMAND EXTEND GrabEvars [ "Grab" "Existential" "Variables" ] - => [ Vernacexpr.VtProofStep false, Vernacexpr.VtLater ] + => [ Vernac_classifier.classify_as_proofstep ] -> [ Proof_global.simple_with_current_proof (fun _ p -> Proof.V82.grab_evars p) ] END @@ -903,7 +903,7 @@ END (* Command to add every unshelved variables to the focus *) VERNAC COMMAND EXTEND Unshelve [ "Unshelve" ] - => [ Vernacexpr.VtProofStep false, Vernacexpr.VtLater ] + => [ Vernac_classifier.classify_as_proofstep ] -> [ Proof_global.simple_with_current_proof (fun _ p -> Proof.unshelve p) ] END @@ -1031,7 +1031,7 @@ VERNAC COMMAND EXTEND Declare_keys CLASSIFIED AS SIDEFF END VERNAC COMMAND EXTEND Print_keys CLASSIFIED AS QUERY -| [ "Print" "Equivalent" "Keys" ] -> [ msg_info (Keys.pr_keys Printer.pr_global) ] +| [ "Print" "Equivalent" "Keys" ] -> [ Feedback.msg_info (Keys.pr_keys Printer.pr_global) ] END diff --git a/ltac/g_ltac.ml4 b/ltac/g_ltac.ml4 index 0c25481d8e..7c161e5cdc 100644 --- a/ltac/g_ltac.ml4 +++ b/ltac/g_ltac.ml4 @@ -231,7 +231,7 @@ GEXTEND Gram Subterm (mode, oid, pc) | IDENT "appcontext"; oid = OPT Constr.ident; "["; pc = Constr.lconstr_pattern; "]" -> - msg_warning (strbrk "appcontext is deprecated"); + Feedback.msg_warning (strbrk "appcontext is deprecated"); Subterm (true,oid, pc) | pc = Constr.lconstr_pattern -> Term pc ] ] ; @@ -334,7 +334,7 @@ let vernac_solve n info tcom b = go back to the top of the prooftree *) let p = Proof.maximal_unfocus Vernacentries.command_focus p in p,status) in - if not status then Pp.feedback Feedback.AddedAxiom + if not status then Feedback.feedback Feedback.AddedAxiom let pr_ltac_selector = function | SelectNth i -> int i ++ str ":" @@ -366,7 +366,8 @@ VERNAC tactic_mode EXTEND VernacSolve vernac_solve g n t def ] | [ - "par" ":" ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => - [ VtProofStep true, VtLater ] -> [ + [ VtProofStep{ parallel = true; proof_block_detection = Some "par" }, + VtLater ] -> [ vernac_solve SelectAll n t def ] END @@ -408,7 +409,7 @@ END VERNAC COMMAND EXTEND VernacPrintLtac CLASSIFIED AS QUERY | [ "Print" "Ltac" reference(r) ] -> - [ msg_notice (Tacintern.print_ltac (snd (Libnames.qualid_of_reference r))) ] + [ Feedback.msg_notice (Tacintern.print_ltac (snd (Libnames.qualid_of_reference r))) ] END let pr_ltac_ref = Libnames.pr_reference @@ -445,3 +446,7 @@ VERNAC COMMAND EXTEND VernacDeclareTacticDefinition Tacentries.register_ltac (Locality.make_module_locality lc) l ] END + +VERNAC COMMAND EXTEND VernacPrintLtacs CLASSIFIED AS QUERY +| [ "Print" "Ltac" "Signatures" ] -> [ Tacentries.print_ltacs () ] +END diff --git a/ltac/g_obligations.ml4 b/ltac/g_obligations.ml4 index 4cd8bf1feb..987b9d5387 100644 --- a/ltac/g_obligations.ml4 +++ b/ltac/g_obligations.ml4 @@ -121,7 +121,7 @@ open Pp VERNAC COMMAND EXTEND Show_Solver CLASSIFIED AS QUERY | [ "Show" "Obligation" "Tactic" ] -> [ - msg_info (str"Program obligation tactic is " ++ print_default_tactic ()) ] + Feedback.msg_info (str"Program obligation tactic is " ++ print_default_tactic ()) ] END VERNAC COMMAND EXTEND Show_Obligations CLASSIFIED AS QUERY @@ -130,8 +130,8 @@ VERNAC COMMAND EXTEND Show_Obligations CLASSIFIED AS QUERY END VERNAC COMMAND EXTEND Show_Preterm CLASSIFIED AS QUERY -| [ "Preterm" "of" ident(name) ] -> [ msg_info (show_term (Some name)) ] -| [ "Preterm" ] -> [ msg_info (show_term None) ] +| [ "Preterm" "of" ident(name) ] -> [ Feedback.msg_info (show_term (Some name)) ] +| [ "Preterm" ] -> [ Feedback.msg_info (show_term None) ] END open Pp diff --git a/ltac/g_rewrite.ml4 b/ltac/g_rewrite.ml4 index 395c2cd1b6..29ffbed196 100644 --- a/ltac/g_rewrite.ml4 +++ b/ltac/g_rewrite.ml4 @@ -262,5 +262,5 @@ TACTIC EXTEND setoid_transitivity END VERNAC COMMAND EXTEND PrintRewriteHintDb CLASSIFIED AS QUERY - [ "Print" "Rewrite" "HintDb" preident(s) ] -> [ Pp.msg_notice (Autorewrite.print_rewrite_hintdb s) ] + [ "Print" "Rewrite" "HintDb" preident(s) ] -> [ Feedback.msg_notice (Autorewrite.print_rewrite_hintdb s) ] END diff --git a/ltac/ltac.mllib b/ltac/ltac.mllib index e0c6f3ac0a..65ed114cff 100644 --- a/ltac/ltac.mllib +++ b/ltac/ltac.mllib @@ -3,6 +3,7 @@ Tacenv Tactic_debug Tacintern Tacentries +Profile_ltac Tacinterp Evar_tactics Tactic_option @@ -10,6 +11,7 @@ Extraargs G_obligations Coretactics Extratactics +Profile_ltac_tactics G_auto G_class Rewrite diff --git a/ltac/profile_ltac.ml b/ltac/profile_ltac.ml new file mode 100644 index 0000000000..7a8ef32c3f --- /dev/null +++ b/ltac/profile_ltac.ml @@ -0,0 +1,323 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Unicode +open Pp +open Printer +open Util + +(** [is_profiling] and the profiling info ([stack]) should be synchronized with + the document; the rest of the ref cells are either local to individual + tactic invocations, or global flags, and need not be synchronized, since no + document-level backtracking happens within tactics. We synchronize + is_profiling via an option. *) +let is_profiling = Flags.profile_ltac + +let set_profiling b = is_profiling := b +let get_profiling () = !is_profiling + +let new_call = ref false +let entered_call () = new_call := true +let is_new_call () = let b = !new_call in new_call := false; b + +(** LtacProf cannot yet handle backtracking into multi-success tactics. + To properly support this, we'd have to somehow recreate our location in the + call-stack, and stop/restart the intervening timers. This is tricky and + possibly expensive, so instead we currently just emit a warning that + profiling results will be off. *) +let encountered_multi_success_backtracking = ref false + +let warn_encountered_multi_success_backtracking () = + if !encountered_multi_success_backtracking then + Feedback.msg_warning (str "Ltac Profiler cannot yet handle backtracking \ + into multi-success tactics; profiling results may be wildly inaccurate.") + +let encounter_multi_success_backtracking () = + if not !encountered_multi_success_backtracking + then begin + encountered_multi_success_backtracking := true; + warn_encountered_multi_success_backtracking () + end + +type entry = { + mutable total : float; + mutable local : float; + mutable ncalls : int; + mutable max_total : float +} + +let empty_entry () = { total = 0.; local = 0.; ncalls = 0; max_total = 0. } + +let add_entry e add_total { total; local; ncalls; max_total } = + if add_total then e.total <- e.total +. total; + e.local <- e.local +. local; + e.ncalls <- e.ncalls + ncalls; + if add_total then e.max_total <- max e.max_total max_total + +type treenode = { + entry : entry; + children : (string, treenode) Hashtbl.t +} + +let empty_treenode n = { entry = empty_entry (); children = Hashtbl.create n } + +(** Tobias Tebbi wrote some tricky code involving mutation. Rather than + rewriting it in a functional style, we simply freeze the state when we need + to by issuing a deep copy of the profiling data. *) +(** TODO: rewrite me in purely functional style *) +let deepcopy_entry { total; local; ncalls; max_total } = + { total; local; ncalls; max_total } + +let rec deepcopy_treenode { entry; children } = + let children' = Hashtbl.create (Hashtbl.length children) in + let iter key subtree = Hashtbl.add children' key (deepcopy_treenode subtree) in + let () = Hashtbl.iter iter children in + { entry = deepcopy_entry entry; children = children' } + +let stack = + let freeze _ = List.map deepcopy_treenode in + Summary.ref ~freeze [empty_treenode 20] ~name:"LtacProf-stack" + +let on_stack = Hashtbl.create 5 + +let get_node c table = + try Hashtbl.find table c + with Not_found -> + let new_node = empty_treenode 5 in + Hashtbl.add table c new_node; + new_node + +let rec add_node node node' = + add_entry node.entry true node'.entry; + Hashtbl.iter + (fun s node' -> add_node (get_node s node.children) node') + node'.children + +let time () = + let times = Unix.times () in + times.Unix.tms_utime +. times.Unix.tms_stime + +(* +let msgnl_with fmt strm = msg_with fmt (strm ++ fnl ()) +let msgnl strm = msgnl_with !Pp_control.std_ft strm + +let rec print_treenode indent (tn : treenode) = + msgnl (str (indent^"{ entry = {")); + Feedback.msg_notice (str (indent^"total = ")); + msgnl (str (indent^(string_of_float (tn.entry.total)))); + Feedback.msg_notice (str (indent^"local = ")); + msgnl (str (indent^(string_of_float tn.entry.local))); + Feedback.msg_notice (str (indent^"ncalls = ")); + msgnl (str (indent^(string_of_int tn.entry.ncalls))); + Feedback.msg_notice (str (indent^"max_total = ")); + msgnl (str (indent^(string_of_float tn.entry.max_total))); + msgnl (str (indent^"}")); + msgnl (str (indent^"children = {")); + Hashtbl.iter + (fun s node -> + msgnl (str (indent^" "^s^" |-> ")); + print_treenode (indent^" ") node + ) + tn.children; + msgnl (str (indent^"} }")) + +let rec print_stack (st : treenode list) = match st with +| [] -> msgnl (str "[]") +| x :: xs -> print_treenode "" x; msgnl (str ("::")); print_stack xs +*) + +let string_of_call ck = + let s = + string_of_ppcmds + (match ck with + | Tacexpr.LtacNotationCall s -> Names.KerName.print s + | Tacexpr.LtacNameCall cst -> Pptactic.pr_ltac_constant cst + | Tacexpr.LtacVarCall (id, t) -> Nameops.pr_id id + | Tacexpr.LtacAtomCall te -> + (Pptactic.pr_glob_tactic (Global.env ()) + (Tacexpr.TacAtom (Loc.ghost, te))) + | Tacexpr.LtacConstrInterp (c, _) -> + pr_glob_constr_env (Global.env ()) c + | Tacexpr.LtacMLCall te -> + (Pptactic.pr_glob_tactic (Global.env ()) + te) + ) in + for i = 0 to String.length s - 1 do if s.[i] = '\n' then s.[i] <- ' ' done; + let s = try String.sub s 0 (CString.string_index_from s 0 "(*") with Not_found -> s in + CString.strip s + +let exit_tactic start_time add_total c = match !stack with +| [] | [_] -> + (* oops, our stack is invalid *) + encounter_multi_success_backtracking () +| node :: (parent :: _ as stack') -> + stack := stack'; + if add_total then Hashtbl.remove on_stack (string_of_call c); + let diff = time () -. start_time in + parent.entry.local <- parent.entry.local -. diff; + let node' = { total = diff; local = diff; ncalls = 1; max_total = diff } in + add_entry node.entry add_total node' + +let tclFINALLY tac (finally : unit Proofview.tactic) = + let open Proofview.Notations in + Proofview.tclIFCATCH + tac + (fun v -> finally <*> Proofview.tclUNIT v) + (fun (exn, info) -> finally <*> Proofview.tclZERO ~info exn) + +let do_profile s call_trace tac = + let open Proofview.Notations in + Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> + if !is_profiling && is_new_call () then + match call_trace with + | (_, c) :: _ -> + let s = string_of_call c in + let parent = List.hd !stack in + let node, add_total = try Hashtbl.find on_stack s, false + with Not_found -> + let node = get_node s parent.children in + Hashtbl.add on_stack s node; + node, true + in + if not add_total && node = List.hd !stack then None else ( + stack := node :: !stack; + let start_time = time () in + Some (start_time, add_total) + ) + | [] -> None + else None)) >>= function + | Some (start_time, add_total) -> + tclFINALLY + tac + (Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> + (match call_trace with + | (_, c) :: _ -> + exit_tactic start_time add_total c + | [] -> ())))) + | None -> tac + + + +let format_sec x = (Printf.sprintf "%.3fs" x) +let format_ratio x = (Printf.sprintf "%.1f%%" (100. *. x)) +let padl n s = ws (max 0 (n - utf8_length s)) ++ str s +let padr n s = str s ++ ws (max 0 (n - utf8_length s)) +let padr_with c n s = + let ulength = utf8_length s in + str (utf8_sub s 0 n) ++ str (String.make (max 0 (n - ulength)) c) + +let rec list_iter_is_last f = function + | [] -> [] + | [x] -> [f true x] + | x :: xs -> f false x :: list_iter_is_last f xs + +let header = + str " tactic self total calls max" ++ + fnl () ++ + str "────────────────────────────────────────┴──────┴──────┴───────┴─────────┘" + +let rec print_node all_total indent prefix (s, n) = + let e = n.entry in + h 0 ( + padr_with '-' 40 (prefix ^ s ^ " ") + ++ padl 7 (format_ratio (e.local /. all_total)) + ++ padl 7 (format_ratio (e.total /. all_total)) + ++ padl 8 (string_of_int e.ncalls) + ++ padl 10 (format_sec (e.max_total)) + ) ++ + print_table all_total indent false n.children + +and print_table all_total indent first_level table = + let fold s n l = if n.entry.total /. all_total < 0.02 then l else (s, n) :: l in + let ls = Hashtbl.fold fold table [] in + match ls with + | [s, n] when not first_level -> + print_node all_total indent (indent ^ "└") (s, n) + | _ -> + let ls = List.sort (fun (_, n1) (_, n2) -> compare n2.entry.total n1.entry.total) ls in + let iter is_last = + let sep0 = if first_level then "" else if is_last then " " else " │" in + let sep1 = if first_level then "─" else if is_last then " └─" else " ├─" in + print_node all_total (indent ^ sep0) (indent ^ sep1) + in + prlist_with_sep fnl (fun pr -> pr) (list_iter_is_last iter ls) + +let print_results () = + let tree = (List.hd !stack).children in + let all_total = -. (List.hd !stack).entry.local in + let global = Hashtbl.create 20 in + let rec cumulate table = + let iter s node = + let node' = get_node s global in + add_entry node'.entry true node.entry; + cumulate node.children + in + Hashtbl.iter iter table + in + cumulate tree; + warn_encountered_multi_success_backtracking (); + let msg = + h 0 (str "total time: " ++ padl 11 (format_sec (all_total))) ++ + fnl () ++ + header ++ + print_table all_total "" true global ++ + fnl () ++ + header ++ + print_table all_total "" true tree + in + Feedback.msg_notice msg + (* FOR DEBUGGING *) + (* ; + msgnl (str""); + print_stack (!stack) + *) + +let print_results_tactic tactic = + let tree = (List.hd !stack).children in + let table_tactic = Hashtbl.create 20 in + let rec cumulate table = + let iter s node = + if String.sub (s ^ ".") 0 (min (1 + String.length s) (String.length tactic)) = tactic + then add_node (get_node s table_tactic) node + else cumulate node.children + in + Hashtbl.iter iter table + in + cumulate tree; + let all_total = -. (List.hd !stack).entry.local in + let tactic_total = + Hashtbl.fold + (fun _ node all_total -> node.entry.total +. all_total) + table_tactic 0. in + warn_encountered_multi_success_backtracking (); + let msg = + h 0 (str"total time: " ++ padl 11 (format_sec (all_total))) ++ + h 0 (str"time spent in tactic: " ++ padl 11 (format_sec (tactic_total))) ++ + fnl () ++ + header ++ + print_table tactic_total "" true table_tactic + in + Feedback.msg_notice msg + +let reset_profile () = + stack := [empty_treenode 20]; + encountered_multi_success_backtracking := false + +let do_print_results_at_close () = if get_profiling () then print_results () + +let _ = Declaremods.append_end_library_hook do_print_results_at_close + +let _ = + let open Goptions in + declare_bool_option + { optsync = true; + optdepr = false; + optname = "Ltac Profiling"; + optkey = ["Ltac"; "Profiling"]; + optread = get_profiling; + optwrite = set_profiling } diff --git a/tools/compat5b.ml b/ltac/profile_ltac.mli index 37cb487c59..7bbdca9425 100644 --- a/tools/compat5b.ml +++ b/ltac/profile_ltac.mli @@ -6,8 +6,20 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* This file is meant for camlp5, for which there is nothing to - add to gain camlp5 compatibility :-). +(** Ltac profiling primitives *) - See [compat5b.mlp] for the [camlp4] counterpart -*) +val do_profile : string -> ('a * Tacexpr.ltac_call_kind) list -> 'b Proofview.tactic -> 'b Proofview.tactic + +val set_profiling : bool -> unit + +val get_profiling : unit -> bool + +val entered_call : unit -> unit + +val print_results : unit -> unit + +val print_results_tactic : string -> unit + +val reset_profile : unit -> unit + +val do_print_results_at_close : unit -> unit diff --git a/ltac/profile_ltac_tactics.ml4 b/ltac/profile_ltac_tactics.ml4 new file mode 100644 index 0000000000..c092a0cb61 --- /dev/null +++ b/ltac/profile_ltac_tactics.ml4 @@ -0,0 +1,39 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i camlp4deps: "grammar/grammar.cma" i*) + +(** Ltac profiling entrypoints *) + +open Profile_ltac +open Stdarg + +DECLARE PLUGIN "profile_ltac_plugin" + +let tclSET_PROFILING b = + Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> set_profiling b)) + +TACTIC EXTEND start_ltac_profiling +| [ "start" "ltac" "profiling" ] -> [ tclSET_PROFILING true ] +END + +TACTIC EXTEND stop_profiling +| [ "stop" "ltac" "profiling" ] -> [ tclSET_PROFILING false ] +END + +VERNAC COMMAND EXTEND ResetLtacProfiling CLASSIFIED AS SIDEFF + [ "Reset" "Ltac" "Profile" ] -> [ reset_profile() ] +END + +VERNAC COMMAND EXTEND ShowLtacProfile CLASSIFIED AS QUERY + [ "Show" "Ltac" "Profile" ] -> [ print_results() ] +END + +VERNAC COMMAND EXTEND ShowLtacProfileTactic CLASSIFIED AS QUERY + [ "Show" "Ltac" "Profile" string(s) ] -> [ print_results_tactic s ] +END diff --git a/ltac/rewrite.ml b/ltac/rewrite.ml index cd8ce7e87a..cb39df8ab5 100644 --- a/ltac/rewrite.ml +++ b/ltac/rewrite.ml @@ -1825,10 +1825,10 @@ let declare_projection n instance_id r = let poly = Global.is_polymorphic r in let env = Global.env () in let sigma = Evd.from_env env in - let evd,c = Evd.fresh_global env sigma r in + let sigma,c = Evd.fresh_global env sigma r in let ty = Retyping.get_type_of env sigma c in let term = proper_projection c ty in - let typ = Typing.unsafe_type_of env sigma term in + let sigma, typ = Typing.type_of env sigma term in let ctx, typ = decompose_prod_assum typ in let typ = let n = @@ -1857,9 +1857,7 @@ let declare_projection n instance_id r = ignore(Declare.declare_constant n (Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition)) -let build_morphism_signature m = - let env = Global.env () in - let sigma = Evd.from_env env in +let build_morphism_signature env sigma m = let m,ctx = Constrintern.interp_constr env sigma m in let sigma = Evd.from_ctx ctx in let t = Typing.unsafe_type_of env sigma m in @@ -1884,8 +1882,10 @@ let build_morphism_signature m = in let morph = e_app_poly env evd PropGlobal.proper_type [| t; sig_; m |] in let evd = solve_constraints env !evd in - let m = Evarutil.nf_evar evd morph in - Pretyping.check_evars env Evd.empty evd m; m + let evd = Evd.nf_constraints evd in + let m = Evarutil.nf_evars_universes evd morph in + Pretyping.check_evars env Evd.empty evd m; + Evd.evar_universe_context evd, m let default_morphism sign m = let env = Global.env () in @@ -1922,12 +1922,13 @@ let add_morphism_infer glob m n = init_setoid (); let poly = Flags.is_universe_polymorphism () in let instance_id = add_suffix n "_Proper" in - let instance = build_morphism_signature m in - let evd = Evd.from_env (Global.env ()) in + let env = Global.env () in + let evd = Evd.from_env env in + let uctx, instance = build_morphism_signature env evd m in if Lib.is_modtype () then let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest instance_id (Entries.ParameterEntry - (None,poly,(instance,Univ.UContext.empty),None), + (None,poly,(instance,Evd.evar_context_universe_context uctx),None), Decl_kinds.IsAssumption Decl_kinds.Logical) in add_instance (Typeclasses.new_instance @@ -1950,7 +1951,7 @@ let add_morphism_infer glob m n = let hook = Lemmas.mk_hook hook in Flags.silently (fun () -> - Lemmas.start_proof instance_id kind evd instance hook; + Lemmas.start_proof instance_id kind (Evd.from_ctx uctx) instance hook; ignore (Pfedit.by (Tacinterp.interp tac))) () let add_morphism glob binders m s n = diff --git a/ltac/tacentries.ml b/ltac/tacentries.ml index ddbd818bf4..f00adecf2a 100644 --- a/ltac/tacentries.ml +++ b/ltac/tacentries.ml @@ -435,7 +435,7 @@ let register_ltac local tacl = with e when Errors.noncritical e -> true (* prim tactics with args, e.g. "apply" *) in let () = if is_primitive then - msg_warning (str "The Ltac name " ++ id_pp ++ + Feedback.msg_warning (str "The Ltac name " ++ id_pp ++ str " may be unusable because of a conflict with a notation.") in NewTac id, body @@ -473,10 +473,39 @@ let register_ltac local tacl = let iter (def, tac) = match def with | NewTac id -> Tacenv.register_ltac false local id tac; - Flags.if_verbose msg_info (Nameops.pr_id id ++ str " is defined") + Flags.if_verbose Feedback.msg_info (Nameops.pr_id id ++ str " is defined") | UpdateTac kn -> Tacenv.redefine_ltac local kn tac; let name = Nametab.shortest_qualid_of_tactic kn in - Flags.if_verbose msg_info (Libnames.pr_qualid name ++ str " is redefined") + Flags.if_verbose Feedback.msg_info (Libnames.pr_qualid name ++ str " is redefined") in List.iter iter defs + +(** Queries *) + +let print_ltacs () = + let entries = KNmap.bindings (Tacenv.ltac_entries ()) in + let sort (kn1, _) (kn2, _) = KerName.compare kn1 kn2 in + let entries = List.sort sort entries in + let map (kn, entry) = + let qid = + try Some (Nametab.shortest_qualid_of_tactic kn) + with Not_found -> None + in + match qid with + | None -> None + | Some qid -> Some (qid, entry.Tacenv.tac_body) + in + let entries = List.map_filter map entries in + let pr_entry (qid, body) = + let (l, t) = match body with + | Tacexpr.TacFun (l, t) -> (l, t) + | _ -> ([], body) + in + let pr_ltac_fun_arg = function + | None -> spc () ++ str "_" + | Some id -> spc () ++ pr_id id + in + hov 2 (pr_qualid qid ++ prlist pr_ltac_fun_arg l) + in + Feedback.msg_notice (prlist_with_sep fnl pr_entry entries) diff --git a/ltac/tacentries.mli b/ltac/tacentries.mli index 402cb2fc96..27df819ee6 100644 --- a/ltac/tacentries.mli +++ b/ltac/tacentries.mli @@ -57,3 +57,8 @@ val create_ltac_quotation : string -> (** [create_ltac_quotation name f e] adds a quotation rule to Ltac, that is, Ltac grammar now accepts arguments of the form ["name" ":" "(" <e> ")"], and generates an argument using [f] on the entry parsed by [e]. *) + +(** {5 Queries} *) + +val print_ltacs : unit -> unit +(** Display the list of ltac definitions currently available. *) diff --git a/ltac/tacenv.ml b/ltac/tacenv.ml index 39db6268b5..005d1f5f48 100644 --- a/ltac/tacenv.ml +++ b/ltac/tacenv.ml @@ -54,7 +54,7 @@ let register_ml_tactic ?(overwrite = false) s (t : ml_tactic array) = if MLTacMap.mem s !tac_tab then if overwrite then let () = tac_tab := MLTacMap.remove s !tac_tab in - msg_warning (str "Overwriting definition of tactic " ++ pr_tacname s) + Feedback.msg_warning (str "Overwriting definition of tactic " ++ pr_tacname s) else Errors.anomaly (str "Cannot redeclare tactic " ++ pr_tacname s ++ str ".") in diff --git a/ltac/tacintern.ml b/ltac/tacintern.ml index 3744449e97..7cda7d1377 100644 --- a/ltac/tacintern.ml +++ b/ltac/tacintern.ml @@ -424,7 +424,7 @@ let intern_hyp_location ist ((occs,id),hl) = (* Reads a pattern *) let intern_pattern ist ?(as_type=false) ltacvars = function | Subterm (b,ido,pc) -> - let (metas,pc) = intern_constr_pattern ist ~as_type ~ltacvars pc in + let (metas,pc) = intern_constr_pattern ist ~as_type:false ~ltacvars pc in ido, metas, Subterm (b,ido,pc) | Term pc -> let (metas,pc) = intern_constr_pattern ist ~as_type ~ltacvars pc in @@ -446,7 +446,7 @@ let opt_cons accu = function | Some id -> Id.Set.add id accu (* Reads the hypotheses of a "match goal" rule *) -let rec intern_match_goal_hyps ist lfun = function +let rec intern_match_goal_hyps ist ?(as_type=false) lfun = function | (Hyp ((_,na) as locna,mp))::tl -> let ido, metas1, pat = intern_pattern ist ~as_type:true lfun mp in let lfun, metas2, hyps = intern_match_goal_hyps ist lfun tl in @@ -455,7 +455,7 @@ let rec intern_match_goal_hyps ist lfun = function | (Def ((_,na) as locna,mv,mp))::tl -> let ido, metas1, patv = intern_pattern ist ~as_type:false lfun mv in let ido', metas2, patt = intern_pattern ist ~as_type:true lfun mp in - let lfun, metas3, hyps = intern_match_goal_hyps ist lfun tl in + let lfun, metas3, hyps = intern_match_goal_hyps ist ~as_type lfun tl in let lfun' = name_cons (opt_cons (opt_cons lfun ido) ido') na in lfun', metas1@metas2@metas3, Def (locna,patv,patt)::hyps | [] -> lfun, [], [] @@ -481,10 +481,6 @@ let rec intern_atomic lf ist x = (* Basic tactics *) | TacIntroPattern l -> TacIntroPattern (List.map (intern_intro_pattern lf ist) l) - | TacIntroMove (ido,hto) -> - TacIntroMove (Option.map (intern_ident lf ist) ido, - intern_move_location ist hto) - | TacExact c -> TacExact (intern_constr ist c) | TacApply (a,ev,cb,inhyp) -> TacApply (a,ev,List.map (intern_constr_with_bindings_arg ist) cb, Option.map (intern_in_hyp_as ist lf) inhyp) @@ -520,16 +516,6 @@ let rec intern_atomic lf ist x = Option.map (intern_or_and_intro_pattern_loc lf ist) ipats), Option.map (clause_app (intern_hyp_location ist)) cls)) l, Option.map (intern_constr_with_bindings ist) el)) - | TacDoubleInduction (h1,h2) -> - let h1 = intern_quantified_hypothesis ist h1 in - let h2 = intern_quantified_hypothesis ist h2 in - TacDoubleInduction (h1,h2) - (* Context management *) - | TacRename l -> - TacRename (List.map (fun (id1,id2) -> - intern_hyp ist id1, - intern_hyp ist id2) l) - (* Conversion *) | TacReduce (r,cl) -> dump_glob_red_expr r; @@ -578,7 +564,7 @@ and intern_tactic_seq onlytac ist = function ist.ltacvars, TacLetIn (isrec,l,intern_tactic onlytac ist' u) | TacMatchGoal (lz,lr,lmr) -> - ist.ltacvars, (TacMatchGoal(lz,lr, intern_match_rule onlytac ist lmr)) + ist.ltacvars, (TacMatchGoal(lz,lr, intern_match_rule onlytac ist ~as_type:true lmr)) | TacMatch (lz,c,lmr) -> ist.ltacvars, TacMatch (lz,intern_tactic_or_tacarg ist c,intern_match_rule onlytac ist lmr) @@ -680,18 +666,18 @@ and intern_tacarg strict onlytac ist = function TacGeneric arg (* Reads the rules of a Match Context or a Match *) -and intern_match_rule onlytac ist = function +and intern_match_rule onlytac ist ?(as_type=false) = function | (All tc)::tl -> - All (intern_tactic onlytac ist tc) :: (intern_match_rule onlytac ist tl) + All (intern_tactic onlytac ist tc) :: (intern_match_rule onlytac ist ~as_type tl) | (Pat (rl,mp,tc))::tl -> let {ltacvars=lfun; genv=env} = ist in - let lfun',metas1,hyps = intern_match_goal_hyps ist lfun rl in - let ido,metas2,pat = intern_pattern ist lfun mp in + let lfun',metas1,hyps = intern_match_goal_hyps ist ~as_type lfun rl in + let ido,metas2,pat = intern_pattern ist ~as_type lfun mp in let fold accu x = Id.Set.add x accu in let ltacvars = List.fold_left fold (opt_cons lfun' ido) metas1 in let ltacvars = List.fold_left fold ltacvars metas2 in let ist' = { ist with ltacvars } in - Pat (hyps,pat,intern_tactic onlytac ist' tc) :: (intern_match_rule onlytac ist tl) + Pat (hyps,pat,intern_tactic onlytac ist' tc) :: (intern_match_rule onlytac ist ~as_type tl) | [] -> [] and intern_genarg ist (GenArg (Rawwit wit, x)) = diff --git a/ltac/tacinterp.ml b/ltac/tacinterp.ml index 5d282a6936..ab61c8abba 100644 --- a/ltac/tacinterp.ml +++ b/ltac/tacinterp.ml @@ -286,9 +286,10 @@ let constr_of_id env id = (** Generic arguments : table of interpretation functions *) +(* Some of the code further down depends on the fact that push_trace does not modify sigma (the evar map) *) let push_trace call ist = match TacStore.get ist.extra f_trace with -| None -> [call] -| Some trace -> call :: trace +| None -> Proofview.tclUNIT [call] +| Some trace -> Proofview.tclLIFT (Proofview.NonLogical.make Profile_ltac.entered_call) <*> Proofview.tclUNIT (call :: trace) let propagate_trace ist loc id v = let v = Value.normalize v in @@ -297,10 +298,11 @@ let propagate_trace ist loc id v = match tacv with | VFun (appl,_,lfun,it,b) -> let t = if List.is_empty it then b else TacFun (it,b) in - let ans = VFun (appl,push_trace(loc,LtacVarCall (id,t)) ist,lfun,it,b) in - of_tacvalue ans - | _ -> v - else v + push_trace(loc,LtacVarCall (id,t)) ist >>= fun trace -> + let ans = VFun (appl,trace,lfun,it,b) in + Proofview.tclUNIT (of_tacvalue ans) + | _ -> Proofview.tclUNIT v + else Proofview.tclUNIT v let append_trace trace v = let v = Value.normalize v in @@ -622,8 +624,13 @@ let interp_gen kind ist allow_patvar flags env sigma (c,ce) = match kind with OfType _ -> WithoutTypeConstraint | _ -> kind in intern_gen kind_for_intern ~allow_patvar ~ltacvars env c in - let trace = - push_trace (loc_of_glob_constr c,LtacConstrInterp (c,vars)) ist in + (* Jason Gross: To avoid unnecessary modifications to tacinterp, as + suggested by Arnaud Spiwack, we run push_trace immediately. We do + this with the kludge of an empty proofview, and rely on the + invariant that running the tactic returned by push_trace does + not modify sigma. *) + let (_, dummy_proofview) = Proofview.init sigma [] in + let (trace,_,_,_) = Proofview.apply env (push_trace (loc_of_glob_constr c,LtacConstrInterp (c,vars)) ist) dummy_proofview in let (evd,c) = catch_error trace (understand_ltac flags env sigma vars kind) c in @@ -684,10 +691,6 @@ let interp_typed_pattern ist env sigma (_,c,_) = interp_gen WithoutTypeConstraint ist true pure_open_constr_flags env sigma c in pattern_of_constr env sigma c -(* Interprets a constr expression casted by the current goal *) -let pf_interp_casted_constr ist gl c = - interp_constr_gen (OfType (pf_concl gl)) ist (pf_env gl) (project gl) c - (* Interprets a constr expression *) let pf_interp_constr ist gl = interp_constr ist (pf_env gl) (project gl) @@ -1173,7 +1176,9 @@ let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : Val.t Ftacti and eval_tactic ist tac : unit Proofview.tactic = match tac with | TacAtom (loc,t) -> let call = LtacAtomCall t in - catch_error_tac (push_trace(loc,call) ist) (interp_atomic ist t) + push_trace(loc,call) ist >>= fun trace -> + Profile_ltac.do_profile "eval_tactic:2" trace + (catch_error_tac trace (interp_atomic ist t)) | TacFun _ | TacLetIn _ -> assert false | TacMatchGoal _ | TacMatch _ -> assert false | TacId [] -> Proofview.tclLIFT (db_breakpoint (curr_debug ist) []) @@ -1242,7 +1247,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with | TacComplete tac -> Tacticals.New.tclCOMPLETE (interp_tactic ist tac) | TacArg a -> interp_tactic ist (TacArg a) | TacInfo tac -> - msg_warning + Feedback.msg_warning (strbrk "The general \"info\" tactic is currently not working." ++ spc()++ strbrk "There is an \"Info\" command to replace it." ++fnl () ++ strbrk "Some specific verbose tactics may also exist, such as info_eauto."); @@ -1255,7 +1260,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with let tac l = let addvar x v accu = Id.Map.add x v accu in let lfun = List.fold_right2 addvar ids l ist.lfun in - let trace = push_trace (loc,LtacNotationCall s) ist in + Ftactic.lift (push_trace (loc,LtacNotationCall s) ist) >>= fun trace -> let ist = { lfun = lfun; extra = TacStore.set ist.extra f_trace trace; } in @@ -1280,7 +1285,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with Ftactic.run tac (fun () -> Proofview.tclUNIT ()) | TacML (loc,opn,l) -> - let trace = push_trace (loc,LtacMLCall tac) ist in + push_trace (loc,LtacMLCall tac) ist >>= fun trace -> let ist = { ist with extra = TacStore.set ist.extra f_trace trace; } in let tac = Tacenv.interp_ml_tactic opn in let args = Ftactic.List.map_right (fun a -> interp_tacarg ist a) l in @@ -1306,15 +1311,17 @@ and interp_ltac_reference loc' mustbetac ist r : Val.t Ftactic.t = try Id.Map.find id ist.lfun with Not_found -> in_gen (topwit wit_var) id in - Ftactic.bind (force_vrec ist v) begin fun v -> - let v = propagate_trace ist loc id v in + let open Ftactic in + force_vrec ist v >>= begin fun v -> + Ftactic.lift (propagate_trace ist loc id v) >>= fun v -> if mustbetac then Ftactic.return (coerce_to_tactic loc id v) else Ftactic.return v end | ArgArg (loc,r) -> let ids = extract_ids [] ist.lfun in let loc_info = ((if Loc.is_ghost loc' then loc else loc'),LtacNameCall r) in - let extra = TacStore.set ist.extra f_avoid_ids ids in - let extra = TacStore.set extra f_trace (push_trace loc_info ist) in + let extra = TacStore.set ist.extra f_avoid_ids ids in + push_trace loc_info ist >>= fun trace -> + let extra = TacStore.set extra f_trace trace in let ist = { lfun = Id.Map.empty; extra = extra; } in let appl = GlbAppl[r,[]] in val_interp ~appl ist (Tacenv.interp_ltac r) @@ -1412,7 +1419,7 @@ and tactic_of_value ist vle = lfun = lfun; extra = TacStore.set ist.extra f_trace []; } in let tac = name_if_glob appl (eval_tactic ist t) in - catch_error_tac trace tac + Profile_ltac.do_profile "tactic_of_value" trace (catch_error_tac trace tac) | (VFun _|VRec _) -> Tacticals.New.tclZEROMSG (str "A fully applied tactic is expected.") else if has_type vle (topwit wit_tactic) then let tac = out_gen (topwit wit_tactic) vle in @@ -1644,24 +1651,6 @@ and interp_atomic ist tac : unit Proofview.tactic = expected behaviour. *) (Tactics.intro_patterns l')) sigma end } - | TacIntroMove (ido,hto) -> - Proofview.Goal.enter { enter = begin fun gl -> - let env = Proofview.Goal.env gl in - let sigma = project gl in - let mloc = interp_move_location ist env sigma hto in - let ido = Option.map (interp_ident ist env sigma) ido in - name_atomic ~env - (TacIntroMove(ido,mloc)) - (Tactics.intro_move ido mloc) - end } - | TacExact c -> - (* spiwack: until the tactic is in the monad *) - Proofview.Trace.name_tactic (fun () -> Pp.str"<exact>") begin - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> - let (sigma, c_interp) = pf_interp_casted_constr ist gl c in - Sigma.Unsafe.of_pair (Tactics.exact_no_check c_interp, sigma) - end } - end | TacApply (a,ev,cb,cl) -> (* spiwack: until the tactic is in the monad *) Proofview.Trace.name_tactic (fun () -> Pp.str"<apply>") begin @@ -1822,26 +1811,6 @@ and interp_atomic ist tac : unit Proofview.tactic = in Sigma.Unsafe.of_pair (tac, sigma) end } - | TacDoubleInduction (h1,h2) -> - let h1 = interp_quantified_hypothesis ist h1 in - let h2 = interp_quantified_hypothesis ist h2 in - name_atomic - (TacDoubleInduction (h1,h2)) - (Elim.h_double_induction h1 h2) - (* Context management *) - | TacRename l -> - Proofview.Goal.enter { enter = begin fun gl -> - let env = pf_env gl in - let sigma = project gl in - let l = - List.map (fun (id1,id2) -> - interp_hyp ist env sigma id1, - interp_ident ist env sigma (snd id2)) l - in - name_atomic ~env - (TacRename l) - (Tactics.rename_hyp l) - end } (* Conversion *) | TacReduce (r,cl) -> @@ -2172,4 +2141,14 @@ let _ = optread = (fun () -> get_debug () != Tactic_debug.DebugOff); optwrite = vernac_debug } +let _ = + let open Goptions in + declare_bool_option + { optsync = false; + optdepr = false; + optname = "Ltac debug"; + optkey = ["Debug";"Ltac"]; + optread = (fun () -> get_debug () != Tactic_debug.DebugOff); + optwrite = vernac_debug } + let () = Hook.set Vernacentries.interp_redexp_hook interp_redexp diff --git a/ltac/tacinterp.mli b/ltac/tacinterp.mli index 8bb6ee4cdf..6f64981eff 100644 --- a/ltac/tacinterp.mli +++ b/ltac/tacinterp.mli @@ -72,6 +72,9 @@ val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr -> Evd.evar_map val interp_hyp : interp_sign -> Environ.env -> Evd.evar_map -> Id.t Loc.located -> Id.t +val interp_constr_gen : Pretyping.typing_constraint -> interp_sign -> + Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Evd.evar_map * constr + val interp_bindings : interp_sign -> Environ.env -> Evd.evar_map -> glob_constr_and_expr bindings -> Evd.evar_map * constr bindings diff --git a/ltac/tacsubst.ml b/ltac/tacsubst.ml index 1326818fc8..2c3c76ef74 100644 --- a/ltac/tacsubst.ml +++ b/ltac/tacsubst.ml @@ -93,7 +93,7 @@ let subst_global_reference subst = let subst_global ref = let ref',t' = subst_global subst ref in if not (eq_constr (Universes.constr_of_global ref') t') then - msg_warning (strbrk "The reference " ++ pr_global ref ++ str " is not " ++ + Feedback.msg_warning (strbrk "The reference " ++ pr_global ref ++ str " is not " ++ str " expanded to \"" ++ pr_lconstr t' ++ str "\", but to " ++ pr_global ref') ; ref' @@ -137,8 +137,6 @@ let rec subst_match_goal_hyps subst = function let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with (* Basic tactics *) | TacIntroPattern l -> TacIntroPattern (List.map (subst_intro_pattern subst) l) - | TacIntroMove _ as x -> x - | TacExact c -> TacExact (subst_glob_constr subst c) | TacApply (a,ev,cb,cl) -> TacApply (a,ev,List.map (subst_glob_with_bindings_arg subst) cb,cl) | TacElim (ev,cb,cbo) -> @@ -162,10 +160,6 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with subst_induction_arg subst c, ids, cls) l in let el' = Option.map (subst_glob_with_bindings subst) el in TacInductionDestruct (isrec,ev,(l',el')) - | TacDoubleInduction (h1,h2) as x -> x - - (* Context management *) - | TacRename l as x -> x (* Conversion *) | TacReduce (r,cl) -> TacReduce (subst_redexp subst r, cl) diff --git a/ltac/tactic_debug.ml b/ltac/tactic_debug.ml index d661f9677c..e657eb9bc2 100644 --- a/ltac/tactic_debug.ml +++ b/ltac/tactic_debug.ml @@ -330,10 +330,9 @@ let db_breakpoint debug s = let is_defined_ltac trace = let rec aux = function - | (_, Tacexpr.LtacNameCall f) :: tail -> - not (Tacenv.is_ltac_for_ml_tactic f) - | (_, Tacexpr.LtacAtomCall _) :: tail -> - false + | (_, Tacexpr.LtacNameCall f) :: _ -> not (Tacenv.is_ltac_for_ml_tactic f) + | (_, Tacexpr.LtacNotationCall f) :: _ -> true + | (_, Tacexpr.LtacAtomCall _) :: _ -> false | _ :: tail -> aux tail | [] -> false in aux (List.rev trace) @@ -341,7 +340,7 @@ let is_defined_ltac trace = let explain_ltac_call_trace last trace loc = let calls = last :: List.rev_map snd trace in let pr_call ck = match ck with - | Tacexpr.LtacNotationCall kn -> quote (KerName.print kn) + | Tacexpr.LtacNotationCall kn -> quote (Pptactic.pr_alias_key kn) | Tacexpr.LtacNameCall cst -> quote (Pptactic.pr_ltac_constant cst) | Tacexpr.LtacMLCall t -> quote (Pptactic.pr_glob_tactic (Global.env()) t) @@ -363,6 +362,7 @@ let explain_ltac_call_trace last trace loc = in match calls with | [] -> mt () + | [a] -> hov 0 (str "Ltac call to " ++ pr_call a ++ str " failed.") | _ -> let kind_of_last_call = match List.last calls with | Tacexpr.LtacConstrInterp _ -> ", last term evaluation failed." @@ -373,10 +373,13 @@ let explain_ltac_call_trace last trace loc = let skip_extensions trace = let rec aux = function - | (_,Tacexpr.LtacNameCall f as tac) :: _ - when Tacenv.is_ltac_for_ml_tactic f -> [tac] - | (_,(Tacexpr.LtacNotationCall _ | Tacexpr.LtacMLCall _) as tac) - :: _ -> [tac] + | (_,Tacexpr.LtacNameCall f as tac) :: _ + when Tacenv.is_ltac_for_ml_tactic f -> [tac] + | (_,Tacexpr.LtacNotationCall _ as tac) :: (_,Tacexpr.LtacMLCall _) :: _ -> + (* Case of an ML defined tactic with entry of the form <<"foo" args>> *) + (* see tacextend.mlp *) + [tac] + | (_,Tacexpr.LtacMLCall _ as tac) :: _ -> [tac] | t :: tail -> t :: aux tail | [] -> [] in List.rev (aux (List.rev trace)) diff --git a/myocamlbuild.ml b/myocamlbuild.ml deleted file mode 100644 index 90df4f00c6..0000000000 --- a/myocamlbuild.ml +++ /dev/null @@ -1,483 +0,0 @@ -(** * Plugin for building Coq via Ocamlbuild *) - -open Ocamlbuild_plugin -open Ocamlbuild_pack -open Printf -open Scanf - -(** WARNING !! this is preliminary stuff. It should allows you to - build coq and its libraries if everything goes right. - Support for all the build rules and configuration options - is progressively added. Tested only on linux + ocaml 3.11 + - local + natdynlink for now. - - Usage: - ./configure -local -opt - ./build (which launches ocamlbuild coq.otarget) - - Then you can (hopefully) launch bin/coqtop, bin/coqide and so on. - Apart from the links in bin, every created files are in _build. - A "./build clean" should give you back a clean source tree - -*) - -(** F.A.Q about ocamlbuild: - -* P / Px ? - - Same, except that the second can be use to signal the main target - of a rule, in order to get a nicer log (otherwise the full command - is used as target name) - -*) - - - -(** Generic file reader, which produces a list of strings, one per line *) - -let read_file f = - let ic = open_in f and l = ref [] in - (try while true do l := (input_line ic)::!l done with End_of_file -> ()); - close_in ic; List.rev !l - - -(** Configuration *) - -(** First, we access coq_config.ml indirectly : we symlink it to - myocamlbuild_config.ml, which is linked with this myocamlbuild.ml *) - -module Coq_config = struct include Myocamlbuild_config end - -let _ = begin - Options.ocamlc := A Coq_config.ocamlc; - Options.ocamlopt := A Coq_config.ocamlopt; - Options.ocamlmklib := A Coq_config.ocamlmklib; - Options.ocamldep := A Coq_config.ocamldep; - Options.ocamldoc := A Coq_config.ocamldoc; - Options.ocamlyacc := A Coq_config.ocamlyacc; - Options.ocamllex := A Coq_config.ocamllex; -end - -let w32 = Coq_config.arch_is_win32 - -let w32pref = "i586-mingw32msvc" -let w32ocamlc = w32pref^"-ocamlc" -let w32ocamlopt = w32pref^"-ocamlopt" -let w32ocamlmklib = w32pref^"-ocamlmklib" -let w32res = w32pref^"-windres" -let w32lib = "/usr/"^w32pref^"/lib/" -let w32bin = "/usr/"^w32pref^"/bin/" -let w32ico = "ide/coq_icon.o" - -let _ = if w32 then begin - Options.ocamlopt := A w32ocamlopt; - Options.ocamlmklib := A w32ocamlmklib; -end - -let use_camlp5 = (Coq_config.camlp4 = "camlp5") - -let camlp4args = - if use_camlp5 then [A "pa_extend.cmo";A "q_MLast.cmo";A "pa_macro.cmo"] - else [] - -let ocaml = A Coq_config.ocaml -let camlp4o = S ((A Coq_config.camlp4o) :: camlp4args) -let camlp4incl = S[A"-I"; A Coq_config.camlp4lib] -let camlp4compat = Sh Coq_config.camlp4compat -let opt = (Coq_config.best = "opt") -let ide = Coq_config.has_coqide -let hasdynlink = Coq_config.has_natdynlink -let os5fix = (Coq_config.natdynlinkflag = "os5fixme") -let dep_dynlink = if hasdynlink then N else Sh"-natdynlink no" -let lablgtkincl = Sh Coq_config.coqideincl -let local = Coq_config.local -let cflags = S[A"-ccopt";A Coq_config.cflags] - -(** Do we want to inspect .ml generated from .ml4 ? *) -let readable_genml = false -let readable_flag = if readable_genml then A"pr_o.cmo" else N - -let _build = Options.build_dir - - -(** Abbreviations about files *) - -let core_libs = - ["lib/clib"; "lib/lib"; "kernel/kernel"; "library/library"; - "engine/engine"; "pretyping/pretyping"; "interp/interp"; "proofs/proofs"; - "parsing/parsing"; "printing/printing"; "tactics/tactics"; - "stm/stm"; "toplevel/toplevel"; "parsing/highparsing"; - "ltac/ltac"] -let core_cma = List.map (fun s -> s^".cma") core_libs -let core_cmxa = List.map (fun s -> s^".cmxa") core_libs -let core_mllib = List.map (fun s -> s^".mllib") core_libs - -let tolink = "tools/tolink.ml" - -let c_headers_base = - ["coq_fix_code.h";"coq_instruct.h"; "coq_memory.h"; - "coq_gc.h"; "coq_interp.h"; "coq_values.h"; - "coq_jumptbl.h"] -let c_headers = List.map ((^) "kernel/byterun/") c_headers_base - -let coqinstrs = "kernel/byterun/coq_instruct.h" -let coqjumps = "kernel/byterun/coq_jumptbl.h" -let copcodes = "kernel/copcodes.ml" - -let libcoqrun = "kernel/byterun/libcoqrun.a" - -let init_vo = "theories/Init/Prelude.vo" - -let nmake = "theories/Numbers/Natural/BigN/NMake_gen.v" -let nmakegen = "theories/Numbers/Natural/BigN/NMake_gen.ml" - -let adapt_name (pref,oldsuf,newsuf) f = - pref ^ (Filename.chop_suffix f oldsuf) ^ newsuf - -let get_names (oldsuf,newsuf) s = - let pref = Filename.dirname s ^ "/" in - List.map (adapt_name (pref,oldsuf,newsuf)) (string_list_of_file s) - -let get_vo_itargets f = - let vo_itargets = get_names (".otarget",".itarget") f in - List.flatten (List.map (get_names (".vo",".v")) vo_itargets) - -let theoriesv = get_vo_itargets "theories/theories.itarget" - -let pluginsv = get_vo_itargets "plugins/pluginsvo.itarget" - -let pluginsmllib = get_names (".cma",".mllib") "plugins/pluginsbyte.itarget" - -(** for correct execution of coqdep_boot, source files should have - been imported in _build (and NMake_gen.v should have been created). *) - -let coqdepdeps = theoriesv @ pluginsv @ pluginsmllib - -let coqtop = "toplevel/coqtop" -let coqide = "ide/coqide" -let coqdepboot = "tools/coqdep_boot" -let coqmktop = "tools/coqmktop" - -(** The list of binaries to build: - (name of link in bin/, name in _build, install both or only best) *) - -type links = Both | Best | BestInPlace | Ide - -let all_binaries = - (if w32 then [ "mkwinapp", "tools/mkwinapp", Best ] else []) @ - [ "coqtop", coqtop, Both; - "coqide", "ide/coqide_main", Ide; - "coqmktop", coqmktop, Both; - "coqc", "tools/coqc", Both; - "coqchk", "checker/main", Both; - "coqdep_boot", coqdepboot, Best; - "coqdep", "tools/coqdep", Best; - "coqdoc", "tools/coqdoc/main", Best; - "coqwc", "tools/coqwc", Best; - "coq_makefile", "tools/coq_makefile", Best; - "coq-tex", "tools/coq_tex", Best; - "gallina", "tools/gallina", Best; - "csdpcert", "plugins/micromega/csdpcert", BestInPlace; - "fake_ide", "tools/fake_ide", Best; - ] - - -let best_oext = if opt then ".native" else ".byte" -let best_ext = if opt then ".opt" else ".byte" -let best_iext = if ide = "opt" then ".opt" else ".byte" - -let coqtopbest = coqtop^best_oext -(* For inner needs, we rather use the bytecode versions of coqdep - and coqmktop: slightly slower but compile quickly, and ok with - w32 cross-compilation *) -let coqdep_boot = coqdepboot^".byte" -let coqmktop_boot = coqmktop^".byte" - -let binariesopt_deps = - let addext b = b ^ ".native" in - let rec deps = function - | [] -> [] - | (_,b,Ide)::l -> if ide="opt" then addext b :: deps l else deps l - | (_,b,_)::l -> if opt then addext b :: deps l else deps l - in deps all_binaries - -let binariesbyte_deps = - let addext b = b ^ ".byte" in - let rec deps = function - | [] -> [] - | (_,b,Ide)::l -> if ide<>"no" then addext b :: deps l else deps l - | (_,b,Both)::l -> addext b :: deps l - | (_,b,_)::l -> if not opt then addext b :: deps l else deps l - in deps all_binaries - -let ln_sf toward f = - Command.execute ~quiet:true (Cmd (S [A"ln";A"-sf";P toward;P f])) - -let rec make_bin_links = function - | [] -> () - | (b,ob,kind)::l -> - make_bin_links l; - let obd = "../"^ !_build^"/"^ob and bd = "bin/"^b in - match kind with - | Ide when ide <> "no" -> - ln_sf (obd^".byte") (bd^".byte"); - if ide = "opt" then ln_sf (obd^".native") (bd^".opt"); - ln_sf (b^best_iext) bd - | Ide (* when ide = "no" *) -> () - | Both -> - ln_sf (obd^".byte") (bd^".byte"); - if opt then ln_sf (obd^".native") (bd^".opt"); - ln_sf (b^best_ext) bd - | Best -> ln_sf (obd^best_oext) bd - | BestInPlace -> ln_sf (b^best_oext) (!_build^"/"^ob) - -let incl f = Ocaml_utils.ocaml_include_flags f - -let cmd cl = (fun _ _ -> (Cmd (S cl))) - -let initial_actions () = begin - (** We "pre-create" a few subdirs in _build *) - Shell.mkdir_p (!_build^"/dev"); - Shell.mkdir_p (!_build^"/bin"); - Shell.mkdir_p (!_build^"/plugins/micromega"); - make_bin_links all_binaries; -end - -let extra_rules () = begin - -(** Virtual target for building all binaries *) - - rule "binariesopt" ~stamp:"binariesopt" ~deps:binariesopt_deps (fun _ _ -> Nop); - rule "binariesbyte" ~stamp:"binariesbyte" ~deps:binariesbyte_deps (fun _ _ -> Nop); - rule "binaries" ~stamp:"binaries" ~deps:["binariesbyte";"binariesopt"] (fun _ _ -> Nop); - -(** We create a special coq_config which mentions _build *) - - rule "coq_config.ml" ~prod:"coq_config.ml" ~dep:"config/coq_config.ml" - (fun _ _ -> - if w32 then cp "config/coq_config.ml" "coq_config.ml" else - let lines = read_file "config/coq_config.ml" in - let lines = List.map (fun s -> s^"\n") lines in - let line0 = "\n(* Adapted variables for ocamlbuild *)\n" in - (* TODO : line2 isn't completely accurate with respect to ./configure: - the case of -local -vmbyteflags foo isn't supported *) - let line1 = - "let vmbyteflags = [\"-dllib\";\"-lcoqrun\"]\n" - in - Echo (lines @ (if local then [line0;line1] else []), - "coq_config.ml")); - -(** Camlp4 extensions *) - - rule ".ml4.ml" ~dep:"%.ml4" ~prod:"%.ml" - (fun env _ -> - let ml4 = env "%.ml4" and ml = env "%.ml" in - Cmd (S[camlp4o;T(tags_of_pathname ml4 ++ "p4mod");readable_flag; - T(tags_of_pathname ml4 ++ "p4option"); camlp4compat; - A"-o"; Px ml; A"-impl"; P ml4])); - - flag_and_dep ["p4mod"; "use_grammar"] (P "grammar/grammar.cma"); - flag_and_dep ["p4mod"; "use_constr"] (P "grammar/q_constr.cmo"); - - flag_and_dep ["p4mod"; "use_compat5"] (P "tools/compat5.cmo"); - flag_and_dep ["p4mod"; "use_compat5b"] (P "tools/compat5b.cmo"); - - if w32 then begin - flag ["p4mod"] (A "-DWIN32"); - dep ["ocaml"; "link"; "ide"] ["ide/ide_win32_stubs.o"]; - end; - - if not use_camlp5 then begin - let mlp_cmo s = - let src=s^".mlp" and dst=s^".cmo" in - rule (src^".cmo") ~dep:src ~prod:dst ~insert:`top - (fun env _ -> - Cmd (S [!Options.ocamlc; A"-c"; A"-pp"; - Quote (S [camlp4o;A"-impl"]); camlp4incl; A"-impl"; P src])) - in - mlp_cmo "tools/compat5"; - mlp_cmo "tools/compat5b"; - end; - -(** All caml files are compiled with +camlp4/5 - and ide files need +lablgtk2 *) - - flag ["compile"; "ocaml"] (S [A"-thread";A"-rectypes"; camlp4incl]); - flag ["link"; "ocaml"] (S [A"-rectypes"; camlp4incl]); - flag ["ocaml"; "ide"; "compile"] lablgtkincl; - flag ["ocaml"; "ide"; "link"] lablgtkincl; - flag ["ocaml"; "ide"; "link"; "byte"] - (S [A"lablgtk.cma"; A"lablgtksourceview2.cma"]); - flag ["ocaml"; "ide"; "link"; "native"] - (S [A"lablgtk.cmxa"; A"lablgtksourceview2.cmxa"]); - -(** C code for the VM *) - - dep ["compile"; "c"] c_headers; - flag ["compile"; "c"] cflags; - dep ["ocaml"; "use_libcoqrun"; "compile"] [libcoqrun]; - dep ["ocaml"; "use_libcoqrun"; "link"; "native"] [libcoqrun]; - flag ["ocaml"; "use_libcoqrun"; "link"; "byte"] (Sh Coq_config.vmbyteflags); - - (* we need to use a different ocamlc. For now we copy the rule *) - if w32 then - rule ".c.o" ~deps:("%.c"::c_headers) ~prod:"%.o" ~insert:`top - (fun env _ -> - let c = env "%.c" in - let o = env "%.o" in - Seq [Cmd (S [P w32ocamlc;cflags;A"-c";Px c]); - mv (Filename.basename o) o]); - -(** VM: Generation of coq_jumbtbl.h and copcodes.ml from coq_instruct.h *) - - rule "coqinstrs" ~dep:coqinstrs ~prods:[coqjumps;copcodes] - (fun _ _ -> - let jmps = ref [] and ops = ref [] and i = ref 0 in - let add_instr instr comma = - if instr = "" then failwith "Empty" else begin - jmps:=sprintf "&&coq_lbl_%s%s \n" instr comma :: !jmps; - ops:=sprintf "let op%s = %d\n" instr !i :: !ops; - incr i - end - in - (** we recognize comma-separated uppercase instruction names *) - let parse_line s = - let b = Scanning.from_string s in - try while true do bscanf b " %[A-Z0-9_]%[,]" add_instr done - with _ -> () - in - List.iter parse_line (read_file coqinstrs); - Seq [Echo (List.rev !jmps, coqjumps); - Echo (List.rev !ops, copcodes)]); - -(** Generation of tolink.ml *) - - rule tolink ~deps:core_mllib ~prod:tolink - (fun _ _ -> - let cat s = String.concat " " (string_list_of_file s) in - let core_mods = String.concat " " (List.map cat core_mllib) in - let core_cmas = String.concat " " core_cma in - Echo (["let copts = \"-cclib -lcoqrun\"\n"; - "let core_libs = \""^core_cmas^"\"\n"; - "let core_objs = \""^core_mods^"\"\n"], - tolink)); - -(** For windows, building coff object file from a .rc (for the icon) *) - - if w32 then rule ".rc.o" ~deps:["%.rc";"ide/coq.ico"] ~prod:"%.o" - (fun env _ -> - let rc = env "%.rc" and o = env "%.o" in - Cmd (S [P w32res;A "--input-format";A "rc";A "--input";P rc; - A "--output-format";A "coff";A "--output"; Px o])); - -(** The windows version of Coqide is now a console-free win32 app, - which moreover contains the Coq icon. If necessary, the mkwinapp - tool can be used later to restore or suppress the console of Coqide. *) - - if w32 then dep ["link"; "ocaml"; "program"; "ide"] [w32ico]; - - if w32 then flag ["link"; "ocaml"; "program"; "ide"] - (S [A "-ccopt"; A "-link -Wl,-subsystem,windows"; P w32ico]); - -(** Coqtop *) - - let () = - let fo = coqtop^".native" and fb = coqtop^".byte" in - let depsall = (if w32 then [w32ico] else [])@[coqmktop_boot;libcoqrun] in - let depso = core_cmxa in - let depsb = core_cma in - let w32flag = - if not w32 then N else S ([A"-camlbin";A w32bin;A "-ccopt";P w32ico]) - in - if opt then rule fo ~prod:fo ~deps:(depsall@depso) ~insert:`top - (cmd [P coqmktop_boot;w32flag;A"-boot";A"-opt";incl fo;A"-thread";camlp4incl;A"-o";Px fo]); - rule fb ~prod:fb ~deps:(depsall@depsb) ~insert:`top - (cmd [P coqmktop_boot;w32flag;A"-boot";A"-top";incl fb;A"-thread";camlp4incl;A"-o";Px fb]); - in - -(** Coq files dependencies *) - - rule "coqdepready" ~stamp:"coqdepready" ~deps:coqdepdeps (fun _ _ -> Nop); - - rule ".v.d" ~prod:"%.v.depends" ~deps:["%.v";coqdep_boot;"coqdepready"] - (fun env _ -> - let v = env "%.v" and vd = env "%.v.depends" in - (** NB: this relies on all .v files being already in _build. *) - Cmd (S [P coqdep_boot;dep_dynlink;P v;Sh">";Px vd])); - -(** Coq files compilation *) - - let coq_build_dep f build = - (** NB: this relies on coqdep producing a single Makefile line - for one .v file, with some specific shape "f.vo ...: f.v deps.vo ..." *) - let src = f^".v" in - let depends = f^".v.depends" in - let rec get_deps keep = function - | [] -> [] - | d::deps when d = src -> get_deps keep deps - | d::deps when keep -> [d] :: get_deps keep deps - | d::deps -> get_deps (String.contains d ':') deps - in - let d = get_deps false (string_list_of_file depends) in - List.iter Outcome.ignore_good (build d) - - in - - let coq_v_rule d init = - let bootflag = if init then A"-noinit" else N in - let gendep = if init then coqtopbest else init_vo in - rule (d^".v.vo") - ~prods:[d^"%.vo";d^"%.glob"] ~deps:[gendep;d^"%.v";d^"%.v.depends"] - (fun env build -> - let f = env (d^"%") in - coq_build_dep f build; - Cmd (S [P coqtopbest;A"-boot";bootflag;A"-compile";Px f])) - in - coq_v_rule "theories/Init/" true; - coq_v_rule "" false; - -(** Generation of _plugin_mod.ml files *) - - rule "_mod.ml" ~prod:"%_plugin_mod.ml" ~dep:"%_plugin.mllib" - (fun env _ -> - let line s = "let _ = Mltop.add_known_module \""^s^"\"\n" in - let mods = - string_list_of_file (env "%_plugin.mllib") @ - [Filename.basename (env "%_plugin")] - in - Echo (List.map line mods, env "%_plugin_mod.ml")); - -(** Rule for native dynlinkable plugins *) - - rule ".cmxa.cmxs" ~prod:"%.cmxs" ~dep:"%.cmxa" - (fun env _ -> - let cmxs = Px (env "%.cmxs") and cmxa = P (env "%.cmxa") in - if os5fix then - Cmd (S [A"../dev/ocamlopt_shared_os5fix.sh"; !Options.ocamlopt; cmxs]) - else - Cmd (S [!Options.ocamlopt;A"-linkall";A"-shared";A"-o";cmxs;cmxa])); - -(** Generation of NMake.v from NMake_gen.ml *) - - rule "NMake" ~prod:nmake ~dep:nmakegen - (cmd [ocaml;P nmakegen;Sh ">";Px nmake]); - -end - -(** Registration of our rules (after the standard ones) *) - -let _ = dispatch begin function - | After_rules -> initial_actions (); extra_rules () - | _ -> () -end - -(** TODO / Remarques: - - * Apres un premier build, le second prend du temps, meme cached: - 1 min 25 pour les 2662 targets en cache. Etonnement, refaire - coqtop.byte ne prend que ~4s, au lieu des ~40s pour coqtop.opt. - A comprendre ... - - * Parallelisation: vraiment pas top - -*) diff --git a/parsing/cLexer.ml4 b/parsing/cLexer.ml4 index 8b8b38c34b..9a7aeaf0ca 100644 --- a/parsing/cLexer.ml4 +++ b/parsing/cLexer.ml4 @@ -199,7 +199,7 @@ let check_keyword str = let check_keyword_to_add s = try check_keyword s with Error.E (UnsupportedUnicode unicode) -> - Flags.if_verbose msg_warning + Flags.if_verbose Feedback.msg_warning (strbrk (Printf.sprintf "Token '%s' contains unicode character 0x%x \ which will not be parsable." s unicode)) @@ -322,7 +322,7 @@ let rec string in_comments bp len = parser | [< '')'; s >] -> let () = match in_comments with | Some 0 -> - msg_warning + Feedback.msg_warning (strbrk "Not interpreting \"*)\" as the end of current \ non-terminated comment because it occurs in a \ @@ -389,9 +389,10 @@ let comment_stop ep = let bp = match !comment_begin with Some bp -> bp | None -> - msgerrnl(str "No begin location for comment '" - ++ str current_s ++str"' ending at " - ++ int ep); + Feedback.msg_notice + (str "No begin location for comment '" + ++ str current_s ++str"' ending at " + ++ int ep); ep-1 in Pp.comments := ((bp,ep),current_s) :: !Pp.comments); Buffer.clear current; diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 1a27d96922..36fffd74fa 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -338,9 +338,6 @@ GEXTEND Gram ExplicitBindings bl | bl = LIST1 constr -> ImplicitBindings bl ] ] ; - opt_bindings: - [ [ bl = LIST1 bindings SEP "," -> bl | -> [NoBindings] ] ] - ; constr_with_bindings: [ [ c = constr; l = with_bindings -> (c, l) ] ] ; @@ -473,10 +470,10 @@ GEXTEND Gram [ [ IDENT "eqn"; ":"; pat = naming_intropattern -> Some (!@loc, pat) | IDENT "_eqn"; ":"; pat = naming_intropattern -> let msg = "Obsolete syntax \"_eqn:H\" could be replaced by \"eqn:H\"" in - msg_warning (strbrk msg); Some (!@loc, pat) + Feedback.msg_warning (strbrk msg); Some (!@loc, pat) | IDENT "_eqn" -> let msg = "Obsolete syntax \"_eqn\" could be replaced by \"eqn:?\"" in - msg_warning (strbrk msg); Some (!@loc, IntroAnonymous) + Feedback.msg_warning (strbrk msg); Some (!@loc, IntroAnonymous) | -> None ] ] ; as_name: @@ -531,13 +528,6 @@ GEXTEND Gram TacAtom (!@loc, TacIntroPattern pl) | IDENT "intros" -> TacAtom (!@loc, TacIntroPattern [!@loc,IntroForthcoming false]) - | IDENT "intro"; id = ident; hto = move_location -> - TacAtom (!@loc, TacIntroMove (Some id, hto)) - | IDENT "intro"; hto = move_location -> TacAtom (!@loc, TacIntroMove (None, hto)) - | IDENT "intro"; id = ident -> TacAtom (!@loc, TacIntroMove (Some id, MoveLast)) - | IDENT "intro" -> TacAtom (!@loc, TacIntroMove (None, MoveLast)) - - | IDENT "exact"; c = constr -> TacAtom (!@loc, TacExact c) | IDENT "apply"; cl = LIST1 constr_with_bindings_arg SEP ","; inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (true,false,cl,inhyp)) @@ -609,16 +599,11 @@ GEXTEND Gram TacAtom (!@loc, TacInductionDestruct (true,false,ic)) | IDENT "einduction"; ic = induction_clause_list -> TacAtom (!@loc, TacInductionDestruct(true,true,ic)) - | IDENT "double"; IDENT "induction"; h1 = quantified_hypothesis; - h2 = quantified_hypothesis -> TacAtom (!@loc, TacDoubleInduction (h1,h2)) | IDENT "destruct"; icl = induction_clause_list -> TacAtom (!@loc, TacInductionDestruct(false,false,icl)) | IDENT "edestruct"; icl = induction_clause_list -> TacAtom (!@loc, TacInductionDestruct(false,true,icl)) - (* Context management *) - | IDENT "rename"; l = LIST1 rename SEP "," -> TacAtom (!@loc, TacRename l) - (* Equality and inversion *) | IDENT "rewrite"; l = LIST1 oriented_rewriter SEP ","; cl = clause_dft_concl; t=opt_by_tactic -> TacAtom (!@loc, TacRewrite (false,l,cl,t)) diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index df42d90847..0df15babd1 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -125,13 +125,13 @@ END let test_plural_form = function | [(_,([_],_))] -> - Flags.if_verbose msg_warning + Flags.if_verbose Feedback.msg_warning (strbrk "Keywords Variables/Hypotheses/Parameters expect more than one assumption") | _ -> () let test_plural_form_types = function | [([_],_)] -> - Flags.if_verbose msg_warning + Flags.if_verbose Feedback.msg_warning (strbrk "Keywords Implicit Types expect more than one type") | _ -> () @@ -448,7 +448,7 @@ GEXTEND Gram VernacInclude(e::l) | IDENT "Include"; "Type"; e = module_type_inl; l = LIST0 ext_module_type -> Flags.if_verbose - msg_warning (strbrk "Include Type is deprecated; use Include instead"); + Feedback.msg_warning (strbrk "Include Type is deprecated; use Include instead"); VernacInclude(e::l) ] ] ; export_token: @@ -667,7 +667,7 @@ GEXTEND Gram (* 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 ]; "]" -> - msg_warning (strbrk "Arguments Scope is deprecated; use Arguments instead"); + Feedback. msg_warning (strbrk "Arguments Scope is deprecated; use Arguments instead"); VernacArgumentsScope (qid,scl) (* Implicit *) @@ -675,7 +675,7 @@ GEXTEND Gram pos = LIST0 [ "["; l = LIST0 implicit_name; "]" -> List.map (fun (id,b,f) -> (ExplByName id,b,f)) l ] -> Flags.if_verbose - msg_warning (strbrk "Implicit Arguments is deprecated; use Arguments instead"); + Feedback.msg_warning (strbrk "Implicit Arguments is deprecated; use Arguments instead"); VernacDeclareImplicits (qid,pos) | IDENT "Implicit"; "Type"; bl = reserv_list -> diff --git a/plugins/btauto/btauto_plugin.mllib b/plugins/btauto/btauto_plugin.mlpack index 319a9c302a..2410f906a3 100644 --- a/plugins/btauto/btauto_plugin.mllib +++ b/plugins/btauto/btauto_plugin.mlpack @@ -1,3 +1,2 @@ Refl_btauto G_btauto -Btauto_plugin_mod diff --git a/plugins/cc/cc_plugin.mllib b/plugins/cc/cc_plugin.mlpack index 1bcfc5378b..27e903fd38 100644 --- a/plugins/cc/cc_plugin.mllib +++ b/plugins/cc/cc_plugin.mlpack @@ -2,4 +2,3 @@ Ccalgo Ccproof Cctac G_congruence -Cc_plugin_mod diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 898dcd2551..76db2f3c2f 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -25,7 +25,7 @@ let init_size=5 let cc_verbose=ref false let debug x = - if !cc_verbose then msg_debug (x ()) + if !cc_verbose then Feedback.msg_debug (x ()) let _= let gdopt= diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index c8924073c7..bd788a425a 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -424,10 +424,10 @@ let cc_tactic depth additionnal_terms = List.map (build_term_to_complete uf newmeta) (epsilons uf) in - Pp.msg_info + Feedback.msg_info (Pp.str "Goal is solvable by congruence but \ some arguments are missing."); - Pp.msg_info + Feedback.msg_info (Pp.str " Try " ++ hov 8 begin diff --git a/plugins/decl_mode/decl_mode_plugin.mllib b/plugins/decl_mode/decl_mode_plugin.mlpack index 39342dbd1c..1b84a0790f 100644 --- a/plugins/decl_mode/decl_mode_plugin.mllib +++ b/plugins/decl_mode/decl_mode_plugin.mlpack @@ -3,4 +3,3 @@ Decl_interp Decl_proof_instr Ppdecl_proof G_decl_mode -Decl_mode_plugin_mod diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index be6ce59bd3..3fa600ac29 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -169,7 +169,7 @@ let do_daimon () = daimon_instr env p end in - if not status then Pp.feedback Feedback.AddedAxiom else () + if not status then Feedback.feedback Feedback.AddedAxiom else () (* post-instruction focus management *) @@ -291,7 +291,7 @@ let justification tac gls= error "Insufficient justification." else begin - msg_warning (str "Insufficient justification."); + Feedback.msg_warning (str "Insufficient justification."); daimon_tac gls end) gls @@ -1293,7 +1293,7 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls = end; match bro with None -> - msg_warning (str "missing case"); + Feedback.msg_warning (str "missing case"); tacnext (mkMeta 1) | Some (sub_ids,tree) -> let br_args = diff --git a/plugins/decl_mode/g_decl_mode.ml4 b/plugins/decl_mode/g_decl_mode.ml4 index 78a95143df..73d3d1bab8 100644 --- a/plugins/decl_mode/g_decl_mode.ml4 +++ b/plugins/decl_mode/g_decl_mode.ml4 @@ -8,6 +8,8 @@ (*i camlp4deps: "grammar/grammar.cma" i*) +DECLARE PLUGIN "decl_mode_plugin" + open Compat open Pp open Decl_expr @@ -98,7 +100,7 @@ let _ = Pptactic.declare_extra_genarg_pprule wit_proof_instr let classify_proof_instr = function | { instr = Pescape |Pend B_proof } -> VtProofMode "Classic", VtNow - | _ -> VtProofStep false, VtLater + | _ -> Vernac_classifier.classify_as_proofstep (* We use the VERNAC EXTEND facility with a custom non-terminal to populate [proof_mode] with a new toplevel interpreter. diff --git a/plugins/derive/derive_plugin.mllib b/plugins/derive/derive_plugin.mlpack index 5ee0fc6da6..5ee0fc6da6 100644 --- a/plugins/derive/derive_plugin.mllib +++ b/plugins/derive/derive_plugin.mlpack diff --git a/plugins/derive/g_derive.ml4 b/plugins/derive/g_derive.ml4 index 39cad4d03c..d4dc7e0eed 100644 --- a/plugins/derive/g_derive.ml4 +++ b/plugins/derive/g_derive.ml4 @@ -10,6 +10,8 @@ open Constrarg (*i camlp4deps: "grammar/grammar.cma" i*) +DECLARE PLUGIN "derive_plugin" + let classify_derive_command _ = Vernacexpr.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]),VtLater) VERNAC COMMAND EXTEND Derive CLASSIFIED BY classify_derive_command diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml index bb9e8e5f5b..3c5f6cb720 100644 --- a/plugins/extraction/common.ml +++ b/plugins/extraction/common.ml @@ -17,8 +17,8 @@ open Table open Miniml open Mlutil -let string_of_id id = - let s = Names.Id.to_string id in +let ascii_of_id id = + let s = Id.to_string id in for i = 0 to String.length s - 2 do if s.[i] == '_' && s.[i+1] == '_' then warning_id s done; @@ -73,18 +73,19 @@ let fnl2 () = fnl () ++ fnl () let space_if = function true -> str " " | false -> mt () -let is_digit = function - | '0'..'9' -> true - | _ -> false +let begins_with s prefix = + let len = String.length prefix in + String.length s >= len && String.equal (String.sub s 0 len) prefix let begins_with_CoqXX s = let n = String.length s in n >= 4 && s.[0] == 'C' && s.[1] == 'o' && s.[2] == 'q' && let i = ref 3 in try while !i < n do - if s.[!i] == '_' then i:=n (*Stop*) - else if is_digit s.[!i] then incr i - else raise Not_found + match s.[!i] with + | '_' -> i:=n (*Stop*) + | '0'..'9' -> incr i + | _ -> raise Not_found done; true with Not_found -> false @@ -109,9 +110,9 @@ let pseudo_qualify = qualify "__" let is_upper s = match s.[0] with 'A' .. 'Z' -> true | _ -> false let is_lower s = match s.[0] with 'a' .. 'z' | '_' -> true | _ -> false -let lowercase_id id = Id.of_string (String.uncapitalize (string_of_id id)) +let lowercase_id id = Id.of_string (String.uncapitalize (ascii_of_id id)) let uppercase_id id = - let s = string_of_id id in + let s = ascii_of_id id in assert (not (String.is_empty s)); if s.[0] == '_' then Id.of_string ("Coq_"^s) else Id.of_string (String.capitalize s) @@ -331,13 +332,10 @@ let reset_renaming_tables flag = existing. *) let modular_rename k id = - let s = string_of_id id in - let prefix,is_ok = - if upperkind k then "Coq_",is_upper else "coq_",is_lower + let s = ascii_of_id id in + let prefix,is_ok = if upperkind k then "Coq_",is_upper else "coq_",is_lower in - if not (is_ok s) || - (Id.Set.mem id (get_keywords ())) || - (String.length s >= 4 && String.equal (String.sub s 0 4) prefix) + if not (is_ok s) || Id.Set.mem id (get_keywords ()) || begins_with s prefix then prefix ^ s else s @@ -345,21 +343,20 @@ let modular_rename k id = with unique numbers *) let modfstlev_rename = - let add_prefixes,get_prefixes,_ = mktable_id true in + let add_index,get_index,_ = mktable_id true in fun l -> - let coqid = Id.of_string "Coq" in let id = Label.to_id l in try - let coqset = get_prefixes id in - let nextcoq = next_ident_away coqid coqset in - add_prefixes id (nextcoq::coqset); - (string_of_id nextcoq)^"_"^(string_of_id id) + let n = get_index id in + add_index id (n+1); + let s = if n == 0 then "" else string_of_int (n-1) in + "Coq"^s^"_"^(ascii_of_id id) with Not_found -> - let s = string_of_id id in + let s = ascii_of_id id in if is_lower s || begins_with_CoqXX s then - (add_prefixes id [coqid]; "Coq_"^s) + (add_index id 1; "Coq_"^s) else - (add_prefixes id []; s) + (add_index id 0; s) (*s Creating renaming for a [module_path] : first, the real function ... *) @@ -404,7 +401,7 @@ let ref_renaming_fun (k,r) = | [""] -> (* this happens only at toplevel of the monolithic case *) let globs = Id.Set.elements (get_global_ids ()) in let id = next_ident_away (kindcase_id k idg) globs in - string_of_id id + Id.to_string id | _ -> modular_rename k idg in add_global_ids (Id.of_string s); @@ -562,7 +559,7 @@ let pp_ocaml_extern k base rls = match rls with (* Standard situation : object in an opened file *) dottify rls' -(* [pp_ocaml_gen] : choosing between [pp_ocaml_extern] or [pp_ocaml_extern] *) +(* [pp_ocaml_gen] : choosing between [pp_ocaml_local] or [pp_ocaml_extern] *) let pp_ocaml_gen k mp rls olab = match common_prefix_from_list mp (get_visible_mps ()) with @@ -579,8 +576,7 @@ let pp_haskell_gen k mp rls = match rls with | s::rls' -> let str = pseudo_qualify rls' in let str = if is_upper str && not (upperkind k) then ("_"^str) else str in - let prf = if not (ModPath.equal (base_mp mp) (top_visible_mp ())) then s ^ "." else "" in - prf ^ str + if ModPath.equal (base_mp mp) (top_visible_mp ()) then str else s^"."^str (* Main name printing function for a reference *) diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 67c1c59017..a03be5743f 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -541,7 +541,7 @@ let print_structure_to_file (fn,si,mo) dry struc = (if dry then None else si); (* Print the buffer content via Coq standard formatter (ok with coqide). *) if not (Int.equal (Buffer.length buf) 0) then begin - Pp.msg_notice (str (Buffer.contents buf)); + Feedback.msg_notice (str (Buffer.contents buf)); Buffer.reset buf end @@ -635,7 +635,7 @@ let simple_extraction r = in let ans = flag ++ print_one_decl struc (modpath_of_r r) d in reset (); - Pp.msg_notice ans + Feedback.msg_notice ans | _ -> assert false diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 098f76bbfb..e40621965f 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -35,17 +35,18 @@ let current_fixpoints = ref ([] : constant list) let none = Evd.empty +(* NB: In OCaml, [type_of] and [get_of] might raise + [SingletonInductiveBecomeProp]. this exception will be catched + in late wrappers around the exported functions of this file, + in order to display the location of the issue. *) + let type_of env c = - try - let polyprop = (lang() == Haskell) in - Retyping.get_type_of ~polyprop env none (strip_outer_cast c) - with SingletonInductiveBecomesProp id -> error_singleton_become_prop id + let polyprop = (lang() == Haskell) in + Retyping.get_type_of ~polyprop env none (strip_outer_cast c) let sort_of env c = - try - let polyprop = (lang() == Haskell) in - Retyping.get_sort_family_of ~polyprop env none (strip_outer_cast c) - with SingletonInductiveBecomesProp id -> error_singleton_become_prop id + let polyprop = (lang() == Haskell) in + Retyping.get_sort_family_of ~polyprop env none (strip_outer_cast c) (*S Generation of flags and signatures. *) @@ -328,11 +329,22 @@ and extract_type_scheme env db c p = (*S Extraction of an inductive type. *) +(* First, a version with cache *) + and extract_ind env kn = (* kn is supposed to be in long form *) let mib = Environ.lookup_mind kn env in match lookup_ind kn mib with | Some ml_ind -> ml_ind | None -> + try + extract_really_ind env kn mib + with SingletonInductiveBecomesProp id -> + (* TODO : which inductive is concerned in the block ? *) + error_singleton_become_prop id (Some (IndRef (kn,0))) + +(* Then the real function *) + +and extract_really_ind env kn mib = (* First, if this inductive is aliased via a Module, we process the original inductive if possible. When at toplevel of the monolithic case, we cannot do much @@ -934,11 +946,13 @@ let extract_fixpoint env vkn (fi,ti,ci) = (* for replacing recursive calls [Rel ..] by the corresponding [Const]: *) let sub = List.rev_map mkConst kns in for i = 0 to n-1 do - if sort_of env ti.(i) != InProp then begin - let e,t = extract_std_constant env vkn.(i) (substl sub ci.(i)) ti.(i) in - terms.(i) <- e; - types.(i) <- t; - end + if sort_of env ti.(i) != InProp then + try + let e,t = extract_std_constant env vkn.(i) (substl sub ci.(i)) ti.(i) in + terms.(i) <- e; + types.(i) <- t; + with SingletonInductiveBecomesProp id -> + error_singleton_become_prop id (Some (ConstRef vkn.(i))) done; current_fixpoints := []; Dfix (Array.map (fun kn -> ConstRef kn) vkn, terms, types) @@ -968,13 +982,17 @@ let extract_constant env kn cb = let e,t = extract_std_constant env kn c typ in Dterm (r,e,t) in - match flag_of_type env typ with + try + match flag_of_type env typ with | (Logic,TypeScheme) -> warn_log (); Dtype (r, [], Tdummy Ktype) | (Logic,Default) -> warn_log (); Dterm (r, MLdummy Kprop, Tdummy Kprop) | (Info,TypeScheme) -> (match cb.const_body with | Undef _ -> warn_info (); mk_typ_ax () - | Def c -> mk_typ (Mod_subst.force_constr c) + | Def c -> + (match cb.const_proj with + | None -> mk_typ (Mod_subst.force_constr c) + | Some pb -> mk_typ pb.proj_body) | OpaqueDef c -> add_opaque r; if access_opaque () then @@ -983,17 +1001,23 @@ let extract_constant env kn cb = | (Info,Default) -> (match cb.const_body with | Undef _ -> warn_info (); mk_ax () - | Def c -> mk_def (Mod_subst.force_constr c) + | Def c -> + (match cb.const_proj with + | None -> mk_def (Mod_subst.force_constr c) + | Some pb -> mk_def pb.proj_body) | OpaqueDef c -> add_opaque r; if access_opaque () then mk_def (Opaqueproof.force_proof (Environ.opaque_tables env) c) else mk_ax ()) + with SingletonInductiveBecomesProp id -> + error_singleton_become_prop id (Some (ConstRef kn)) let extract_constant_spec env kn cb = let r = ConstRef kn in let typ = Typeops.type_of_constant_type env cb.const_type in - match flag_of_type env typ with + try + match flag_of_type env typ with | (Logic, TypeScheme) -> Stype (r, [], Some (Tdummy Ktype)) | (Logic, Default) -> Sval (r, Tdummy Kprop) | (Info, TypeScheme) -> @@ -1008,26 +1032,34 @@ let extract_constant_spec env kn cb = | (Info, Default) -> let t = snd (record_constant_type env kn (Some typ)) in Sval (r, type_expunge env t) + with SingletonInductiveBecomesProp id -> + error_singleton_become_prop id (Some (ConstRef kn)) let extract_with_type env c = - let typ = type_of env c in - match flag_of_type env typ with + try + let typ = type_of env c in + match flag_of_type env typ with | (Info, TypeScheme) -> let s,vl = type_sign_vl env typ in let db = db_from_sign s in let t = extract_type_scheme env db c (List.length s) in Some (vl, t) | _ -> None + with SingletonInductiveBecomesProp id -> + error_singleton_become_prop id None let extract_constr env c = reset_meta_count (); - let typ = type_of env c in - match flag_of_type env typ with + try + let typ = type_of env c in + match flag_of_type env typ with | (_,TypeScheme) -> MLdummy Ktype, Tdummy Ktype | (Logic,_) -> MLdummy Kprop, Tdummy Kprop | (Info,Default) -> - let mlt = extract_type env [] 1 typ [] in - extract_term env Mlenv.empty mlt c [], mlt + let mlt = extract_type env [] 1 typ [] in + extract_term env Mlenv.empty mlt c [], mlt + with SingletonInductiveBecomesProp id -> + error_singleton_become_prop id None let extract_inductive env kn = let ind = extract_ind env kn in diff --git a/plugins/extraction/extraction_plugin.mllib b/plugins/extraction/extraction_plugin.mlpack index ad32124347..9184f65017 100644 --- a/plugins/extraction/extraction_plugin.mllib +++ b/plugins/extraction/extraction_plugin.mlpack @@ -9,4 +9,3 @@ Scheme Json Extract_env G_extraction -Extraction_plugin_mod diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.ml4 index eb2f022443..19fda4aead 100644 --- a/plugins/extraction/g_extraction.ml4 +++ b/plugins/extraction/g_extraction.ml4 @@ -8,6 +8,8 @@ (*i camlp4deps: "grammar/grammar.cma" i*) +DECLARE PLUGIN "extraction_plugin" + (* ML names *) open Genarg @@ -101,7 +103,7 @@ END VERNAC COMMAND EXTEND PrintExtractionInline CLASSIFIED AS QUERY | [ "Print" "Extraction" "Inline" ] - -> [ msg_info (print_extraction_inline ()) ] + -> [Feedback. msg_info (print_extraction_inline ()) ] END VERNAC COMMAND EXTEND ResetExtractionInline CLASSIFIED AS SIDEFF @@ -123,7 +125,7 @@ END VERNAC COMMAND EXTEND PrintExtractionBlacklist CLASSIFIED AS QUERY | [ "Print" "Extraction" "Blacklist" ] - -> [ msg_info (print_extraction_blacklist ()) ] + -> [ Feedback.msg_info (print_extraction_blacklist ()) ] END VERNAC COMMAND EXTEND ResetExtractionBlacklist CLASSIFIED AS SIDEFF diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index 466c8054b8..560fe5aea8 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -300,7 +300,7 @@ let warning_axioms () = if List.is_empty info_axioms then () else begin let s = if Int.equal (List.length info_axioms) 1 then "axiom" else "axioms" in - msg_warning + Feedback.msg_warning (str ("The following "^s^" must be realized in the extracted code:") ++ hov 1 (spc () ++ prlist_with_sep spc safe_pr_global info_axioms) ++ str "." ++ fnl ()) @@ -310,7 +310,7 @@ let warning_axioms () = else begin let s = if Int.equal (List.length log_axioms) 1 then "axiom was" else "axioms were" in - msg_warning + Feedback.msg_warning (str ("The following logical "^s^" encountered:") ++ hov 1 (spc () ++ prlist_with_sep spc safe_pr_global log_axioms ++ str ".\n") @@ -326,12 +326,12 @@ let warning_opaques accessed = else let lst = hov 1 (spc () ++ prlist_with_sep spc safe_pr_global opaques) in if accessed then - msg_warning + Feedback.msg_warning (str "The extraction is currently set to bypass opacity,\n" ++ str "the following opaque constant bodies have been accessed :" ++ lst ++ str "." ++ fnl ()) else - msg_warning + Feedback.msg_warning (str "The extraction now honors the opacity constraints by default,\n" ++ str "the following opaque constants have been extracted as axioms :" ++ lst ++ str "." ++ fnl () ++ @@ -339,7 +339,7 @@ let warning_opaques accessed = ++ fnl ()) let warning_both_mod_and_cst q mp r = - msg_warning + Feedback.msg_warning (str "The name " ++ pr_qualid q ++ str " is ambiguous, " ++ str "do you mean module " ++ pr_long_mp mp ++ @@ -358,7 +358,7 @@ let check_inside_module () = err (str "You can't do that within a Module Type." ++ fnl () ++ str "Close it and try again.") else if Lib.is_module () then - msg_warning + Feedback.msg_warning (str "Extraction inside an opened module is experimental.\n" ++ str "In case of problem, close it first.\n") @@ -368,7 +368,7 @@ let check_inside_section () = str "Close it and try again.") let warning_id s = - msg_warning (str ("The identifier "^s^ + Feedback.msg_warning (str ("The identifier "^s^ " contains __ which is reserved for the extraction")) let error_constant r = @@ -391,9 +391,15 @@ let error_no_module_expr mp = ++ str "some Declare Module outside any Module Type.\n" ++ str "This situation is currently unsupported by the extraction.") -let error_singleton_become_prop id = +let error_singleton_become_prop id og = + let loc = + match og with + | Some g -> fnl () ++ str "in " ++ safe_pr_global g ++ + str " (or in its mutual block)" + | None -> mt () + in err (str "The informative inductive type " ++ pr_id id ++ - str " has a Prop instance.\n" ++ + str " has a Prop instance" ++ loc ++ str "." ++ fnl () ++ str "This happens when a sort-polymorphic singleton inductive type\n" ++ str "has logical parameters, such as (I,I) : (True * True) : Prop.\n" ++ str "The Ocaml extraction cannot handle this situation yet.\n" ++ @@ -443,7 +449,7 @@ let error_remaining_implicit k = let warning_remaining_implicit k = let s = msg_of_implicit k in - msg_warning + Feedback.msg_warning (str ("At least an implicit occurs after extraction : "^s^".") ++ fnl () ++ str "Extraction SafeImplicits is unset, extracting nonetheless," ++ fnl () ++ str "but this code is potentially unsafe, please review it manually.") @@ -459,7 +465,7 @@ let check_loaded_modfile mp = match base_mp mp with | _ -> () let info_file f = - Flags.if_verbose msg_info + Flags.if_verbose Feedback.msg_info (str ("The file "^f^" has been created by extraction.")) diff --git a/plugins/extraction/table.mli b/plugins/extraction/table.mli index 2b163610e9..62c20bd3a7 100644 --- a/plugins/extraction/table.mli +++ b/plugins/extraction/table.mli @@ -30,7 +30,7 @@ val error_inductive : global_reference -> 'a val error_nb_cons : unit -> 'a val error_module_clash : module_path -> module_path -> 'a val error_no_module_expr : module_path -> 'a -val error_singleton_become_prop : Id.t -> 'a +val error_singleton_become_prop : Id.t -> global_reference option -> 'a val error_unknown_module : qualid -> 'a val error_scheme : unit -> 'a val error_not_visible : global_reference -> 'a diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4 index 134b6ba947..cec3505a97 100644 --- a/plugins/firstorder/g_ground.ml4 +++ b/plugins/firstorder/g_ground.ml4 @@ -74,7 +74,7 @@ END VERNAC COMMAND EXTEND Firstorder_Print_Solver CLASSIFIED AS QUERY | [ "Print" "Firstorder" "Solver" ] -> [ - Pp.msg_info + Feedback.msg_info (Pp.(++) (Pp.str"Firstorder solver tactic is ") (print_default_solver ())) ] END @@ -131,7 +131,7 @@ ARGUMENT EXTEND firstorder_using | [ "using" reference(a) "," ne_reference_list_sep(l,",") ] -> [ a::l ] | [ "using" reference(a) reference(b) reference_list(l) ] -> [ Flags.if_verbose - Pp.msg_warning (Pp.str "Deprecated syntax; use \",\" as separator"); + Feedback.msg_warning (Pp.str "Deprecated syntax; use \",\" as separator"); a::b::l ] | [ ] -> [ [] ] @@ -153,6 +153,8 @@ TACTIC EXTEND gintuition END open Proofview.Notations +open Cc_plugin +open Decl_mode_plugin let default_declarative_automation = Proofview.tclUNIT () >>= fun () -> (* delay for [congruence_depth] *) diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index 3b9f67f664..d7da85b4f4 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -32,7 +32,7 @@ let ground_tac solver startseq gl= update_flags (); let rec toptac skipped seq gl= if Tacinterp.get_debug()=Tactic_debug.DebugOn 0 - then Pp.msg_debug (Printer.pr_goal gl); + then Feedback.msg_debug (Printer.pr_goal gl); tclORELSE (axiom_tac seq.gl seq) begin try diff --git a/plugins/firstorder/ground_plugin.mllib b/plugins/firstorder/ground_plugin.mlpack index 447a1fb513..65fb2e9a1d 100644 --- a/plugins/firstorder/ground_plugin.mllib +++ b/plugins/firstorder/ground_plugin.mlpack @@ -5,4 +5,3 @@ Rules Instances Ground G_ground -Ground_plugin_mod diff --git a/plugins/fourier/fourier_plugin.mllib b/plugins/fourier/fourier_plugin.mlpack index 0383b1a80b..b6262f8aeb 100644 --- a/plugins/fourier/fourier_plugin.mllib +++ b/plugins/fourier/fourier_plugin.mlpack @@ -1,4 +1,3 @@ Fourier FourierR G_fourier -Fourier_plugin_mod diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 879145c2fa..52094cf085 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -52,17 +52,17 @@ let rec print_debug_queue e = let _ = match e with | Some e -> - Pp.msg_debug (hov 0 (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal" ++ fnl() ++ goal)) + Feedback.msg_debug (hov 0 (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal" ++ fnl() ++ goal)) | None -> begin - Pp.msg_debug (str " from " ++ lmsg ++ str " on goal" ++ fnl() ++ goal); + Feedback.msg_debug (str " from " ++ lmsg ++ str " on goal" ++ fnl() ++ goal); end in print_debug_queue None ; end let observe strm = if do_observe () - then Pp.msg_debug strm + then Feedback.msg_debug strm else () let do_observe_tac s tac g = diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 91a826c731..5b4fb25955 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -19,7 +19,7 @@ exception Toberemoved let observe s = if do_observe () - then Pp.msg_debug s + then Feedback.msg_debug s (* Transform an inductive induction principle into diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 6dfc23511e..c63527deaf 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -193,12 +193,12 @@ let warning_error names e = let (e, _) = Cerrors.process_vernac_interp_error (e, Exninfo.null) in match e with | Building_graph e -> - Pp.msg_warning + Feedback.msg_warning (str "Cannot define graph(s) for " ++ h 1 (pr_enum Libnames.pr_reference names) ++ if do_observe () then (spc () ++ Errors.print e) else mt ()) | Defining_principle e -> - Pp.msg_warning + Feedback.msg_warning (str "Cannot define principle(s) for "++ h 1 (pr_enum Libnames.pr_reference names) ++ if do_observe () then Errors.print e else mt ()) diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 8a0a1a064d..c424fe1226 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -14,7 +14,7 @@ open Misctypes let observe strm = if do_observe () - then Pp.msg_debug strm + then Feedback.msg_debug strm else () (*let observennl strm = if do_observe () @@ -1217,7 +1217,7 @@ let compute_params_name relnames (args : (Name.t * Glob_term.glob_constr * bool) if Array.for_all (fun l -> let (n',nt',is_defined') = List.nth l i in - Name.equal n n' && Notation_ops.eq_glob_constr nt nt' && (is_defined : bool) == is_defined') + Name.equal n n' && glob_constr_eq nt nt' && (is_defined : bool) == is_defined') rels_params then l := param::!l diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 84a4d910ef..0cacb003d8 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -267,12 +267,12 @@ let derive_inversion fix_names = lind; with e when Errors.noncritical e -> let e' = process_vernac_interp_error e in - msg_warning + Feedback.msg_warning (str "Cannot build inversion information" ++ if do_observe () then (fnl() ++ Errors.print e') else mt ()) with e when Errors.noncritical e -> let e' = process_vernac_interp_error e in - msg_warning + Feedback.msg_warning (str "Cannot build inversion information (early)" ++ if do_observe () then (fnl() ++ Errors.print e') else mt ()) @@ -292,12 +292,12 @@ let warning_error names e = in match e with | Building_graph e -> - Pp.msg_warning + Feedback.msg_warning (str "Cannot define graph(s) for " ++ h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ e_explain e) | Defining_principle e -> - Pp.msg_warning + Feedback.msg_warning (str "Cannot define principle(s) for "++ h 1 (prlist_with_sep (fun _ -> str","++spc ()) Ppconstr.pr_id names) ++ e_explain e) diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 72529fbbe3..94530bfde2 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -53,7 +53,7 @@ let pr_constr_with_binding prc (c,bl) : Pp.std_ppcmds = let observe strm = if do_observe () - then Pp.msg_debug strm + then Feedback.msg_debug strm else () (*let observennl strm = diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index c71d9a9ca4..99a165044c 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -504,19 +504,19 @@ let rec merge_app c1 c2 id1 id2 shift filter_shift_stable = let lnk = Array.append shift.lnk1 shift.lnk2 in match c1 , c2 with | GApp(_,f1, arr1), GApp(_,f2,arr2) when isVarf id1 f1 && isVarf id2 f2 -> - let _ = prstr "\nICI1!\n";Pp.flush_all() in + let _ = prstr "\nICI1!\n" in let args = filter_shift_stable lnk (arr1 @ arr2) in GApp (Loc.ghost,GVar (Loc.ghost,shift.ident) , args) | GApp(_,f1, arr1), GApp(_,f2,arr2) -> raise NoMerge | GLetIn(_,nme,bdy,trm) , _ -> - let _ = prstr "\nICI2!\n";Pp.flush_all() in + let _ = prstr "\nICI2!\n" in let newtrm = merge_app trm c2 id1 id2 shift filter_shift_stable in GLetIn(Loc.ghost,nme,bdy,newtrm) | _, GLetIn(_,nme,bdy,trm) -> - let _ = prstr "\nICI3!\n";Pp.flush_all() in + let _ = prstr "\nICI3!\n" in let newtrm = merge_app c1 trm id1 id2 shift filter_shift_stable in GLetIn(Loc.ghost,nme,bdy,newtrm) - | _ -> let _ = prstr "\nICI4!\n";Pp.flush_all() in + | _ -> let _ = prstr "\nICI4!\n" in raise NoMerge let rec merge_app_unsafe c1 c2 shift filter_shift_stable = @@ -527,14 +527,14 @@ let rec merge_app_unsafe c1 c2 shift filter_shift_stable = GApp (Loc.ghost,GVar(Loc.ghost,shift.ident) , args) (* FIXME: what if the function appears in the body of the let? *) | GLetIn(_,nme,bdy,trm) , _ -> - let _ = prstr "\nICI2 '!\n";Pp.flush_all() in + let _ = prstr "\nICI2 '!\n" in let newtrm = merge_app_unsafe trm c2 shift filter_shift_stable in GLetIn(Loc.ghost,nme,bdy,newtrm) | _, GLetIn(_,nme,bdy,trm) -> - let _ = prstr "\nICI3 '!\n";Pp.flush_all() in + let _ = prstr "\nICI3 '!\n" in let newtrm = merge_app_unsafe c1 trm shift filter_shift_stable in GLetIn(Loc.ghost,nme,bdy,newtrm) - | _ -> let _ = prstr "\nICI4 '!\n";Pp.flush_all() in raise NoMerge + | _ -> let _ = prstr "\nICI4 '!\n" in raise NoMerge diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 10f08d3d13..95b4967faa 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -214,17 +214,17 @@ let print_debug_queue b e = begin let lmsg,goal = Stack.pop debug_queue in if b then - Pp.msg_debug (hov 1 (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal" ++ fnl() ++ goal)) + Feedback.msg_debug (hov 1 (lmsg ++ (str " raised exception " ++ Errors.print e) ++ str " on goal" ++ fnl() ++ goal)) else begin - Pp.msg_debug (hov 1 (str " from " ++ lmsg ++ str " on goal"++fnl() ++ goal)); + Feedback.msg_debug (hov 1 (str " from " ++ lmsg ++ str " on goal"++fnl() ++ goal)); end; (* print_debug_queue false e; *) end let observe strm = if do_observe () - then Pp.msg_debug strm + then Feedback.msg_debug strm else () @@ -1529,7 +1529,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let hook _ _ = let term_ref = Nametab.locate (qualid_of_ident term_id) in let f_ref = declare_f function_name (IsProof Lemma) arg_types term_ref in - let _ = Table.extraction_inline true [Ident (Loc.ghost,term_id)] in + let _ = Extraction_plugin.Table.extraction_inline true [Ident (Loc.ghost,term_id)] in (* message "start second proof"; *) let stop = try com_eqn (List.length res_vars) equation_id functional_ref f_ref term_ref (subst_var function_name equation_lemma_type); @@ -1537,7 +1537,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num with e when Errors.noncritical e -> begin if do_observe () - then msg_debug (str "Cannot create equation Lemma " ++ Errors.print e) + then Feedback.msg_debug (str "Cannot create equation Lemma " ++ Errors.print e) else anomaly (Pp.str "Cannot create equation Lemma") ; true diff --git a/plugins/funind/recdef_plugin.mllib b/plugins/funind/recdef_plugin.mlpack index ec1f5436ca..2b443f2a1b 100644 --- a/plugins/funind/recdef_plugin.mllib +++ b/plugins/funind/recdef_plugin.mlpack @@ -8,4 +8,3 @@ Invfun Indfun Merge G_indfun -Recdef_plugin_mod diff --git a/plugins/micromega/Lia.v b/plugins/micromega/Lia.v index 3e58e81ac2..52bf5ed3df 100644 --- a/plugins/micromega/Lia.v +++ b/plugins/micromega/Lia.v @@ -16,7 +16,7 @@ Require Import ZMicromega. Require Import ZArith. Require Import RingMicromega. Require Import VarMap. -Require Tauto. +Require Coq.micromega.Tauto. Declare ML Module "micromega_plugin". Ltac preprocess := diff --git a/plugins/micromega/Psatz.v b/plugins/micromega/Psatz.v index ba1f8956e3..fafd8a5f21 100644 --- a/plugins/micromega/Psatz.v +++ b/plugins/micromega/Psatz.v @@ -20,7 +20,7 @@ Require Import ZArith. Require Import Rdefinitions. Require Import RingMicromega. Require Import VarMap. -Require Tauto. +Require Coq.micromega.Tauto. Declare ML Module "micromega_plugin". Ltac preprocess := diff --git a/plugins/micromega/QMicromega.v b/plugins/micromega/QMicromega.v index 432683635f..b13285f537 100644 --- a/plugins/micromega/QMicromega.v +++ b/plugins/micromega/QMicromega.v @@ -168,7 +168,7 @@ Proof. exact H. Qed. -Require Import Tauto. +Require Import Coq.micromega.Tauto. Definition Qnormalise := @cnf_normalise Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool. Definition Qnegate := @cnf_negate Q 0 1 Qplus Qmult Qminus Qopp Qeq_bool. diff --git a/plugins/micromega/RMicromega.v b/plugins/micromega/RMicromega.v index 72353a99e5..2352d78d63 100644 --- a/plugins/micromega/RMicromega.v +++ b/plugins/micromega/RMicromega.v @@ -533,7 +533,7 @@ Proof. exact H. Qed. -Require Import Tauto. +Require Import Coq.micromega.Tauto. Definition Rnormalise := @cnf_normalise Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool. Definition Rnegate := @cnf_negate Q 0%Q 1%Q Qplus Qmult Qminus Qopp Qeq_bool. diff --git a/plugins/micromega/RingMicromega.v b/plugins/micromega/RingMicromega.v index 751a81df12..ed49c3df43 100644 --- a/plugins/micromega/RingMicromega.v +++ b/plugins/micromega/RingMicromega.v @@ -794,7 +794,7 @@ Definition xnormalise (t:Formula C) : list (NFormula) := | OpLe => (psub lhs rhs ,Strict) :: nil end. -Require Import Tauto. +Require Import Coq.micromega.Tauto. Definition cnf_normalise (t:Formula C) : cnf (NFormula) := List.map (fun x => x::nil) (xnormalise t). diff --git a/plugins/micromega/ZMicromega.v b/plugins/micromega/ZMicromega.v index d7ddef2be4..5aa8d03f99 100644 --- a/plugins/micromega/ZMicromega.v +++ b/plugins/micromega/ZMicromega.v @@ -198,7 +198,7 @@ Definition xnormalise (t:Formula Z) : list (NFormula Z) := | OpLe => (psub lhs (padd rhs (Pc 1)),NonStrict) :: nil end. -Require Import Tauto BinNums. +Require Import Coq.micromega.Tauto BinNums. Definition normalise (t:Formula Z) : cnf (NFormula Z) := List.map (fun x => x::nil) (xnormalise t). diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 0fcfbfc711..e4aa1448eb 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -961,7 +961,7 @@ struct let parse_expr parse_constant parse_exp ops_spec env term = if debug - then Pp.msg_debug (Pp.str "parse_expr: " ++ Printer.prterm term); + then Feedback.msg_debug (Pp.str "parse_expr: " ++ Printer.prterm term); (* let constant_or_variable env term = @@ -1082,7 +1082,7 @@ struct let rconstant term = if debug - then Pp.msg_debug (Pp.str "rconstant: " ++ Printer.prterm term ++ fnl ()); + then Feedback.msg_debug (Pp.str "rconstant: " ++ Printer.prterm term ++ fnl ()); let res = rconstant term in if debug then (Printf.printf "rconstant -> %a\n" pp_Rcst res ; flush stdout) ; @@ -1122,7 +1122,7 @@ struct let parse_arith parse_op parse_expr env cstr gl = if debug - then Pp.msg_debug (Pp.str "parse_arith: " ++ Printer.prterm cstr ++ fnl ()); + then Feedback.msg_debug (Pp.str "parse_arith: " ++ Printer.prterm cstr ++ fnl ()); match kind_of_term cstr with | App(op,args) -> let (op,lhs,rhs) = parse_op gl (op,args) in @@ -1651,12 +1651,12 @@ let micromega_tauto negate normalise unsat deduce spec prover env polys1 polys2 if debug then begin - Pp.pp (Pp.str "Formula....\n") ; + Feedback.msg_notice (Pp.str "Formula....\n") ; let formula_typ = (Term.mkApp(Lazy.force coq_Cstr, [|spec.coeff|])) in let ff = dump_formula formula_typ (dump_cstr spec.typ spec.dump_coeff) ff in - Pp.pp (Printer.prterm ff) ; Pp.pp_flush (); - Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff + Feedback.msg_notice (Printer.prterm ff); + Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff end; match witness_list_tags prover cnf_ff with @@ -1676,11 +1676,11 @@ let micromega_tauto negate normalise unsat deduce spec prover env polys1 polys2 if debug then begin - Pp.pp (Pp.str "\nAFormula\n") ; + Feedback.msg_notice (Pp.str "\nAFormula\n") ; let formula_typ = (Term.mkApp( Lazy.force coq_Cstr,[| spec.coeff|])) in let ff' = dump_formula formula_typ (dump_cstr spec.typ spec.dump_coeff) ff' in - Pp.pp (Printer.prterm ff') ; Pp.pp_flush (); + Feedback.msg_notice (Printer.prterm ff'); Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff' end; @@ -1733,7 +1733,7 @@ let micromega_gen with | ParseError -> Tacticals.New.tclFAIL 0 (Pp.str "Bad logical fragment") | Mfourier.TimeOut -> Tacticals.New.tclFAIL 0 (Pp.str "Timeout") - | CsdpNotFound -> flush stdout ; Pp.pp_flush () ; + | CsdpNotFound -> flush stdout ; Tacticals.New.tclFAIL 0 (Pp.str (" Skipping what remains of this tactic: the complexity of the goal requires " ^ "the use of a specialized external tool called csdp. \n\n" @@ -1818,7 +1818,7 @@ let micromega_genr prover = with | Mfourier.TimeOut -> Tacticals.New.tclFAIL 0 (Pp.str "TimeOut") | ParseError -> Tacticals.New.tclFAIL 0 (Pp.str "Bad logical fragment") - | CsdpNotFound -> flush stdout ; Pp.pp_flush () ; + | CsdpNotFound -> Tacticals.New.tclFAIL 0 (Pp.str (" Skipping what remains of this tactic: the complexity of the goal requires " ^ "the use of a specialized external tool called csdp. \n\n" @@ -1903,7 +1903,7 @@ let call_csdpcert_q provername poly = let cert = Certificate.q_cert_of_pos cert in if Mc.qWeakChecker poly cert then Some cert - else ((print_string "buggy certificate" ; flush stdout) ;None) + else ((print_string "buggy certificate") ;None) let call_csdpcert_z provername poly = let l = List.map (fun (e,o) -> (z_to_q_pol e,o)) poly in diff --git a/plugins/micromega/micromega_plugin.mllib b/plugins/micromega/micromega_plugin.mlpack index f53a9e3797..ed253da3fd 100644 --- a/plugins/micromega/micromega_plugin.mllib +++ b/plugins/micromega/micromega_plugin.mlpack @@ -7,4 +7,3 @@ Certificate Persistent_cache Coq_micromega G_micromega -Micromega_plugin_mod diff --git a/plugins/micromega/persistent_cache.ml b/plugins/micromega/persistent_cache.ml index 6a03e2d61f..88b13abf9a 100644 --- a/plugins/micromega/persistent_cache.ml +++ b/plugins/micromega/persistent_cache.ml @@ -212,9 +212,11 @@ let find t k = res let memo cache f = - let tbl = lazy (open_in cache) in - fun x -> - let tbl = Lazy.force tbl in + let tbl = lazy (try Some (open_in cache) with _ -> None) in + fun x -> + match Lazy.force tbl with + | None -> f x + | Some tbl -> try find tbl x with diff --git a/plugins/nsatz/nsatz_plugin.mllib b/plugins/nsatz/nsatz_plugin.mlpack index e991fb76f7..b55adf43c0 100644 --- a/plugins/nsatz/nsatz_plugin.mllib +++ b/plugins/nsatz/nsatz_plugin.mlpack @@ -3,4 +3,3 @@ Polynom Ideal Nsatz G_nsatz -Nsatz_plugin_mod diff --git a/plugins/omega/omega_plugin.mllib b/plugins/omega/omega_plugin.mlpack index 2b387fdcee..df7f1047f2 100644 --- a/plugins/omega/omega_plugin.mllib +++ b/plugins/omega/omega_plugin.mlpack @@ -1,4 +1,3 @@ Omega Coq_omega G_omega -Omega_plugin_mod diff --git a/plugins/plugins.itarget b/plugins/plugins.itarget deleted file mode 100644 index 56aa42b069..0000000000 --- a/plugins/plugins.itarget +++ /dev/null @@ -1,3 +0,0 @@ -pluginsopt.otarget -pluginsbyte.otarget -pluginsvo.otarget
\ No newline at end of file diff --git a/plugins/pluginsbyte.itarget b/plugins/pluginsbyte.itarget deleted file mode 100644 index d8752f8b80..0000000000 --- a/plugins/pluginsbyte.itarget +++ /dev/null @@ -1,21 +0,0 @@ -btauto/btauto_plugin.cma -setoid_ring/newring_plugin.cma -extraction/extraction_plugin.cma -decl_mode/decl_mode_plugin.cma -firstorder/ground_plugin.cma -rtauto/rtauto_plugin.cma -fourier/fourier_plugin.cma -romega/romega_plugin.cma -omega/omega_plugin.cma -micromega/micromega_plugin.cma -cc/cc_plugin.cma -nsatz/nsatz_plugin.cma -funind/recdef_plugin.cma -syntax/ascii_syntax_plugin.cma -syntax/nat_syntax_plugin.cma -syntax/numbers_syntax_plugin.cma -syntax/r_syntax_plugin.cma -syntax/string_syntax_plugin.cma -syntax/z_syntax_plugin.cma -quote/quote_plugin.cma -derive/derive_plugin.cma
\ No newline at end of file diff --git a/plugins/pluginsdyn.itarget b/plugins/pluginsdyn.itarget deleted file mode 100644 index 220e5182d9..0000000000 --- a/plugins/pluginsdyn.itarget +++ /dev/null @@ -1,24 +0,0 @@ -btauto/btauto_plugin.cmxs -field/field_plugin.cmxs -setoid_ring/newring_plugin.cmxs -extraction/extraction_plugin.cmxs -decl_mode/decl_mode_plugin.cmxs -firstorder/ground_plugin.cmxs -rtauto/rtauto_plugin.cmxs -fourier/fourier_plugin.cmxs -romega/romega_plugin.cmxs -omega/omega_plugin.cmxs -micromega/micromega_plugin.cmxs -subtac/subtac_plugin.cmxs -ring/ring_plugin.cmxs -cc/cc_plugin.cmxs -nsatz/nsatz_plugin.cmxs -funind/recdef_plugin.cmxs -syntax/ascii_syntax_plugin.cmxs -syntax/nat_syntax_plugin.cmxs -syntax/numbers_syntax_plugin.cmxs -syntax/r_syntax_plugin.cmxs -syntax/string_syntax_plugin.cmxs -syntax/z_syntax_plugin.cmxs -quote/quote_plugin.cmxs -derive/derive_plugin.cmxs diff --git a/plugins/pluginsopt.itarget b/plugins/pluginsopt.itarget deleted file mode 100644 index 04a1e711cb..0000000000 --- a/plugins/pluginsopt.itarget +++ /dev/null @@ -1,21 +0,0 @@ -btauto/btauto_plugin.cmxa -setoid_ring/newring_plugin.cmxa -extraction/extraction_plugin.cmxa -decl_mode/decl_mode_plugin.cmxa -firstorder/ground_plugin.cmxa -rtauto/rtauto_plugin.cmxa -fourier/fourier_plugin.cmxa -romega/romega_plugin.cmxa -omega/omega_plugin.cmxa -micromega/micromega_plugin.cmxa -cc/cc_plugin.cmxa -nsatz/nsatz_plugin.cmxa -funind/recdef_plugin.cmxa -syntax/ascii_syntax_plugin.cmxa -syntax/nat_syntax_plugin.cmxa -syntax/numbers_syntax_plugin.cmxa -syntax/r_syntax_plugin.cmxa -syntax/string_syntax_plugin.cmxa -syntax/z_syntax_plugin.cmxa -quote/quote_plugin.cmxa -derive/derive_plugin.cmxa diff --git a/plugins/pluginsvo.itarget b/plugins/pluginsvo.itarget deleted file mode 100644 index a59bf29c98..0000000000 --- a/plugins/pluginsvo.itarget +++ /dev/null @@ -1,12 +0,0 @@ -btauto/vo.otarget -fourier/vo.otarget -funind/vo.otarget -nsatz/vo.otarget -micromega/vo.otarget -omega/vo.otarget -quote/vo.otarget -romega/vo.otarget -rtauto/vo.otarget -setoid_ring/vo.otarget -extraction/vo.otarget -derive/vo.otarget
\ No newline at end of file diff --git a/plugins/quote/quote_plugin.mllib b/plugins/quote/quote_plugin.mllib deleted file mode 100644 index d1b3ccbe1e..0000000000 --- a/plugins/quote/quote_plugin.mllib +++ /dev/null @@ -1,3 +0,0 @@ -Quote -G_quote -Quote_plugin_mod diff --git a/plugins/quote/quote_plugin.mlpack b/plugins/quote/quote_plugin.mlpack new file mode 100644 index 0000000000..2e9be09d8d --- /dev/null +++ b/plugins/quote/quote_plugin.mlpack @@ -0,0 +1,2 @@ +Quote +G_quote diff --git a/plugins/romega/ReflOmegaCore.v b/plugins/romega/ReflOmegaCore.v index 36511386ac..5e43dfc42d 100644 --- a/plugins/romega/ReflOmegaCore.v +++ b/plugins/romega/ReflOmegaCore.v @@ -1074,16 +1074,19 @@ Qed. avait utilisé le test précédent et fait une elimination dessus. *) Ltac elim_eq_term t1 t2 := + let Aux := fresh "Aux" in pattern (eq_term t1 t2); apply bool_eq_ind; intro Aux; [ generalize (eq_term_true t1 t2 Aux); clear Aux | generalize (eq_term_false t1 t2 Aux); clear Aux ]. Ltac elim_beq t1 t2 := + let Aux := fresh "Aux" in pattern (beq t1 t2); apply bool_eq_ind; intro Aux; [ generalize (beq_true t1 t2 Aux); clear Aux | generalize (beq_false t1 t2 Aux); clear Aux ]. Ltac elim_bgt t1 t2 := + let Aux := fresh "Aux" in pattern (bgt t1 t2); apply bool_eq_ind; intro Aux; [ generalize (bgt_true t1 t2 Aux); clear Aux | generalize (bgt_false t1 t2 Aux); clear Aux ]. diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index dca46cbcf7..a059512d84 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -9,7 +9,7 @@ open Pp open Util open Const_omega -module OmegaSolver = Omega.MakeOmegaSolver (Bigint) +module OmegaSolver = Omega_plugin.Omega.MakeOmegaSolver (Bigint) open OmegaSolver (* \section{Useful functions and flags} *) @@ -172,7 +172,7 @@ let print_env_reification env = in let prop_info = str "ENVIRONMENT OF PROPOSITIONS :" ++ fnl () ++ loop 'P' 0 env.props in let term_info = str "ENVIRONMENT OF TERMS :" ++ fnl () ++ loop 'V' 0 env.terms in - msg_debug (prop_info ++ fnl () ++ term_info) + Feedback.msg_debug (prop_info ++ fnl () ++ term_info) (* \subsection{Gestion des environnements de variable pour Omega} *) (* generation d'identifiant d'equation pour Omega *) diff --git a/plugins/romega/romega_plugin.mllib b/plugins/romega/romega_plugin.mlpack index 1625009d06..38d0e94111 100644 --- a/plugins/romega/romega_plugin.mllib +++ b/plugins/romega/romega_plugin.mlpack @@ -1,4 +1,3 @@ Const_omega Refl_omega G_romega -Romega_plugin_mod diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml index 3ba92b9f22..f3eae5f501 100644 --- a/plugins/rtauto/proof_search.ml +++ b/plugins/rtauto/proof_search.ml @@ -547,7 +547,7 @@ let pp_info () = int s_info.created_branches ++ str " created" ++ fnl () ++ str "Hypotheses : " ++ int s_info.created_hyps ++ str " created" ++ fnl () in - msg_info + Feedback.msg_info ( str "Proof-search statistics :" ++ fnl () ++ count_info ++ str "Branch ends: " ++ diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index 73dc13e72e..0a0b459156 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -276,7 +276,7 @@ let rtauto_tac gls= begin reset_info (); if !verbose then - msg_info (str "Starting proof-search ..."); + Feedback.msg_info (str "Starting proof-search ..."); end in let search_start_time = System.get_time () in let prf = @@ -286,10 +286,10 @@ let rtauto_tac gls= let search_end_time = System.get_time () in let _ = if !verbose then begin - msg_info (str "Proof tree found in " ++ + Feedback.msg_info (str "Proof tree found in " ++ System.fmt_time_difference search_start_time search_end_time); pp_info (); - msg_info (str "Building proof term ... ") + Feedback.msg_info (str "Building proof term ... ") end in let build_start_time=System.get_time () in let _ = step_count := 0; node_count := 0 in @@ -302,7 +302,7 @@ let rtauto_tac gls= let build_end_time=System.get_time () in let _ = if !verbose then begin - msg_info (str "Proof term built in " ++ + Feedback.msg_info (str "Proof term built in " ++ System.fmt_time_difference build_start_time build_end_time ++ fnl () ++ str "Proof size : " ++ int !step_count ++ @@ -319,9 +319,9 @@ let rtauto_tac gls= Proofview.V82.of_tactic (Tactics.exact_no_check term) gls in let tac_end_time = System.get_time () in let _ = - if !check then msg_info (str "Proof term type-checking is on"); + if !check then Feedback.msg_info (str "Proof term type-checking is on"); if !verbose then - msg_info (str "Internal tactic executed in " ++ + Feedback.msg_info (str "Internal tactic executed in " ++ System.fmt_time_difference tac_start_time tac_end_time) in result diff --git a/plugins/rtauto/rtauto_plugin.mllib b/plugins/rtauto/rtauto_plugin.mlpack index 0e34604495..61c5e945bc 100644 --- a/plugins/rtauto/rtauto_plugin.mllib +++ b/plugins/rtauto/rtauto_plugin.mlpack @@ -1,4 +1,3 @@ Proof_search Refl_tauto G_rtauto -Rtauto_plugin_mod diff --git a/plugins/setoid_ring/g_newring.ml4 b/plugins/setoid_ring/g_newring.ml4 index f5a7340487..f64226e334 100644 --- a/plugins/setoid_ring/g_newring.ml4 +++ b/plugins/setoid_ring/g_newring.ml4 @@ -60,9 +60,9 @@ VERNAC COMMAND EXTEND AddSetoidRing CLASSIFIED AS SIDEFF let (k,set,cst,pre,post,power,sign, div) = process_ring_mods l in add_theory id (ic t) set k cst (pre,post) power sign div] | [ "Print" "Rings" ] => [Vernac_classifier.classify_as_query] -> [ - msg_notice (strbrk "The following ring structures have been declared:"); + Feedback.msg_notice (strbrk "The following ring structures have been declared:"); Spmap.iter (fun fn fi -> - msg_notice (hov 2 + Feedback.msg_notice (hov 2 (Ppconstr.pr_id (Libnames.basename fn)++spc()++ str"with carrier "++ pr_constr fi.ring_carrier++spc()++ str"and equivalence relation "++ pr_constr fi.ring_req)) @@ -89,9 +89,9 @@ VERNAC COMMAND EXTEND AddSetoidField CLASSIFIED AS SIDEFF let (k,set,inj,cst_tac,pre,post,power,sign,div) = process_field_mods l in add_field_theory id (ic t) set k cst_tac inj (pre,post) power sign div] | [ "Print" "Fields" ] => [Vernac_classifier.classify_as_query] -> [ - msg_notice (strbrk "The following field structures have been declared:"); + Feedback.msg_notice (strbrk "The following field structures have been declared:"); Spmap.iter (fun fn fi -> - msg_notice (hov 2 + Feedback.msg_notice (hov 2 (Ppconstr.pr_id (Libnames.basename fn)++spc()++ str"with carrier "++ pr_constr fi.field_carrier++spc()++ str"and equivalence relation "++ pr_constr fi.field_req)) diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 271bf35a88..57ef920325 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -34,15 +34,6 @@ open Proofview.Notations (****************************************************************************) (* controlled reduction *) -(** ppedrot: something dubious here, we're obviously using evars the wrong - way. FIXME! *) - -let mark_arg i c = mkEvar(Evar.unsafe_of_int i,[|c|]) -let unmark_arg f c = - match destEvar c with - | (i,[|c|]) -> f (Evar.repr i) c - | _ -> assert false - type protect_flag = Eval|Prot|Rec let tag_arg tag_rec map subs i c = @@ -75,12 +66,10 @@ and mk_clos_app_but f_map subs f args n = let fargs, args' = Array.chop n args in let f' = mkApp(f,fargs) in match f_map (global_of_constr_nofail f') with - Some map -> - mk_clos_deep - (fun s' -> unmark_arg (tag_arg (mk_clos_but f_map s') map s')) - subs - (mkApp (mark_arg (-1) f', Array.mapi mark_arg args')) - | None -> mk_clos_app_but f_map subs f args (n+1) + | Some map -> + let f i t = tag_arg (mk_clos_but f_map subs) map subs i t in + mk_red (FApp (f (-1) f', Array.mapi f args')) + | None -> mk_atom (mkApp (f, args)) let interp_map l t = try Some(List.assoc_f eq_gr t l) with Not_found -> None @@ -106,6 +95,7 @@ let protect_tac_in map id = (****************************************************************************) let closed_term t l = + let open Quote_plugin in let l = List.map Universes.constr_of_global l in let cs = List.fold_right Quote.ConstrSet.add l Quote.ConstrSet.empty in if Quote.closed_under cs t then tclIDTAC else tclFAIL 0 (mt()) @@ -527,7 +517,7 @@ let ring_equality env evd (r,add,mul,opp,req) = let op_morph = op_morph r add mul opp req add_m_lem mul_m_lem opp_m_lem in Flags.if_verbose - msg_info + Feedback.msg_info (str"Using setoid \""++pr_constr req++str"\""++spc()++ str"and morphisms \""++pr_constr add_m_lem ++ str"\","++spc()++ str"\""++pr_constr mul_m_lem++ @@ -536,7 +526,7 @@ let ring_equality env evd (r,add,mul,opp,req) = op_morph) | None -> (Flags.if_verbose - msg_info + Feedback.msg_info (str"Using setoid \""++pr_constr req ++str"\"" ++ spc() ++ str"and morphisms \""++pr_constr add_m_lem ++ str"\""++spc()++str"and \""++ diff --git a/plugins/setoid_ring/newring_plugin.mllib b/plugins/setoid_ring/newring_plugin.mllib deleted file mode 100644 index 7d6c495889..0000000000 --- a/plugins/setoid_ring/newring_plugin.mllib +++ /dev/null @@ -1,3 +0,0 @@ -Newring -Newring_plugin_mod -G_newring diff --git a/plugins/setoid_ring/newring_plugin.mlpack b/plugins/setoid_ring/newring_plugin.mlpack new file mode 100644 index 0000000000..23663b4090 --- /dev/null +++ b/plugins/setoid_ring/newring_plugin.mlpack @@ -0,0 +1,2 @@ +Newring +G_newring diff --git a/plugins/syntax/ascii_syntax.ml b/plugins/syntax/ascii_syntax.ml index 67c9dd0a38..03b49e3336 100644 --- a/plugins/syntax/ascii_syntax.ml +++ b/plugins/syntax/ascii_syntax.ml @@ -6,6 +6,10 @@ (* * GNU Lesser General Public License Version 2.1 *) (***********************************************************************) +(* Poor's man DECLARE PLUGIN *) +let __coq_plugin_name = "ascii_syntax_plugin" +let () = Mltop.add_known_module __coq_plugin_name + open Pp open Errors open Util diff --git a/plugins/syntax/ascii_syntax_plugin.mllib b/plugins/syntax/ascii_syntax_plugin.mllib deleted file mode 100644 index b00f92506e..0000000000 --- a/plugins/syntax/ascii_syntax_plugin.mllib +++ /dev/null @@ -1,2 +0,0 @@ -Ascii_syntax -Ascii_syntax_plugin_mod diff --git a/plugins/syntax/ascii_syntax_plugin.mlpack b/plugins/syntax/ascii_syntax_plugin.mlpack new file mode 100644 index 0000000000..7b9213a0e2 --- /dev/null +++ b/plugins/syntax/ascii_syntax_plugin.mlpack @@ -0,0 +1 @@ +Ascii_syntax diff --git a/plugins/syntax/nat_syntax.ml b/plugins/syntax/nat_syntax.ml index 5f44904c3c..3142c8cf00 100644 --- a/plugins/syntax/nat_syntax.ml +++ b/plugins/syntax/nat_syntax.ml @@ -6,6 +6,10 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(* Poor's man DECLARE PLUGIN *) +let __coq_plugin_name = "nat_syntax_plugin" +let () = Mltop.add_known_module __coq_plugin_name + (* This file defines the printer for natural numbers in [nat] *) (*i*) @@ -25,7 +29,7 @@ let threshold = of_int 5000 let nat_of_int dloc n = if is_pos_or_zero n then begin if less_than threshold n then - msg_warning + Feedback.msg_warning (strbrk "Stack overflow or segmentation fault happens when " ++ strbrk "working with large numbers in nat (observed threshold " ++ strbrk "may vary from 5000 to 70000 depending on your system " ++ diff --git a/plugins/syntax/nat_syntax_plugin.mllib b/plugins/syntax/nat_syntax_plugin.mllib deleted file mode 100644 index 69b0cb20f6..0000000000 --- a/plugins/syntax/nat_syntax_plugin.mllib +++ /dev/null @@ -1,2 +0,0 @@ -Nat_syntax -Nat_syntax_plugin_mod diff --git a/plugins/syntax/nat_syntax_plugin.mlpack b/plugins/syntax/nat_syntax_plugin.mlpack new file mode 100644 index 0000000000..39bdd62f47 --- /dev/null +++ b/plugins/syntax/nat_syntax_plugin.mlpack @@ -0,0 +1 @@ +Nat_syntax diff --git a/plugins/syntax/numbers_syntax.ml b/plugins/syntax/numbers_syntax.ml index fe9f1319eb..57cb2f897a 100644 --- a/plugins/syntax/numbers_syntax.ml +++ b/plugins/syntax/numbers_syntax.ml @@ -6,6 +6,10 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(* Poor's man DECLARE PLUGIN *) +let __coq_plugin_name = "numbers_syntax_plugin" +let () = Mltop.add_known_module __coq_plugin_name + (* digit-based syntax for int31, bigN bigZ and bigQ *) open Bigint @@ -180,7 +184,7 @@ let bigN_of_pos_bigint dloc n = let word = word_of_pos_bigint dloc h n in let args = if h < n_inlined then [word] - else [Nat_syntax.nat_of_int dloc (of_int (h-n_inlined));word] + else [Nat_syntax_plugin.Nat_syntax.nat_of_int dloc (of_int (h-n_inlined));word] in GApp (dloc, ref_constructor, args) diff --git a/plugins/syntax/numbers_syntax_plugin.mllib b/plugins/syntax/numbers_syntax_plugin.mllib deleted file mode 100644 index ebc0bb2022..0000000000 --- a/plugins/syntax/numbers_syntax_plugin.mllib +++ /dev/null @@ -1,2 +0,0 @@ -Numbers_syntax -Numbers_syntax_plugin_mod diff --git a/plugins/syntax/numbers_syntax_plugin.mlpack b/plugins/syntax/numbers_syntax_plugin.mlpack new file mode 100644 index 0000000000..e48c00a0d0 --- /dev/null +++ b/plugins/syntax/numbers_syntax_plugin.mlpack @@ -0,0 +1 @@ +Numbers_syntax diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 05d73f9ec1..3ae2d45f32 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -10,6 +10,10 @@ open Util open Names open Globnames +(* Poor's man DECLARE PLUGIN *) +let __coq_plugin_name = "r_syntax_plugin" +let () = Mltop.add_known_module __coq_plugin_name + exception Non_closed_number (**********************************************************************) diff --git a/plugins/syntax/r_syntax_plugin.mllib b/plugins/syntax/r_syntax_plugin.mllib deleted file mode 100644 index 5c173a140f..0000000000 --- a/plugins/syntax/r_syntax_plugin.mllib +++ /dev/null @@ -1,2 +0,0 @@ -R_syntax -R_syntax_plugin_mod diff --git a/plugins/syntax/r_syntax_plugin.mlpack b/plugins/syntax/r_syntax_plugin.mlpack new file mode 100644 index 0000000000..d4ee75ea48 --- /dev/null +++ b/plugins/syntax/r_syntax_plugin.mlpack @@ -0,0 +1 @@ +R_syntax diff --git a/plugins/syntax/string_syntax.ml b/plugins/syntax/string_syntax.ml index 2e696f391f..de0fa77eff 100644 --- a/plugins/syntax/string_syntax.ml +++ b/plugins/syntax/string_syntax.ml @@ -7,10 +7,14 @@ (***********************************************************************) open Globnames -open Ascii_syntax +open Ascii_syntax_plugin.Ascii_syntax open Glob_term open Coqlib +(* Poor's man DECLARE PLUGIN *) +let __coq_plugin_name = "string_syntax_plugin" +let () = Mltop.add_known_module __coq_plugin_name + exception Non_closed_string (* make a string term from the string s *) diff --git a/plugins/syntax/string_syntax_plugin.mllib b/plugins/syntax/string_syntax_plugin.mllib deleted file mode 100644 index b108c9e007..0000000000 --- a/plugins/syntax/string_syntax_plugin.mllib +++ /dev/null @@ -1,2 +0,0 @@ -String_syntax -String_syntax_plugin_mod diff --git a/plugins/syntax/string_syntax_plugin.mlpack b/plugins/syntax/string_syntax_plugin.mlpack new file mode 100644 index 0000000000..45d6e0fa23 --- /dev/null +++ b/plugins/syntax/string_syntax_plugin.mlpack @@ -0,0 +1 @@ +String_syntax diff --git a/plugins/syntax/z_syntax.ml b/plugins/syntax/z_syntax.ml index 53c1b5d7a0..ce86c0a65f 100644 --- a/plugins/syntax/z_syntax.ml +++ b/plugins/syntax/z_syntax.ml @@ -12,6 +12,10 @@ open Util open Names open Bigint +(* Poor's man DECLARE PLUGIN *) +let __coq_plugin_name = "z_syntax_plugin" +let () = Mltop.add_known_module __coq_plugin_name + exception Non_closed_number (**********************************************************************) diff --git a/plugins/syntax/z_syntax_plugin.mllib b/plugins/syntax/z_syntax_plugin.mllib deleted file mode 100644 index 36d41acc20..0000000000 --- a/plugins/syntax/z_syntax_plugin.mllib +++ /dev/null @@ -1,2 +0,0 @@ -Z_syntax -Z_syntax_plugin_mod diff --git a/plugins/syntax/z_syntax_plugin.mlpack b/plugins/syntax/z_syntax_plugin.mlpack new file mode 100644 index 0000000000..411260c04c --- /dev/null +++ b/plugins/syntax/z_syntax_plugin.mlpack @@ -0,0 +1 @@ +Z_syntax diff --git a/pretyping/classops.ml b/pretyping/classops.ml index ece92b66ba..55220f44c0 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -387,7 +387,7 @@ let add_coercion_in_graph (ic,source,target) = end; let is_ambig = match !ambig_paths with [] -> false | _ -> true in if is_ambig && is_verbose () then - msg_warning (message_ambig !ambig_paths) + Feedback.msg_warning (message_ambig !ambig_paths) type coercion = { coercion_type : coe_typ; diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 4fb4112022..129725c6d2 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -50,11 +50,11 @@ type bound_ident_map = Id.t Id.Map.t exception PatternMatchingFailure let warn_bound_meta name = - msg_warning (str "Collision between bound variable " ++ pr_id name ++ + Feedback.msg_warning (str "Collision between bound variable " ++ pr_id name ++ str " and a metavariable of same name.") let warn_bound_bound name = - msg_warning (str "Collision between bound variables of name " ++ pr_id name) + Feedback.msg_warning (str "Collision between bound variables of name " ++ pr_id name) let constrain n (ids, m as x) (names, terms as subst) = try diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index c973e1cef3..86921c49b0 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -620,7 +620,7 @@ and share_names flags n l avoid env sigma c t = share_names flags (n-1) ((Name id,Explicit,None,t'')::l) avoid env sigma appc c' (* If built with the f/n notation: we renounce to share names *) | _ -> - if n>0 then msg_warning (strbrk "Detyping.detype: cannot factorize fix enough"); + if n>0 then Feedback.msg_warning (strbrk "Detyping.detype: cannot factorize fix enough"); let c = detype flags avoid env sigma c in let t = detype flags avoid env sigma t in (List.rev l,c,t) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 08973a05c4..e5fc5a188d 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -103,8 +103,7 @@ let position_problem l2r = function | CUMUL -> Some l2r let occur_rigidly ev evd t = - let (l, app) = decompose_app_vect t in - let rec aux 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 @@ -116,7 +115,7 @@ let occur_rigidly ev evd t = | Prod (_, b, t) -> ignore(aux b || aux t); true | Rel _ | Var _ -> false | Case _ -> false - in Array.exists (fun t -> try ignore(aux t); false with Occur -> true) app + in try ignore(aux t); false with Occur -> true (* [check_conv_record env sigma (t1,stack1) (t2,stack2)] tries to decompose the problem (t1 stack1) = (t2 stack2) into a problem @@ -368,8 +367,6 @@ let rec evar_conv_x ts env evd pbty term1 term2 = and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty ((term1,sk1 as appr1),csts1) ((term2,sk2 as appr2),csts2) = - let default_fail i = (* costly *) - UnifFailure (i,ConversionFailed (env, Stack.zip appr1, Stack.zip appr2)) in let quick_fail i = (* not costly, loses info *) UnifFailure (i, NotSameHead) in @@ -421,7 +418,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty let not_only_app = Stack.not_purely_applicative skM in let f1 i = match Stack.list_of_app_stack skF with - | None -> default_fail evd + | None -> quick_fail evd | Some lF -> let tM = Stack.zip apprM in miller_pfenning on_left @@ -468,10 +465,11 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty let flex_rigid on_left ev (termF, skF as apprF) (termR, skR as apprR) = let switch f a b = if on_left then f a b else f b a in let eta evd = - match kind_of_term termR with - | Lambda _ -> eta env evd false skR termR skF termF - | Construct u -> eta_constructor ts env evd skR u skF termF - | _ -> UnifFailure (evd,NotSameHead) + match kind_of_term termR with + | Lambda _ when (* if ever problem is ill-typed: *) List.is_empty skR -> + eta env evd false skR termR skF termF + | Construct u -> eta_constructor ts env evd skR u skF termF + | _ -> UnifFailure (evd,NotSameHead) in match Stack.list_of_app_stack skF with | None -> @@ -501,15 +499,18 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty (* Evar must be undefined since we have flushed evars *) let () = if !debug_unification then let open Pp in - pp (v 0 (pr_state appr1 ++ cut () ++ pr_state appr2 ++ cut ()) + Feedback.msg_notice (v 0 (pr_state appr1 ++ cut () ++ pr_state appr2 ++ cut ()) ++ fnl ()) in match (flex_kind_of_term (fst ts) env evd term1 sk1, flex_kind_of_term (fst ts) env evd term2 sk2) with | Flexible (sp1,al1 as ev1), Flexible (sp2,al2 as ev2) -> + (* sk1[?ev1] =? sk2[?ev2] *) let f1 i = + (* Try first-order unification *) match ise_stack2 false env i (evar_conv_x ts) sk1 sk2 with - |None, Success i' -> - (* Evar can be defined in i' *) + | None, Success i' -> + (* We do have sk1[] = sk2[]: we now unify ?ev1 and ?ev2 *) + (* Note that ?ev1 and ?ev2, may have been instantiated in the meantime *) let ev1' = whd_evar i' (mkEvar ev1) in if isEvar ev1' then solve_simple_eqn (evar_conv_x ts) env i' @@ -517,7 +518,9 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty else evar_eqappr_x ts env evd pbty ((ev1', sk1), csts1) ((term2, sk2), csts2) - |Some (r,[]), Success i' -> + | Some (r,[]), Success i' -> + (* We have sk1'[] = sk2[] for some sk1' s.t. sk1[]=sk1'[r[]] *) + (* we now unify r[?ev1] and ?ev2 *) let ev2' = whd_evar i' (mkEvar ev2) in if isEvar ev2' then solve_simple_eqn (evar_conv_x ts) env i' @@ -525,16 +528,46 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty else evar_eqappr_x ts env evd pbty ((ev2', sk1), csts1) ((term2, sk2), csts2) - - |Some ([],r), Success i' -> + | Some ([],r), Success i' -> + (* Symmetrically *) + (* We have sk1[] = sk2'[] for some sk2' s.t. sk2[]=sk2'[r[]] *) + (* we now unify ?ev1 and r[?ev2] *) let ev1' = whd_evar i' (mkEvar ev1) in if isEvar ev1' then solve_simple_eqn (evar_conv_x ts) env i' (position_problem true pbty,destEvar ev1',Stack.zip(term2,r)) else evar_eqappr_x ts env evd pbty ((ev1', sk1), csts1) ((term2, sk2), csts2) - |_, (UnifFailure _ as x) -> x - |Some _, _ -> UnifFailure (i,NotSameArgSize) + | None, (UnifFailure _ as x) -> + (* sk1 and sk2 have no common outer part *) + if Stack.not_purely_applicative sk2 then + (* Ad hoc compatibility with 8.4 which treated non-app as rigid *) + flex_rigid true ev1 appr1 appr2 + else + if Stack.not_purely_applicative sk1 then + (* Ad hoc compatibility with 8.4 which treated non-app as rigid *) + flex_rigid false ev2 appr2 appr1 + else + (* We could instead try Miller unification, then + postpone to see if other equations help, as in: + [Check fun a b : unit => (eqᵣefl : _ a = _ a b)] *) + x + | Some _, Success _ -> + (* sk1 and sk2 have a common outer part *) + if Stack.not_purely_applicative sk2 then + (* Ad hoc compatibility with 8.4 which treated non-app as rigid *) + flex_rigid true ev1 appr1 appr2 + else + if Stack.not_purely_applicative sk1 then + (* Ad hoc compatibility with 8.4 which treated non-app as rigid *) + flex_rigid false ev2 appr2 appr1 + else + (* We could instead try Miller unification, then + postpone to see if other equations help, as in: + [Check fun a b c : unit => (eqᵣefl : _ a b = _ c a b)] *) + UnifFailure (i,NotSameArgSize) + | _, _ -> anomaly (Pp.str "Unexpected result from ise_stack2.") + and f2 i = if Evar.equal sp1 sp2 then match ise_stack2 false env i (evar_conv_x ts) sk1 sk2 with @@ -712,10 +745,10 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty ise_try evd [f3; f4] (* Eta-expansion *) - | Rigid, _ when isLambda term1 -> + | Rigid, _ when isLambda term1 && (* if ever ill-typed: *) List.is_empty sk1 -> eta env evd true sk1 term1 sk2 term2 - | _, Rigid when isLambda term2 -> + | _, Rigid when isLambda term2 && (* if ever ill-typed: *) List.is_empty sk2 -> eta env evd false sk2 term2 sk1 term1 | Rigid, Rigid -> begin @@ -1071,7 +1104,7 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = abstract_free_holes evd subst, true with TypingFailed evd -> evd, false -let second_order_matching_with_args ts env evd ev l t = +let second_order_matching_with_args ts env evd pbty ev l t = (* let evd,ev = evar_absorb_arguments env evd ev l in let argoccs = Array.map_to_list (fun _ -> None) (snd ev) in @@ -1079,8 +1112,9 @@ let second_order_matching_with_args ts env evd ev l t = if b then Success evd else UnifFailure (evd, ConversionFailed (env,mkApp(mkEvar ev,l),t)) if b then Success evd else -*) - UnifFailure (evd, ConversionFailed (env,mkApp(mkEvar ev,l),t)) + *) + let pb = (pbty,env,mkApp(mkEvar ev,l),t) in + UnifFailure (evd, CannotSolveConstraint (pb,ProblemBeyondCapabilities)) let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = let t1 = apprec_nohdbeta ts env evd (whd_head_evar evd t1) in @@ -1096,7 +1130,9 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = type inference *) (match choose_less_dependent_instance evk1 evd term2 args1 with | Some evd -> Success evd - | None -> UnifFailure (evd, ConversionFailed (env,term1,term2))) + | None -> + let reason = ProblemBeyondCapabilities in + UnifFailure (evd, CannotSolveConstraint ((pbty,env,t1,t2),reason))) | (Rel _|Var _), Evar (evk2,args2) when app_empty && List.for_all (fun a -> Term.eq_constr a term1 || isEvar a) (remove_instance_local_defs evd evk2 args2) -> @@ -1104,7 +1140,9 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = type inference *) (match choose_less_dependent_instance evk2 evd term1 args2 with | Some evd -> Success evd - | None -> UnifFailure (evd, ConversionFailed (env,term1,term2))) + | None -> + let reason = ProblemBeyondCapabilities in + UnifFailure (evd, CannotSolveConstraint ((pbty,env,t1,t2),reason))) | Evar (evk1,args1), Evar (evk2,args2) when Evar.equal evk1 evk2 -> 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 @@ -1119,20 +1157,20 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = ise_try evd [(fun evd -> first_order_unification ts env evd (ev1,l1) appr2); (fun evd -> - second_order_matching_with_args ts env evd ev1 l1 t2)] + second_order_matching_with_args ts env evd pbty ev1 l1 t2)] | _,Evar ev2 when Array.length l2 <= Array.length l1 -> (* On "u u1 .. u(n+p) = ?n t1 .. tn", try first-order unification *) (* and otherwise second-order matching *) ise_try evd [(fun evd -> first_order_unification ts env evd (ev2,l2) appr1); (fun evd -> - second_order_matching_with_args ts env evd ev2 l2 t1)] + second_order_matching_with_args ts env evd pbty ev2 l2 t1)] | Evar ev1,_ -> (* Try second-order pattern-matching *) - second_order_matching_with_args ts env evd ev1 l1 t2 + second_order_matching_with_args ts env evd pbty ev1 l1 t2 | _,Evar ev2 -> (* Try second-order pattern-matching *) - second_order_matching_with_args ts env evd ev2 l2 t1 + second_order_matching_with_args ts env evd pbty ev2 l2 t1 | _ -> (* Some head evar have been instantiated, or unknown kind of problem *) evar_conv_x ts env evd pbty t1 t2 diff --git a/pretyping/find_subterm.ml b/pretyping/find_subterm.ml index ae8b91c346..df1fc20f1d 100644 --- a/pretyping/find_subterm.ml +++ b/pretyping/find_subterm.ml @@ -108,7 +108,6 @@ let replace_term_occ_gen_modulo occs like_first test bywhat cl occ t = raise (SubtermUnificationError (!nested,((cl,!pos),t),lastpos,e)) in let rec substrec k t = if nowhere_except_in && !pos > maxocc then t else - if not (Vars.closed0 t) then subst_below k t else try let subst = test.match_fun test.testing_state t in if Locusops.is_selected !pos occs then diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index e3b6fb08a8..04100c8a73 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -336,8 +336,8 @@ let glob_visible_short_qualid c = let add_and_check_ident id set = if Id.Set.mem id set then - Pp.(msg_warning - (str "Collision between bound variables of name " ++ Id.print id)); + Feedback.msg_warning + Pp.(str "Collision between bound variables of name " ++ Id.print id); Id.Set.add id set let bound_glob_vars = diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 8b061e3c2a..5d36fc78ef 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -184,7 +184,7 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = (match dest_recarg ra with | Mrec (_,j) when is_rec -> (depPvect.(j),rest) | Imbr _ -> - msg_warning (strbrk "Ignoring recursive call"); + Feedback.msg_warning (strbrk "Ignoring recursive call"); (None,rest) | _ -> (None, rest)) in diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 17bf28793f..2a5e999651 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -389,16 +389,16 @@ let native_norm env sigma c ty = let code, upd = mk_norm_code penv sigma prefix c in match Nativelib.compile ml_filename code with | true, fn -> - if !Flags.debug then Pp.msg_debug (Pp.str "Running norm ..."); + if !Flags.debug then Feedback.msg_debug (Pp.str "Running norm ..."); let t0 = Sys.time () in Nativelib.call_linker ~fatal:true prefix fn (Some upd); let t1 = Sys.time () in let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in - if !Flags.debug then Pp.msg_debug (Pp.str time_info); + if !Flags.debug then Feedback.msg_debug (Pp.str time_info); let res = nf_val env !Nativelib.rt1 ty in let t2 = Sys.time () in let time_info = Format.sprintf "Reification done in %.5f@." (t2 -. t1) in - if !Flags.debug then Pp.msg_debug (Pp.str time_info); + if !Flags.debug then Feedback.msg_debug (Pp.str time_info); res | _ -> anomaly (Pp.str "Compilation failure") diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 827071054a..d6305d81a8 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -348,7 +348,7 @@ let rec pat_of_raw metas vars = function | GHole _ -> PMeta None | GCast (_,c,_) -> - Pp.msg_warning (strbrk "Cast not taken into account in constr pattern"); + Feedback.msg_warning (strbrk "Cast not taken into account in constr pattern"); pat_of_raw metas vars c | GIf (_,c,(_,None),b1,b2) -> PIf (pat_of_raw metas vars c, diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml index cf5b08c58f..b0715af734 100644 --- a/pretyping/pretype_errors.ml +++ b/pretyping/pretype_errors.ml @@ -14,15 +14,16 @@ open Type_errors type unification_error = | OccurCheck of existential_key * constr - | NotClean of existential * env * constr + | NotClean of existential * env * constr (* Constr is a variable not in scope *) | NotSameArgSize | NotSameHead | NoCanonicalStructure - | ConversionFailed of env * constr * constr + | ConversionFailed of env * constr * constr (* Non convertible closed terms *) | MetaOccurInBody of existential_key | InstanceNotSameType of existential_key * env * types * types | UnifUnivInconsistency of Univ.univ_inconsistency | CannotSolveConstraint of Evd.evar_constraint * unification_error + | ProblemBeyondCapabilities type position = (Id.t * Locus.hyp_location_flag) option diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli index f617df9ee7..880f48e5f9 100644 --- a/pretyping/pretype_errors.mli +++ b/pretyping/pretype_errors.mli @@ -24,6 +24,7 @@ type unification_error = | InstanceNotSameType of existential_key * env * types * types | UnifUnivInconsistency of Univ.univ_inconsistency | CannotSolveConstraint of Evd.evar_constraint * unification_error + | ProblemBeyondCapabilities type position = (Id.t * Locus.hyp_location_flag) option diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 5d1f77a5a2..378294c984 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -143,7 +143,7 @@ let interp_universe_level_name evd (loc,s) = with Not_found -> try let id = try Id.of_string s with _ -> raise Not_found in - evd, Idmap.find id names + evd, snd (Idmap.find id names) with Not_found -> if not (is_strict_universe_declarations ()) then new_univ_level_variable ~loc ~name:s univ_rigid evd @@ -184,8 +184,7 @@ type inference_flags = { } let frozen_holes (sigma, sigma') = - let fold evk _ accu = Evar.Set.add evk accu in - Evd.fold_undefined fold sigma Evar.Set.empty + (); fun ev -> Evar.Map.mem ev (Evd.undefined_map sigma) let pending_holes (sigma, sigma') = let fold evk _ accu = @@ -194,7 +193,7 @@ let pending_holes (sigma, sigma') = Evd.fold_undefined fold sigma' Evar.Set.empty let apply_typeclasses env evdref frozen fail_evar = - let filter_frozen evk = Evar.Set.mem evk frozen in + let filter_frozen = 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)) diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 6499ddd537..bbb6a92663 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -216,7 +216,7 @@ let compute_canonical_projections (con,ind) = if Flags.is_verbose () then (let con_pp = Nametab.pr_global_env Id.Set.empty (ConstRef con) and proji_sp_pp = Nametab.pr_global_env Id.Set.empty (ConstRef proji_sp) in - msg_warning (strbrk "No global reference exists for projection value" + Feedback.msg_warning (strbrk "No global reference exists for projection value" ++ Termops.print_constr t ++ strbrk " in instance " ++ con_pp ++ str " of " ++ proji_sp_pp ++ strbrk ", ignoring it.")); l @@ -250,7 +250,7 @@ let open_canonical_structure i (_,o) = and new_can_s = (Termops.print_constr s.o_DEF) in let prj = (Nametab.pr_global_env Id.Set.empty proj) and hd_val = (pr_cs_pattern cs_pat) in - msg_warning (strbrk "Ignoring canonical projection to " ++ hd_val + Feedback.msg_warning (strbrk "Ignoring canonical projection to " ++ hd_val ++ strbrk " by " ++ prj ++ strbrk " in " ++ new_can_s ++ strbrk ": redundant with " ++ old_can_s)) lo diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index b6eb3a0379..79cb7a2f67 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -802,14 +802,15 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma = let rec whrec cst_l (x, stack as s) = let () = if !debug_RAKAM then let open Pp in - pp (h 0 (str "<<" ++ Termops.print_constr x ++ + Feedback.msg_notice + (h 0 (str "<<" ++ Termops.print_constr x ++ str "|" ++ cut () ++ Cst_stack.pr cst_l ++ str "|" ++ cut () ++ Stack.pr Termops.print_constr stack ++ str ">>") ++ fnl ()) in let fold () = let () = if !debug_RAKAM then - let open Pp in pp (str "<><><><><>" ++ fnl ()) in + let open Pp in Feedback.msg_notice (str "<><><><><>" ++ fnl ()) in (s,cst_l) in match kind_of_term x with diff --git a/pretyping/unification.ml b/pretyping/unification.ml index a4a386530d..21cf5548f2 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -657,7 +657,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb and cN = Evarutil.whd_head_evar sigma curn in let () = if !debug_unification then - msg_debug (Termops.print_constr_env curenv cM ++ str" ~= " ++ Termops.print_constr_env curenv cN) + Feedback.msg_debug (Termops.print_constr_env curenv cM ++ str" ~= " ++ Termops.print_constr_env curenv cN) in match (kind_of_term cM,kind_of_term cN) with | Meta k1, Meta k2 -> @@ -1054,12 +1054,14 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb else error_cannot_unify (fst curenvnb) sigma (cM,cN) in - if !debug_unification then msg_debug (str "Starting unification"); + if !debug_unification then Feedback.msg_debug (str "Starting unification"); let opt = { at_top = conv_at_top; with_types = false; with_cs = true } in try let res = - if occur_meta_or_undefined_evar sigma m || occur_meta_or_undefined_evar sigma n - || subterm_restriction opt flags then None + if subterm_restriction opt flags || + occur_meta_or_undefined_evar sigma m || occur_meta_or_undefined_evar sigma n + then + None else let sigma, b = match flags.modulo_conv_on_closed_terms with | Some convflags -> infer_conv ~pb:cv_pb ~ts:convflags env sigma m n @@ -1075,10 +1077,10 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb let a = match res with | Some sigma -> sigma, ms, es | None -> unirec_rec (env,0) cv_pb opt subst m n in - if !debug_unification then msg_debug (str "Leaving unification with success"); + if !debug_unification then Feedback.msg_debug (str "Leaving unification with success"); a with e -> - if !debug_unification then msg_debug (str "Leaving unification with failure"); + if !debug_unification then Feedback.msg_debug (str "Leaving unification with failure"); raise e diff --git a/printing/pptactic.ml b/printing/pptactic.ml index 44c832bd7a..5356cdee8a 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -366,6 +366,23 @@ module Make in str "<" ++ name ++ str ">" ++ args + let pr_alias_key key = + try + let prods = (KNmap.find key !prnotation_tab).pptac_prods in + (* First printing strategy: only the head symbol *) + match prods with + | TacTerm s :: prods -> str s + | _ -> + (* Second printing strategy; if ever Tactic Notation is eventually *) + (* accepting notations not starting with an identifier *) + let rec pr = function + | [] -> [] + | TacTerm s :: prods -> s :: pr prods + | TacNonTerm (_,_,id) :: prods -> ".." :: pr prods in + str (String.concat " " (pr prods)) + with Not_found -> + KerName.print key + let pr_alias_gen pr_gen lev key l = try let pp = KNmap.find key !prnotation_tab in @@ -816,7 +833,6 @@ module Make (* Printing tactics as arguments *) let rec pr_atom0 a = tag_atom a (match a with | TacIntroPattern [] -> primitive "intros" - | TacIntroMove (None,MoveLast) -> primitive "intro" | t -> str "(" ++ pr_atom1 t ++ str ")" ) @@ -828,15 +844,6 @@ module Make | TacIntroPattern (_::_ as p) -> hov 1 (primitive "intros" ++ spc () ++ prlist_with_sep spc (Miscprint.pr_intro_pattern pr.pr_dconstr) p) - | TacIntroMove (None,MoveLast) as t -> - pr_atom0 t - | TacIntroMove (Some id,MoveLast) -> - primitive "intro" ++ spc () ++ pr_id id - | TacIntroMove (ido,hto) -> - hov 1 (primitive "intro" ++ pr_opt pr_id ido ++ - Miscprint.pr_move_location pr.pr_name hto) - | TacExact c -> - hov 1 (primitive "exact" ++ pr_constrarg c) | TacApply (a,ev,cb,inhyp) -> hov 1 ( (if a then mt() else primitive "simple ") ++ @@ -909,23 +916,6 @@ module Make pr_opt (pr_clauses None pr.pr_name) cl) l ++ pr_opt pr_eliminator el ) - | TacDoubleInduction (h1,h2) -> - hov 1 ( - primitive "double induction" - ++ pr_arg pr_quantified_hypothesis h1 - ++ pr_arg pr_quantified_hypothesis h2 - ) - - (* Context management *) - | TacRename l -> - hov 1 ( - primitive "rename" ++ brk (1,1) - ++ prlist_with_sep - (fun () -> str "," ++ brk (1,1)) - (fun (i1,i2) -> - pr.pr_name i1 ++ spc () ++ str "into" ++ spc () ++ pr.pr_name i2) - l - ) (* Conversion *) | TacReduce (r,h) -> diff --git a/printing/pptacticsig.mli b/printing/pptacticsig.mli index 4ef2ea9189..c08d6044db 100644 --- a/printing/pptacticsig.mli +++ b/printing/pptacticsig.mli @@ -45,9 +45,13 @@ module type Pp = sig val pr_extend : (Val.t -> std_ppcmds) -> int -> ml_tactic_entry -> Val.t list -> std_ppcmds + val pr_alias_key : Names.KerName.t -> std_ppcmds + val pr_alias : (Val.t -> std_ppcmds) -> int -> Names.KerName.t -> Val.t list -> std_ppcmds + val pr_alias_key : Names.KerName.t -> std_ppcmds + val pr_ltac_constant : Nametab.ltac_constant -> std_ppcmds val pr_raw_tactic : raw_tactic_expr -> std_ppcmds diff --git a/printing/printer.ml b/printing/printer.ml index cb075c64fb..cc8da4097d 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -28,10 +28,7 @@ let delayed_emacs_cmd s = if !Flags.print_emacs then s () else str "" let get_current_context () = - try Pfedit.get_current_goal_context () - with e when Logic.catchable_exception e -> - let env = Global.env () in - (Evd.from_env env, env) + Pfedit.get_current_context () (**********************************************************************) (** Terms *) @@ -551,7 +548,7 @@ let default_pr_subgoals ?(pr_first=true) close_cmd sigma seeds shelf stack goals (* Side effect! This has to be made more robust *) let () = match close_cmd with - | Some cmd -> msg_info cmd + | Some cmd -> Feedback.msg_info cmd | None -> () in match goals with @@ -629,12 +626,12 @@ let pr_open_subgoals ?(proof=Proof_global.give_me_the_proof ()) () = begin match bgoals,shelf,given_up with | [] , [] , [] -> pr_subgoals None sigma seeds shelf stack goals | [] , [] , _ -> - msg_info (str "No more subgoals, but there are some goals you gave up:"); + Feedback.msg_info (str "No more subgoals, but there are some goals you gave up:"); fnl () ++ pr_subgoals ~pr_first:false None bsigma seeds [] [] given_up ++ fnl () ++ str "You need to go back and solve them." | [] , _ , _ -> - msg_info (str "All the remaining goals are on the shelf."); + Feedback.msg_info (str "All the remaining goals are on the shelf."); fnl () ++ pr_subgoals ~pr_first:false None bsigma seeds [] [] shelf | _ , _, _ -> diff --git a/printing/printing.mllib b/printing/printing.mllib index 652a34fa1f..bc8f0750e1 100644 --- a/printing/printing.mllib +++ b/printing/printing.mllib @@ -2,12 +2,8 @@ Genprint Pputils Ppannotation Ppconstr -Ppconstrsig Printer Pptactic -Pptacticsig Printmod Prettyp Ppvernac -Ppvernacsig -Richprinter diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 1ef0b087ba..78dce0d64c 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -491,7 +491,8 @@ let clenv_unify_binding_type clenv c t u = let evd,c = w_coerce_to_type (cl_env clenv) clenv.evd c t u in TypeProcessed, { clenv with evd = evd }, c with - | PretypeError (_,_,ActualTypeNotCoercible (_,_,NotClean _)) as e -> + | PretypeError (_,_,ActualTypeNotCoercible (_,_, + (NotClean _ | ConversionFailed _))) as e -> raise e | e when precatchable_exception e -> TypeNotProcessed, clenv, c diff --git a/proofs/clenv.mli b/proofs/clenv.mli index 59b166ea01..e9236b1da3 100644 --- a/proofs/clenv.mli +++ b/proofs/clenv.mli @@ -6,6 +6,10 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(** This file defines clausenv, which is a deprecated way to handle open terms + in the proof engine. Most of the API here is legacy except for the + evar-based clauses. *) + open Names open Term open Environ diff --git a/proofs/clenvtac.mli b/proofs/clenvtac.mli index 00e74a2478..aa091aecda 100644 --- a/proofs/clenvtac.mli +++ b/proofs/clenvtac.mli @@ -6,6 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(** Legacy components of the previous proof engine. *) + open Term open Clenv open Tacexpr diff --git a/proofs/goal.mli b/proofs/goal.mli index 8a3d6e815a..6a79c1f451 100644 --- a/proofs/goal.mli +++ b/proofs/goal.mli @@ -6,7 +6,9 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* This module implements the abstract interface to goals *) +(** This module implements the abstract interface to goals. Most of the code + here is useless and should be eventually removed. Consider using + {!Proofview.Goal} instead. *) type goal = Evar.t diff --git a/proofs/logic.mli b/proofs/logic.mli index 9aa4ac2074..2764d28c02 100644 --- a/proofs/logic.mli +++ b/proofs/logic.mli @@ -6,6 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(** Legacy proof engine. Do not use in newly written code. *) + open Names open Term open Evd diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index 5367a907e5..2863384b59 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -71,23 +71,34 @@ let get_nth_V82_goal i = with Failure _ -> raise NoSuchGoal let get_goal_context_gen i = - try -let { it=goal ; sigma=sigma; } = get_nth_V82_goal i in -(sigma, Refiner.pf_env { it=goal ; sigma=sigma; }) - with Proof_global.NoCurrentProof -> Errors.error "No focused proof." + let { it=goal ; sigma=sigma; } = get_nth_V82_goal i in + (sigma, Refiner.pf_env { it=goal ; sigma=sigma; }) let get_goal_context i = try get_goal_context_gen i - with NoSuchGoal -> Errors.error "No such goal." + with Proof_global.NoCurrentProof -> Errors.error "No focused proof." + | NoSuchGoal -> Errors.error "No such goal." let get_current_goal_context () = try get_goal_context_gen 1 - with NoSuchGoal -> + with Proof_global.NoCurrentProof -> Errors.error "No focused proof." + | NoSuchGoal -> (* spiwack: returning empty evar_map, since if there is no goal, under focus, there is no accessible evar either *) let env = Global.env () in (Evd.from_env env, env) +let get_current_context () = + try get_goal_context_gen 1 + with Proof_global.NoCurrentProof -> + let env = Global.env () in + (Evd.from_env env, env) + | NoSuchGoal -> + (* No more focused goals ? *) + let p = get_pftreestate () in + let evd = Proof.in_proof p (fun x -> x) in + (evd, Global.env ()) + let current_proof_statement () = match Proof_global.V82.get_current_initial_conclusions () with | (id,([concl],strength)) -> id,strength,concl @@ -111,7 +122,7 @@ let solve ?with_end_tac gi info_lvl tac pr = let () = match info_lvl with | None -> () - | Some i -> Pp.msg_info (hov 0 (Proofview.Trace.pr_info ~lvl:i info)) + | Some i -> Feedback.msg_info (hov 0 (Proofview.Trace.pr_info ~lvl:i info)) in (p,status) with diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index cd89920151..666730e1af 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -6,6 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(** Global proof state. A quite redundant wrapper on {!Proof_global}. *) + open Loc open Names open Term @@ -93,6 +95,14 @@ val get_goal_context : int -> Evd.evar_map * env val get_current_goal_context : unit -> Evd.evar_map * env +(** [get_current_context ()] returns the context of the + current focused goal. If there is no focused goal but there + is a proof in progress, it returns the corresponding evar_map. + If there is no pending proof then it returns the current global + environment and empty evar_map. *) + +val get_current_context : unit -> Evd.evar_map * env + (** [current_proof_statement] *) val current_proof_statement : diff --git a/proofs/proof_type.mli b/proofs/proof_type.mli index ef0d52b62d..f7798a0edb 100644 --- a/proofs/proof_type.mli +++ b/proofs/proof_type.mli @@ -6,6 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(** Legacy proof engine. Do not use in newly written code. *) + open Evd open Names open Term @@ -26,31 +28,6 @@ type prim_rule = type rule = prim_rule -(** The type [goal sigma] is the type of subgoal. It has the following form -{v it = \{ evar_concl = [the conclusion of the subgoal] - evar_hyps = [the hypotheses of the subgoal] - evar_body = Evar_Empty; - evar_info = \{ pgm : [The Realizer pgm if any] - lc : [Set of evar num occurring in subgoal] \}\} - sigma = \{ stamp = [an int chardacterizing the ed field, for quick compare] - ed : [A set of existential variables depending in the subgoal] - number of first evar, - it = \{ evar_concl = [the type of first evar] - evar_hyps = [the context of the evar] - evar_body = [the body of the Evar if any] - evar_info = \{ pgm : [Useless ??] - lc : [Set of evars occurring - in the type of evar] \} \}; - ... - number of last evar, - it = \{ evar_concl = [the type of evar] - evar_hyps = [the context of the evar] - evar_body = [the body of the Evar if any] - evar_info = \{ pgm : [Useless ??] - lc : [Set of evars occurring - in the type of evar] \} \} \} v} -*) - type goal = Goal.goal type tactic = goal sigma -> goal list sigma diff --git a/proofs/proof_using.ml b/proofs/proof_using.ml index 681a7fa1ad..caa9b328a0 100644 --- a/proofs/proof_using.ml +++ b/proofs/proof_using.ml @@ -128,7 +128,7 @@ let suggest_Proof_using name env vars ids_typ context_ids = if S.equal all_needed fwd_typ then valid (str "Type*"); if S.equal all all_needed then valid(str "All"); valid (pr_set false needed); - msg_info ( + Feedback.msg_info ( str"The proof of "++ str name ++ spc() ++ str "should start with one of the following commands:"++spc()++ v 0 ( diff --git a/proofs/proof_using.mli b/proofs/proof_using.mli index 1bf38b6908..b2c65412f8 100644 --- a/proofs/proof_using.mli +++ b/proofs/proof_using.mli @@ -6,6 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(** Utility code for section variables handling in Proof using... *) + val process_expr : Environ.env -> Vernacexpr.section_subset_expr -> Constr.types list -> Names.Id.t list diff --git a/proofs/proofs.mllib b/proofs/proofs.mllib index 9130a186ba..804a543605 100644 --- a/proofs/proofs.mllib +++ b/proofs/proofs.mllib @@ -2,7 +2,6 @@ Miscprint Goal Evar_refiner Proof_using -Proof_errors Logic Refine Proof diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml index 2d886b8e1f..13b5848a33 100644 --- a/proofs/redexpr.ml +++ b/proofs/redexpr.ml @@ -31,7 +31,7 @@ let cbv_vm env sigma c = let cbv_native env sigma c = if Coq_config.no_native_compiler then - let () = msg_warning (str "native_compute disabled at configure time; falling back to vm_compute.") in + let () = Feedback.msg_warning (str "native_compute disabled at configure time; falling back to vm_compute.") in cbv_vm env sigma c else let ctyp = Retyping.get_type_of env sigma c in @@ -221,7 +221,7 @@ let reduction_of_red_expr env = let am = if !simplIsCbn then strong_cbn (make_flag f) else simpl in let () = if not (!simplIsCbn || List.is_empty f.rConst) then - Pp.msg_warning (Pp.strbrk "The legacy simpl does not deal with delta flags.") in + Feedback.msg_warning (Pp.strbrk "The legacy simpl does not deal with delta flags.") in (contextualize (if head_style then whd_am else am) am o,DEFAULTcast) | Cbv f -> (e_red (cbv_norm_flags (make_flag f)),DEFAULTcast) | Cbn f -> diff --git a/proofs/redexpr.mli b/proofs/redexpr.mli index b91911087d..d4c2c4a6c9 100644 --- a/proofs/redexpr.mli +++ b/proofs/redexpr.mli @@ -6,6 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(** Interpretation layer of redexprs such as hnf, cbv, etc. *) + open Names open Term open Pattern diff --git a/proofs/refine.mli b/proofs/refine.mli index 17c7e28ca9..a9798b7040 100644 --- a/proofs/refine.mli +++ b/proofs/refine.mli @@ -6,6 +6,11 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(** The primitive refine tactic used to fill the holes in partial proofs. This + is the recommanded way to write tactics when the proof term is easy to + write down. Note that this is not the user-level refine tactic defined + in Ltac which is actually based on the one below. *) + open Proofview (** {6 The refine tactic} *) diff --git a/proofs/refiner.ml b/proofs/refiner.ml index 186525e159..23433692cd 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -57,7 +57,7 @@ let tclIDTAC gls = goal_goal_list gls (* the message printing identity tactic *) let tclIDTAC_MESSAGE s gls = - Pp.msg_info (hov 0 s); pp_flush (); tclIDTAC gls + Feedback.msg_info (hov 0 s); tclIDTAC gls (* General failure tactic *) let tclFAIL_s s gls = errorlabstrm "Refiner.tclFAIL_s" (str s) @@ -218,7 +218,8 @@ let tclSHOWHYPS (tac : tactic) (goal: Goal.goal Evd.sigma) (fun acc d -> (Names.Id.to_string (get_id d)) ^ " " ^ acc) "" lh)) "" newhyps in - pp (str (emacs_str "<infoH>") + Feedback.msg_notice + (str (emacs_str "<infoH>") ++ (hov 0 (str s)) ++ (str (emacs_str "</infoH>")) ++ fnl()); tclIDTAC goal;; diff --git a/proofs/refiner.mli b/proofs/refiner.mli index dd9153a023..6dcafb77a4 100644 --- a/proofs/refiner.mli +++ b/proofs/refiner.mli @@ -6,6 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(** Legacy proof engine. Do not use in newly written code. *) + open Evd open Proof_type diff --git a/stm/asyncTaskQueue.ml b/stm/asyncTaskQueue.ml index c7faef3333..a7b381ad62 100644 --- a/stm/asyncTaskQueue.ml +++ b/stm/asyncTaskQueue.ml @@ -104,7 +104,8 @@ module Make(T : Task) = struct marshal_err ("unmarshal_more_data: "^s) let report_status ?(id = !Flags.async_proofs_worker_id) s = - Pp.feedback ~state_id:Stateid.initial (Feedback.WorkerStatus(id, s)) + let open Feedback in + feedback ~id:(State Stateid.initial) (WorkerStatus(id, s)) module Worker = Spawn.Sync(struct end) @@ -123,7 +124,7 @@ module Make(T : Task) = struct "-async-proofs-worker-priority"; Flags.string_of_priority !Flags.async_proofs_worker_priority] | ("-ideslave"|"-emacs"|"-emacs-U"|"-batch")::tl -> set_slave_opt tl - | ("-async-proofs" |"-toploop" |"-vi2vo" + | ("-async-proofs" |"-toploop" |"-vio2vo" |"-load-vernac-source" |"-l" |"-load-vernac-source-verbose" |"-lv" |"-compile" |"-compile-verbose" |"-async-proofs-worker-priority" |"-worker-id") :: _ :: tl -> @@ -302,8 +303,8 @@ module Make(T : Task) = struct let main_loop () = let slave_feeder oc fb = Marshal.to_channel oc (RespFeedback fb) []; flush oc in - Pp.set_feeder (fun x -> slave_feeder (Option.get !slave_oc) x); - Pp.log_via_feedback (fun msg -> Richpp.repr (Richpp.richpp_of_pp msg)); + Feedback.set_feeder (fun x -> slave_feeder (Option.get !slave_oc) x); + Feedback.set_logger Feedback.feedback_logger; Universes.set_remote_new_univ_level (bufferize (fun () -> marshal_response (Option.get !slave_oc) RespGetCounterNewUnivLevel; match unmarshal_more_data (Option.get !slave_ic) with diff --git a/stm/dag.ml b/stm/dag.ml index 0c7f9f34bd..99e7c92648 100644 --- a/stm/dag.ml +++ b/stm/dag.ml @@ -8,15 +8,6 @@ module type S = sig - module Cluster : - sig - type 'd t - val equal : 'd t -> 'd t -> bool - val compare : 'd t -> 'd t -> int - val to_string : 'd t -> string - val data : 'd t -> 'd - end - type node module NodeSet : Set.S with type elt = node @@ -31,45 +22,57 @@ module type S = sig val del_nodes : ('e,'i,'d) t -> NodeSet.t -> ('e,'i,'d) t val all_nodes : ('e,'i,'d) t -> NodeSet.t - val iter : ('e,'i,'d) t -> - (node -> 'd Cluster.t option -> 'i option -> - (node * 'e) list -> unit) -> unit - - val create_cluster : ('e,'i,'d) t -> node list -> 'd -> ('e,'i,'d) t - val cluster_of : ('e,'i,'d) t -> node -> 'd Cluster.t option - val del_cluster : ('e,'i,'d) t -> 'd Cluster.t -> ('e,'i,'d) t - val get_info : ('e,'i,'d) t -> node -> 'i option val set_info : ('e,'i,'d) t -> node -> 'i -> ('e,'i,'d) t val clear_info : ('e,'i,'d) t -> node -> ('e,'i,'d) t + module Property : + sig + type 'd t + val equal : 'd t -> 'd t -> bool + val compare : 'd t -> 'd t -> int + val to_string : 'd t -> string + val data : 'd t -> 'd + val having_it : 'd t -> NodeSet.t + end + + val create_property : ('e,'i,'d) t -> node list -> 'd -> ('e,'i,'d) t + val property_of : ('e,'i,'d) t -> node -> 'd Property.t list + val del_property : ('e,'i,'d) t -> 'd Property.t -> ('e,'i,'d) t + + val iter : ('e,'i,'d) t -> + (node -> 'd Property.t list -> 'i option -> + (node * 'e) list -> unit) -> unit + end module Make(OT : Map.OrderedType) = struct -module Cluster = +module NodeSet = Set.Make(OT) + +module Property = struct - type 'd t = 'd * int - let equal (_,i1) (_,i2) = Int.equal i1 i2 - let compare (_,i1) (_,i2) = Int.compare i1 i2 - let to_string (_,i) = string_of_int i - let data (d,_) = d + type 'd t = { data : 'd; uid : int; having_it : NodeSet.t } + let equal { uid = i1 } { uid = i2 } = Int.equal i1 i2 + let compare { uid = i1 } { uid = i2 } = Int.compare i1 i2 + let to_string { uid = i } = string_of_int i + let data { data = d } = d + let having_it { having_it } = having_it end type node = OT.t module NodeMap = CMap.Make(OT) -module NodeSet = Set.Make(OT) type ('edge,'info,'data) t = { graph : (node * 'edge) list NodeMap.t; - clusters : 'data Cluster.t NodeMap.t; + properties : 'data Property.t list NodeMap.t; infos : 'info NodeMap.t; } let empty = { graph = NodeMap.empty; - clusters = NodeMap.empty; + properties = NodeMap.empty; infos = NodeMap.empty; } @@ -94,7 +97,7 @@ let del_edge dag id tgt = { dag with let del_nodes dag s = { infos = NodeMap.filter (fun n _ -> not(NodeSet.mem n s)) dag.infos; - clusters = NodeMap.filter (fun n _ -> not(NodeSet.mem n s)) dag.clusters; + properties = NodeMap.filter (fun n _ -> not(NodeSet.mem n s)) dag.properties; graph = NodeMap.filter (fun n l -> let drop = NodeSet.mem n s in if not drop then @@ -102,20 +105,31 @@ let del_nodes dag s = { not drop) dag.graph } +let map_add_list k v m = + try + let l = NodeMap.find k m in + NodeMap.add k (v::l) m + with Not_found -> NodeMap.add k [v] m + let clid = ref 1 -let create_cluster dag l data = +let create_property dag l data = incr clid; - { dag with clusters = - List.fold_right (fun x clusters -> - NodeMap.add x (data, !clid) clusters) l dag.clusters } - -let cluster_of dag id = - try Some (NodeMap.find id dag.clusters) - with Not_found -> None - -let del_cluster dag c = - { dag with clusters = - NodeMap.filter (fun _ c' -> not (Cluster.equal c' c)) dag.clusters } + let having_it = List.fold_right NodeSet.add l NodeSet.empty in + let property = { Property.data; uid = !clid; having_it } in + { dag with properties = + List.fold_right (fun x ps -> map_add_list x property ps) l dag.properties } + +let property_of dag id = + try NodeMap.find id dag.properties + with Not_found -> [] + +let del_property dag c = + { dag with properties = + NodeMap.filter (fun _ cl -> cl <> []) + (NodeMap.map (fun cl -> + List.filter (fun c' -> + not (Property.equal c' c)) cl) + dag.properties) } let get_info dag id = try Some (NodeMap.find id dag.infos) @@ -126,7 +140,7 @@ let set_info dag id info = { dag with infos = NodeMap.add id info dag.infos } let clear_info dag id = { dag with infos = NodeMap.remove id dag.infos } let iter dag f = - NodeMap.iter (fun k v -> f k (cluster_of dag k) (get_info dag k) v) dag.graph + NodeMap.iter (fun k v -> f k (property_of dag k) (get_info dag k) v) dag.graph let all_nodes dag = NodeMap.domain dag.graph diff --git a/stm/dag.mli b/stm/dag.mli index 6b4442df00..e783cd8ee1 100644 --- a/stm/dag.mli +++ b/stm/dag.mli @@ -7,19 +7,7 @@ (************************************************************************) module type S = sig - - (* A cluster is just a set of nodes. This set holds some data. - Stm uses this to group nodes contribution to the same proofs and - that can be evaluated asynchronously *) - module Cluster : - sig - type 'd t - val equal : 'd t -> 'd t -> bool - val compare : 'd t -> 'd t -> int - val to_string : 'd t -> string - val data : 'd t -> 'd - end - + type node module NodeSet : Set.S with type elt = node @@ -34,19 +22,35 @@ module type S = sig val del_nodes : ('e,'i,'d) t -> NodeSet.t -> ('e,'i,'d) t val all_nodes : ('e,'i,'d) t -> NodeSet.t - val iter : ('e,'i,'d) t -> - (node -> 'd Cluster.t option -> 'i option -> - (node * 'e) list -> unit) -> unit - - val create_cluster : ('e,'i,'d) t -> node list -> 'd -> ('e,'i,'d) t - val cluster_of : ('e,'i,'d) t -> node -> 'd Cluster.t option - val del_cluster : ('e,'i,'d) t -> 'd Cluster.t -> ('e,'i,'d) t - val get_info : ('e,'i,'d) t -> node -> 'i option val set_info : ('e,'i,'d) t -> node -> 'i -> ('e,'i,'d) t val clear_info : ('e,'i,'d) t -> node -> ('e,'i,'d) t -end + (* A property applies to a set of nodes and holds some data. + Stm uses this feature to group nodes contributing to the same proofs and + to structure proofs in boxes limiting the scope of errors *) + module Property : + sig + type 'd t + val equal : 'd t -> 'd t -> bool + val compare : 'd t -> 'd t -> int + val to_string : 'd t -> string + val data : 'd t -> 'd + val having_it : 'd t -> NodeSet.t + end + + val create_property : ('e,'i,'d) t -> node list -> 'd -> ('e,'i,'d) t + val property_of : ('e,'i,'d) t -> node -> 'd Property.t list + val del_property : ('e,'i,'d) t -> 'd Property.t -> ('e,'i,'d) t + + val iter : ('e,'i,'d) t -> + (node -> 'd Property.t list -> 'i option -> + (node * 'e) list -> unit) -> unit + + end -module Make(OT : Map.OrderedType) : S with type node = OT.t +module Make(OT : Map.OrderedType) : S +with type node = OT.t +and type NodeSet.t = Set.Make(OT).t +and type NodeSet.elt = OT.t diff --git a/stm/lemmas.ml b/stm/lemmas.ml index ce5ef01699..0a63a3a0fe 100644 --- a/stm/lemmas.ml +++ b/stm/lemmas.ml @@ -150,7 +150,7 @@ let find_mutually_recursive_statements thms = assert (List.is_empty rest); (* One occ. of common coind ccls and no common inductive hyps *) if not (List.is_empty common_same_indhyp) then - if_verbose msg_info (str "Assuming mutual coinductive statements."); + if_verbose Feedback.msg_info (str "Assuming mutual coinductive statements."); flush_all (); indccl, true, [] | [], _::_ -> @@ -158,7 +158,7 @@ let find_mutually_recursive_statements thms = | ind :: _ -> if List.distinct_f ind_ord (List.map pi1 ind) then - if_verbose msg_info + if_verbose Feedback.msg_info (strbrk ("Coinductive statements do not follow the order of "^ "definition, assuming the proof to be by induction.")); @@ -306,7 +306,7 @@ let admit (id,k,e) pl hook () = let () = match k with | Global, _, _ -> () | Local, _, _ | Discharge, _, _ -> - msg_warning (str "Let definition" ++ spc () ++ pr_id id ++ spc () ++ + Feedback.msg_warning (str "Let definition" ++ spc () ++ pr_id id ++ spc () ++ str "declared as an axiom.") in let () = assumption_message id in @@ -336,7 +336,7 @@ let universe_proof_terminator compute_guard hook = make_terminator begin function | Admitted (id,k,pe,(ctx,pl)) -> admit (id,k,pe) pl (hook (Some ctx)) (); - Pp.feedback Feedback.AddedAxiom + Feedback.feedback Feedback.AddedAxiom | Proved (opaque,idopt,proof) -> let is_opaque, export_seff, exports = match opaque with | Vernacexpr.Transparent -> false, true, [] @@ -520,13 +520,5 @@ let save_proof ?proof = function (* Miscellaneous *) let get_current_context () = - try Pfedit.get_current_goal_context () - with e when Logic.catchable_exception e -> - try (* No more focused goals ? *) - let p = Pfedit.get_pftreestate () in - let evd = Proof.in_proof p (fun x -> x) in - (evd, Global.env ()) - with Proof_global.NoCurrentProof -> - let env = Global.env () in - (Evd.from_env env, env) + Pfedit.get_current_context () diff --git a/stm/lemmas.mli b/stm/lemmas.mli index 9120787d1c..f751598f04 100644 --- a/stm/lemmas.mli +++ b/stm/lemmas.mli @@ -65,4 +65,3 @@ val save_proof : ?proof:Proof_global.closed_proof -> Vernacexpr.proof_end -> uni and the current global env *) val get_current_context : unit -> Evd.evar_map * Environ.env - diff --git a/stm/proofBlockDelimiter.ml b/stm/proofBlockDelimiter.ml new file mode 100644 index 0000000000..ce12185cba --- /dev/null +++ b/stm/proofBlockDelimiter.ml @@ -0,0 +1,184 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Stm + +module Util : sig + +val simple_goal : Evd.evar_map -> Goal.goal -> Goal.goal list -> bool +val is_focused_goal_simple : Stateid.t -> [ `Simple of Goal.goal list | `Not ] + +type 'a until = [ `Stop | `Found of static_block_declaration | `Cont of 'a ] + +val crawl : + document_view -> ?init:document_node option -> + ('a -> document_node -> 'a until) -> 'a -> + static_block_declaration option + +val unit_val : Stm.DynBlockData.t +val of_bullet_val : Vernacexpr.bullet -> Stm.DynBlockData.t +val to_bullet_val : Stm.DynBlockData.t -> Vernacexpr.bullet +val of_vernac_expr_val : Vernacexpr.vernac_expr -> Stm.DynBlockData.t +val to_vernac_expr_val : Stm.DynBlockData.t -> Vernacexpr.vernac_expr + +end = struct + +let unit_tag = DynBlockData.create "unit" +let unit_val = DynBlockData.Easy.inj () unit_tag + +let of_bullet_val, to_bullet_val = DynBlockData.Easy.make_dyn "bullet" +let of_vernac_expr_val, to_vernac_expr_val = DynBlockData.Easy.make_dyn "vernac_expr" + +let simple_goal sigma g gs = + let open Evar in + let open Evd in + let open Evarutil in + let evi = Evd.find sigma g in + Set.is_empty (evars_of_term evi.evar_concl) && + Set.is_empty (evars_of_filtered_evar_info (nf_evar_info sigma evi)) && + not (List.exists (Proofview.depends_on sigma g) gs) + +let is_focused_goal_simple id = + match state_of_id id with + | `Expired | `Error _ | `Valid None -> `Not + | `Valid (Some { proof }) -> + let proof = Proof_global.proof_of_state proof in + let focused, r1, r2, r3, sigma = Proof.proof proof in + let rest = List.(flatten (map (fun (x,y) -> x @ y) r1)) @ r2 @ r3 in + if List.for_all (fun x -> simple_goal sigma x rest) focused + then `Simple focused + else `Not + +type 'a until = [ `Stop | `Found of static_block_declaration | `Cont of 'a ] + +let crawl { entry_point; prev_node } ?(init=Some entry_point) f acc = + let rec crawl node acc = + match node with + | None -> None + | Some node -> + match f acc node with + | `Stop -> None + | `Found x -> Some x + | `Cont acc -> crawl (prev_node node) acc in + crawl init acc + +end + +include Util + +(* ****************** - foo - bar - baz *********************************** *) + +let static_bullet ({ entry_point; prev_node } as view) = + match entry_point.ast with + | Vernacexpr.VernacBullet b -> + let base = entry_point.indentation in + let last_tac = prev_node entry_point in + crawl view ~init:last_tac (fun prev node -> + if node.indentation < base then `Stop else + 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; + dynamic_switch = node.id; carry_on_data = of_bullet_val b } + | _ -> `Stop) entry_point + | _ -> assert false + +let dynamic_bullet { dynamic_switch = id; carry_on_data = b } = + match is_focused_goal_simple id with + | `Simple focused -> + `ValidBlock { + base_state = id; + goals_to_admit = focused; + recovery_command = Some (Vernacexpr.VernacBullet (to_bullet_val b)) + } + | `Not -> `Leaks + +let () = register_proof_block_delimiter + "bullet" static_bullet dynamic_bullet + +(* ******************** { block } ***************************************** *) + +let static_curly_brace ({ entry_point; prev_node } as view) = + assert(entry_point.ast = Vernacexpr.VernacEndSubproof); + crawl view (fun (nesting,prev) node -> + match node.ast with + | Vernacexpr.VernacSubproof _ when nesting = 0 -> + `Found { stop = entry_point.id; start = prev.id; + dynamic_switch = node.id; carry_on_data = unit_val } + | Vernacexpr.VernacSubproof _ -> + `Cont (nesting - 1,node) + | Vernacexpr.VernacEndSubproof -> + `Cont (nesting + 1,node) + | _ -> `Cont (nesting,node)) (-1, entry_point) + +let dynamic_curly_brace { dynamic_switch = id } = + match is_focused_goal_simple id with + | `Simple focused -> + `ValidBlock { + base_state = id; + goals_to_admit = focused; + recovery_command = Some Vernacexpr.VernacEndSubproof + } + | `Not -> `Leaks + +let () = register_proof_block_delimiter + "curly" static_curly_brace dynamic_curly_brace + +(* ***************** par: ************************************************* *) + +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; + dynamic_switch = pid; carry_on_data = unit_val } + +let dynamic_par { dynamic_switch = id } = + match is_focused_goal_simple id with + | `Simple focused -> + `ValidBlock { + base_state = id; + goals_to_admit = focused; + recovery_command = None; + } + | `Not -> `Leaks + +let () = register_proof_block_delimiter "par" static_par dynamic_par + +(* ***************** simple indentation *********************************** *) + +let static_indent ({ entry_point; prev_node } as view) = + Printf.eprintf "@%d\n" (Stateid.to_int entry_point.id); + match prev_node entry_point with + | None -> None + | Some last_tac -> + if last_tac.indentation <= entry_point.indentation then None + else + 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; + dynamic_switch = node.id; + carry_on_data = of_vernac_expr_val entry_point.ast } + ) last_tac + +let dynamic_indent { dynamic_switch = id; carry_on_data = e } = + Printf.eprintf "%s\n" (Stateid.to_string id); + match is_focused_goal_simple id with + | `Simple [] -> `Leaks + | `Simple focused -> + let but_last = List.tl (List.rev focused) in + `ValidBlock { + base_state = id; + goals_to_admit = but_last; + recovery_command = Some (to_vernac_expr_val e); + } + | `Not -> `Leaks + +let () = register_proof_block_delimiter "indent" static_indent dynamic_indent + diff --git a/stm/proofBlockDelimiter.mli b/stm/proofBlockDelimiter.mli new file mode 100644 index 0000000000..a55032a470 --- /dev/null +++ b/stm/proofBlockDelimiter.mli @@ -0,0 +1,41 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(* This file implements proof block detection for: + - blocks delimited by { and } + - bullets with indentation + - par: terminator + + It exports utility functions to ease the development of other proof block + detection code. +*) + +(** A goal is simple if it nor depends on nor impacts on any other goal. + This function is used to detect, dynamically, if a proof block leaks, + i.e. if skipping it could impact other goals (like not instantiating their + type). `Simple carries the list of focused goals. +*) +val simple_goal : Evd.evar_map -> Goal.goal -> Goal.goal list -> bool +val is_focused_goal_simple : Stateid.t -> [ `Simple of Goal.goal list | `Not ] + +type 'a until = [ `Stop | `Found of Stm.static_block_declaration | `Cont of 'a ] + +(* Simpler function to crawl the document backward to detect the block. + * ?init is the entry point of the document view if not given *) +val crawl : + Stm.document_view -> ?init:Stm.document_node option -> + ('a -> Stm.document_node -> 'a until) -> 'a -> + Stm.static_block_declaration option + +(* Dummy value for static_block_declaration when no real value is needed *) +val unit_val : Stm.DynBlockData.t + +(* Bullets *) +val of_bullet_val : Vernacexpr.bullet -> Stm.DynBlockData.t +val to_bullet_val : Stm.DynBlockData.t -> Vernacexpr.bullet + diff --git a/stm/stm.ml b/stm/stm.ml index ebafed8d37..c0813827de 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -18,6 +18,7 @@ open Names open Util open Ppvernac open Vernac_classifier +open Feedback module Hooks = struct @@ -27,28 +28,23 @@ let with_fail, with_fail_hook = Hook.make () let state_computed, state_computed_hook = Hook.make ~default:(fun state_id ~in_cache -> - feedback ~state_id Feedback.Processed) () + feedback ~id:(State state_id) Processed) () let state_ready, state_ready_hook = Hook.make ~default:(fun state_id -> ()) () let forward_feedback, forward_feedback_hook = Hook.make ~default:(function - | { Feedback.id = Feedback.Edit edit_id; route; contents } -> - feedback ~edit_id ~route contents - | { Feedback.id = Feedback.State state_id; route; contents } -> - feedback ~state_id ~route contents) () + | { id = id; route; contents } -> + feedback ~id:id ~route contents) () let parse_error, parse_error_hook = Hook.make - ~default:(function - | Feedback.Edit edit_id -> fun loc msg -> - feedback ~edit_id (Feedback.ErrorMsg (loc, string_of_ppcmds msg)) - | Feedback.State state_id -> fun loc msg -> - feedback ~state_id (Feedback.ErrorMsg (loc, string_of_ppcmds msg))) () + ~default:(fun id loc msg -> + feedback ~id (ErrorMsg (loc, Pp.string_of_ppcmds msg))) () let execution_error, execution_error_hook = Hook.make ~default:(fun state_id loc msg -> - feedback ~state_id (Feedback.ErrorMsg (loc, string_of_ppcmds msg))) () + feedback ~id:(State state_id) (ErrorMsg (loc, Pp.string_of_ppcmds msg))) () let unreachable_state, unreachable_state_hook = Hook.make ~default:(fun _ _ -> ()) () @@ -80,14 +76,20 @@ let interactive () = let async_proofs_workers_extra_env = ref [||] -type ast = { verbose : bool; loc : Loc.t; mutable expr : vernac_expr } -let pr_ast { expr } = pr_vernac expr +type aast = { + verbose : bool; + loc : Loc.t; + indentation : int; + strlen : int; + mutable expr : vernac_expr; (* mutable: Proof using hinted by aux file *) +} +let pr_ast { expr; indentation } = int indentation ++ str " " ++ pr_vernac expr let default_proof_mode () = Proof_global.get_default_proof_mode_name () (* Commands piercing opaque *) let may_pierce_opaque = function - | { expr = VernacPrint (PrintName _) } -> true + | { expr = VernacPrint _ } -> true | { expr = VernacExtend (("Extraction",_), _) } -> true | { expr = VernacExtend (("SeparateExtraction",_), _) } -> true | { expr = VernacExtend (("ExtractionLibrary",_), _) } -> true @@ -103,14 +105,14 @@ let vernac_interp ?proof id ?route { verbose; loc; expr } = | VernacResetName _ | VernacResetInitial | VernacBack _ | VernacBackTo _ | VernacRestart | VernacUndo _ | VernacUndoTo _ | VernacBacktrack _ | VernacAbortAll | VernacAbort _ -> true - | VernacTime (_,e) | VernacRedirect (_,(_,e)) -> internal_command e + | VernacTime (_,e) | VernacTimeout (_,e) | VernacRedirect (_,(_,e)) -> internal_command e | _ -> false in if internal_command expr then begin - prerr_endline (fun () -> "ignoring " ^ string_of_ppcmds(pr_vernac expr)) + prerr_endline (fun () -> "ignoring " ^ Pp.string_of_ppcmds(pr_vernac expr)) end else begin - set_id_for_feedback ?route (Feedback.State id); + set_id_for_feedback ?route (State id); Aux_file.record_in_aux_set_at loc; - prerr_endline (fun () -> "interpreting " ^ string_of_ppcmds(pr_vernac expr)); + prerr_endline (fun () -> "interpreting " ^ Pp.string_of_ppcmds(pr_vernac expr)); try Hooks.(call interp ?verbosely:(Some verbose) ?proof (loc, expr)) with e -> let e = Errors.push e in @@ -118,17 +120,31 @@ let vernac_interp ?proof id ?route { verbose; loc; expr } = end (* Wrapper for Vernac.parse_sentence to set the feedback id *) -let vernac_parse ?newtip ?route eid s = +let indentation_of_string s = + let len = String.length s in + let rec aux n i precise = + if i >= len then 0, precise, len + else + match s.[i] with + | ' ' | '\t' -> aux (succ n) (succ i) precise + | '\n' | '\r' -> aux 0 (succ i) true + | _ -> n, precise, len in + aux 0 0 false + +let vernac_parse ?(indlen_prev=fun() -> 0) ?newtip ?route eid s = let feedback_id = - if Option.is_empty newtip then Feedback.Edit eid - else Feedback.State (Option.get newtip) in + if Option.is_empty newtip then Edit eid + else State (Option.get newtip) in + let indentation, precise, strlen = indentation_of_string s in + let indentation = + if precise then indentation else indlen_prev () + indentation in set_id_for_feedback ?route feedback_id; let pa = Pcoq.Gram.parsable (Stream.of_string s) in Flags.with_option Flags.we_are_parsing (fun () -> try match Pcoq.Gram.entry_parse Pcoq.main_entry pa with | None -> raise (Invalid_argument "vernac_parse") - | Some ast -> ast + | Some (loc, ast) -> indentation, strlen, loc, ast with e when Errors.noncritical e -> let (e, info) = Errors.push e in let loc = Option.default Loc.ghost (Loc.get_loc info) in @@ -138,13 +154,13 @@ let vernac_parse ?newtip ?route eid s = let pr_open_cur_subgoals () = try Printer.pr_open_subgoals () - with Proof_global.NoCurrentProof -> str"" + with Proof_global.NoCurrentProof -> Pp.str "" let update_global_env () = if Proof_global.there_are_pending_proofs () then Proof_global.update_global_env () -module Vcs_ = Vcs.Make(Stateid) +module Vcs_ = Vcs.Make(Stateid.Self) type future_proof = Proof_global.closed_proof_output Future.computation type proof_mode = string type depth = int @@ -154,22 +170,27 @@ type branch_type = | `Proof of proof_mode * depth | `Edit of proof_mode * Stateid.t * Stateid.t * vernac_qed_type * Vcs_.Branch.t ] +(* TODO 8.7 : split commands and tactics, since this type is too messy now *) type cmd_t = { - ctac : bool; (* is a tactic, needed by the 8.4 semantics of Undo *) + ctac : bool; (* is a tactic *) ceff : bool; (* is a side-effecting command in the middle of a proof *) - cast : ast; + cast : aast; cids : Id.t list; - cqueue : [ `MainQueue | `TacQueue of cancel_switch | `QueryQueue of cancel_switch | `SkipQueue ] } -type fork_t = ast * Vcs_.Branch.t * Vernacexpr.opacity_guarantee * Id.t list + cblock : proof_block_name option; + cqueue : [ `MainQueue + | `TacQueue of cancel_switch + | `QueryQueue of cancel_switch + | `SkipQueue ] } +type fork_t = aast * Vcs_.Branch.t * Vernacexpr.opacity_guarantee * Id.t list type qed_t = { - qast : ast; + qast : aast; keep : vernac_qed_type; mutable fproof : (future_proof * cancel_switch) option; brname : Vcs_.Branch.t; brinfo : branch_type Vcs_.branch_info } -type seff_t = ast option -type alias_t = Stateid.t * ast +type seff_t = aast option +type alias_t = Stateid.t * aast type transaction = | Cmd of cmd_t | Fork of fork_t @@ -181,40 +202,69 @@ type step = [ `Cmd of cmd_t | `Fork of fork_t * Stateid.t option | `Qed of qed_t * Stateid.t - | `Sideff of [ `Ast of ast * Stateid.t | `Id of Stateid.t ] + | `Sideff of [ `Ast of aast * Stateid.t | `Id of Stateid.t ] | `Alias of alias_t ] type visit = { step : step; next : Stateid.t } +let mkTransTac cast cblock cqueue = + Cmd { ctac = true; cast; cblock; cqueue; cids = []; ceff = false } +let mkTransCmd cast cids ceff cqueue = + Cmd { ctac = false; cast; cblock = None; cqueue; cids; ceff } (* Parts of the system state that are morally part of the proof state *) let summary_pstate = [ Evarutil.meta_counter_summary_name; Evd.evar_counter_summary_name; "program-tcc-table" ] -type state = { - system : States.state; - proof : Proof_global.state; - shallow : bool +type cached_state = + | Empty + | Error of Exninfo.iexn + | Valid of state +and state = { (* TODO: inline records in OCaml 4.03 *) + system : States.state; (* summary + libstack *) + proof : Proof_global.state; (* proof state *) + shallow : bool (* is the state trimmed down (libstack) *) } type branch = Vcs_.Branch.t * branch_type Vcs_.branch_info type backup = { mine : branch; others : branch list } -type 'vcs state_info = { (* Make private *) - mutable n_reached : int; - mutable n_goals : int; - mutable state : state option; +type 'vcs state_info = { (* TODO: Make this record private to VCS *) + mutable n_reached : int; (* debug cache: how many times was computed *) + mutable n_goals : int; (* open goals: indentation *) + mutable state : cached_state; (* state value *) mutable vcs_backup : 'vcs option * backup option; } let default_info () = - { n_reached = 0; n_goals = 0; state = None; vcs_backup = None,None } + { n_reached = 0; n_goals = 0; state = Empty; vcs_backup = None,None } + +module DynBlockData : Dyn.S = Dyn.Make(struct end) + +(* Clusters of nodes implemented as Dag properties. While Dag and Vcs impose + * no constraint on properties, here we impose boxes to be non overlapping. + * Such invariant makes sense for the current kinds of boxes (proof blocks and + * entire proofs) but may make no sense and dropped/refined in the future. + * Such invariant is useful to detect broken proof block detection code *) +type box = + | ProofTask of pt + | ProofBlock of static_block_declaration * proof_block_name +and pt = { (* TODO: inline records in OCaml 4.03 *) + lemma : Stateid.t; + qed : Stateid.t; +} +and static_block_declaration = { + start : Stateid.t; + stop : Stateid.t; + dynamic_switch : Stateid.t; + carry_on_data : DynBlockData.t; +} (* Functions that work on a Vcs with a specific branch type *) module Vcs_aux : sig - val proof_nesting : (branch_type, 't,'i) Vcs_.t -> int + val proof_nesting : (branch_type, 't,'i,'c) Vcs_.t -> int val find_proof_at_depth : - (branch_type, 't, 'i) Vcs_.t -> int -> + (branch_type, 't, 'i,'c) Vcs_.t -> int -> Vcs_.Branch.t * branch_type Vcs_.branch_info exception Expired - val visit : (branch_type, transaction,'i) Vcs_.t -> Vcs_.Dag.node -> visit + val visit : (branch_type, transaction,'i,'c) Vcs_.t -> Vcs_.Dag.node -> visit end = struct (* {{{ *) @@ -230,7 +280,7 @@ end = struct (* {{{ *) let find_proof_at_depth vcs pl = try List.find (function | _, { Vcs_.kind = `Proof(m, n) } -> Int.equal n pl - | _, { Vcs_.kind = `Edit _ } -> anomaly(str"find_proof_at_depth") + | _, { Vcs_.kind = `Edit _ } -> anomaly(Pp.str "find_proof_at_depth") | _ -> false) (List.map (fun h -> h, Vcs_.get_branch vcs h) (Vcs_.branches vcs)) with Not_found -> failwith "find_proof_at_depth" @@ -238,9 +288,9 @@ end = struct (* {{{ *) exception Expired let visit vcs id = if Stateid.equal id Stateid.initial then - anomaly(str"Visiting the initial state id") + anomaly(Pp.str "Visiting the initial state id") else if Stateid.equal id Stateid.dummy then - anomaly(str"Visiting the dummy state id") + anomaly(Pp.str "Visiting the dummy state id") else try match Vcs_.Dag.from_node (Vcs_.dag vcs) id with @@ -256,7 +306,7 @@ end = struct (* {{{ *) | [n, Sideff (Some x); p, Noop] | [p, Noop; n, Sideff (Some x)]-> { step = `Sideff(`Ast (x,p)); next = n } | [n, Sideff (Some x)]-> {step = `Sideff(`Ast (x,Stateid.dummy)); next=n} - | _ -> anomaly (str ("Malformed VCS at node "^Stateid.to_string id)) + | _ -> anomaly (Pp.str ("Malformed VCS at node "^Stateid.to_string id)) with Not_found -> raise Expired end (* }}} *) @@ -278,7 +328,7 @@ module VCS : sig pos : id; } - type vcs = (branch_type, transaction, vcs state_info) Vcs_.t + type vcs = (branch_type, transaction, vcs state_info, box) Vcs_.t val init : id -> unit @@ -292,30 +342,32 @@ module VCS : sig val rewrite_merge : id -> ours:transaction -> at:id -> Branch.t -> unit val delete_branch : Branch.t -> unit val commit : id -> transaction -> unit - val mk_branch_name : ast -> Branch.t + val mk_branch_name : aast -> Branch.t val edit_branch : Branch.t val branch : ?root:id -> ?pos:id -> Branch.t -> branch_type -> unit val reset_branch : Branch.t -> id -> unit - val reachable : id -> Vcs_.NodeSet.t + val reachable : id -> Stateid.Set.t val cur_tip : unit -> id val get_info : id -> vcs state_info - val reached : id -> bool -> unit + val reached : id -> unit val goals : id -> int -> unit - val set_state : id -> state -> unit - val get_state : id -> state option + val set_state : id -> cached_state -> unit + 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 create_cluster : id list -> qed:id -> start:id -> unit - val cluster_of : id -> (id * id) option - val delete_cluster_of : id -> unit + val create_proof_task_box : id list -> qed:id -> start:id -> unit + val create_proof_block : static_block_declaration -> string -> unit + val box_of : id -> box list + val delete_boxes_of : id -> unit + val proof_task_box_of : id -> pt option val proof_nesting : unit -> int val checkout_shallowest_proof_branch : unit -> unit - val propagate_sideff : replay:ast option -> unit + val propagate_sideff : replay:aast option -> unit val gc : unit -> unit @@ -331,7 +383,6 @@ end = struct (* {{{ *) include Vcs_ exception Expired = Vcs_aux.Expired - module StateidSet = Set.Make(Stateid) open Printf let print_dag vcs () = @@ -339,21 +390,21 @@ end = struct (* {{{ *) "stm_" ^ Str.global_replace (Str.regexp " ") "_" (System.process_id ()) in let string_of_transaction = function | Cmd { cast = t } | Fork (t, _,_,_) -> - (try string_of_ppcmds (pr_ast t) with _ -> "ERR") + (try Pp.string_of_ppcmds (pr_ast t) with _ -> "ERR") | Sideff (Some t) -> sprintf "Sideff(%s)" - (try string_of_ppcmds (pr_ast t) with _ -> "ERR") + (try Pp.string_of_ppcmds (pr_ast t) with _ -> "ERR") | Sideff None -> "EnvChange" | Noop -> " " | Alias (id,_) -> sprintf "Alias(%s)" (Stateid.to_string id) | Qed { qast } -> string_of_ppcmds (pr_ast qast) in let is_green id = match get_info vcs id with - | Some { state = Some _ } -> true + | Some { state = Valid _ } -> true | _ -> false in let is_red id = match get_info vcs id with - | Some s -> Int.equal s.n_reached ~-1 + | Some { state = Error _ } -> true | _ -> false in let head = current_branch vcs in let heads = @@ -373,8 +424,6 @@ end = struct (* {{{ *) let edge tr = sprintf "<<FONT POINT-SIZE=\"12\" FACE=\"sans\">%s</FONT>>" (quote (string_of_transaction tr)) in - let ids = ref StateidSet.empty in - let clus = Hashtbl.create 13 in let node_info id = match get_info vcs id with | None -> "" @@ -387,39 +436,71 @@ end = struct (* {{{ *) let nodefmt oc id = fprintf oc "%s [label=%s,style=filled,fillcolor=%s];\n" (node id) (node_info id) (color id) in - let add_to_clus_or_ids from cf = - match cf with - | None -> ids := StateidSet.add from !ids; false - | Some c -> Hashtbl.replace clus c - (try let n = Hashtbl.find clus c in from::n - with Not_found -> [from]); true in + + let ids = ref Stateid.Set.empty in + let boxes = ref [] in + (* Fill in *) + Dag.iter graph (fun from _ _ l -> + ids := Stateid.Set.add from !ids; + List.iter (fun box -> boxes := box :: !boxes) + (Dag.property_of graph from); + List.iter (fun (dest, _) -> + ids := Stateid.Set.add dest !ids; + List.iter (fun box -> boxes := box :: !boxes) + (Dag.property_of graph dest)) + l); + boxes := CList.sort_uniquize Dag.Property.compare !boxes; + let oc = open_out fname_dot in output_string oc "digraph states {\n"; Dag.iter graph (fun from cf _ l -> - let c1 = add_to_clus_or_ids from cf in List.iter (fun (dest, trans) -> - let c2 = add_to_clus_or_ids dest (Dag.cluster_of graph dest) in - fprintf oc "%s -> %s [xlabel=%s,labelfloat=%b];\n" - (node from) (node dest) (edge trans) (c1 && c2)) l + fprintf oc "%s -> %s [xlabel=%s,labelfloat=true];\n" + (node from) (node dest) (edge trans)) l ); - StateidSet.iter (nodefmt oc) !ids; - Hashtbl.iter (fun c nodes -> - fprintf oc "subgraph cluster_%s {\n" (Dag.Cluster.to_string c); - List.iter (nodefmt oc) nodes; - fprintf oc "color=blue; }\n" - ) clus; + + let contains b1 b2 = + Stateid.Set.subset + (Dag.Property.having_it b2) (Dag.Property.having_it b1) in + let same_box = Dag.Property.equal in + let outerboxes boxes = + List.filter (fun b -> + not (List.exists (fun b1 -> + not (same_box b1 b) && contains b1 b) boxes) + ) boxes in + let rec rec_print b = + boxes := CList.remove same_box b !boxes; + let sub_boxes = List.filter (contains b) (outerboxes !boxes) in + fprintf oc "subgraph cluster_%s {\n" (Dag.Property.to_string b); + List.iter rec_print sub_boxes; + Stateid.Set.iter (fun id -> + if Stateid.Set.mem id !ids then begin + ids := Stateid.Set.remove id !ids; + nodefmt oc id + end) + (Dag.Property.having_it b); + match Dag.Property.data b with + | ProofBlock ({ dynamic_switch = id }, lbl) -> + fprintf oc "label=\"%s (test:%s)\";\n" lbl (Stateid.to_string id); + fprintf oc "color=red; }\n" + | ProofTask _ -> fprintf oc "color=blue; }\n" + in + List.iter rec_print (outerboxes !boxes); + Stateid.Set.iter (nodefmt oc) !ids; + List.iteri (fun i (b,id) -> let shape = if Branch.equal head b then "box3d" else "box" in fprintf oc "b%d -> %s;\n" i (node id); fprintf oc "b%d [shape=%s,label=\"%s\"];\n" i shape (Branch.to_string b); ) heads; + output_string oc "}\n"; close_out oc; ignore(Sys.command ("dot -Tpdf -Gcharset=latin1 " ^ fname_dot ^ " -o" ^ fname_ps)) - type vcs = (branch_type, transaction, vcs state_info) t + type vcs = (branch_type, transaction, vcs state_info, box) t let vcs : vcs ref = ref (empty Stateid.dummy) let init id = @@ -456,13 +537,12 @@ end = struct (* {{{ *) | Some x -> x | None -> raise Vcs_aux.Expired let set_state id s = - (get_info id).state <- Some s; + (get_info id).state <- s; if Flags.async_proofs_is_master () then Hooks.(call state_ready id) let get_state id = (get_info id).state - let reached id b = + let reached id = let info = get_info id in - if b then info.n_reached <- info.n_reached + 1 - else info.n_reached <- -1 + info.n_reached <- info.n_reached + 1 let goals id n = (get_info id).n_goals <- n let cur_tip () = get_branch_pos (current_branch ()) @@ -512,9 +592,19 @@ end = struct (* {{{ *) let l = nodes_in_slice ~start ~stop in let copy_info v id = Vcs_.set_info v id - { (get_info id) with state = None; vcs_backup = None,None } in + { (get_info id) with state = Empty; vcs_backup = None,None } in let copy_info_w_state v id = Vcs_.set_info v id { (get_info id) with vcs_backup = None,None } in + let copy_proof_blockes v = + let nodes = Vcs_.Dag.all_nodes (Vcs_.dag v) in + let props = + Stateid.Set.fold (fun n pl -> Vcs_.property_of !vcs n @ pl) nodes [] in + let props = CList.sort_uniquize Vcs_.Dag.Property.compare props in + List.fold_left (fun v p -> + Vcs_.create_property v + (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 = List.fold_right (fun (id,tr) v -> @@ -522,28 +612,52 @@ end = struct (* {{{ *) let v = copy_info v id in v) l v in (* Stm should have reached the beginning of proof *) - assert (not (Option.is_empty (get_info start).state)); + assert (match (get_info start).state with Valid _ -> true | _ -> false); (* We put in the new dag the most recent state known to master *) let rec fill id = - if (get_info id).state = None then fill (Vcs_aux.visit v id).next - else copy_info_w_state v id in + 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 (* We put in the new dag the first state (since Qed shall run on it, * see check_task_aux) *) - copy_info_w_state v start + let v = copy_info_w_state v start in + copy_proof_blockes v let nodes_in_slice ~start ~stop = List.rev (List.map fst (nodes_in_slice ~start ~stop)) - let create_cluster l ~qed ~start = vcs := create_cluster !vcs l (qed,start) - let cluster_of id = Option.map Dag.Cluster.data (cluster_of !vcs id) - let delete_cluster_of id = - Option.iter (fun x -> vcs := delete_cluster !vcs x) (Vcs_.cluster_of !vcs id) + let topo_invariant l = + let all = List.fold_right Stateid.Set.add l Stateid.Set.empty in + List.for_all + (fun x -> + let props = property_of !vcs x in + let sets = List.map Dag.Property.having_it props in + List.for_all (fun s -> Stateid.Set.(subset s all || subset all s)) sets) + l + + let create_proof_task_box l ~qed ~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 + 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) + let delete_boxes_of id = + List.iter (fun x -> vcs := delete_property !vcs x) (property_of !vcs id) + let proof_task_box_of id = + match + CList.map_filter (function ProofTask x -> Some x | _ -> None) (box_of id) + with + | [] -> None + | [x] -> Some x + | _ -> anomaly (str "node with more than 1 proof task box") let gc () = let old_vcs = !vcs in let new_vcs, erased_nodes = gc old_vcs in - Vcs_.NodeSet.iter (fun id -> + Stateid.Set.iter (fun id -> match (Vcs_aux.visit old_vcs id).step with | `Qed ({ fproof = Some (_, cancel_switch) }, _) | `Cmd { cqueue = `TacQueue cancel_switch } @@ -600,7 +714,10 @@ end = struct (* {{{ *) end (* }}} *) let state_of_id id = - try `Valid (VCS.get_info id).state + try match (VCS.get_info id).state with + | Valid s -> `Valid (Some s) + | Error (e,_) -> `Error e + | Empty -> `Valid None with VCS.Expired -> `Expired @@ -620,6 +737,7 @@ module State : sig val install_cached : Stateid.t -> unit val is_cached : ?cache:Summary.marshallable -> Stateid.t -> bool + val is_cached_and_valid : ?cache:Summary.marshallable -> Stateid.t -> bool val exn_on : Stateid.t -> ?valid:Stateid.t -> iexn -> iexn @@ -665,51 +783,60 @@ end = struct (* {{{ *) proof, Summary.project_summary (States.summary_of_state system) summary_pstate - let freeze marshallable id = VCS.set_state id (freeze_global_state marshallable) + let freeze marshallable id = + VCS.set_state id (Valid (freeze_global_state marshallable)) + let freeze_invalid id iexn = VCS.set_state id (Error iexn) - let is_cached ?(cache=`No) id = + let is_cached ?(cache=`No) id only_valid = if Stateid.equal id !cur_id then try match VCS.get_info id with - | { state = None } when cache = `Yes -> freeze `No id; true - | { state = None } when cache = `Shallow -> freeze `Shallow id; true + | { state = Empty } when cache = `Yes -> freeze `No id; true + | { state = Empty } when cache = `Shallow -> freeze `Shallow id; true | _ -> true with VCS.Expired -> false else try match VCS.get_info id with - | { state = Some _ } -> true - | _ -> false + | { state = Empty } -> false + | { state = Valid _ } -> true + | { state = Error _ } -> not only_valid with VCS.Expired -> false + let is_cached_and_valid ?cache id = is_cached ?cache id true + let is_cached ?cache id = is_cached ?cache id false + let install_cached id = - if Stateid.equal id !cur_id then () else (* optimization *) - let s = - match VCS.get_info id with - | { state = Some s } -> s - | _ -> anomaly (str "unfreezing a non existing state") in - unfreeze_global_state s; cur_id := id + match VCS.get_info id with + | { state = Valid s } -> + if Stateid.equal id !cur_id then () (* optimization *) + else begin unfreeze_global_state s; cur_id := id end + | { state = Error ie } -> cur_id := id; Exninfo.iraise ie + | _ -> + (* coqc has a 1 slot cache and only for valid states *) + if interactive () = `No && Stateid.equal id !cur_id then () + else anomaly (str "installing a non cached state") let get_cached id = try match VCS.get_info id with - | { state = Some s } -> s + | { state = Valid s } -> s | _ -> anomaly (str "not a cached state") with VCS.Expired -> anomaly (str "not a cached state (expired)") let assign id what = - if VCS.get_state id <> None then () else + if VCS.get_state id <> Empty then () else try match what with | `Full s -> let s = try let prev = (VCS.visit id).next in - if is_cached prev + if is_cached_and_valid prev then { s with proof = Proof_global.copy_terminators ~src:(get_cached prev).proof ~tgt:s.proof } else s with VCS.Expired -> s in - VCS.set_state id s + VCS.set_state id (Valid s) | `Proof(ontop,(pstate,counters)) -> - if is_cached ontop then + if is_cached_and_valid ontop then let s = get_cached ontop in let s = { s with proof = Proof_global.copy_terminators ~src:s.proof ~tgt:pstate } in @@ -718,7 +845,7 @@ end = struct (* {{{ *) (Summary.surgery_summary (States.summary_of_state s.system) counters) } in - VCS.set_state id s + VCS.set_state id (Valid s) with VCS.Expired -> () let exn_on id ?valid (e, info) = @@ -740,7 +867,7 @@ end = struct (* {{{ *) let define ?safe_id ?(redefine=false) ?(cache=`No) ?(feedback_processed=true) f id = - feedback ~state_id:id Feedback.(ProcessingIn !Flags.async_proofs_worker_id); + feedback ~id:(State id) (ProcessingIn !Flags.async_proofs_worker_id); let str_id = Stateid.to_string id in if is_cached id && not redefine then anomaly (str"defining state "++str str_id++str" twice"); @@ -757,20 +884,22 @@ end = struct (* {{{ *) cur_id := id; if feedback_processed then Hooks.(call state_computed id ~in_cache:false); - VCS.reached id true; + VCS.reached id; if Proof_global.there_are_pending_proofs () then VCS.goals id (Proof_global.get_open_goals ()) with e -> let (e, info) = Errors.push e in let good_id = !cur_id in - cur_id := Stateid.dummy; - VCS.reached id false; - Hooks.(call unreachable_state id (e, info)); - match Stateid.get info, safe_id with - | None, None -> iraise (exn_on id ~valid:good_id (e, info)) - | None, Some good_id -> iraise (exn_on id ~valid:good_id (e, info)) - | Some _, None -> iraise (e, info) - | Some (_,at), Some id -> iraise (e, Stateid.add info ~valid:id at) + VCS.reached id; + let ie = + match Stateid.get info, safe_id with + | None, None -> (exn_on id ~valid:good_id (e, info)) + | None, Some good_id -> (exn_on id ~valid:good_id (e, info)) + | Some _, None -> (e, info) + | Some (_,at), Some id -> (e, Stateid.add info ~valid:id at) in + if cache = `Yes || cache = `Shallow then freeze_invalid id ie; + Hooks.(call unreachable_state id ie); + Exninfo.iraise ie end (* }}} *) @@ -846,7 +975,7 @@ end = struct (* {{{ *) let back_safe () = let id = fold_until (fun n (id,_,_,_,_) -> - if n >= 0 && State.is_cached id then `Stop id else `Cont (succ n)) + if n >= 0 && State.is_cached_and_valid id then `Stop id else `Cont (succ n)) 0 (VCS.get_branch_pos (VCS.current_branch ())) in backto id @@ -945,6 +1074,75 @@ let _ = Errors.register_handler (function | RemoteException ppcmd -> ppcmd | _ -> raise Unhandled) +(****************** proof structure for error recovery ************************) +(******************************************************************************) + +type document_node = { + indentation : int; + ast : Vernacexpr.vernac_expr; + id : Stateid.t; +} + +type document_view = { + entry_point : document_node; + prev_node : document_node -> document_node option; +} + +type static_block_detection = + document_view -> static_block_declaration option + +type recovery_action = { + base_state : Stateid.t; + goals_to_admit : Goal.goal list; + recovery_command : Vernacexpr.vernac_expr option; +} + +type dynamic_block_error_recovery = + static_block_declaration -> [ `ValidBlock of recovery_action | `Leaks ] + +let proof_block_delimiters = ref [] + +let register_proof_block_delimiter name static dynamic = + if List.mem_assoc name !proof_block_delimiters then + Errors.errorlabstrm "STM" (str "Duplicate block delimiter " ++ str name); + proof_block_delimiters := (name, (static,dynamic)) :: !proof_block_delimiters + +let mk_doc_node id = function + | { step = `Cmd { ctac; cast = { indentation; expr }}; next } when ctac -> + Some { indentation; ast = expr; id } + | { step = `Sideff (`Ast ({ indentation; expr }, _)); next } -> + Some { indentation; ast = expr; id } + | _ -> None +let prev_node { id } = + let id = (VCS.visit id).next in + mk_doc_node id (VCS.visit id) +let cur_node id = mk_doc_node id (VCS.visit id) + +let is_block_name_enabled name = + match !Flags.async_proofs_tac_error_resilience with + | `None -> false + | `All -> true + | `Only l -> List.mem name l + +let detect_proof_block id name = + let name = match name with None -> "indent" | Some x -> x in + if is_block_name_enabled name && + (if Flags.async_proofs_is_master () then + !Flags.async_proofs_mode != Flags.APoff else true) + then + match cur_node id with + | None -> () + | Some entry_point -> try + let static, _ = List.assoc name !proof_block_delimiters in + begin match static { prev_node; entry_point } with + | None -> () + | Some ({ start; stop } as decl) -> + VCS.create_proof_block decl name + end + with Not_found -> + Errors.errorlabstrm "STM" + (str "Unknown proof block delimiter " ++ str name) + (****************************** THE SCHEDULER *********************************) (******************************************************************************) @@ -1062,7 +1260,7 @@ end = struct (* {{{ *) List.iter (fun (id,s) -> State.assign id s) l; `End | `Fresh, BuildProof { t_assign; t_loc; t_name; t_states; t_drop }, RespBuiltProof (pl, time) -> - feedback (Feedback.InProgress ~-1); + feedback (InProgress ~-1); t_assign (`Val pl); record_pb_time t_name t_loc time; if !Flags.async_proofs_full || t_drop @@ -1070,7 +1268,7 @@ end = struct (* {{{ *) else `End | `Fresh, BuildProof { t_assign; t_loc; t_name; t_states }, RespError { e_error_at; e_safe_id = valid; e_msg; e_safe_states } -> - feedback (Feedback.InProgress ~-1); + feedback (InProgress ~-1); let info = Stateid.add ~valid Exninfo.null e_error_at in let e = (RemoteException e_msg, info) in t_assign (`Exn e); @@ -1086,7 +1284,7 @@ end = struct (* {{{ *) let e = (RemoteException (strbrk s), info) in t_assign (`Exn e); Hooks.(call execution_error start Loc.ghost (strbrk s)); - feedback (Feedback.InProgress ~-1) + feedback (InProgress ~-1) let build_proof_here ~drop_pt (id,valid) loc eop = Future.create (State.exn_on id ~valid) (fun () -> @@ -1097,7 +1295,7 @@ end = struct (* {{{ *) Aux_file.record_in_aux_at loc "proof_build_time" (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1)); let p = Proof_global.return_proof ~allow_partial:drop_pt () in - if drop_pt then Pp.feedback ~state_id:id Feedback.Complete; + if drop_pt then feedback ~id:(State id) Complete; p) let perform_buildp { Stateid.exn_info; stop; document; loc } drop my_states = @@ -1121,7 +1319,7 @@ end = struct (* {{{ *) Lemmas.(standard_proof_terminator [] (mk_hook (fun _ _ -> ()))) in vernac_interp stop ~proof:(pobject, terminator) - { verbose = false; loc; + { verbose = false; loc; indentation = 0; strlen = 0; expr = (VernacEndProof (Proved (Opaque None,None))) }) in ignore(Future.join checked_proof); end; @@ -1137,7 +1335,7 @@ end = struct (* {{{ *) let e_msg = iprint (e, info) in prerr_endline (fun () -> "failed with the following exception:"); prerr_endline (fun () -> string_of_ppcmds e_msg); - let e_safe_states = List.filter State.is_cached my_states in + let e_safe_states = List.filter State.is_cached_and_valid my_states in RespError { e_error_at; e_safe_id; e_msg; e_safe_states } let perform_states query = @@ -1155,12 +1353,12 @@ end = struct (* {{{ *) let prev = try let { next = prev; step } = VCS.visit id in - if State.is_cached prev && List.mem prev seen + if State.is_cached_and_valid prev && List.mem prev seen then Some (prev, State.get_cached prev, step) else None with VCS.Expired -> None in let this = - if State.is_cached id then Some (State.get_cached id) else None in + if State.is_cached_and_valid id then Some (State.get_cached id) else None in match prev, this with | _, None -> None | Some (prev, o, `Cmd { cast = { expr }}), Some n @@ -1190,7 +1388,7 @@ end = struct (* {{{ *) "The system state could not be sent to the worker process. "^ "Falling back to local, lazy, evaluation.")); t_assign(`Comp(build_proof_here ~drop_pt t_exn_info t_loc t_stop)); - feedback (Feedback.InProgress ~-1) + feedback (InProgress ~-1) end (* }}} *) @@ -1262,7 +1460,7 @@ end = struct (* {{{ *) * looking at the ones that happen to be present in the current env *) Reach.known_state ~cache:`No start; vernac_interp stop ~proof - { verbose = false; loc; + { verbose = false; loc; indentation = 0; strlen = 0; expr = (VernacEndProof (Proved (Opaque None,None))) }; `OK proof end @@ -1270,7 +1468,7 @@ end = struct (* {{{ *) let (e, info) = Errors.push e in (try match Stateid.get info with | None -> - pperrnl ( + msg_error ( str"File " ++ str name ++ str ": proof of " ++ str r_name ++ spc () ++ iprint (e, info)) | Some (_, cur) -> @@ -1280,12 +1478,12 @@ end = struct (* {{{ *) | { step = `Qed ( { qast = { loc } }, _) } | { step = `Sideff (`Ast ( { loc }, _)) } -> let start, stop = Loc.unloc loc in - pperrnl ( + msg_error ( str"File " ++ str name ++ str ": proof of " ++ str r_name ++ str ": chars " ++ int start ++ str "-" ++ int stop ++ spc () ++ iprint (e, info)) | _ -> - pperrnl ( + msg_error ( str"File " ++ str name ++ str ": proof of " ++ str r_name ++ spc () ++ iprint (e, info)) with e -> @@ -1378,7 +1576,7 @@ end = struct (* {{{ *) else let f, t_assign = Future.create_delegate ~name:pname (State.exn_on id ~valid) in let t_uuid = Future.uuid f in - feedback (Feedback.InProgress 1); + feedback (InProgress 1); let task = ProofTask.(BuildProof { t_exn_info; t_start = start; t_stop = stop; t_assign; t_drop = drop_pt; t_loc = loc; t_uuid; t_name = pname; @@ -1415,7 +1613,7 @@ and TacTask : sig t_state : Stateid.t; t_state_fb : Stateid.t; t_assign : output Future.assignement -> unit; - t_ast : int * ast; + t_ast : int * aast; t_goal : Goal.goal; t_kill : unit -> unit; t_name : string } @@ -1432,7 +1630,7 @@ end = struct (* {{{ *) t_state : Stateid.t; t_state_fb : Stateid.t; t_assign : output Future.assignement -> unit; - t_ast : int * ast; + t_ast : int * aast; t_goal : Goal.goal; t_kill : unit -> unit; t_name : string } @@ -1441,7 +1639,7 @@ end = struct (* {{{ *) r_state : Stateid.t; r_state_fb : Stateid.t; r_document : VCS.vcs option; - r_ast : int * ast; + r_ast : int * aast; r_goal : Goal.goal; r_name : string } @@ -1471,8 +1669,7 @@ end = struct (* {{{ *) match resp with | RespBuiltSubProof o -> t_assign (`Val o); `Stay ((),[]) | RespError msg -> - let info = Stateid.add ~valid:t_state Exninfo.null t_state_fb in - let e = (RemoteException msg, info) in + let e = (RemoteException msg, Exninfo.null) in t_assign (`Exn e); t_kill (); `Stay ((),[]) @@ -1500,7 +1697,7 @@ end = struct (* {{{ *) List.for_all (Context.Named.Declaration.for_all (Evarutil.is_ground_term sigma0)) Evd.(evar_context g)) then - Errors.errorlabstrm "Stm" (strbrk("the par: goal selector supports ground "^ + Errors.errorlabstrm "STM" (strbrk("the par: goal selector supports ground "^ "goals only")) else begin let (i, ast) = r_ast in @@ -1508,12 +1705,12 @@ end = struct (* {{{ *) vernac_interp r_state_fb ast; let _,_,_,_,sigma = Proof.proof (Proof_global.give_me_the_proof ()) in match Evd.(evar_body (find sigma r_goal)) with - | Evd.Evar_empty -> Errors.errorlabstrm "Stm" (str "no progress") + | Evd.Evar_empty -> Errors.errorlabstrm "STM" (str "no progress") | Evd.Evar_defined t -> let t = Evarutil.nf_evar sigma t in if Evarutil.is_ground_term sigma t then t, Evd.evar_universe_context sigma - else Errors.errorlabstrm "Stm" (str"The solution is not ground") + else Errors.errorlabstrm "STM" (str"The solution is not ground") end) () in RespBuiltSubProof (t,uc) @@ -1527,13 +1724,15 @@ end (* }}} *) and Partac : sig val vernac_interp : - cancel_switch -> int -> Stateid.t -> Stateid.t -> ast -> unit + cancel_switch -> int -> Stateid.t -> Stateid.t -> aast -> unit end = struct (* {{{ *) module TaskQueue = AsyncTaskQueue.MakeQueue(TacTask) - let vernac_interp cancel nworkers safe_id id { verbose; loc; expr = e } = + let vernac_interp cancel nworkers safe_id id + { indentation; verbose; loc; expr = e; strlen } + = let e, time, fail = let rec find time fail = function | VernacTime (_,e) | VernacRedirect (_,(_,e)) -> find true fail e @@ -1550,7 +1749,7 @@ end = struct (* {{{ *) Future.create_delegate ~name:(Printf.sprintf "subgoal %d" i) (State.exn_on id ~valid:safe_id) in - let t_ast = (i, { verbose; loc; expr = e }) in + let t_ast = (i, { indentation; verbose; loc; expr = e; strlen }) in let t_name = Goal.uid g in TaskQueue.enqueue_task queue ({ t_state = safe_id; t_state_fb = id; @@ -1584,16 +1783,16 @@ end (* }}} *) and QueryTask : sig - type task = { t_where : Stateid.t; t_for : Stateid.t ; t_what : ast } + type task = { t_where : Stateid.t; t_for : Stateid.t ; t_what : aast } include AsyncTaskQueue.Task with type task := task end = struct (* {{{ *) type task = - { t_where : Stateid.t; t_for : Stateid.t ; t_what : ast } + { t_where : Stateid.t; t_for : Stateid.t ; t_what : aast } type request = - { r_where : Stateid.t ; r_for : Stateid.t ; r_what : ast; r_doc : VCS.vcs } + { r_where : Stateid.t ; r_for : Stateid.t ; r_what : aast; r_doc : VCS.vcs } type response = unit let name = ref "queryworker" @@ -1625,11 +1824,11 @@ end = struct (* {{{ *) Reach.known_state ~cache:`No r_where; try vernac_interp r_for { r_what with verbose = true }; - feedback ~state_id:r_for Feedback.Processed + feedback ~id:(State r_for) Processed with e when Errors.noncritical e -> let e = Errors.push e in let msg = string_of_ppcmds (iprint e) in - feedback ~state_id:r_for (Feedback.ErrorMsg (Loc.ghost, msg)) + feedback ~id:(State r_for) (ErrorMsg (Loc.ghost, msg)) let name_of_task { t_what } = string_of_ppcmds (pr_ast t_what) let name_of_request { r_what } = string_of_ppcmds (pr_ast r_what) @@ -1639,7 +1838,7 @@ end (* }}} *) and Query : sig val init : unit -> unit - val vernac_interp : cancel_switch -> Stateid.t -> Stateid.t -> ast -> unit + val vernac_interp : cancel_switch -> Stateid.t -> Stateid.t -> aast -> unit end = struct (* {{{ *) @@ -1676,9 +1875,9 @@ let async_policy () = (!compilation_mode = BuildVio || !async_proofs_mode <> APoff) let delegate name = - let time = get_hint_bp_time name in - time >= 1.0 || !Flags.compilation_mode = Flags.BuildVio - || !Flags.async_proofs_full + get_hint_bp_time name >= !Flags.async_proofs_delegation_threshold + || !Flags.compilation_mode = Flags.BuildVio + || !Flags.async_proofs_full let collect_proof keep cur hd brkind id = prerr_endline (fun () -> "Collecting proof ending at "^Stateid.to_string id); @@ -1728,7 +1927,7 @@ let collect_proof keep cur hd brkind id = let name = name ids in `ASync (parent last,proof_using_ast last,accn,name,delegate name) | `Fork((_, hd', GuaranteesOpacity, ids), _) when - has_proof_no_using last && not (State.is_cached (parent last)) && + has_proof_no_using last && not (State.is_cached_and_valid (parent last)) && !Flags.compilation_mode = Flags.BuildVio -> assert (VCS.Branch.equal hd hd'||VCS.Branch.equal hd VCS.edit_branch); (try @@ -1764,7 +1963,7 @@ let collect_proof keep cur hd brkind id = let rc = collect (Some cur) [] id in if is_empty rc then make_sync `AlreadyEvaluated rc else if (keep == VtKeep || keep == VtKeepAsAxiom) && - (not(State.is_cached id) || !Flags.async_proofs_full) + (not(State.is_cached_and_valid id) || !Flags.async_proofs_full) then check_policy rc else make_sync `AlreadyEvaluated rc @@ -1794,6 +1993,71 @@ let log_processing_sync id name reason = log_string Printf.(sprintf let wall_clock_last_fork = ref 0.0 let known_state ?(redefine_qed=false) ~cache id = + + let error_absorbing_tactic id blockname exn = + (* We keep the static/dynamic part of block detection separate, since + the static part could be performed earlier. As of today there is + no advantage in doing so since no UI can exploit such piece of info *) + detect_proof_block id blockname; + + let boxes = VCS.box_of id in + let valid_boxes = CList.map_filter (function + | ProofBlock ({ stop } as decl, name) when Stateid.equal stop id -> + Some (decl, name) + | _ -> None) boxes in + assert(List.length valid_boxes < 2); + if valid_boxes = [] then iraise exn + else + let decl, name = List.hd valid_boxes in + try + let _, dynamic_check = List.assoc name !proof_block_delimiters in + match dynamic_check decl with + | `Leaks -> iraise exn + | `ValidBlock { base_state; goals_to_admit; recovery_command } -> begin + let tac = + let open Proofview.Notations in + Proofview.Goal.nf_enter { enter = fun gl -> + if CList.mem_f Evar.equal + (Proofview.Goal.goal gl) goals_to_admit then + Proofview.give_up else Proofview.tclUNIT () + } in + match (VCS.get_info base_state).state with + | Valid { proof } -> + Proof_global.unfreeze proof; + Proof_global.with_current_proof (fun _ p -> + feedback ~id:(State id) Feedback.AddedAxiom; + fst (Pfedit.solve Vernacexpr.SelectAll None tac p), ()); + Option.iter (fun expr -> vernac_interp id { + verbose = true; loc = Loc.ghost; expr; indentation = 0; + strlen = 0 }) + recovery_command + | _ -> assert false + end + with Not_found -> + Errors.errorlabstrm "STM" + (str "Unknown proof block delimiter " ++ str name) + in + + (* Absorb tactic errors from f () *) + let resilient_tactic id blockname f = + if !Flags.async_proofs_tac_error_resilience = `None || + (Flags.async_proofs_is_master () && + !Flags.async_proofs_mode = Flags.APoff) + then f () + else + try f () + with e when Errors.noncritical e -> + let ie = Errors.push e in + error_absorbing_tactic id blockname ie in + (* Absorb errors from f x *) + let resilient_command f x = + if not !Flags.async_proofs_cmd_error_resilience || + (Flags.async_proofs_is_master () && + !Flags.async_proofs_mode = Flags.APoff) + then f x + else + try f x + with e when Errors.noncritical e -> () in (* ugly functions to process nested lemmas, i.e. hard to reproduce * side effects *) @@ -1812,9 +2076,9 @@ let known_state ?(redefine_qed=false) ~cache id = and reach ?(redefine_qed=false) ?(cache=cache) id = prerr_endline (fun () -> "reaching: " ^ Stateid.to_string id); if not redefine_qed && State.is_cached ~cache id then begin - State.install_cached id; Hooks.(call state_computed id ~in_cache:true); - prerr_endline (fun () -> "reached (cache)") + prerr_endline (fun () -> "reached (cache)"); + State.install_cached id end else let step, cache_step, feedback_processed = let view = VCS.visit id in @@ -1824,29 +2088,38 @@ let known_state ?(redefine_qed=false) ~cache id = ), cache, true | `Cmd { cast = x; cqueue = `SkipQueue } -> (fun () -> reach view.next), cache, true - | `Cmd { cast = x; cqueue = `TacQueue cancel } -> (fun () -> - reach ~cache:`Shallow view.next; - Hooks.(call tactic_being_run true); - Partac.vernac_interp - cancel !Flags.async_proofs_n_tacworkers view.next id x; - Hooks.(call tactic_being_run false) + | `Cmd { cast = x; cqueue = `TacQueue cancel; cblock } -> (fun () -> + resilient_tactic id cblock (fun () -> + reach ~cache:`Shallow view.next; + Hooks.(call tactic_being_run true); + Partac.vernac_interp + cancel !Flags.async_proofs_n_tacworkers view.next id x; + Hooks.(call tactic_being_run false)) ), cache, true | `Cmd { cast = x; cqueue = `QueryQueue cancel } when Flags.async_proofs_is_master () -> (fun () -> reach view.next; Query.vernac_interp cancel view.next id x ), cache, false - | `Cmd { cast = x; ceff = eff; ctac } -> (fun () -> - reach view.next; - if ctac then Hooks.(call tactic_being_run true); + | `Cmd { cast = x; ceff = eff; ctac = true; cblock } -> (fun () -> + resilient_tactic id cblock (fun () -> + reach view.next; + Hooks.(call tactic_being_run true); + vernac_interp id x; + Hooks.(call tactic_being_run false)); + if eff then update_global_env () + ), (if eff then `Yes else cache), true + | `Cmd { cast = x; ceff = eff } -> (fun () -> + resilient_command reach view.next; vernac_interp id x; - if ctac then Hooks.(call tactic_being_run false); - if eff then update_global_env ()), (if eff then `Yes else cache), true + if eff then update_global_env () + ), (if eff then `Yes else cache), true | `Fork ((x,_,_,_), None) -> (fun () -> - reach view.next; vernac_interp id x; + resilient_command reach view.next; + vernac_interp id x; wall_clock_last_fork := Unix.gettimeofday () ), `Yes, true - | `Fork ((x,_,_,_), Some prev) -> (fun () -> + | `Fork ((x,_,_,_), Some prev) -> (fun () -> (* nested proof *) reach ~cache:`Shallow prev; reach view.next; (try vernac_interp id x; @@ -1863,7 +2136,7 @@ let known_state ?(redefine_qed=false) ~cache id = let drop_pt = keep == VtKeepAsAxiom in let stop, exn_info, loc = eop, (id, eop), x.loc in log_processing_async id name; - VCS.create_cluster nodes ~qed:id ~start; + VCS.create_proof_task_box nodes ~qed:id ~start; begin match brinfo, qed.fproof with | { VCS.kind = `Edit _ }, None -> assert false | { VCS.kind = `Edit (_,_,_, okeep, _) }, Some (ofp, cancel) -> @@ -1897,7 +2170,7 @@ let known_state ?(redefine_qed=false) ~cache id = if not delegate then ignore(Future.compute fp); reach view.next; vernac_interp id ~proof x; - feedback ~state_id:id Feedback.Incomplete + feedback ~id:(State id) Incomplete | { VCS.kind = `Master }, _ -> assert false end; Proof_global.discard_all () @@ -2034,7 +2307,6 @@ let check_task name (tasks,rcbackup) i = let vcs = VCS.backup () in try let rc = Future.purify (Slaves.check_task name tasks) i in - pperr_flush (); VCS.restore vcs; rc with e when Errors.noncritical e -> VCS.restore vcs; false @@ -2044,7 +2316,6 @@ let finish_tasks name u d p (t,rcbackup as tasks) = let finish_task u (_,_,i) = let vcs = VCS.backup () in let u = Future.purify (Slaves.finish_task name u d p t) i in - pperr_flush (); VCS.restore vcs; u in try @@ -2052,7 +2323,7 @@ let finish_tasks name u d p (t,rcbackup as tasks) = (u,a,true), p with e -> let e = Errors.push e in - pperrnl (str"File " ++ str name ++ str ":" ++ spc () ++ iprint e); + msg_error (str"File " ++ str name ++ str ":" ++ spc () ++ iprint e); exit 1 let merge_proof_branch ?valid ?id qast keep brname = @@ -2118,10 +2389,11 @@ let snapshot_vio ldir long_f_dot_vo = let reset_task_queue = Slaves.reset_task_queue (* Document building *) -let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) = +let process_transaction ?(newtip=Stateid.fresh ()) ~tty + ({ verbose; loc; expr } as x) c + = let warn_if_pos a b = if b then msg_warning(pr_ast a ++ str" should not be part of a script") in - let v, x = expr, { verbose = verbose; loc; expr } in prerr_endline (fun () -> "{{{ processing: "^ string_of_ppcmds (pr_ast x)); let vcs = VCS.backup () in try @@ -2176,7 +2448,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) = | VtQuery (false,(report_id,route)), VtNow when tty = true -> finish (); (try Future.purify (vernac_interp report_id ~route) - { verbose = true; loc; expr } + {x with verbose = true } with e when Errors.noncritical e -> let e = Errors.push e in iraise (State.exn_on report_id e)); `Ok @@ -2195,8 +2467,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) = may_pierce_opaque x then `SkipQueue else `MainQueue in - VCS.commit id (Cmd { - ctac=false;ceff=false;cast = x; cids = []; cqueue = queue }); + VCS.commit id (mkTransCmd x [] false queue); Backtrack.record (); if w == VtNow then finish (); `Ok | VtQuery (false,_), VtLater -> anomaly(str"classifier: VtQuery + VtLater must imply part_of_script") @@ -2219,8 +2490,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) = anomaly(str"VtProofMode must be executed VtNow") | VtProofMode mode, VtNow -> let id = VCS.new_node ~id:newtip () in - VCS.commit id (Cmd { - ctac=false;ceff=false;cast = x;cids=[];cqueue = `MainQueue}); + VCS.commit id (mkTransCmd x [] false `MainQueue); List.iter (fun bn -> match VCS.get_branch bn with | { VCS.root; kind = `Master; pos } -> () @@ -2235,11 +2505,14 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) = Backtrack.record (); finish (); `Ok - | VtProofStep paral, w -> + | VtProofStep { parallel; proof_block_detection = cblock }, w -> let id = VCS.new_node ~id:newtip () in - let queue = if paral then `TacQueue (ref false) else `MainQueue in - VCS.commit id (Cmd { - ctac = true;ceff = false;cast = x;cids = [];cqueue = queue }); + let queue = if parallel then `TacQueue (ref false) else `MainQueue in + VCS.commit id (mkTransTac x cblock queue); + (* Static proof block detection delayed until an error really occurs. + If/when and UI will make something useful with this piece of info, + detection should occur here. + 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 @@ -2256,8 +2529,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) = let in_proof = not (VCS.Branch.equal head VCS.Branch.master) in let id = VCS.new_node ~id:newtip () in VCS.checkout VCS.Branch.master; - VCS.commit id (Cmd { - ctac=false;ceff=in_proof;cast=x;cids=l;cqueue=`MainQueue }); + VCS.commit id (mkTransCmd x l in_proof `MainQueue); (* We can't replay a Definition since universes may be differently * inferred. This holds in Coq >= 8.5 *) let replay = match x.expr with @@ -2292,8 +2564,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) = VCS.branch bname (`Proof (proof_mode, VCS.proof_nesting () + 1)); Proof_global.activate_proof_mode proof_mode; end else begin - VCS.commit id (Cmd { - ctac=false;ceff=in_proof;cast=x;cids=[];cqueue=`MainQueue }); + VCS.commit id (mkTransCmd x [] in_proof `MainQueue); (* We hope it can be replayed, but we can't really know *) VCS.propagate_sideff ~replay:(Some x); VCS.checkout_shallowest_proof_branch (); @@ -2305,11 +2576,11 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) = anomaly(str"classifier: VtUnknown must imply VtNow") end in (* Proof General *) - begin match v with + begin match expr with | VernacStm (PGLast _) -> if not (VCS.Branch.equal head VCS.Branch.master) then vernac_interp Stateid.dummy - { verbose = true; loc = Loc.ghost; + { verbose = true; loc = Loc.ghost; indentation = 0; strlen = 0; expr = VernacShow (ShowGoal OpenSubgoals) } | _ -> () end; @@ -2320,34 +2591,40 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) = let e = Errors.push e in handle_failure e vcs tty -let print_ast id = - try - match VCS.visit id with - | { step = `Cmd { cast = { loc; expr } } } - | { step = `Fork (({ loc; expr }, _, _, _), _) } - | { step = `Qed ({ qast = { loc; expr } }, _) } -> - let xml = - try Texmacspp.tmpp expr loc - with e -> Xml_datatype.PCData ("ERROR " ^ Printexc.to_string e) in - xml; - | _ -> Xml_datatype.PCData "ERROR" - with _ -> Xml_datatype.PCData "ERROR" +let get_ast id = + match VCS.visit id with + | { step = `Cmd { cast = { loc; expr } } } + | { step = `Fork (({ loc; expr }, _, _, _), _) } + | { step = `Qed ({ qast = { loc; expr } }, _) } -> + Some (expr, loc) + | _ -> None let stop_worker n = Slaves.cancel_worker n +(* You may need to know the len + indentation of previous command to compute + * the indentation of the current one. + * Eg. foo. bar. + * Here bar is indented of the indentation of foo + its strlen (4) *) +let ind_len_of id = + if Stateid.equal id Stateid.initial then 0 + else match (VCS.visit id).step with + | `Cmd { ctac = true; cast = { indentation; strlen } } -> + indentation + strlen + | _ -> 0 + let add ~ontop ?newtip ?(check=ignore) verb eid s = let cur_tip = VCS.cur_tip () in - if Stateid.equal ontop cur_tip then begin - let _, ast as loc_ast = vernac_parse ?newtip eid s in - check(loc_ast); - let clas = classify_vernac ast in - match process_transaction ?newtip ~tty:false verb clas loc_ast with - | `Ok -> VCS.cur_tip (), `NewTip - | `Unfocus qed_id -> qed_id, `Unfocus (VCS.cur_tip ()) - end else begin + if not (Stateid.equal ontop cur_tip) then (* For now, arbitrary edits should be announced with edit_at *) - anomaly(str"Not yet implemented, the GUI should not try this") - end + anomaly(str"Not yet implemented, the GUI should not try this"); + let indentation, strlen, loc, ast = + vernac_parse ~indlen_prev:(fun () -> ind_len_of ontop) ?newtip eid s in + check(loc,ast); + let clas = classify_vernac ast in + let aast = { verbose = verb; indentation; strlen; loc; expr = ast } in + match process_transaction ?newtip ~tty:false aast clas with + | `Ok -> VCS.cur_tip (), `NewTip + | `Unfocus qed_id -> qed_id, `Unfocus (VCS.cur_tip ()) let set_perspective id_list = Slaves.set_perspective id_list @@ -2357,20 +2634,20 @@ type focus = { tip : Stateid.t } -let query ~at ?(report_with=(Stateid.dummy,Feedback.default_route)) s = +let query ~at ?(report_with=(Stateid.dummy,default_route)) s = Future.purify (fun s -> if Stateid.equal at Stateid.dummy then finish () else Reach.known_state ~cache:`Yes at; let newtip, route = report_with in - let _, ast as loc_ast = vernac_parse ~newtip ~route 0 s in + let indentation, strlen, loc, ast = vernac_parse ~newtip ~route 0 s in let clas = classify_vernac ast in + let aast = { verbose = true; indentation; strlen; loc; expr = ast } in match clas with | VtStm (w,_), _ -> - ignore(process_transaction - ~tty:false true (VtStm (w,false), VtNow) loc_ast) + ignore(process_transaction ~tty:false aast (VtStm (w,false), VtNow)) | _ -> ignore(process_transaction - ~tty:false true (VtQuery (false,report_with), VtNow) loc_ast)) + ~tty:false aast (VtQuery (false,report_with), VtNow))) s let edit_at id = @@ -2395,7 +2672,7 @@ let edit_at id = | _ -> assert false in let is_ancestor_of_cur_branch id = - Vcs_.NodeSet.mem id + Stateid.Set.mem id (VCS.reachable (VCS.get_branch_pos (VCS.current_branch ()))) in let has_failed qed_id = match VCS.visit qed_id with @@ -2410,13 +2687,13 @@ let edit_at id = | { next } -> master_for_br root next in let reopen_branch start at_id mode qed_id tip old_branch = let master_id, cancel_switch, keep = - (* Hum, this should be the real start_id in the clusted and not next *) + (* Hum, this should be the real start_id in the cluster and not next *) match VCS.visit qed_id with | { step = `Qed ({ fproof = Some (_,cs); keep },_) } -> start, cs, keep - | _ -> anomaly (str "Cluster not ending with Qed") in + | _ -> anomaly (str "ProofTask not ending with Qed") in VCS.branch ~root:master_id ~pos:id VCS.edit_branch (`Edit (mode, qed_id, master_id, keep, old_branch)); - VCS.delete_cluster_of id; + VCS.delete_boxes_of id; cancel_switch := true; Reach.known_state ~cache:(interactive ()) id; VCS.checkout_shallowest_proof_branch (); @@ -2430,14 +2707,14 @@ let edit_at id = let { mine = brname, brinfo; others } = Backtrack.branches_of id in List.iter (fun (name,{ VCS.kind = k; root; pos }) -> if not(VCS.Branch.equal name VCS.Branch.master) && - Vcs_.NodeSet.mem root ancestors then + Stateid.Set.mem root ancestors then VCS.branch ~root ~pos name k) others; VCS.reset_branch VCS.Branch.master (master_for_br brinfo.VCS.root id); VCS.branch ~root:brinfo.VCS.root ~pos:brinfo.VCS.pos (Option.default brname bn) (no_edit brinfo.VCS.kind); - VCS.delete_cluster_of id; + VCS.delete_boxes_of id; VCS.gc (); VCS.print (); if not !Flags.async_proofs_full then @@ -2452,14 +2729,14 @@ let edit_at id = | Some{ mine = bn, { VCS.kind = `Proof(m,_) }} -> Some(m,bn) | Some{ mine = _, { VCS.kind = `Edit(m,_,_,_,bn) }} -> Some (m,bn) | _ -> None in - match focused, VCS.cluster_of id, branch_info with + match focused, VCS.proof_task_box_of id, branch_info with | _, Some _, None -> assert false - | false, Some (qed_id,start), Some(mode,bn) -> + | false, Some { qed = qed_id ; lemma = start }, Some(mode,bn) -> let tip = VCS.cur_tip () in if has_failed qed_id && is_pure qed_id && not !Flags.async_proofs_never_reopen_branch then reopen_branch start id mode qed_id tip bn else backto id (Some bn) - | true, Some (qed_id,_), Some(mode,bn) -> + | true, Some { qed = qed_id }, Some(mode,bn) -> if on_cur_branch id then begin assert false end else if is_ancestor_of_cur_branch id then begin @@ -2502,9 +2779,10 @@ let restore d = VCS.restore d (*********************** TTY API (PG, coqtop, coqc) ***************************) (******************************************************************************) -let interp verb (_,e as lexpr) = +let interp verb (loc,e) = let clas = classify_vernac e in - let rc = process_transaction ~tty:true verb clas lexpr in + let aast = { verbose = verb; indentation = 0; strlen = 0; loc; expr = e } in + let rc = process_transaction ~tty:true aast clas in if rc <> `Ok then anomaly(str"tty loop can't be mixed with the STM protocol"); if interactive () = `Yes || (!Flags.async_proofs_mode = Flags.APoff && diff --git a/stm/stm.mli b/stm/stm.mli index 4279921b3b..37ec1f0a13 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -20,7 +20,9 @@ open Loc The sentence [s] is parsed in the state [ontop]. If [newtip] is provided, then the returned state id is guaranteed to be [newtip] *) -val add : ontop:Stateid.t -> ?newtip:Stateid.t -> ?check:(vernac_expr located -> unit) -> +val add : + ontop:Stateid.t -> ?newtip:Stateid.t -> + ?check:(vernac_expr located -> unit) -> bool -> edit_id -> string -> Stateid.t * [ `NewTip | `Unfocus of Stateid.t ] @@ -76,7 +78,9 @@ val get_current_state : unit -> Stateid.t (* Misc *) val init : unit -> unit -val print_ast : Stateid.t -> Xml_datatype.xml + +(* This returns the node at that position *) +val get_ast : Stateid.t -> (Vernacexpr.vernac_expr * Loc.t) option (* Filename *) val set_compilation_hints : string -> unit @@ -94,6 +98,82 @@ module ProofTask : AsyncTaskQueue.Task module TacTask : AsyncTaskQueue.Task module QueryTask : AsyncTaskQueue.Task +(** document structure customization *************************************** **) + +(* A proof block delimiter defines a syntactic delimiter for sub proofs + that, when contain an error, do not impact the rest of the proof. + While checking a proof, if an error occurs in a (valid) block then + processing can skip the entire block and go on to give feedback + on the rest of the proof. + + static_block_detection and dynamic_block_validation are run when + the closing block marker is parsed/executed respectively. + + static_block_detection is for example called when "}" is parsed and + declares a block containing all proof steps between it and the matching + "{". + + dynamic_block_validation is called when an error "crosses" the "}" statement. + Depending on the nature of the goal focused by "{" the block may absorb the + error or not. For example if the focused goal occurs in the type of + another goal, then the block is leaky. + Note that one can design proof commands that need no dynamic validation. + + Example of document: + + .. { tac1. tac2. } .. + + Corresponding DAG: + + .. (3) <-- { -- (4) <-- tac1 -- (5) <-- tac2 -- (6) <-- } -- (7) .. + + Declaration of block [-------------------------------------------] + + start = 5 the first state_id that could fail in the block + stop = 7 the node that may absorb the error + dynamic_switch = 4 dynamic check on this node + carry_on_data = () no need to carry extra data from static to dynamic + checks +*) + +module DynBlockData : Dyn.S + +type static_block_declaration = { + start : Stateid.t; + stop : Stateid.t; + dynamic_switch : Stateid.t; + carry_on_data : DynBlockData.t; +} + +type document_node = { + indentation : int; + ast : Vernacexpr.vernac_expr; + id : Stateid.t; +} + +type document_view = { + entry_point : document_node; + prev_node : document_node -> document_node option; +} + +type static_block_detection = + document_view -> static_block_declaration option + +type recovery_action = { + base_state : Stateid.t; + goals_to_admit : Goal.goal list; + recovery_command : Vernacexpr.vernac_expr option; +} + +type dynamic_block_error_recovery = + static_block_declaration -> [ `ValidBlock of recovery_action | `Leaks ] + +val register_proof_block_delimiter : + Vernacexpr.proof_block_name -> + static_block_detection -> + dynamic_block_error_recovery -> + unit + (** customization ********************************************************** **) (* From the master (or worker, but beware that to install the hook @@ -120,12 +200,13 @@ type state = { proof : Proof_global.state; shallow : bool } -val state_of_id : Stateid.t -> [ `Valid of state option | `Expired ] +val state_of_id : + Stateid.t -> [ `Valid of state option | `Expired | `Error of exn ] (** read-eval-print loop compatible interface ****************************** **) (* Adds a new line to the document. It replaces the core of Vernac.interp. - [finish] is called as the last bit of this function is the system + [finish] is called as the last bit of this function if the system is running interactively (-emacs or coqtop). *) val interp : bool -> vernac_expr located -> unit @@ -135,7 +216,7 @@ val get_all_proof_names : unit -> Id.t list val get_current_proof_name : unit -> Id.t option val show_script : ?proof:Proof_global.closed_proof -> unit -> unit -(** Reverse dependency hooks *) +(* Hooks to be set by other Coq components in order to break file cycles *) val process_error_hook : Future.fix_exn Hook.t val interp_hook : (?verbosely:bool -> ?proof:Proof_global.closed_proof -> Loc.t * Vernacexpr.vernac_expr -> unit) Hook.t diff --git a/stm/stm.mllib b/stm/stm.mllib index 92b3a869a9..939ee187ae 100644 --- a/stm/stm.mllib +++ b/stm/stm.mllib @@ -7,6 +7,6 @@ Vernac_classifier Lemmas CoqworkmgrApi AsyncTaskQueue -Texmacspp Stm +ProofBlockDelimiter Vio_checking diff --git a/stm/vcs.ml b/stm/vcs.ml index 38c029901d..c483ea4a9d 100644 --- a/stm/vcs.ml +++ b/stm/vcs.ml @@ -22,51 +22,49 @@ module type S = sig end type id - - (* Branches have [branch_info] attached to them. *) + type ('kind) branch_info = { kind : [> `Master] as 'kind; root : id; pos : id; } - - type ('kind,'diff,'info) t constraint 'kind = [> `Master ] - - val empty : id -> ('kind,'diff,'info) t - - val current_branch : ('k,'e,'i) t -> Branch.t - val branches : ('k,'e,'i) t -> Branch.t list - - val get_branch : ('k,'e,'i) t -> Branch.t -> 'k branch_info - val reset_branch : ('k,'e,'i) t -> Branch.t -> id -> ('k,'e,'i) t + + type ('kind,'diff,'info,'property_data) t constraint 'kind = [> `Master ] + + val empty : id -> ('kind,'diff,'info,'property_data) t + + val current_branch : ('k,'e,'i,'c) t -> Branch.t + val branches : ('k,'e,'i,'c) t -> Branch.t list + + val get_branch : ('k,'e,'i,'c) t -> Branch.t -> 'k branch_info + val reset_branch : ('k,'e,'i,'c) t -> Branch.t -> id -> ('k,'e,'i,'c) t val branch : - ('kind,'e,'i) t -> ?root:id -> ?pos:id -> - Branch.t -> 'kind -> ('kind,'e,'i) t - val delete_branch : ('k,'e,'i) t -> Branch.t -> ('k,'e,'i) t + ('kind,'e,'i,'c) t -> ?root:id -> ?pos:id -> + Branch.t -> 'kind -> ('kind,'e,'i,'c) t + val delete_branch : ('k,'e,'i,'c) t -> Branch.t -> ('k,'e,'i,'c) t val merge : - ('k,'diff,'i) t -> id -> ours:'diff -> theirs:'diff -> ?into:Branch.t -> - Branch.t -> ('k,'diff,'i) t - val commit : ('k,'diff,'i) t -> id -> 'diff -> ('k,'diff,'i) t + ('k,'diff,'i,'c) t -> id -> ours:'diff -> theirs:'diff -> ?into:Branch.t -> + Branch.t -> ('k,'diff,'i,'c) t + val commit : ('k,'diff,'i,'c) t -> id -> 'diff -> ('k,'diff,'i,'c) t val rewrite_merge : - ('k,'diff,'i) t -> id -> ours:'diff -> theirs:'diff -> at:id -> - Branch.t -> ('k,'diff,'i) t - val checkout : ('k,'e,'i) t -> Branch.t -> ('k,'e,'i) t - - val set_info : ('k,'e,'info) t -> id -> 'info -> ('k,'e,'info) t - val get_info : ('k,'e,'info) t -> id -> 'info option + ('k,'diff,'i,'c) t -> id -> ours:'diff -> theirs:'diff -> at:id -> + Branch.t -> ('k,'diff,'i,'c) t + val checkout : ('k,'e,'i,'c) t -> Branch.t -> ('k,'e,'i,'c) t - module NodeSet : Set.S with type elt = id - - val gc : ('k,'e,'info) t -> ('k,'e,'info) t * NodeSet.t - - val reachable : ('k,'e,'info) t -> id -> NodeSet.t + val set_info : ('k,'e,'info,'c) t -> id -> 'info -> ('k,'e,'info,'c) t + val get_info : ('k,'e,'info,'c) t -> id -> 'info option + (* Read only dag *) module Dag : Dag.S with type node = id - val dag : ('kind,'diff,'info) t -> ('diff,'info,id*id) Dag.t + val dag : ('kind,'diff,'info,'cdata) t -> ('diff,'info,'cdata) Dag.t + + val create_property : ('k,'e,'i,'c) t -> id list -> 'c -> ('k,'e,'i,'c) t + val property_of : ('k,'e,'i,'c) t -> id -> 'c Dag.Property.t list + val delete_property : ('k,'e,'i,'c) t -> 'c Dag.Property.t -> ('k,'e,'i,'c) t - val create_cluster : ('k,'e,'i) t -> id list -> (id * id) -> ('k,'e,'i) t - val cluster_of : ('k,'e,'i) t -> id -> (id * id) Dag.Cluster.t option - val delete_cluster : ('k,'e,'i) t -> (id * id) Dag.Cluster.t -> ('k,'e,'i) t + (* Removes all unreachable nodes and returns them *) + val gc : ('k,'e,'info,'c) t -> ('k,'e,'info,'c) t * Dag.NodeSet.t + val reachable : ('k,'e,'info,'c) t -> id -> Dag.NodeSet.t end @@ -78,7 +76,6 @@ type id = OT.t module NodeSet = Dag.NodeSet - module Branch = struct type t = string @@ -99,10 +96,10 @@ type 'kind branch_info = { pos : id; } -type ('kind,'edge,'info) t = { +type ('kind,'edge,'info,'property_data) t = { cur_branch : Branch.t; heads : 'kind branch_info BranchMap.t; - dag : ('edge,'info,id*id) Dag.t; + dag : ('edge,'info,'property_data) Dag.t; } let empty root = { @@ -167,9 +164,9 @@ let checkout vcs name = { vcs with cur_branch = name } let set_info vcs id info = { vcs with dag = Dag.set_info vcs.dag id info } let get_info vcs id = Dag.get_info vcs.dag id -let create_cluster vcs l i = { vcs with dag = Dag.create_cluster vcs.dag l i } -let cluster_of vcs i = Dag.cluster_of vcs.dag i -let delete_cluster vcs c = { vcs with dag = Dag.del_cluster vcs.dag c } +let create_property vcs l i = { vcs with dag = Dag.create_property vcs.dag l i } +let property_of vcs i = Dag.property_of vcs.dag i +let delete_property vcs c = { vcs with dag = Dag.del_property vcs.dag c } let branches vcs = BranchMap.fold (fun x _ accu -> x :: accu) vcs.heads [] let dag vcs = vcs.dag diff --git a/stm/vcs.mli b/stm/vcs.mli index 8f22fee843..46b40f8a4c 100644 --- a/stm/vcs.mli +++ b/stm/vcs.mli @@ -19,10 +19,11 @@ As a consequence, "checkout" just updates the current branch. The type [id] is the type of commits (a node in the dag) - The type [Vcs.t] has 3 parameters: + The type [Vcs.t] has 4 parameters: ['info] data attached to a node (like a system state) ['diff] data attached to an edge (the commit content, a "patch") ['kind] extra data attached to a branch (like being the master branch) + ['cdata] extra data hold by dag properties *) module type S = sig @@ -45,46 +46,51 @@ module type S = sig pos : id; } - type ('kind,'diff,'info) t constraint 'kind = [> `Master ] + type ('kind,'diff,'info,'property_data) t constraint 'kind = [> `Master ] - val empty : id -> ('kind,'diff,'info) t + val empty : id -> ('kind,'diff,'info,'property_data) t - val current_branch : ('k,'e,'i) t -> Branch.t - val branches : ('k,'e,'i) t -> Branch.t list + val current_branch : ('k,'e,'i,'c) t -> Branch.t + val branches : ('k,'e,'i,'c) t -> Branch.t list - val get_branch : ('k,'e,'i) t -> Branch.t -> 'k branch_info - val reset_branch : ('k,'e,'i) t -> Branch.t -> id -> ('k,'e,'i) t + val get_branch : ('k,'e,'i,'c) t -> Branch.t -> 'k branch_info + val reset_branch : ('k,'e,'i,'c) t -> Branch.t -> id -> ('k,'e,'i,'c) t val branch : - ('kind,'e,'i) t -> ?root:id -> ?pos:id -> - Branch.t -> 'kind -> ('kind,'e,'i) t - val delete_branch : ('k,'e,'i) t -> Branch.t -> ('k,'e,'i) t + ('kind,'e,'i,'c) t -> ?root:id -> ?pos:id -> + Branch.t -> 'kind -> ('kind,'e,'i,'c) t + val delete_branch : ('k,'e,'i,'c) t -> Branch.t -> ('k,'e,'i,'c) t val merge : - ('k,'diff,'i) t -> id -> ours:'diff -> theirs:'diff -> ?into:Branch.t -> - Branch.t -> ('k,'diff,'i) t - val commit : ('k,'diff,'i) t -> id -> 'diff -> ('k,'diff,'i) t + ('k,'diff,'i,'c) t -> id -> ours:'diff -> theirs:'diff -> ?into:Branch.t -> + Branch.t -> ('k,'diff,'i,'c) t + val commit : ('k,'diff,'i,'c) t -> id -> 'diff -> ('k,'diff,'i,'c) t val rewrite_merge : - ('k,'diff,'i) t -> id -> ours:'diff -> theirs:'diff -> at:id -> - Branch.t -> ('k,'diff,'i) t - val checkout : ('k,'e,'i) t -> Branch.t -> ('k,'e,'i) t + ('k,'diff,'i,'c) t -> id -> ours:'diff -> theirs:'diff -> at:id -> + Branch.t -> ('k,'diff,'i,'c) t + val checkout : ('k,'e,'i,'c) t -> Branch.t -> ('k,'e,'i,'c) t - val set_info : ('k,'e,'info) t -> id -> 'info -> ('k,'e,'info) t - val get_info : ('k,'e,'info) t -> id -> 'info option + val set_info : ('k,'e,'info,'c) t -> id -> 'info -> ('k,'e,'info,'c) t + val get_info : ('k,'e,'info,'c) t -> id -> 'info option - module NodeSet : Set.S with type elt = id + (* Read only dag *) + module Dag : Dag.S with type node = id + val dag : ('kind,'diff,'info,'cdata) t -> ('diff,'info,'cdata) Dag.t - (* Removes all unreachable nodes and returns them *) - val gc : ('k,'e,'info) t -> ('k,'e,'info) t * NodeSet.t + (* Properties are not a concept typical of a VCS, but a useful metadata + * of a DAG (or graph). *) + val create_property : ('k,'e,'i,'c) t -> id list -> 'c -> ('k,'e,'i,'c) t + val property_of : ('k,'e,'i,'c) t -> id -> 'c Dag.Property.t list + val delete_property : ('k,'e,'i,'c) t -> 'c Dag.Property.t -> ('k,'e,'i,'c) t - val reachable : ('k,'e,'info) t -> id -> NodeSet.t + (* Removes all unreachable nodes and returns them *) + val gc : ('k,'e,'info,'c) t -> ('k,'e,'info,'c) t * Dag.NodeSet.t + val reachable : ('k,'e,'info,'c) t -> id -> Dag.NodeSet.t - (* read only dag *) - module Dag : Dag.S with type node = id - val dag : ('kind,'diff,'info) t -> ('diff,'info,id * id) Dag.t - val create_cluster : ('k,'e,'i) t -> id list -> (id * id) -> ('k,'e,'i) t - val cluster_of : ('k,'e,'i) t -> id -> (id * id) Dag.Cluster.t option - val delete_cluster : ('k,'e,'i) t -> (id * id) Dag.Cluster.t -> ('k,'e,'i) t - end -module Make(OT : Map.OrderedType) : S with type id = OT.t +module Make(OT : Map.OrderedType) : S +with type id = OT.t +and type Dag.node = OT.t +and type Dag.NodeSet.t = Set.Make(OT).t +and type Dag.NodeSet.elt = OT.t + diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index b1df3c9ca6..a602d6b8a8 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -21,8 +21,9 @@ let string_of_vernac_type = function | VtQed VtKeep -> "Qed(keep)" | VtQed VtKeepAsAxiom -> "Qed(admitted)" | VtQed VtDrop -> "Qed(drop)" - | VtProofStep false -> "ProofStep" - | VtProofStep true -> "ProofStep (parallel)" + | VtProofStep { parallel; proof_block_detection } -> + "ProofStep " ^ if parallel then "par " else "" ^ + Option.default "" proof_block_detection | VtProofMode s -> "ProofMode " ^ s | VtQuery (b,(id,route)) -> "Query " ^ string_of_in_script b ^ " report " ^ Stateid.to_string id ^ @@ -93,7 +94,9 @@ let rec classify_vernac e = (match classify_vernac e with | ( VtQuery _ | VtProofStep _ | VtSideff _ | VtStm _ | VtProofMode _ ), _ as x -> x - | VtQed _, _ -> VtProofStep false, VtNow + | VtQed _, _ -> + VtProofStep { parallel = false; proof_block_detection = None }, + VtNow | (VtStartProof _ | VtUnknown), _ -> VtUnknown, VtNow) (* Qed *) | VernacAbort _ -> VtQed VtDrop, VtLater @@ -105,12 +108,19 @@ let rec classify_vernac e = VtQuery (true,(Stateid.dummy,Feedback.default_route)), VtLater (* ProofStep *) | VernacProof _ - | VernacBullet _ | VernacFocus _ | VernacUnfocus - | VernacSubproof _ | VernacEndSubproof + | VernacSubproof _ | VernacCheckGuard | VernacUnfocused - | VernacSolveExistential _ -> VtProofStep false, VtLater + | VernacSolveExistential _ -> + VtProofStep { parallel = false; proof_block_detection = None }, VtLater + | VernacBullet _ -> + VtProofStep { parallel = false; proof_block_detection = Some "bullet" }, + VtLater + | VernacEndSubproof -> + VtProofStep { parallel = false; + proof_block_detection = Some "curly" }, + VtLater (* Options changing parser *) | VernacUnsetOption (["Default";"Proof";"Using"]) | VernacSetOption (["Default";"Proof";"Using"],_) -> VtSideff [], VtNow @@ -219,4 +229,4 @@ let rec classify_vernac e = let classify_as_query = VtQuery (true,(Stateid.dummy,Feedback.default_route)), VtLater let classify_as_sideeff = VtSideff [], VtLater -let classify_as_proofstep = VtProofStep false, VtLater +let classify_as_proofstep = VtProofStep { parallel = false; proof_block_detection = None}, VtLater diff --git a/tactics/auto.ml b/tactics/auto.ml index 6b58baa997..e57b48e9e0 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -229,11 +229,11 @@ let tclLOG (dbg,depth,trace) pp tac = Proofview.V82.tactic begin fun gl -> try let out = Proofview.V82.of_tactic tac gl in - msg_debug (str s ++ spc () ++ pp () ++ str ". (*success*)"); + Feedback.msg_debug (str s ++ spc () ++ pp () ++ str ". (*success*)"); out with reraise -> let reraise = Errors.push reraise in - msg_debug (str s ++ spc () ++ pp () ++ str ". (*fail*)"); + Feedback.msg_debug (str s ++ spc () ++ pp () ++ str ". (*fail*)"); iraise reraise end | Info -> @@ -289,10 +289,10 @@ let tclTRY_dbg d tac = let delay f = Proofview.tclUNIT () >>= fun () -> f () in let tac = match level with | Off -> tac - | Debug | Info -> delay (fun () -> msg_debug (pr_dbg_header d ++ fnl () ++ pr_info_trace d); 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 () -> msg_debug (pr_info_nop d); Proofview.tclUNIT ()) + | Info -> delay (fun () -> Feedback.msg_debug (pr_info_nop d); Proofview.tclUNIT ()) | Off | Debug -> Proofview.tclUNIT () in Tacticals.New.tclORELSE0 tac after diff --git a/tactics/auto.mli b/tactics/auto.mli index 8c4f359041..0fd95aeadb 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -6,6 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(** This files implements auto and related automation tactics *) + open Names open Term open Clenv @@ -13,8 +15,6 @@ open Pattern open Decl_kinds open Hints -(** Auto and related automation tactics *) - val priority : ('a * full_hint) list -> ('a * full_hint) list val default_search_depth : int ref diff --git a/tactics/autorewrite.mli b/tactics/autorewrite.mli index ac613b57ce..0706571795 100644 --- a/tactics/autorewrite.mli +++ b/tactics/autorewrite.mli @@ -6,6 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(** This files implements the autorewrite tactic. *) + open Term open Tacexpr open Equality diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index cfbcc47505..0172d28c5a 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -455,7 +455,7 @@ let hints_tac hints = | None -> aux i foundone tl | Some {it = gls; sigma = s';} -> if !typeclasses_debug then - msg_debug (pr_depth (i :: info.auto_depth) ++ str": " ++ Lazy.force pp + Feedback.msg_debug (pr_depth (i :: info.auto_depth) ++ str": " ++ Lazy.force pp ++ str" on" ++ spc () ++ pr_ev s gl); let sgls = evars_to_goals @@ -504,7 +504,7 @@ let hints_tac hints = in let e' = match foundone with None -> e | Some e' -> merge_failures e e' in if !typeclasses_debug then - msg_debug + Feedback.msg_debug ((if do_backtrack then str"Backtracking after " else str "Not backtracking after ") ++ Lazy.force pp); @@ -514,7 +514,7 @@ let hints_tac hints = sk glsv fk') | [] -> if foundone == None && !typeclasses_debug then - msg_debug (pr_depth info.auto_depth ++ str": no match for " ++ + Feedback.msg_debug (pr_depth info.auto_depth ++ str": no match for " ++ Printer.pr_constr_env (Goal.V82.env s gl) s concl ++ spc () ++ str ", " ++ int (List.length poss) ++ str" possibilities"); match foundone with @@ -851,6 +851,15 @@ let set_typeclasses_debug = optread = get_typeclasses_debug; optwrite = set_typeclasses_debug; } +let set_typeclasses_debug = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "debug output for typeclasses proof search"; + optkey = ["Debug";"Typeclasses"]; + optread = get_typeclasses_debug; + optwrite = set_typeclasses_debug; } + let set_typeclasses_depth = declare_int_option { optsync = true; diff --git a/tactics/class_tactics.mli b/tactics/class_tactics.mli index f1bcfa7dd4..cac4b88445 100644 --- a/tactics/class_tactics.mli +++ b/tactics/class_tactics.mli @@ -6,6 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +(** This files implements typeclasses eauto *) + open Names open Constr open Tacmach diff --git a/tactics/eauto.ml b/tactics/eauto.ml index f0f408c24d..2cae9b7946 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -344,13 +344,13 @@ let mk_eauto_dbg d = else Off let pr_info_nop = function - | Info -> msg_debug (str "idtac.") + | Info -> Feedback.msg_debug (str "idtac.") | _ -> () let pr_dbg_header = function | Off -> () - | Debug -> msg_debug (str "(* debug eauto : *)") - | Info -> msg_debug (str "(* info eauto : *)") + | Debug -> Feedback.msg_debug (str "(* debug eauto : *)") + | Info -> Feedback.msg_debug (str "(* info eauto : *)") let pr_info dbg s = if dbg != Info then () @@ -361,7 +361,7 @@ let pr_info dbg s = | State sp -> let mindepth = loop sp in let indent = String.make (mindepth - sp.depth) ' ' in - msg_debug (str indent ++ Lazy.force s.last_tactic ++ str "."); + Feedback.msg_debug (str indent ++ Lazy.force s.last_tactic ++ str "."); mindepth in ignore (loop s) diff --git a/tactics/hints.ml b/tactics/hints.ml index b2104ba433..6f8da00d89 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -692,7 +692,7 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, else begin if not eapply then failwith "make_apply_entry"; if verbose then - msg_warning (str "the hint: eapply " ++ pr_lconstr c ++ + Feedback.msg_warning (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); @@ -707,10 +707,43 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, c is a constr cty is the type of constr *) +let pr_hint_term env sigma ctx = function + | IsGlobRef gr -> pr_global gr + | IsConstr (c, ctx) -> + let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in + pr_constr_env env sigma c + +(** We need an object to record the side-effect of registering + global universes associated with a hint. *) +let cache_context_set (_,c) = + Global.push_context_set false c + +let input_context_set : Univ.ContextSet.t -> Libobject.obj = + let open Libobject in + declare_object + { (default_object "Global universe context") with + cache_function = cache_context_set; + load_function = (fun _ -> cache_context_set); + discharge_function = (fun (_,a) -> Some a); + classify_function = (fun a -> Keep a) } + let fresh_global_or_constr env sigma poly cr = - match cr with - | IsGlobRef gr -> Universes.fresh_global_instance env gr - | IsConstr (c, ctx) -> (c, ctx) + let isgr, (c, ctx) = + match cr with + | IsGlobRef gr -> + true, Universes.fresh_global_instance env gr + | IsConstr (c, ctx) -> false, (c, ctx) + in + if poly then (c, ctx) + else if Univ.ContextSet.is_empty ctx then (c, ctx) + else begin + if isgr then + Feedback.msg_warning (str"Using polymorphic hint " ++ + pr_hint_term env sigma ctx cr ++ str" monomorphically" ++ + str" use Polymorphic Hint to use it polymorphically."); + Lib.add_anonymous_leaf (input_context_set ctx); + (c, Univ.ContextSet.empty) + end let make_resolves env sigma flags pri poly ?name cr = let c, ctx = fresh_global_or_constr env sigma poly cr in @@ -1077,7 +1110,7 @@ let prepare_hint check (poly,local) env init (sigma,c) = let diff = Univ.ContextSet.diff (Evd.universe_context_set sigma) (Evd.universe_context_set init) in if poly then IsConstr (c', diff) else if local then IsConstr (c', diff) - else (Global.push_context_set false diff; + else (Lib.add_anonymous_leaf (input_context_set diff); IsConstr (c', Univ.ContextSet.empty)) let interp_hints poly = @@ -1152,18 +1185,24 @@ let expand_constructor_hints env sigma lems = match kind_of_term lem with | Ind (ind,u) -> List.init (nconstructors ind) - (fun i -> IsConstr (mkConstructU ((ind,i+1),u), - Univ.ContextSet.empty)) + (fun i -> + let ctx = Univ.ContextSet.diff (Evd.universe_context_set evd) + (Evd.universe_context_set sigma) in + not (Univ.ContextSet.is_empty ctx), + IsConstr (mkConstructU ((ind,i+1),u),ctx)) | _ -> - [prepare_hint false (false,true) env sigma (evd,lem)]) lems - + [match prepare_hint false (false,true) env sigma (evd,lem) with + | IsConstr (c, ctx) -> + not (Univ.ContextSet.is_empty ctx), IsConstr (c, ctx) + | IsGlobRef _ -> assert false (* Impossible return value *) ]) lems (* builds a hint database from a constr signature *) (* typically used with (lid, ltyp) = pf_hyps_types <some goal> *) let add_hint_lemmas env sigma eapply lems hint_db = let lems = expand_constructor_hints env sigma lems in let hintlist' = - List.map_append (make_resolves env sigma (eapply,true,false) None false) lems in + List.map_append (fun (poly, lem) -> + make_resolves env sigma (eapply,true,false) None poly lem) lems in Hint_db.add_list env sigma hintlist' hint_db let make_local_hint_db env sigma ts eapply lems = @@ -1182,12 +1221,6 @@ let make_local_hint_db env sigma ts eapply lems = add_hint_lemmas env sigma eapply lems (Hint_db.add_list env sigma hintlist (Hint_db.empty ts false)) -let make_local_hint_db = - if Flags.profile then - let key = Profile.declare_profile "make_local_hint_db" in - Profile.profile4 key make_local_hint_db - else make_local_hint_db - let make_local_hint_db env sigma ?ts eapply lems = make_local_hint_db env sigma ts eapply lems @@ -1336,7 +1369,7 @@ let is_imported h = try KNmap.find h.uid !statustable with Not_found -> true let warn h x = let hint = pr_hint h in let (mp, _, _) = KerName.repr h.uid in - let () = msg_warning (str "Hint used but not imported: " ++ hint ++ print_mp mp) in + let () = Feedback.msg_warning (str "Hint used but not imported: " ++ hint ++ print_mp mp) in Proofview.tclUNIT x let run_hint tac k = match !warn_hint with diff --git a/tactics/hipattern.ml4 b/tactics/hipattern.ml index bcec90f803..fded54fcb1 100644 --- a/tactics/hipattern.ml4 +++ b/tactics/hipattern.ml @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(*i camlp4deps: "grammar/grammar.cma grammar/q_constr.cmo" i*) - open Pp open Errors open Util @@ -243,9 +241,36 @@ type equation_kind = exception NoEquationFound -let coq_refl_leibniz1_pattern = PATTERN [ forall x:_, _ x x ] -let coq_refl_leibniz2_pattern = PATTERN [ forall A:_, forall x:A, _ A x x ] -let coq_refl_jm_pattern = PATTERN [ forall A:_, forall x:A, _ A x A x ] +open Glob_term +open Decl_kinds +open Evar_kinds + +let mkPattern c = snd (Patternops.pattern_of_glob_constr c) +let mkGApp f args = GApp (Loc.ghost, f, args) +let mkGHole = + GHole (Loc.ghost, QuestionMark (Define false), Misctypes.IntroAnonymous, None) +let mkGProd id c1 c2 = + GProd (Loc.ghost, Name (Id.of_string id), Explicit, c1, c2) +let mkGArrow c1 c2 = + GProd (Loc.ghost, Anonymous, Explicit, c1, c2) +let mkGVar id = GVar (Loc.ghost, Id.of_string id) +let mkGPatVar id = GPatVar(Loc.ghost, (false, Id.of_string id)) +let mkGRef r = GRef (Loc.ghost, Lazy.force r, None) +let mkGAppRef r args = mkGApp (mkGRef r) args + +(** forall x : _, _ x x *) +let coq_refl_leibniz1_pattern = + mkPattern (mkGProd "x" mkGHole (mkGApp mkGHole [mkGVar "x"; mkGVar "x";])) + +(** forall A:_, forall x:A, _ A x x *) +let coq_refl_leibniz2_pattern = + mkPattern (mkGProd "A" mkGHole (mkGProd "x" (mkGVar "A") + (mkGApp mkGHole [mkGVar "A"; mkGVar "x"; mkGVar "x";]))) + +(** forall A:_, forall x:A, _ A x A x *) +let coq_refl_jm_pattern = + mkPattern (mkGProd "A" mkGHole (mkGProd "x" (mkGVar "A") + (mkGApp mkGHole [mkGVar "A"; mkGVar "x"; mkGVar "A"; mkGVar "x";]))) open Globnames @@ -301,7 +326,8 @@ let is_equality_type t = op2bool (match_with_equality_type t) (* Arrows/Implication/Negation *) -let coq_arrow_pattern = PATTERN [ ?X1 -> ?X2 ] +(** X1 -> X2 **) +let coq_arrow_pattern = mkPattern (mkGArrow (mkGPatVar "X1") (mkGPatVar "X2")) let match_arrow_pattern t = let result = matches coq_arrow_pattern t in @@ -381,10 +407,15 @@ let rec first_match matcher = function (*** Equality *) (* Patterns "(eq ?1 ?2 ?3)" and "(identity ?1 ?2 ?3)" *) -let coq_eq_pattern_gen eq = lazy PATTERN [ %eq ?X1 ?X2 ?X3 ] +(** %eq ?X1 ?X2 ?X3 *) +let coq_eq_pattern_gen eq = + lazy (mkPattern (mkGAppRef eq (List.map mkGPatVar ["X1"; "X2"; "X3";]))) let coq_eq_pattern = coq_eq_pattern_gen coq_eq_ref let coq_identity_pattern = coq_eq_pattern_gen coq_identity_ref -let coq_jmeq_pattern = lazy PATTERN [ %coq_jmeq_ref ?X1 ?X2 ?X3 ?X4 ] +(** %coq_jmeq_ref ?X1 ?X2 ?X3 ?X4 *) +let coq_jmeq_pattern = + lazy (mkPattern + (mkGAppRef coq_jmeq_ref (List.map mkGPatVar ["X1"; "X2"; "X3"; "X4"]))) let match_eq eqn eq_pat = let pat = @@ -464,7 +495,8 @@ let find_sigma_data_decompose ex = (* fails with PatternMatchingFailure *) match_sigma ex (* Pattern "(sig ?1 ?2)" *) -let coq_sig_pattern = lazy PATTERN [ %coq_sig_ref ?X1 ?X2 ] +let coq_sig_pattern = + lazy (mkPattern (mkGAppRef coq_sig_ref [mkGPatVar "X1"; mkGPatVar "X2"])) let match_sigma t = match Id.Map.bindings (matches (Lazy.force coq_sig_pattern) t) with @@ -480,17 +512,25 @@ let is_matching_sigma t = is_matching (Lazy.force coq_sig_pattern) t (* Pattern "{<?1>x=y}+{~(<?1>x=y)}" *) (* i.e. "(sumbool (eq ?1 x y) ~(eq ?1 x y))" *) -let coq_eqdec_inf_pattern = - lazy PATTERN [ { ?X2 = ?X3 :> ?X1 } + { ~ ?X2 = ?X3 :> ?X1 } ] +let coq_eqdec ~sum ~rev = + lazy ( + let eqn = mkGAppRef coq_eq_ref (List.map mkGPatVar ["X1"; "X2"; "X3"]) in + let args = [eqn; mkGAppRef coq_not_ref [eqn]] in + let args = if rev then List.rev args else args in + mkPattern (mkGAppRef sum [eqn; mkGAppRef coq_not_ref [eqn]]) + ) + +(** { ?X2 = ?X3 :> ?X1 } + { ~ ?X2 = ?X3 :> ?X1 } *) +let coq_eqdec_inf_pattern = coq_eqdec ~sum:coq_sumbool_ref ~rev:false -let coq_eqdec_inf_rev_pattern = - lazy PATTERN [ { ~ ?X2 = ?X3 :> ?X1 } + { ?X2 = ?X3 :> ?X1 } ] +(** { ~ ?X2 = ?X3 :> ?X1 } + { ?X2 = ?X3 :> ?X1 } *) +let coq_eqdec_inf_rev_pattern = coq_eqdec ~sum:coq_sumbool_ref ~rev:true -let coq_eqdec_pattern = - lazy PATTERN [ %coq_or_ref (?X2 = ?X3 :> ?X1) (~ ?X2 = ?X3 :> ?X1) ] +(** %coq_or_ref (?X2 = ?X3 :> ?X1) (~ ?X2 = ?X3 :> ?X1) *) +let coq_eqdec_pattern = coq_eqdec ~sum:coq_or_ref ~rev:false -let coq_eqdec_rev_pattern = - lazy PATTERN [ %coq_or_ref (~ ?X2 = ?X3 :> ?X1) (?X2 = ?X3 :> ?X1) ] +(** %coq_or_ref (~ ?X2 = ?X3 :> ?X1) (?X2 = ?X3 :> ?X1) *) +let coq_eqdec_rev_pattern = coq_eqdec ~sum:coq_or_ref ~rev:true let op_or = coq_or_ref let op_sum = coq_sumbool_ref @@ -510,8 +550,8 @@ let match_eqdec t = | _ -> anomaly (Pp.str "Unexpected pattern") (* Patterns "~ ?" and "? -> False" *) -let coq_not_pattern = lazy PATTERN [ ~ _ ] -let coq_imp_False_pattern = lazy PATTERN [ _ -> %coq_False_ref ] +let coq_not_pattern = lazy (mkPattern (mkGAppRef coq_not_ref [mkGHole])) +let coq_imp_False_pattern = lazy (mkPattern (mkGArrow mkGHole (mkGRef coq_False_ref))) let is_matching_not t = is_matching (Lazy.force coq_not_pattern) t let is_matching_imp_False t = is_matching (Lazy.force coq_imp_False_pattern) t diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 15e9d3a943..991922d909 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1307,7 +1307,7 @@ let enforce_prop_bound_names rename tac = mkProd (Anonymous,t,aux (push_rel (LocalAssum (Anonymous,t)) env) sigma (i-1) t') | LetIn (na,c,t,t') -> mkLetIn (na,c,t,aux (push_rel (LocalDef (na,c,t)) env) sigma (i-1) t') - | _ -> print_int i; Pp.msg (print_constr t); assert false in + | _ -> print_int i; Feedback.msg_notice (print_constr t); assert false in let rename_branch i = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in @@ -1377,6 +1377,8 @@ let general_elim with_evars clear_flag (c, lbindc) elim = let t = try snd (reduce_to_quantified_ind env sigma ct) with UserError _ -> ct in let elimtac = elimination_clause_scheme with_evars in let indclause = make_clenv_binding env sigma (c, t) lbindc in + let sigma = meta_merge sigma (clear_metas indclause.evd) in + Proofview.Unsafe.tclEVARS sigma <*> Tacticals.New.tclTHEN (general_elim_clause_gen elimtac indclause elim) (apply_clear_request clear_flag (use_clear_hyp_by_default ()) c) @@ -1659,7 +1661,7 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind)) if n<0 then error "Applied theorem has not enough premisses."; let clause = make_clenv_binding_apply env sigma (Some n) (c,thm_ty) lbind in Clenvtac.res_pf clause ~with_evars ~flags - with UserError _ as exn -> + with exn when catchable_exception exn -> Proofview.tclZERO exn in let rec try_red_apply thm_ty (exn0, info) = @@ -2451,9 +2453,10 @@ let intro_patterns_bound_to n destopt = intro_patterns_core true [] [] [] destopt (Some (true,n)) 0 (fun _ l -> clear_wildcards l) -let intro_patterns_to destopt = +let intro_patterns_to destopt l = + (* Eta-expansion because of a side-effect *) intro_patterns_core (use_bracketing_last_or_and_intro_pattern ()) - [] [] [] destopt None 0 (fun _ l -> clear_wildcards l) + [] [] [] destopt None 0 (fun _ l -> clear_wildcards l) l let intro_pattern_to destopt pat = intro_patterns_to destopt [dloc,pat] @@ -2939,7 +2942,7 @@ let expand_hyp id = Tacticals.New.tclTRY (unfold_body id) <*> clear [id] let check_unused_names names = if not (List.is_empty names) && Flags.is_verbose () then - msg_warning + Feedback.msg_warning (str"Unused introduction " ++ str (String.plural (List.length names) "pattern") ++ str": " ++ prlist_with_sep spc (Miscprint.pr_intro_pattern diff --git a/tactics/tactics.mli b/tactics/tactics.mli index df41951c32..fa7b6791ea 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -21,7 +21,10 @@ open Unification open Misctypes open Locus -(** Main tactics. *) +(** Main tactics defined in ML. This file is huge and should probably be split + in more reasonable units at some point. Because of its size and age, the + implementation features various styles and stages of the proof engine. + This has to be uniformized someday. *) (** {6 General functions. } *) diff --git a/test-suite/Makefile b/test-suite/Makefile index 91b8a4ed08..b9c27a2fcf 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -421,7 +421,7 @@ ide : $(patsubst %.fake,%.fake.log,$(wildcard ide/*.fake)) @echo "TEST $<" $(HIDE){ \ echo $(call log_intro,$<); \ - $(BIN)fake_ide $< "$(BIN)coqtop -boot -async-proofs on" 2>&1; \ + $(BIN)fake_ide $< "$(BIN)coqtop -boot -async-proofs on -async-proofs-tactic-error-resiliency off -async-proofs-command-error-resiliency off" 2>&1; \ if [ $$? = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ diff --git a/test-suite/bugs/closed/3649.v b/test-suite/bugs/closed/3649.v index fc60897d21..fc4c171e2c 100644 --- a/test-suite/bugs/closed/3649.v +++ b/test-suite/bugs/closed/3649.v @@ -2,6 +2,7 @@ (* File reduced by coq-bug-finder from original input, then from 9518 lines to 404 lines, then from 410 lines to 208 lines, then from 162 lines to 77 lines *) (* coqc version trunk (September 2014) compiled on Sep 18 2014 21:0:5 with OCaml 4.01.0 coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (07e4438bd758c2ced8caf09a6961ccd77d84e42b) *) +Declare ML Module "coretactics". Reserved Notation "x -> y" (at level 99, right associativity, y at level 200). Reserved Notation "x = y" (at level 70, no associativity). Delimit Scope type_scope with type. diff --git a/test-suite/bugs/closed/4498.v b/test-suite/bugs/closed/4498.v new file mode 100644 index 0000000000..ccdb2dddda --- /dev/null +++ b/test-suite/bugs/closed/4498.v @@ -0,0 +1,24 @@ +Require Export Coq.Unicode.Utf8. +Require Export Coq.Classes.Morphisms. +Require Export Coq.Relations.Relation_Definitions. + +Set Universe Polymorphism. + +Reserved Notation "a ~> b" (at level 90, right associativity). + +Class Category := { + ob : Type; + uhom := Type : Type; + hom : ob → ob → uhom where "a ~> b" := (hom a b); + compose : ∀ {A B C}, (B ~> C) → (A ~> B) → (A ~> C); + equiv : ∀ {A B}, relation (A ~> B); + is_equiv : ∀ {A B}, @Equivalence (A ~> B) equiv; + comp_respects : ∀ {A B C}, + Proper (@equiv B C ==> @equiv A B ==> @equiv A C) (@compose A B C); +}. + +Require Export Coq.Setoids.Setoid. + +Add Parametric Morphism `{C : Category} {A B C} : (@compose _ A B C) with + signature equiv ==> equiv ==> equiv as compose_mor. +Proof. apply comp_respects. Qed.
\ No newline at end of file diff --git a/test-suite/bugs/closed/4628.v b/test-suite/bugs/closed/4628.v new file mode 100644 index 0000000000..7d4a15d689 --- /dev/null +++ b/test-suite/bugs/closed/4628.v @@ -0,0 +1,46 @@ +Module first. + Polymorphic Record BAR (A:Type) := + { foo: A->Prop; bar: forall (x y: A), foo x -> foo y}. + +Section A. +Context {A:Type}. + +Set Printing Universes. + +Hint Resolve bar. +Goal forall (P:BAR A) x y, foo _ P x -> foo _ P y. +intros. +eauto. +Qed. +End A. +End first. + +Module firstbest. + Polymorphic Record BAR (A:Type) := + { foo: A->Prop; bar: forall (x y: A), foo x -> foo y}. + +Section A. +Context {A:Type}. + +Set Printing Universes. + +Polymorphic Hint Resolve bar. +Goal forall (P:BAR A) x y, foo _ P x -> foo _ P y. +intros. +eauto. +Qed. +End A. +End firstbest. + +Module second. +Axiom foo: Set. +Axiom foo': Set. + +Polymorphic Record BAR (A:Type) := + { bar: foo' -> foo}. +Set Printing Universes. + +Lemma baz@{i}: forall (P:BAR@{Set} nat), foo' -> foo. + eauto using bar. +Qed. +End second. diff --git a/test-suite/bugs/closed/4644.v b/test-suite/bugs/closed/4644.v new file mode 100644 index 0000000000..f09b27c2b1 --- /dev/null +++ b/test-suite/bugs/closed/4644.v @@ -0,0 +1,52 @@ +(* Testing a regression of unification in 8.5 in problems of the form + "match ?y with ... end = ?x args" *) + +Lemma foo : exists b, forall a, match a with tt => tt end = b a. +Proof. +eexists. intro. +refine (_ : _ = match _ with tt => _ end). +refine eq_refl. +Qed. + +(**********************************************************************) + +Axiom proof_admitted : False. +Tactic Notation "admit" := case proof_admitted. +Require Export Coq.Classes.Morphisms. +Require Import Coq.Lists.List. + +Global Set Implicit Arguments. + +Definition list_caset A (P : list A -> Type) (N : P nil) (C : forall x xs, P (x::xs)) + ls + : P ls + := match ls with + | nil => N + | x::xs => C x xs + end. + +Axiom list_caset_Proper' + : forall {A P}, + Proper (eq + ==> pointwise_relation _ (pointwise_relation _ eq) + ==> eq + ==> eq) + (@list_caset A (fun _ => P)). +Goal forall (T T' : Set) (a3 : list T), exists y2, forall (a4 : T' -> bool), + match a3 with + | nil => 0 + | (_ :: _)%list => 1 + end = y2 a4. + clear; eexists; intros. + reflexivity. Undo. + Local Ltac t := + lazymatch goal with + | [ |- match ?v with nil => ?N | cons x xs => @?C x xs end = _ :> ?P ] + => let T := type of v in + let A := match (eval hnf in T) with list ?A => A end in + refine (@list_caset_Proper' A P _ _ _ _ _ _ _ _ _ + : @list_caset A (fun _ => P) N C v = match _ with nil => _ | cons x xs => _ end) + end. + (etransitivity; [ t | reflexivity ]) || fail 0 "too early". + Undo. + t. diff --git a/test-suite/bugs/closed/4710.v b/test-suite/bugs/closed/4710.v new file mode 100644 index 0000000000..fdc8501099 --- /dev/null +++ b/test-suite/bugs/closed/4710.v @@ -0,0 +1,12 @@ +Set Primitive Projections. +Record Foo' := Foo { foo : nat }. +Extraction foo. +Record Foo2 (a : nat) := Foo2c { foo2p : nat; foo2b : bool }. +Extraction Language Ocaml. +Extraction foo2p. + +Definition bla (x : Foo2 0) := foo2p _ x. +Extraction bla. + +Definition bla' (a : nat) (x : Foo2 a) := foo2b _ x. +Extraction bla'. diff --git a/test-suite/bugs/closed/4737.v b/test-suite/bugs/closed/4737.v new file mode 100644 index 0000000000..84ed45e454 --- /dev/null +++ b/test-suite/bugs/closed/4737.v @@ -0,0 +1,9 @@ +Goal True. +Proof. +exact I; cycle 1. +Qed. + +Goal True. +Proof. +exact I; swap 1 2. +Qed. diff --git a/test-suite/bugs/closed/4746.v b/test-suite/bugs/closed/4746.v new file mode 100644 index 0000000000..d64cc6fe68 --- /dev/null +++ b/test-suite/bugs/closed/4746.v @@ -0,0 +1,14 @@ +Variables P Q : nat -> Prop. +Variable f : nat -> nat. + +Goal forall (x:nat), (forall y, P y -> forall z, Q z -> y=f z -> False) -> False. +Proof. +intros. +ecase H with (3:=eq_refl). +Abort. + +Goal forall (x:nat), (forall y, y=x -> False) -> False. +Proof. +intros. +unshelve ecase H with (1:=eq_refl). +Qed. diff --git a/test-suite/bugs/closed/4782.v b/test-suite/bugs/closed/4782.v new file mode 100644 index 0000000000..ed44437861 --- /dev/null +++ b/test-suite/bugs/closed/4782.v @@ -0,0 +1,9 @@ +(* About typing of with bindings *) + +Record r : Type := mk_r { type : Type; cond : type -> Prop }. + +Inductive p : Prop := consp : forall (e : r) (x : type e), cond e x -> p. + +Goal p. +Fail apply consp with (fun _ : bool => mk_r unit (fun x => True)) nil. + diff --git a/test-suite/bugs/closed/4787.v b/test-suite/bugs/closed/4787.v new file mode 100644 index 0000000000..b586cba50f --- /dev/null +++ b/test-suite/bugs/closed/4787.v @@ -0,0 +1,9 @@ +(* [Unset Bracketing Last Introduction Pattern] was not working *) + +Unset Bracketing Last Introduction Pattern. + +Goal forall T (x y : T * T), fst x = fst y /\ snd x = snd y -> x = y. +do 10 ((intros [] || intro); simpl); reflexivity. +Qed. + + diff --git a/test-suite/bugs/closed/4813.v b/test-suite/bugs/closed/4813.v new file mode 100644 index 0000000000..5f8ea74c1a --- /dev/null +++ b/test-suite/bugs/closed/4813.v @@ -0,0 +1,9 @@ +(* On the strength of "apply with" (see also #4782) *) + +Record ProverT := { Facts : Type }. +Record ProverT_correct (P : ProverT) := { Valid : Facts P -> Prop ; + Valid_weaken : Valid = Valid }. +Definition reflexivityValid (_ : unit) := True. +Definition reflexivityProver_correct : ProverT_correct {| Facts := unit |}. +Proof. + eapply Build_ProverT_correct with (Valid := reflexivityValid). diff --git a/test-suite/bugs/closed/4816.v b/test-suite/bugs/closed/4816.v new file mode 100644 index 0000000000..86597c88fa --- /dev/null +++ b/test-suite/bugs/closed/4816.v @@ -0,0 +1,17 @@ +Section foo. +Polymorphic Universes A B. +Fail Constraint A <= B. +End foo. +(* gives an anomaly Universe undefined *) + +Universes X Y. +Section Foo. + Polymorphic Universes Z W. + Polymorphic Constraint W < Z. + + Fail Definition bla := Type@{W}. + Polymorphic Definition bla := Type@{W}. + Section Bar. + Fail Constraint X <= Z. + End Bar. +End Foo. diff --git a/test-suite/bugs/opened/4813.v b/test-suite/bugs/opened/4813.v new file mode 100644 index 0000000000..7c65accfea --- /dev/null +++ b/test-suite/bugs/opened/4813.v @@ -0,0 +1,5 @@ +(* An example one would like to see succeeding *) + +Record T := BT { t : Set }. +Record U (x : T) := BU { u : t x -> Prop }. +Definition A (H : unit -> Prop) : U (BT unit) := BU _ H. diff --git a/test-suite/interactive/proof_block.v b/test-suite/interactive/proof_block.v new file mode 100644 index 0000000000..31e3493768 --- /dev/null +++ b/test-suite/interactive/proof_block.v @@ -0,0 +1,66 @@ +Goal False /\ True. +Proof. +split. + idtac. + idtac. + exact I. +idtac. +idtac. +exact I. +Qed. + +Lemma baz : (exists n, n = 3 /\ n = 3) /\ True. +Proof. +split. { eexists. split. par: trivial. } +trivial. +Qed. + +Lemma baz1 : (True /\ False) /\ True. +Proof. +split. { split. par: trivial. } +trivial. +Qed. + +Lemma foo : (exists n, n = 3 /\ n = 3) /\ True. +Proof. +split. + { idtac. + unshelve eexists. + { apply 3. } + { split. + { idtac. trivialx. } + { reflexivity. } } } + trivial. +Qed. + +Lemma foo1 : False /\ True. +Proof. +split. + { exact I. } + { exact I. } +Qed. + +Definition banana := true + 4. + +Check banana. + +Lemma bar : (exists n, n = 3 /\ n = 3) /\ True. +Proof. +split. + - idtac. + unshelve eexists. + + apply 3. + + split. + * idtacx. trivial. + * reflexivity. + - trivial. +Qed. + +Lemma baz2 : ((1=0 /\ False) /\ True) /\ False. +Proof. +split. split. split. + - solve [ auto ]. + - solve [ trivial ]. + - solve [ trivial ]. + - exact 6. +Qed.
\ No newline at end of file diff --git a/test-suite/output/ltac.out b/test-suite/output/ltac.out index 20e274e254..21a8cf9ede 100644 --- a/test-suite/output/ltac.out +++ b/test-suite/output/ltac.out @@ -3,3 +3,22 @@ Error: Ltac variable y depends on pattern variable name z which is not bound in Ltac f x y z := symmetry in x, y; auto with z; auto; intros **; clearbody x; generalize dependent z +The command has indeed failed with message: +In nested Ltac calls to "g1" and "refine", last call failed. +The term "I" has type "True" while it is expected to have type "False". +The command has indeed failed with message: +In nested Ltac calls to "f1" and "refine", last call failed. +The term "I" has type "True" while it is expected to have type "False". +The command has indeed failed with message: +In nested Ltac calls to "g2", "g1" and "refine", last call failed. +The term "I" has type "True" while it is expected to have type "False". +The command has indeed failed with message: +In nested Ltac calls to "f2", "f1" and "refine", last call failed. +The term "I" has type "True" while it is expected to have type "False". +The command has indeed failed with message: +Ltac call to "h" failed. +Error: Ltac variable x is bound to I which cannot be coerced to +a declared or quantified hypothesis. +The command has indeed failed with message: +In nested Ltac calls to "h" and "injection", last call failed. +Error: No primitive equality found. diff --git a/test-suite/output/ltac.v b/test-suite/output/ltac.v index 373b870b9f..dfa60eeda0 100644 --- a/test-suite/output/ltac.v +++ b/test-suite/output/ltac.v @@ -25,3 +25,21 @@ Ltac f x y z := generalize dependent z. Print Ltac f. + +(* Error messages *) + +Ltac g1 x := refine x. +Tactic Notation "g2" constr(x) := g1 x. +Tactic Notation "f1" constr(x) := refine x. +Ltac f2 x := f1 x. +Goal False. +Fail g1 I. +Fail f1 I. +Fail g2 I. +Fail f2 I. + +Ltac h x := injection x. +Goal True -> False. +Fail h I. +intro H. +Fail h H. diff --git a/test-suite/success/coindprim.v b/test-suite/success/coindprim.v index 4e0b7bf5c6..5b9265b6a8 100644 --- a/test-suite/success/coindprim.v +++ b/test-suite/success/coindprim.v @@ -1,36 +1,75 @@ +Require Import Program. + Set Primitive Projections. -CoInductive stream A := { hd : A; tl : stream A }. +CoInductive Stream (A : Type) := mkStream { hd : A; tl : Stream A}. -CoFixpoint ticks : stream unit := - {| hd := tt; tl := ticks |}. +Arguments mkStream [A] hd tl. +Arguments hd [A] s. +Arguments tl [A] s. -Arguments hd [ A ] s. -Arguments tl [ A ] s. +Definition eta {A} (s : Stream A) := {| hd := s.(hd); tl := s.(tl) |}. -CoInductive bisim {A} : stream A -> stream A -> Prop := - | bisims s s' : hd s = hd s' -> bisim (tl s) (tl s') -> bisim s s'. +CoFixpoint ones := {| hd := 1; tl := ones |}. +CoFixpoint ticks := {| hd := tt; tl := ticks |}. -Lemma bisim_refl {A} (s : stream A) : bisim s s. -Proof. - revert s. - cofix aux. intros. constructor. reflexivity. apply aux. -Defined. +CoInductive stream_equiv {A} {s : Stream A} {s' : Stream A} : Prop := + mkStreamEq { hdeq : s.(hd) = s'.(hd); tleq : stream_equiv _ s.(tl) s'.(tl) }. +Arguments stream_equiv {A} s s'. -Lemma constr : forall (A : Type) (s : stream A), - bisim s (Build_stream _ s.(hd) s.(tl)). -Proof. - intros. constructor. reflexivity. simpl. apply bisim_refl. -Defined. +Program CoFixpoint ones_eq : stream_equiv ones ones.(tl) := + {| hdeq := eq_refl; tleq := ones_eq |}. + +CoFixpoint stream_equiv_refl {A} (s : Stream A) : stream_equiv s s := + {| hdeq := eq_refl; tleq := stream_equiv_refl (tl s) |}. + +CoFixpoint stream_equiv_sym {A} (s s' : Stream A) (H : stream_equiv s s') : stream_equiv s' s := + {| hdeq := eq_sym H.(hdeq); tleq := stream_equiv_sym _ _ H.(tleq) |}. + +CoFixpoint stream_equiv_trans {A} {s s' s'' : Stream A} + (H : stream_equiv s s') (H' : stream_equiv s' s'') : stream_equiv s s'' := + {| hdeq := eq_trans H.(hdeq) H'.(hdeq); + tleq := stream_equiv_trans H.(tleq) H'.(tleq) |}. -Lemma constr' : forall (A : Type) (s : stream A), - s = Build_stream _ s.(hd) s.(tl). +Program Definition eta_eq {A} (s : Stream A) : stream_equiv s (eta s):= + {| hdeq := eq_refl; tleq := stream_equiv_refl (tl (eta s))|}. + +Section Parks. + Variable A : Type. + + Variable R : Stream A -> Stream A -> Prop. + Hypothesis bisim1 : forall s1 s2:Stream A, + R s1 s2 -> hd s1 = hd s2. + Hypothesis bisim2 : forall s1 s2:Stream A, + R s1 s2 -> R (tl s1) (tl s2). + CoFixpoint park_ppl : + forall s1 s2:Stream A, R s1 s2 -> stream_equiv s1 s2 := + fun s1 s2 (p : R s1 s2) => + mkStreamEq _ _ _ (bisim1 s1 s2 p) + (park_ppl (tl s1) + (tl s2) + (bisim2 s1 s2 p)). +End Parks. + +Program CoFixpoint iterate {A} (f : A -> A) (x : A) : Stream A := + {| hd := x; tl := iterate f (f x) |}. + +Program CoFixpoint map {A B} (f : A -> B) (s : Stream A) : Stream B := + {| hd := f s.(hd); tl := map f s.(tl) |}. + +Theorem map_iterate A (f : A -> A) (x : A) : stream_equiv (iterate f (f x)) + (map f (iterate f x)). Proof. - intros. - Fail destruct s. -Abort. +apply park_ppl with +(R:= fun s1 s2 => exists x : A, s1 = iterate f (f x) /\ + s2 = map f (iterate f x)). +now intros s1 s2 (x0,(->,->)). +intros s1 s2 (x0,(->,->)). +now exists (f x0). +now exists x. +Qed. -Eval compute in constr _ ticks. +Fail Check (fun A (s : Stream A) => eq_refl : s = eta s). Notation convertible x y := (eq_refl x : x = y). diff --git a/test-suite/success/ltacprof.v b/test-suite/success/ltacprof.v new file mode 100644 index 0000000000..d5552695c4 --- /dev/null +++ b/test-suite/success/ltacprof.v @@ -0,0 +1,8 @@ +(** Some LtacProf tests *) + +Set Ltac Profiling. +Ltac multi := (idtac + idtac). +Goal True. + try (multi; fail). (* Used to result in: Anomaly: Uncaught exception Failure("hd"). Please report. *) +Admitted. +Show Ltac Profile. diff --git a/theories/Compat/Coq84.v b/theories/Compat/Coq84.v index e46a556a98..39bc59a653 100644 --- a/theories/Compat/Coq84.v +++ b/theories/Compat/Coq84.v @@ -7,6 +7,10 @@ (************************************************************************) (** Compatibility file for making Coq act similar to Coq v8.4 *) + +(** Any compatibility changes to make future versions of Coq behave like Coq 8.5 are likely needed to make them behave like Coq 8.4. *) +Require Export Coq.Compat.Coq85. + (** See https://coq.inria.fr/bugs/show_bug.cgi?id=4319 for updates *) (** This is required in Coq 8.5 to use the [omega] tactic; in Coq 8.4, it's automatically available. But ZArith_base puts infix ~ at level 7, and we don't want that, so we don't [Import] it. *) Require Coq.omega.Omega. @@ -56,8 +60,6 @@ Tactic Notation "symmetry" := symmetry. Tactic Notation "split" := split. Tactic Notation "esplit" := esplit. -Global Set Regular Subst Tactic. - (** Many things now import [PeanoNat] rather than [NPeano], so we require it so that the old absolute names in [NPeano.Nat] are available. *) Require Coq.Numbers.Natural.Peano.NPeano. diff --git a/theories/Compat/Coq85.v b/theories/Compat/Coq85.v index af2e04f88b..3fc74943e1 100644 --- a/theories/Compat/Coq85.v +++ b/theories/Compat/Coq85.v @@ -12,5 +12,5 @@ behave as "intros [H|H]" but leave instead hypotheses quantified in the goal, here producing subgoals A->C and B->C. *) -Unset Bracketing Last Introduction Pattern. - +Global Unset Bracketing Last Introduction Pattern. +Global Unset Regular Subst Tactic. diff --git a/theories/MSets/MSetAVL.v b/theories/MSets/MSetAVL.v index cc023cc3f8..a3c265a21f 100644 --- a/theories/MSets/MSetAVL.v +++ b/theories/MSets/MSetAVL.v @@ -417,6 +417,7 @@ Local Open Scope Int_scope. Let's do its job by hand: *) Ltac join_tac := + let l := fresh "l" in intro l; induction l as [| lh ll _ lx lr Hlr]; [ | intros x r; induction r as [| rh rl Hrl rx rr _]; unfold join; [ | destruct ((rh+2) <? lh) eqn:LT; diff --git a/theories/Reals/Ranalysis_reg.v b/theories/Reals/Ranalysis_reg.v index e57af7311f..0c27d407c3 100644 --- a/theories/Reals/Ranalysis_reg.v +++ b/theories/Reals/Ranalysis_reg.v @@ -109,6 +109,7 @@ Ltac intro_hyp_glob trm := | Rabs => idtac | ?X1 => let p := constr:(X1) in + let HYPPD := fresh "HYPPD" in match goal with | _:(derivable p) |- _ => idtac | |- (derivable p) => idtac @@ -250,6 +251,7 @@ Ltac intro_hyp_pt trm pt := end | ?X1 => let p := constr:(X1) in + let HYPPD := fresh "HYPPD" in match goal with | _:(derivable_pt p pt) |- _ => idtac | |- (derivable_pt p pt) => idtac @@ -341,8 +343,10 @@ Ltac is_diff_pt := | _:(derivable_pt ?X1 ?X2) |- (derivable_pt ?X1 ?X2) => assumption | _:(derivable ?X1) |- (derivable_pt ?X1 ?X2) => + let HypDDPT := fresh "HypDDPT" in cut (derivable X1); [ intro HypDDPT; apply HypDDPT | assumption ] | |- (True -> derivable_pt _ _) => + let HypTruE := fresh "HypTruE" in intro HypTruE; clear HypTruE; is_diff_pt | _ => try @@ -411,6 +415,7 @@ Ltac is_diff_glob := apply (derivable_comp X2 X1); is_diff_glob | _:(derivable ?X1) |- (derivable ?X1) => assumption | |- (True -> derivable _) => + let HypTruE := fresh "HypTruE" in intro HypTruE; clear HypTruE; is_diff_glob | _ => try @@ -490,14 +495,17 @@ Ltac is_cont_pt := | _:(continuity_pt ?X1 ?X2) |- (continuity_pt ?X1 ?X2) => assumption | _:(continuity ?X1) |- (continuity_pt ?X1 ?X2) => + let HypDDPT := fresh "HypDDPT" in cut (continuity X1); [ intro HypDDPT; apply HypDDPT | assumption ] | _:(derivable_pt ?X1 ?X2) |- (continuity_pt ?X1 ?X2) => apply derivable_continuous_pt; assumption | _:(derivable ?X1) |- (continuity_pt ?X1 ?X2) => + let HypDDPT := fresh "HypDDPT" in cut (continuity X1); [ intro HypDDPT; apply HypDDPT | apply derivable_continuous; assumption ] | |- (True -> continuity_pt _ _) => + let HypTruE := fresh "HypTruE" in intro HypTruE; clear HypTruE; is_cont_pt | _ => try @@ -567,6 +575,7 @@ Ltac is_cont_glob := apply (continuity_comp X2 X1); try is_cont_glob || assumption | _:(continuity ?X1) |- (continuity ?X1) => assumption | |- (True -> continuity _) => + let HypTruE := fresh "HypTruE" in intro HypTruE; clear HypTruE; is_cont_glob | _:(derivable ?X1) |- (continuity ?X1) => apply derivable_continuous; assumption diff --git a/theories/theories.itarget b/theories/theories.itarget deleted file mode 100644 index aacab2d978..0000000000 --- a/theories/theories.itarget +++ /dev/null @@ -1,25 +0,0 @@ -Arith/vo.otarget -Bool/vo.otarget -Classes/vo.otarget -Compat/vo.otarget -FSets/vo.otarget -MSets/vo.otarget -Structures/vo.otarget -Init/vo.otarget -Lists/vo.otarget -Vectors/vo.otarget -Logic/vo.otarget -PArith/vo.otarget -NArith/vo.otarget -Numbers/vo.otarget -Program/vo.otarget -QArith/vo.otarget -Reals/vo.otarget -Relations/vo.otarget -Setoids/vo.otarget -Sets/vo.otarget -Sorting/vo.otarget -Strings/vo.otarget -Unicode/vo.otarget -Wellfounded/vo.otarget -ZArith/vo.otarget diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index 7b76514e46..45e843e609 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -27,8 +27,9 @@ let rec print_list sep = function | x :: l -> print x; print sep; print_list sep l | [] -> () -let list_iter_i f = - let rec aux i = function [] -> () | a::l -> f i a; aux (i+1) l in aux 1 +let rec print_prefix_list sep = function + | x :: l -> print sep; print x; print_prefix_list sep l + | [] -> () let section s = let l = String.length s in @@ -49,8 +50,9 @@ let section s = let lib_dirs = ["kernel"; "lib"; "library"; "parsing"; "pretyping"; "interp"; "printing"; "intf"; - "proofs"; "tactics"; "tools"; "toplevel"; - "stm"; "grammar"; "config"; "ltac"; "engine"] + "proofs"; "tactics"; "tools"; "ltacprof"; + "toplevel"; "stm"; "grammar"; "config"; + "ltac"; "engine"] let usage () = @@ -103,8 +105,10 @@ let is_genrule r = (* generic rule (like bar%foo: ...) *) Str.string_match genrule r 0 let string_prefix a b = - let rec aux i = try if a.[i] = b.[i] then aux (i+1) else i with |Invalid_argument _ -> i in - String.sub a 0 (aux 0) + let rec aux i = + try if a.[i] = b.[i] then aux (i+1) else i with Invalid_argument _ -> i + in + String.sub a 0 (aux 0) let is_prefix dir1 dir2 = let l1 = String.length dir1 in @@ -119,7 +123,10 @@ let is_prefix dir1 dir2 = let physical_dir_of_logical_dir ldir = let le = String.length ldir - 1 in - let pdir = if le >= 0 && ldir.[le] = '.' then String.sub ldir 0 (le - 1) else String.copy ldir in + let pdir = + if le >= 0 && ldir.[le] = '.' then String.sub ldir 0 (le - 1) + else String.copy ldir + in for i = 0 to le - 1 do if pdir.[i] = '.' then pdir.[i] <- '/'; done; @@ -134,62 +141,74 @@ let standard opt = print "\"\n\n" let classify_files_by_root var files (inc_ml,inc_i,inc_r) = - if not (List.exists (fun (pdir,_,_) -> pdir = ".") inc_r) - && not (List.exists (fun (pdir,_,_) -> pdir = ".") inc_i) then - begin - let absdir_of_files = List.rev_map + if List.exists (fun (pdir,_,_) -> pdir = ".") inc_r + || List.exists (fun (pdir,_,_) -> pdir = ".") inc_i + then () + else + let absdir_of_files =List.rev_map (fun x -> CUnix.canonical_path_name (Filename.dirname x)) - files in - (* files in scope of a -I option (assuming they are no overlapping) *) - let has_inc_i = List.exists (fun (_,a) -> List.mem a absdir_of_files) inc_ml in - if has_inc_i then - begin - printf "%sINC=" var; - List.iter (fun (pdir,absdir) -> - if List.mem absdir absdir_of_files - then printf - "$(filter $(wildcard %s/*),$(%s)) " - pdir var - ) inc_ml; - printf "\n"; - end; - (* Files in the scope of a -R option (assuming they are disjoint) *) - list_iter_i (fun i (pdir,_,abspdir) -> - if List.exists (is_prefix abspdir) absdir_of_files then - printf "%s%d=$(patsubst %s/%%,%%,$(filter %s/%%,$(%s)))\n" - var i pdir pdir var) - (inc_i@inc_r); - end + files + in + (* files in scope of a -I option (assuming they are no overlapping) *) + if List.exists (fun (_,a) -> List.mem a absdir_of_files) inc_ml then + begin + printf "%sINC=" var; + List.iter (fun (pdir,absdir) -> + if List.mem absdir absdir_of_files + then printf "$(filter $(wildcard %s/*),$(%s)) " pdir var) + inc_ml; + printf "\n"; + end; + (* Files in the scope of a -R option (assuming they are disjoint) *) + List.iteri (fun i (pdir,_,abspdir) -> + if List.exists (is_prefix abspdir) absdir_of_files then + printf "%s%d=$(patsubst %s/%%,%%,$(filter %s/%%,$(%s)))\n" + var i pdir pdir var) + (inc_i@inc_r) let vars_to_put_by_root var_x_files_l (inc_ml,inc_i,inc_r) = - let var_x_absdirs_l = List.rev_map - (fun (v,l) -> (v,List.rev_map (fun x -> CUnix.canonical_path_name (Filename.dirname x)) l)) - var_x_files_l in - let var_filter f g = List.fold_left (fun acc (var,dirs) -> - if f dirs - then (g var)::acc else acc) [] var_x_absdirs_l in - (* All files caught by a -R . option (assuming it is the only one) *) + let var_x_absdirs_l = + List.rev_map + (fun (v,l) -> + (v,List.rev_map + (fun x -> CUnix.canonical_path_name (Filename.dirname x)) l)) + var_x_files_l + in + let var_filter f g = + List.fold_left + (fun acc (var,dirs) -> if f dirs then (g var)::acc else acc) + [] var_x_absdirs_l + in + (* All files caught by a -R . option (assuming it is the only one) *) match inc_i@inc_r with - |[(".",t,_)] -> (None,[".",physical_dir_of_logical_dir t,List.rev_map fst var_x_files_l]) + |[(".",t,_)] -> + (None,[".",physical_dir_of_logical_dir t,List.rev_map fst var_x_files_l]) |l -> try let out = List.assoc "." (List.rev_map (fun (p,l,_) -> (p,l)) l) in - let () = prerr_string "Warning: install rule assumes that -R/-Q . _ is the only -R/-Q option\n" in + let () = prerr_string "Warning: install rule assumes that -R/-Q . _ is the only -R/-Q option\n" + in (None,[".",physical_dir_of_logical_dir out,List.rev_map fst var_x_files_l]) with Not_found -> - ( (* vars for -Q options *) - Some (var_filter (fun l -> List.exists (fun (_,a) -> List.mem a l) inc_ml) (fun x -> x)), + let varq = var_filter + (fun l -> List.exists (fun (_,a) -> List.mem a l) inc_ml) + (fun x -> x) + in (* (physical dir, physical dir of logical path,vars) for -R options (assuming physical dirs are disjoint) *) - if l = [] then - [".","$(INSTALLDEFAULTROOT)",[]] - else - Util.List.fold_left_i (fun i out (pdir,ldir,abspdir) -> - let vars_r = var_filter (List.exists (is_prefix abspdir)) (fun x -> x^string_of_int i) in - let pdir' = physical_dir_of_logical_dir ldir in - (pdir,pdir',vars_r)::out) 1 [] l - ) + let other = + if l = [] then + [".","$(INSTALLDEFAULTROOT)",[]] + else + Util.List.fold_left_i (fun i out (pdir,ldir,abspdir) -> + let vars_r = var_filter + (List.exists (is_prefix abspdir)) + (fun x -> x^string_of_int i) + in + let pdir' = physical_dir_of_logical_dir ldir in + (pdir,pdir',vars_r)::out) 1 [] l + in (Some varq, other) let install_include_by_root perms = let install_dir for_i (pdir,pdir',vars) = @@ -265,33 +284,38 @@ let where_put_doc = function install-doc will put anything in $INSTALLDEFAULTROOT\n" in "$(INSTALLDEFAULTROOT)" -let install (vfiles,(mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles),_,sds) inc = function +let install (vfiles,(mlis,ml4s,mls,mllibs,mlpacks),_,sds) inc = function |Project_file.NoInstall -> () |is_install -> let not_empty = function |[] -> false |_::_ -> true in - let cmofiles = List.rev_append mlpackfiles (List.rev_append mlfiles ml4files) in - let cmifiles = List.rev_append mlifiles cmofiles in - let cmxsfiles = List.rev_append cmofiles mllibfiles in - let where_what_cmxs = vars_to_put_by_root [("CMXSFILES",cmxsfiles)] inc in + let cmos = List.rev_append mlpacks (List.rev_append mls ml4s) in + let cmis = List.rev_append mlis cmos in + let cmxss = List.rev_append cmos mllibs in + let where_what_cmxs = vars_to_put_by_root [("CMXSFILES",cmxss)] inc in let where_what_oth = vars_to_put_by_root - [("VOFILES",vfiles);("VFILES",vfiles);("GLOBFILES",vfiles);("NATIVEFILES",vfiles);("CMOFILES",cmofiles);("CMIFILES",cmifiles);("CMAFILES",mllibfiles)] + [("VOFILES",vfiles);("VFILES",vfiles); + ("GLOBFILES",vfiles);("NATIVEFILES",vfiles); + ("CMOFILES",cmos);("CMIFILES",cmis);("CMAFILES",mllibs)] inc in let doc_dir = where_put_doc inc in - let () = if is_install = Project_file.UnspecInstall then - print "userinstall:\n\t+$(MAKE) USERINSTALL=true install\n\n" in - if (not_empty cmxsfiles) then begin + if is_install = Project_file.UnspecInstall then begin + print "userinstall:\n\t+$(MAKE) USERINSTALL=true install\n\n" + end; + if not_empty cmxss then begin print "install-natdynlink:\n"; install_include_by_root "0755" where_what_cmxs; print "\n"; end; - if (not_empty cmxsfiles) then begin + if not_empty cmxss then begin print "install-toploop: $(MLLIBFILES:.mllib=.cmxs)\n"; printf "\t install -d \"$(DSTROOT)\"$(COQTOPINSTALL)/\n"; printf "\t install -m 0755 $? \"$(DSTROOT)\"$(COQTOPINSTALL)/\n"; print "\n"; end; print "install:"; - if (not_empty cmxsfiles) then print "$(if $(HASNATDYNLINK_OR_EMPTY),install-natdynlink)"; + if not_empty cmxss then begin + print "$(if $(HASNATDYNLINK_OR_EMPTY),install-natdynlink)"; + end; print "\n"; install_include_by_root "0644" where_what_oth; List.iter @@ -306,7 +330,7 @@ let install (vfiles,(mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles),_,sds) in print "\tdone\n" in print "install-doc:\n"; if not_empty vfiles then install_one_kind "html" doc_dir; - if not_empty mlifiles then install_one_kind "mlihtml" doc_dir; + if not_empty mlis then install_one_kind "mlihtml" doc_dir; print "\n"; let uninstall_one_kind kind dir = printf "\tprintf 'cd \"$${DSTROOT}\"$(COQDOCINSTALL)/%s \\\\\\n' >> \"$@\"\n" dir; @@ -316,10 +340,10 @@ let install (vfiles,(mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles),_,sds) in in printf "uninstall_me.sh: %s\n" !makefile_name; print "\techo '#!/bin/sh' > $@\n"; - if (not_empty cmxsfiles) then uninstall_by_root where_what_cmxs; + if not_empty cmxss then uninstall_by_root where_what_cmxs; uninstall_by_root where_what_oth; if not_empty vfiles then uninstall_one_kind "html" doc_dir; - if not_empty mlifiles then uninstall_one_kind "mlihtml" doc_dir; + if not_empty mlis then uninstall_one_kind "mlihtml" doc_dir; print "\tchmod +x $@\n"; print "\n"; print "uninstall: uninstall_me.sh\n"; @@ -338,11 +362,14 @@ let make_makefile sds = let clean sds sps = print "clean::\n"; - if !some_mlfile || !some_mlifile || !some_ml4file || !some_mllibfile || !some_mlpackfile then begin - print "\trm -f $(ALLCMOFILES) $(CMIFILES) $(CMAFILES)\n"; - print "\trm -f $(ALLCMOFILES:.cmo=.cmx) $(CMXAFILES) $(CMXSFILES) $(ALLCMOFILES:.cmo=.o) $(CMXAFILES:.cmxa=.a)\n"; - print "\trm -f $(addsuffix .d,$(MLFILES) $(MLIFILES) $(ML4FILES) $(MLLIBFILES) $(MLPACKFILES))\n"; - end; + if !some_mlfile || !some_mlifile || !some_ml4file + || !some_mllibfile || !some_mlpackfile + then + begin + print "\trm -f $(ALLCMOFILES) $(CMIFILES) $(CMAFILES)\n"; + print "\trm -f $(ALLCMOFILES:.cmo=.cmx) $(CMXAFILES) $(CMXSFILES) $(ALLCMOFILES:.cmo=.o) $(CMXAFILES:.cmxa=.a)\n"; + print "\trm -f $(addsuffix .d,$(MLFILES) $(MLIFILES) $(ML4FILES) $(MLLIBFILES) $(MLPACKFILES))\n"; + end; if !some_vfile then begin print "\trm -f $(OBJFILES) $(OBJFILES:.o=.native) $(NATIVEFILES)\n"; @@ -379,38 +406,67 @@ let header_includes () = () let implicit () = section "Implicit rules."; let mli_rules () = - print "$(MLIFILES:.mli=.cmi): %.cmi: %.mli\n\t$(CAMLC) $(ZDEBUG) $(ZFLAGS) $<\n\n"; + print "$(MLIFILES:.mli=.cmi): %.cmi: %.mli\n"; + print "\t$(SHOW)'CAMLC -c $<'\n"; + print "\t$(HIDE)$(CAMLC) $(ZDEBUG) $(ZFLAGS) $<\n\n"; print "$(addsuffix .d,$(MLIFILES)): %.mli.d: %.mli\n"; - print "\t$(OCAMLFIND) ocamldep -slash $(OCAMLLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in + print "\t$(SHOW)'CAMLDEP $<'\n"; + print "\t$(HIDE)$(CAMLDEP) $(OCAMLLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" + in let ml4_rules () = - print "$(ML4FILES:.ml4=.cmo): %.cmo: %.ml4\n\t$(CAMLC) $(ZDEBUG) $(ZFLAGS) $(PP) -impl $<\n\n"; + print "$(ML4FILES:.ml4=.cmo): %.cmo: %.ml4\n"; + print "\t$(SHOW)'CAMLC -pp -c $<'\n"; + print "\t$(HIDE)$(CAMLC) $(ZDEBUG) $(ZFLAGS) $(PP) -impl $<\n\n"; print "$(filter-out $(addsuffix .cmx,$(foreach lib,$(MLPACKFILES:.mlpack=_MLPACK_DEPENDENCIES),$($(lib)))),$(ML4FILES:.ml4=.cmx)): %.cmx: %.ml4\n"; - print "\t$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $(PP) -impl $<\n\n"; + print "\t$(SHOW)'CAMLOPT -pp -c $<'\n"; + print "\t$(HIDE)$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $(PP) -impl $<\n\n"; print "$(addsuffix .d,$(ML4FILES)): %.ml4.d: %.ml4\n"; - print "\t$(OCAMLFIND) ocamldep -slash $(OCAMLLIBS) $(PP) -impl \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in + print "\t$(SHOW)'CAMLDEP -pp $<'\n"; + print "\t$(HIDE)$(CAMLDEP) $(OCAMLLIBS) $(PP) -impl \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in let ml_rules () = - print "$(MLFILES:.ml=.cmo): %.cmo: %.ml\n\t$(CAMLC) $(ZDEBUG) $(ZFLAGS) $<\n\n"; + print "$(MLFILES:.ml=.cmo): %.cmo: %.ml\n"; + print "\t$(SHOW)'CAMLC -c $<'\n"; + print "\t$(HIDE)$(CAMLC) $(ZDEBUG) $(ZFLAGS) $<\n\n"; print "$(filter-out $(addsuffix .cmx,$(foreach lib,$(MLPACKFILES:.mlpack=_MLPACK_DEPENDENCIES),$($(lib)))),$(MLFILES:.ml=.cmx)): %.cmx: %.ml\n"; - print "\t$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $<\n\n"; + print "\t$(SHOW)'CAMLOPT -c $<'\n"; + print "\t$(HIDE)$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) $<\n\n"; print "$(addsuffix .d,$(MLFILES)): %.ml.d: %.ml\n"; - print "\t$(OCAMLFIND) ocamldep -slash $(OCAMLLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in + print "\t$(SHOW)'CAMLDEP $<'\n"; + print "\t$(HIDE)$(CAMLDEP) $(OCAMLLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in let cmxs_rules () = (* order is important here when there is foo.ml and foo.mllib *) - print "$(filter-out $(MLLIBFILES:.mllib=.cmxs),$(MLFILES:.ml=.cmxs) $(ML4FILES:.ml4=.cmxs) $(MLPACKFILES:.mlpack=.cmxs)): %.cmxs: %.cmx -\t$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -shared -o $@ $<\n\n"; - print "$(MLLIBFILES:.mllib=.cmxs): %.cmxs: %.cmxa\n\t$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -linkall -shared -o $@ $<\n\n" in + print "$(filter-out $(MLLIBFILES:.mllib=.cmxs),$(MLFILES:.ml=.cmxs) $(ML4FILES:.ml4=.cmxs) $(MLPACKFILES:.mlpack=.cmxs)): %.cmxs: %.cmx\n"; + print "\t$(SHOW)'CAMLOPT -shared -o $@'\n"; + print "\t$(HIDE)$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -shared -o $@ $<\n\n"; + print "$(MLLIBFILES:.mllib=.cmxs): %.cmxs: %.cmxa\n"; + print "\t$(SHOW)'CAMLOPT -shared -o $@'\n"; + print "\t$(HIDE)$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -linkall -shared -o $@ $<\n\n" + in let mllib_rules () = - print "$(MLLIBFILES:.mllib=.cma): %.cma: | %.mllib\n\t$(CAMLLINK) $(ZDEBUG) $(ZFLAGS) -a -o $@ $^\n\n"; - print "$(MLLIBFILES:.mllib=.cmxa): %.cmxa: | %.mllib\n\t$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -a -o $@ $^\n\n"; + print "$(MLLIBFILES:.mllib=.cma): %.cma: | %.mllib\n"; + print "\t$(SHOW)'CAMLC -a -o $@'\n"; + print "\t$(HIDE)$(CAMLLINK) $(ZDEBUG) $(ZFLAGS) -a -o $@ $^\n\n"; + print "$(MLLIBFILES:.mllib=.cmxa): %.cmxa: | %.mllib\n"; + print "\t$(SHOW)'CAMLOPT -a -o $@'\n"; + print "\t$(HIDE)$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -a -o $@ $^\n\n"; print "$(addsuffix .d,$(MLLIBFILES)): %.mllib.d: %.mllib\n"; - print "\t$(COQDEP) $(OCAMLLIBS) -c \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in + print "\t$(SHOW)'COQDEP $<'\n"; + print "\t$(HIDE)$(COQDEP) $(OCAMLLIBS) -c \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" + in let mlpack_rules () = - print "$(MLPACKFILES:.mlpack=.cmo): %.cmo: | %.mlpack\n\t$(CAMLLINK) $(ZDEBUG) $(ZFLAGS) -pack -o $@ $^\n\n"; - print "$(MLPACKFILES:.mlpack=.cmx): %.cmx: | %.mlpack\n\t$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -pack -o $@ $^\n\n"; + print "$(MLPACKFILES:.mlpack=.cmo): %.cmo: | %.mlpack\n"; + print "\t$(SHOW)'CAMLC -pack -o $@'\n"; + print "\t$(HIDE)$(CAMLLINK) $(ZDEBUG) $(ZFLAGS) -pack -o $@ $^\n\n"; + print "$(MLPACKFILES:.mlpack=.cmx): %.cmx: | %.mlpack\n"; + print "\t$(SHOW)'CAMLOPT -pack -o $@'\n"; + print "\t$(HIDE)$(CAMLOPTLINK) $(ZDEBUG) $(ZFLAGS) -pack -o $@ $^\n\n"; print "$(addsuffix .d,$(MLPACKFILES)): %.mlpack.d: %.mlpack\n"; - print "\t$(COQDEP) $(OCAMLLIBS) -c \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n"; -in + print "\t$(SHOW)'COQDEP $<'\n"; + print "\t$(HIDE)$(COQDEP) $(OCAMLLIBS) -c \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" + in let v_rules () = - print "$(VOFILES): %.vo: %.v\n\t$(COQC) $(COQDEBUG) $(COQFLAGS) $*\n\n"; + print "$(VOFILES): %.vo: %.v\n"; + print "\t$(SHOW)COQC $*\n"; + print "\t$(HIDE)$(COQC) $(COQDEBUG) $(COQFLAGS) $*\n\n"; print "$(GLOBFILES): %.glob: %.v\n\t$(COQC) $(COQDEBUG) $(COQFLAGS) $*\n\n"; print "$(VFILES:.v=.vio): %.vio: %.v\n\t$(COQC) -quick $(COQDEBUG) $(COQFLAGS) $*\n\n"; print "$(GFILES): %.g: %.v\n\t$(GALLINA) $<\n\n"; @@ -419,7 +475,8 @@ in print "$(VFILES:.v=.g.tex): %.g.tex: %.v\n\t$(COQDOC) $(COQDOCFLAGS) -latex -g $< -o $@\n\n"; print "$(GHTMLFILES): %.g.html: %.v %.glob\n\t$(COQDOC) $(COQDOCFLAGS) -html -g $< -o $@\n\n"; print "$(addsuffix .d,$(VFILES)): %.v.d: %.v\n"; - print "\t$(COQDEP) $(COQLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n"; + print "\t$(SHOW)'COQDEP $<'\n"; + print "\t$(HIDE)$(COQDEP) $(COQLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n"; print "$(addsuffix .beautified,$(VFILES)): %.v.beautified:\n\t$(COQC) $(COQDEBUG) $(COQFLAGS) -beautify $*\n\n" in if !some_mlifile then mli_rules (); @@ -471,6 +528,7 @@ let variables is_install opt (args,defs) = print "CAMLOPTC?=$(OCAMLFIND) opt -c -rectypes -thread\n"; print "CAMLLINK?=$(OCAMLFIND) ocamlc -rectypes -thread\n"; print "CAMLOPTLINK?=$(OCAMLFIND) opt -rectypes -thread\n"; + print "CAMLDEP?=$(OCAMLFIND) ocamldep -slash -ml-synonym .ml4 -ml-synonym .mlpack\n"; print "CAMLLIB?=$(shell $(OCAMLFIND) printconf stdlib)\n"; print "GRAMMARS?=grammar.cma\n"; print "ifeq ($(CAMLP4),camlp5) @@ -515,7 +573,11 @@ let parameters () = print "# TIMECMD set a command to log .v compilation time;\n"; print "# TIMED if non empty, use the default time command as TIMECMD;\n"; print "# ZDEBUG/COQDEBUG to specify debug flags for ocamlc&ocamlopt/coqc;\n"; - print "# DSTROOT to specify a prefix to install path.\n\n"; + print "# DSTROOT to specify a prefix to install path.\n"; + print "# VERBOSE to disable the short display of compilation rules.\n\n"; + print "VERBOSE?=\n"; + print "SHOW := $(if $(VERBOSE),@true \"\",@echo \"\")\n"; + print "HIDE := $(if $(VERBOSE),,@)\n\n"; print "# Here is a hack to make $(eval $(shell works:\n"; print "define donewline\n\n\nendef\n"; print "includecmdwithout@ = $(eval $(subst @,$(donewline),$(shell { $(1) | tr -d '\\r' | tr '\\n' '@'; })))\n"; @@ -526,28 +588,35 @@ let parameters () = print " $(filter-out Warning: Error:,\\\n"; print " $(shell $(COQBIN)coqtop -q -noinit -batch -quiet -print-mod-uid $(1))))\n\n" -let include_dirs (inc_ml,inc_i,inc_r) = +let include_dirs (inc_ml,inc_q,inc_r) = let parse_ml_includes l = List.map (fun (x,_) -> "-I \"" ^ x ^ "\"") l in - let parse_includes l = List.map (fun (x,l,_) -> - let l' = if l = "" then "\"\"" else l in - "-Q \"" ^ x ^ "\" " ^ l' ^"") l in - let parse_rec_includes l = List.map (fun (p,l,_) -> - let l' = if l = "" then "\"\"" else l in - "-R \"" ^ p ^ "\" " ^ l' ^"") l in + let includes = + List.map (fun (p,l,_) -> + let l' = if l = "" then "\"\"" else l in + " \"" ^ p ^ "\" " ^ l' ^"") in let str_ml = parse_ml_includes inc_ml in - let str_i = parse_includes inc_i in - let str_r = parse_rec_includes inc_r in - section "Libraries definitions."; - if !some_ml4file || !some_mlfile || !some_mlifile then begin - print "OCAMLLIBS?="; print_list "\\\n " str_ml; print "\n"; - end; - if !some_vfile || !some_mllibfile || !some_mlpackfile then begin - print "COQLIBS?="; print_list "\\\n " str_i; - List.iter (fun x -> print "\\\n "; print x) str_r; - List.iter (fun x -> print "\\\n "; print x) str_ml; print "\n"; - print "COQDOCLIBS?="; print_list "\\\n " str_i; - List.iter (fun x -> print "\\\n "; print x) str_r; print "\n\n"; - end + section "Libraries definitions."; + if !some_ml4file || !some_mlfile || !some_mlifile then begin + print "OCAMLLIBS?="; print_list "\\\n " str_ml; print "\n"; + end; + if !some_vfile || !some_mllibfile || !some_mlpackfile then begin + print "COQLIBS?="; + print_prefix_list "\\\n -Q" (includes inc_q); + print_prefix_list "\\\n -R" (includes inc_r); + print_prefix_list "\\\n " str_ml; + print "\n"; + end; + if !some_vfile then begin + print "COQCHKLIBS?="; + print_prefix_list "\\\n -R" (includes inc_q); + print_prefix_list "\\\n -R" (includes inc_r); + print "\n"; + print "COQDOCLIBS?="; + print_prefix_list "\\\n -R" (includes inc_q); + print_prefix_list "\\\n -R" (includes inc_r); + print "\n"; + end; + print "\n" let double_colon = ["clean"; "cleanall"; "archclean"] @@ -578,10 +647,13 @@ let forpacks l = let () = if l <> [] then section "Ad-hoc implicit rules for mlpack." in List.iter (fun it -> let h = Filename.chop_extension it in + let pk = String.capitalize (Filename.basename h) in printf "$(addsuffix .cmx,$(filter $(basename $(MLFILES)),$(%s_MLPACK_DEPENDENCIES))): %%.cmx: %%.ml\n" h; - printf "\t$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) -for-pack %s $<\n\n" (String.capitalize (Filename.basename h)); + printf "\t$(SHOW)'CAMLOPT -c -for-pack %s $<'\n" pk; + printf "\t$(HIDE)$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) -for-pack %s $<\n\n" pk; printf "$(addsuffix .cmx,$(filter $(basename $(ML4FILES)),$(%s_MLPACK_DEPENDENCIES))): %%.cmx: %%.ml4\n" h; - printf "\t$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) -for-pack %s $(PP) -impl $<\n\n" (String.capitalize (Filename.basename h)) + printf "\t$(SHOW)'CAMLOPT -c -pp -for-pack %s $<'\n" pk; + printf "\t$(HIDE)$(CAMLOPTC) $(ZDEBUG) $(ZFLAGS) -for-pack %s $(PP) -impl $<\n\n" pk ) l let main_targets vfiles (mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles) other_targets inc = @@ -720,7 +792,7 @@ let main_targets vfiles (mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles) other print "all-gal.pdf: $(VFILES)\n"; print "\t$(COQDOC) -toc $(COQDOCFLAGS) -pdf -g $(COQDOCLIBS) -o $@ `$(COQDEP) -sort -suffix .v $^`\n\n"; print "validate: $(VOFILES)\n"; - print "\t$(COQCHK) $(COQCHKFLAGS) $(COQLIBS) $(notdir $(^:.vo=))\n\n"; + print "\t$(COQCHK) $(COQCHKFLAGS) $(COQCHKLIBS) $(notdir $(^:.vo=))\n\n"; print "beautify: $(VFILES:=.beautified)\n"; print "\tfor file in $^; do mv $${file%.beautified} $${file%beautified}old && mv $${file} $${file%.beautified}; done\n"; print "\t@echo \'Do not do \"make clean\" until you are sure that everything went well!\'\n"; @@ -773,22 +845,24 @@ let command_line args = print_list args; print "\n#\n\n" -let ensure_root_dir (v,(mli,ml4,ml,mllib,mlpack),_,_) ((ml_inc,i_inc,r_inc) as l) = +let ensure_root_dir (vfiles,(mlis,ml4s,mls,mllibs,mlpacks),_,_) inc = + let (ml_inc,i_inc,r_inc) = inc in let here = Sys.getcwd () in - let not_tops =List.for_all (fun s -> s <> Filename.basename s) in + let not_tops = List.for_all (fun s -> s <> Filename.basename s) in if List.exists (fun (_,_,x) -> x = here) i_inc || List.exists (fun (_,_,x) -> is_prefix x here) r_inc - || (not_tops v && not_tops mli && not_tops ml4 && not_tops ml - && not_tops mllib && not_tops mlpack) then - l + || (not_tops vfiles && not_tops mlis && not_tops ml4s && not_tops mls + && not_tops mllibs && not_tops mlpacks) + then + inc else ((".",here)::ml_inc,i_inc,(".","Top",here)::r_inc) -let warn_install_at_root_directory - (vfiles,(mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles),_,_) (inc_ml,inc_i,inc_r) = +let warn_install_at_root_directory (vfiles,(mlis,ml4s,mls,mllibs,mlpacks),_,_) inc = + let (inc_ml,inc_i,inc_r) = inc in let inc_top = List.filter (fun (_,ldir,_) -> ldir = "") (inc_r@inc_i) in let inc_top_p = List.map (fun (p,_,_) -> p) inc_top in - let files = vfiles @ mlifiles @ ml4files @ mlfiles @ mllibfiles @ mlpackfiles in + let files = vfiles @ mlis @ ml4s @ mls @ mllibs @ mlpacks in if List.exists (fun f -> List.mem (Filename.dirname f) inc_top_p) files then Printf.eprintf "Warning: install target will copy files at the first level of the coq contributions installation directory; option -R or -Q %sis recommended\n" @@ -826,7 +900,9 @@ let do_makefile args = |[] -> var := false |_::_ -> var := true in let (project_file,makefile,is_install,opt),l = - try Project_file.process_cmd_line Filename.current_dir_name (None,None,Project_file.UnspecInstall,true) [] args + try + Project_file.process_cmd_line Filename.current_dir_name + (None,None,Project_file.UnspecInstall,true) [] args with Project_file.Parsing_error -> usage () in let (v_f,(mli_f,ml4_f,ml_f,mllib_f,mlpack_f),sps,sds as targets), inc, defs = Project_file.split_arguments l in @@ -850,7 +926,9 @@ let do_makefile args = List.iter check_dep (Str.split (Str.regexp "[ \t]+") dependencies)) sps; let inc = ensure_root_dir targets inc in - if is_install <> Project_file.NoInstall then warn_install_at_root_directory targets inc; + if is_install <> Project_file.NoInstall then begin + warn_install_at_root_directory targets inc; + end; check_overlapping_include inc; banner (); header_includes (); diff --git a/tools/coqc.ml b/tools/coqc.ml index d4f1447b17..ecbbfefac6 100644 --- a/tools/coqc.ml +++ b/tools/coqc.ml @@ -88,7 +88,7 @@ let parse_args () = (* Options for coqtop : a) options with 0 argument *) - | ("-notactics"|"-bt"|"-debug"|"-nolib"|"-boot"|"-time" + | ("-notactics"|"-bt"|"-debug"|"-nolib"|"-boot"|"-time"|"-profile-ltac" |"-batch"|"-noinit"|"-nois"|"-noglob"|"-no-glob" |"-q"|"-full"|"-profile"|"-just-parsing"|"-echo" |"-unsafe"|"-quiet" |"-silent"|"-m"|"-xml"|"-v7"|"-v8"|"-beautify"|"-strict-implicit" diff --git a/tools/coqdep.ml b/tools/coqdep.ml index 13705edaaa..9886b263cb 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -502,7 +502,7 @@ let coqdep () = let user = coqlib//"user-contrib" in if Sys.file_exists user then add_rec_dir_no_import add_coqlib_known user []; List.iter (fun s -> add_rec_dir_no_import add_coqlib_known s []) - (Envars.xdg_dirs (fun x -> Pp.msg_warning (Pp.str x))); + (Envars.xdg_dirs (fun x -> Feedback.msg_warning (Pp.str x))); List.iter (fun s -> add_rec_dir_no_import add_coqlib_known s []) Envars.coqpath; end; List.iter (fun (f,d) -> add_mli_known f d ".mli") !mliAccu; @@ -527,4 +527,4 @@ let _ = coqdep () with Errors.UserError(s,p) -> let pp = if s <> "_" then Pp.(str s ++ str ": " ++ p) else p in - Pp.msgerrnl pp + Feedback.msg_error pp diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml index c63e4aaa64..0f7937d729 100644 --- a/tools/coqdep_common.ml +++ b/tools/coqdep_common.ml @@ -9,11 +9,11 @@ open Printf open Coqdep_lexer open Unix -open System +open Minisys (** [coqdep_boot] is a stripped-down version of [coqdep], whose behavior is the one of [coqdep -boot]. Its only dependencies - are [Coqdep_lexer] and [Unix], and it should stay so. + are [Coqdep_lexer], [Unix] and [Minisys], and it should stay so. If it need someday some additional information, pass it via options (see for instance [option_natdynlk] below). *) @@ -526,7 +526,7 @@ let rec add_directory recur add_file phys_dir log_dir = | FileRegular f -> add_file phys_dir log_dir f in - System.check_unix_dir (fun s -> eprintf "*** Warning: %s\n" s) phys_dir; + 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/coqdoc/cpretty.mll b/tools/coqdoc/cpretty.mll index 81c01f29d8..005ffdae72 100644 --- a/tools/coqdoc/cpretty.mll +++ b/tools/coqdoc/cpretty.mll @@ -239,6 +239,12 @@ let s = String.sub s isp (String.length s - isp) in Output.keyword s (lexeme_start lexbuf + isp) + let only_gallina () = + !Cdglobals.gallina && !in_proof <> None + + let parse_comments () = + !Cdglobals.parse_comments && not (only_gallina ()) + } (*s Regular expressions *) @@ -480,7 +486,7 @@ rule coq_bol = parse in if eol then coq_bol lexbuf else coq lexbuf } | space* end_kw { let eol = - if not (!in_proof <> None && !Cdglobals.gallina) then + if not (only_gallina ()) then begin backtrack lexbuf; body_bol lexbuf end else skip_to_dot lexbuf in @@ -529,14 +535,15 @@ rule coq_bol = parse coq_bol lexbuf } | space* "(*" { comment_level := 1; - if !Cdglobals.parse_comments then begin - let s = lexeme lexbuf in - let nbsp,isp = count_spaces s in - Output.indentation nbsp; - Output.start_comment (); - end; - let eol = comment lexbuf in - if eol then coq_bol lexbuf else coq lexbuf } + let eol = + if parse_comments () then begin + let s = lexeme lexbuf in + let nbsp, isp = count_spaces s in + Output.indentation nbsp; + Output.start_comment (); + comment lexbuf + end else skipped_comment lexbuf in + if eol then coq_bol lexbuf else coq lexbuf } | eof { () } | _ @@ -544,7 +551,7 @@ rule coq_bol = parse if not !Cdglobals.gallina then begin backtrack lexbuf; body_bol lexbuf end else - skip_to_dot lexbuf + skip_to_dot_or_brace lexbuf in if eol then coq_bol lexbuf else coq lexbuf } @@ -552,7 +559,7 @@ rule coq_bol = parse and coq = parse | nl - { if not (!in_proof <> None && !Cdglobals.gallina) then Output.line_break(); coq_bol lexbuf } + { if not (only_gallina ()) then Output.line_break(); coq_bol lexbuf } | "(**" space_nl { Output.end_coq (); Output.start_doc (); let eol = doc_bol lexbuf in @@ -560,16 +567,12 @@ and coq = parse if eol then coq_bol lexbuf else coq lexbuf } | "(*" { comment_level := 1; - if !Cdglobals.parse_comments then begin - let s = lexeme lexbuf in - let nbsp,isp = count_spaces s in - Output.indentation nbsp; - Output.start_comment (); - end; - let eol = comment lexbuf in - if eol then coq_bol lexbuf - else coq lexbuf - } + let eol = + if parse_comments () then begin + Output.start_comment (); + comment lexbuf + end else skipped_comment lexbuf in + if eol then coq_bol lexbuf else coq lexbuf } | nl+ space* "]]" { if not !formatted then begin @@ -644,7 +647,7 @@ and coq = parse if not !Cdglobals.gallina then begin backtrack lexbuf; body lexbuf end else - skip_to_dot lexbuf + skip_to_dot_or_brace lexbuf in if eol then coq_bol lexbuf else coq lexbuf} @@ -814,9 +817,10 @@ and doc indents = parse | Some is -> doc_list_bol is | None -> doc_bol in - let eol = comment lexbuf in - if eol then bol_parse lexbuf else doc indents lexbuf - } + let eol = + if !Cdglobals.parse_comments then comment lexbuf + else skipped_comment lexbuf in + if eol then bol_parse lexbuf else doc indents lexbuf } | '*'* "*)" space_nl* "(**" {(match indents with | Some _ -> Output.stop_item () @@ -935,7 +939,9 @@ and escaped_coq = parse Output.sublexer_in_doc '['; escaped_coq lexbuf } | "(*" { Tokens.flush_sublexer (); comment_level := 1; - ignore (comment lexbuf); escaped_coq lexbuf } + ignore (if !Cdglobals.parse_comments then comment lexbuf + else skipped_comment lexbuf); + escaped_coq lexbuf } | "*)" { (* likely to be a syntax error: we escape *) backtrack lexbuf } | eof @@ -975,76 +981,101 @@ and comments = parse | _ { Output.char (lexeme_char lexbuf 0); comments lexbuf } -(*s Skip comments *) +and skipped_comment = parse + | "(*" + { incr comment_level; + skipped_comment lexbuf } + | "*)" space* nl + { decr comment_level; + if !comment_level > 0 then skipped_comment lexbuf else true } + | "*)" + { decr comment_level; + if !comment_level > 0 then skipped_comment lexbuf else false } + | eof { false } + | _ { skipped_comment lexbuf } and comment = parse - | "(*" { incr comment_level; - if !Cdglobals.parse_comments then Output.start_comment (); - comment lexbuf } - | "*)" space* nl { - if !Cdglobals.parse_comments then - (Output.end_comment (); Output.line_break ()); - decr comment_level; if !comment_level > 0 then comment lexbuf else true } - | "*)" { - if !Cdglobals.parse_comments then (Output.end_comment ()); - decr comment_level; if !comment_level > 0 then comment lexbuf else false } - | "[" { - if !Cdglobals.parse_comments then - if !Cdglobals.plain_comments then Output.char '[' + | "(*" + { incr comment_level; + Output.start_comment (); + comment lexbuf } + | "*)" space* nl + { Output.end_comment (); + Output.line_break (); + decr comment_level; + if !comment_level > 0 then comment lexbuf else true } + | "*)" + { Output.end_comment (); + decr comment_level; + if !comment_level > 0 then comment lexbuf else false } + | "[" + { if !Cdglobals.plain_comments then Output.char '[' else (brackets := 1; Output.start_inline_coq (); escaped_coq lexbuf; Output.end_inline_coq ()); - comment lexbuf } - | "[[" nl { - if !Cdglobals.parse_comments then - if !Cdglobals.plain_comments then (Output.char '['; Output.char '[') + comment lexbuf } + | "[[" nl + { if !Cdglobals.plain_comments then (Output.char '['; Output.char '[') else (formatted := true; Output.start_inline_coq_block (); let _ = body_bol lexbuf in Output.end_inline_coq_block (); formatted := false); - comment lexbuf} + comment lexbuf } | "$" - { if !Cdglobals.parse_comments then - if !Cdglobals.plain_comments then Output.char '$' - else (Output.start_latex_math (); escaped_math_latex lexbuf); + { if !Cdglobals.plain_comments then Output.char '$' + else (Output.start_latex_math (); escaped_math_latex lexbuf); comment lexbuf } | "$$" - { if !Cdglobals.parse_comments - then - (if !Cdglobals.plain_comments then Output.char '$'; Output.char '$'); - doc None lexbuf } + { if !Cdglobals.plain_comments then Output.char '$'; + Output.char '$'; + comment lexbuf } | "%" - { if !Cdglobals.parse_comments - then - if !Cdglobals.plain_comments then Output.char '%' - else escaped_latex lexbuf; comment lexbuf } + { if !Cdglobals.plain_comments then Output.char '%' + else escaped_latex lexbuf; + comment lexbuf } | "%%" - { if !Cdglobals.parse_comments - then - (if !Cdglobals.plain_comments then Output.char '%'; Output.char '%'); + { if !Cdglobals.plain_comments then Output.char '%'; + Output.char '%'; comment lexbuf } | "#" - { if !Cdglobals.parse_comments - then - if !Cdglobals.plain_comments then Output.char '$' - else escaped_html lexbuf; comment lexbuf } + { if !Cdglobals.plain_comments then Output.char '#' + else escaped_html lexbuf; + comment lexbuf } | "##" - { if !Cdglobals.parse_comments - then - (if !Cdglobals.plain_comments then Output.char '#'; Output.char '#'); + { if !Cdglobals.plain_comments then Output.char '#'; + Output.char '#'; comment lexbuf } | eof { false } - | space+ { if !Cdglobals.parse_comments - then Output.indentation (fst (count_spaces (lexeme lexbuf))); - comment lexbuf } - | nl { if !Cdglobals.parse_comments - then Output.line_break (); comment lexbuf } - | _ { if !Cdglobals.parse_comments then Output.char (lexeme_char lexbuf 0); - comment lexbuf } + | space+ + { Output.indentation (fst (count_spaces (lexeme lexbuf))); + comment lexbuf } + | nl + { Output.line_break (); + comment lexbuf } + | _ { Output.char (lexeme_char lexbuf 0); + comment lexbuf } and skip_to_dot = parse | '.' space* nl { true } | eof | '.' space+ { false } - | "(*" { comment_level := 1; ignore (comment lexbuf); skip_to_dot lexbuf } + | "(*" + { comment_level := 1; + ignore (skipped_comment lexbuf); + skip_to_dot lexbuf } + | _ { skip_to_dot lexbuf } + +and skip_to_dot_or_brace = parse + | '.' space* nl { true } + | eof | '.' space+ { false } + | "(*" + { comment_level := 1; + ignore (skipped_comment lexbuf); + skip_to_dot_or_brace lexbuf } + | "}" space* nl + { true } + | "}" + { false } + | space* + { skip_to_dot_or_brace lexbuf } | _ { skip_to_dot lexbuf } and body_bol = parse @@ -1114,12 +1145,18 @@ and body = parse let eol = doc_bol lexbuf in Output.end_doc (); Output.start_coq (); if eol then body_bol lexbuf else body lexbuf } - | "(*" { Tokens.flush_sublexer(); comment_level := 1; - if !Cdglobals.parse_comments then Output.start_comment (); - let eol = comment lexbuf in - if eol - then begin if not !Cdglobals.parse_comments then Output.line_break(); body_bol lexbuf end - else body lexbuf } + | "(*" + { Tokens.flush_sublexer(); comment_level := 1; + let eol = + if parse_comments () then begin + Output.start_comment (); + comment lexbuf + end else begin + let eol = skipped_comment lexbuf in + if eol then Output.line_break(); + eol + end in + if eol then body_bol lexbuf else body lexbuf } | "where" { Tokens.flush_sublexer(); Output.ident (lexeme lexbuf) None; diff --git a/tools/fake_ide.ml b/tools/fake_ide.ml index e81f4038d6..221fb36d8d 100644 --- a/tools/fake_ide.ml +++ b/tools/fake_ide.ml @@ -28,7 +28,8 @@ let error_xml s = Printf.eprintf "fake_id: error: %a\n%!" print_xml s; exit 1 -let logger level content = Printf.eprintf "%a\n%! " print_xml content +let logger level content = + Printf.eprintf "%a\n%! " print_xml (Richpp.repr content) let base_eval_call ?(print=true) ?(fail=true) call coqtop = if print then prerr_endline (Xmlprotocol.pr_call call); @@ -36,15 +37,14 @@ let base_eval_call ?(print=true) ?(fail=true) call coqtop = Xml_printer.print coqtop.xml_printer xml_query; let rec loop () = let xml = Xml_parser.parse coqtop.xml_parser in - if Pp.is_message xml then - let message = Pp.to_message xml in - let level = message.Pp.message_level in - let content = message.Pp.message_content in + match Xmlprotocol.is_message xml with + | Some (level, content) -> logger level content; loop () - else if Feedback.is_feedback xml then - loop () - else (Xmlprotocol.to_answer call xml) + | None -> + if Xmlprotocol.is_feedback xml then + loop () + else Xmlprotocol.to_answer call xml in let res = loop () in if print then prerr_endline (Xmlprotocol.pr_full_value call res); diff --git a/tools/ocamllibdep.mll b/tools/ocamllibdep.mll index 670ff487c5..57fcd5dd21 100644 --- a/tools/ocamllibdep.mll +++ b/tools/ocamllibdep.mll @@ -33,10 +33,6 @@ rule mllib_list = parse open Printf open Unix -(** [coqdep_boot] is a stripped-down version of [coqdep] used to treat - with mllib files. -*) - (* Makefile's escaping rules are awful: $ is escaped by doubling and other special characters are escaped by backslash prefixing while backslashes themselves must be escaped only if part of a sequence @@ -132,6 +128,7 @@ let add_ml_known, search_ml_known = mkknown () let add_mlpack_known, search_mlpack_known = mkknown () let mllibAccu = ref ([] : (string * dir) list) +let mlpackAccu = ref ([] : (string * dir) list) let add_caml_known phys_dir f = let basename,suff = get_extension f [".ml";".ml4";".mlpack"] in @@ -148,18 +145,15 @@ let traite_fichier_modules md ext = let chan = open_in (md ^ ext) in let list = mllib_list (Lexing.from_channel chan) in List.fold_left - (fun a_faire str -> match search_mlpack_known str with - | Some mldir -> - let file = file_name str mldir in - a_faire^" "^file - | None -> + (fun acc str -> + match search_mlpack_known str with + | Some mldir -> (file_name str mldir) :: acc + | None -> match search_ml_known str with - | Some mldir -> - let file = file_name str mldir in - a_faire^" "^file - | None -> a_faire) "" list + | Some mldir -> (file_name str mldir) :: acc + | None -> acc) [] (List.rev list) with - | Sys_error _ -> "" + | Sys_error _ -> [] | Syntax_error (i,j) -> error_cannot_parse (md^ext) (i,j) let addQueue q v = q := v :: !q @@ -167,22 +161,43 @@ let addQueue q v = q := v :: !q let treat_file old_name = let name = Filename.basename old_name in let dirname = Some (Filename.dirname old_name) in - match get_extension name [".mllib"] with + match get_extension name [".mllib";".mlpack"] with | (base,".mllib") -> addQueue mllibAccu (base,dirname) + | (base,".mlpack") -> addQueue mlpackAccu (base,dirname) | _ -> () let mllib_dependencies () = List.iter (fun (name,dirname) -> let fullname = file_name name dirname in - let dep = traite_fichier_modules fullname ".mllib" in + let deps = traite_fichier_modules fullname ".mllib" in + let sdeps = String.concat " " deps in let efullname = escape fullname in - printf "%s_MLLIB_DEPENDENCIES:=%s\n" efullname dep; - printf "%s.cma:$(addsuffix .cmo,$(%s_MLLIB_DEPENDENCIES))\n" efullname efullname; - printf "%s.cmxa %s.cmxs:$(addsuffix .cmx,$(%s_MLLIB_DEPENDENCIES))\n" efullname efullname efullname; + printf "%s_MLLIB_DEPENDENCIES:=%s\n" efullname sdeps; + printf "%s.cma:$(addsuffix .cmo,$(%s_MLLIB_DEPENDENCIES))\n" + efullname efullname; + printf "%s.cmxa %s.cmxs:$(addsuffix .cmx,$(%s_MLLIB_DEPENDENCIES))\n" + efullname efullname efullname; flush Pervasives.stdout) (List.rev !mllibAccu) +let mlpack_dependencies () = + List.iter + (fun (name,dirname) -> + let fullname = file_name name dirname in + let modname = String.capitalize name in + let deps = traite_fichier_modules fullname ".mlpack" in + let sdeps = String.concat " " deps in + let efullname = escape fullname in + printf "%s_MLPACK_DEPENDENCIES:=%s\n" efullname sdeps; + List.iter (fun d -> printf "%s_FORPACK:= -for-pack %s\n" d modname) deps; + printf "%s.cmo:$(addsuffix .cmo,$(%s_MLPACK_DEPENDENCIES))\n" + efullname efullname; + printf "%s.cmx %s.cmxs:$(addsuffix .cmx,$(%s_MLPACK_DEPENDENCIES))\n" + efullname efullname efullname; + flush Pervasives.stdout) + (List.rev !mlpackAccu) + let rec parse = function | "-I" :: r :: ll -> (* To solve conflict (e.g. same filename in kernel and checker) @@ -192,10 +207,11 @@ let rec parse = function | f :: ll -> treat_file f; parse ll | [] -> () -let coqdep_boot () = +let main () = if Array.length Sys.argv < 2 then exit 1; parse (List.tl (Array.to_list Sys.argv)); - mllib_dependencies () + mllib_dependencies (); + mlpack_dependencies () -let _ = Printexc.catch coqdep_boot () +let _ = Printexc.catch main () } diff --git a/toplevel/class.ml b/toplevel/class.ml index a9c53b4d4e..10e9b30bee 100644 --- a/toplevel/class.ml +++ b/toplevel/class.ml @@ -262,7 +262,7 @@ let add_new_coercion_core coef stre poly source target isid = in check_source (Some cls); if not (uniform_cond (llp-ind) lvs) then - msg_warning (explain_coercion_error coef NotUniform); + Feedback.msg_warning (explain_coercion_error coef NotUniform); let clt = try get_target tg ind @@ -310,7 +310,7 @@ let add_coercion_hook poly local ref = in let () = try_add_new_coercion ref stre poly in let msg = pr_global_env Id.Set.empty ref ++ str " is now a coercion" in - Flags.if_verbose msg_info msg + Flags.if_verbose Feedback.msg_info msg let add_coercion_hook poly = Lemmas.mk_hook (add_coercion_hook poly) diff --git a/toplevel/command.ml b/toplevel/command.ml index 5865fec060..f0f678e08c 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -119,7 +119,7 @@ let interp_definition pl bl p red_option c ctypopt = impl_eq (List.assoc_f Pervasives.(=) key impsty) va (* FIXME *) in if not (try List.for_all chk imps2 with Not_found -> false) - then msg_warning + then Feedback.msg_warning (strbrk "Implicit arguments declaration relies on type." ++ spc () ++ strbrk "The term declares more implicits than the type here."); let vars = Univ.LSet.union (Universes.universes_of_constr body) @@ -140,7 +140,7 @@ let get_locality id = function | Discharge -> (** If a Let is defined outside a section, then we consider it as a local definition *) let msg = pr_id id ++ strbrk " is declared as a local definition" in - let () = msg_warning msg in + let () = Feedback.msg_warning msg in true | Local -> true | Global -> false @@ -171,7 +171,7 @@ let declare_definition ident (local, p, k) ce pl imps hook = let () = if Pfedit.refining () then let msg = strbrk "Section definition " ++ pr_id ident ++ strbrk " is not visible from current goals" in - msg_warning msg + Feedback.msg_warning msg in gr | Discharge | Local | Global -> @@ -217,7 +217,7 @@ match local with let () = assumption_message ident in let () = if is_verbose () && Pfedit.refining () then - msg_warning (str"Variable" ++ spc () ++ pr_id ident ++ + Feedback.msg_warning (str"Variable" ++ spc () ++ pr_id ident ++ strbrk " is not visible from current goals") in let r = VarRef ident in @@ -706,7 +706,7 @@ let declare_mutual_inductive_with_eliminations mie pl impls = constrimpls) impls; let warn_prim = match mie.mind_entry_record with Some (Some _) -> not prim | _ -> false in - if_verbose msg_info (minductive_message warn_prim names); + if_verbose Feedback.msg_info (minductive_message warn_prim names); if mie.mind_entry_private == None then declare_default_schemes mind; mind @@ -799,7 +799,7 @@ let check_mutuality env isfix fixl = let po = partial_order Id.equal preorder in match List.filter (function (_,Inr _) -> true | _ -> false) po with | (x,Inr xge)::(y,Inr yge)::rest -> - msg_warning (non_full_mutual_message x xge y yge isfix rest) + Feedback.msg_warning (non_full_mutual_message x xge y yge isfix rest) | _ -> () type structured_fixpoint_expr = { diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index b81c8da718..65c5917b72 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -36,7 +36,7 @@ let load_rcfile() = else raise (Sys_error ("Cannot read rcfile: "^ !rcfile)) else try - let warn x = msg_warning (str x) in + let warn x = Feedback.msg_warning (str x) in let inferedrc = List.find CUnix.file_readable_p [ Envars.xdg_config_home warn / rcdefaultname^"."^Coq_config.version; Envars.xdg_config_home warn / rcdefaultname; @@ -52,10 +52,10 @@ let load_rcfile() = *) with reraise -> let reraise = Errors.push reraise in - let () = msg_info (str"Load of rcfile failed.") in + let () = Feedback.msg_info (str"Load of rcfile failed.") in iraise reraise else - Flags.if_verbose msg_info (str"Skipping rcfile loading.") + Flags.if_verbose Feedback.msg_info (str"Skipping rcfile loading.") (* Recursively puts dir in the LoadPath if -nois was not passed *) let add_stdlib_path ~unix_path ~coq_root ~with_ml = @@ -78,7 +78,7 @@ let push_ml_include s = ml_includes := s :: !ml_includes let init_load_path () = let coqlib = Envars.coqlib () in let user_contrib = coqlib/"user-contrib" in - let xdg_dirs = Envars.xdg_dirs ~warn:(fun x -> msg_warning (str x)) in + let xdg_dirs = Envars.xdg_dirs ~warn:(fun x -> Feedback.msg_warning (str x)) in let coqpath = Envars.coqpath in let coq_root = Names.DirPath.make [Nameops.coq_root] in (* NOTE: These directories are searched from last to first *) @@ -127,7 +127,7 @@ let init_ocaml_path () = [ [ "config" ]; [ "dev" ]; [ "lib" ]; [ "kernel" ]; [ "library" ]; [ "engine" ]; [ "pretyping" ]; [ "interp" ]; [ "parsing" ]; [ "proofs" ]; [ "tactics" ]; [ "toplevel" ]; [ "printing" ]; [ "intf" ]; - [ "grammar" ]; [ "ide" ] ] + [ "grammar" ]; [ "ide" ]; [ "ltac" ]; ] let get_compat_version = function | "8.5" -> Flags.Current @@ -135,6 +135,6 @@ let get_compat_version = function | "8.3" -> Flags.V8_3 | "8.2" -> Flags.V8_2 | ("8.1" | "8.0") as s -> - msg_warning (str "Compatibility with version " ++ str s ++ str " not supported."); + Feedback.msg_warning (str "Compatibility with version " ++ str s ++ str " not supported."); Flags.V8_2 | s -> Errors.errorlabstrm "get_compat_version" (str "Unknown compatibility version \"" ++ str s ++ str "\".") diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 040c339249..c8879963e5 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -13,6 +13,8 @@ open Flags open Vernac open Pcoq +let top_stderr x = msg_with !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. *) @@ -59,7 +61,7 @@ let prompt_char ic ibuf count = | ll::_ -> Int.equal ibuf.len ll | [] -> Int.equal ibuf.len 0 in - if bol && not !print_emacs then msgerr (str (ibuf.prompt())); + if bol && not !print_emacs then top_stderr (str (ibuf.prompt())); try let c = input_char ic in if c == '\n' then ibuf.bols <- (ibuf.len+1) :: ibuf.bols; @@ -310,23 +312,23 @@ let read_sentence () = *) let do_vernac () = - msgerrnl (mt ()); - if !print_emacs then msgerr (str (top_buffer.prompt())); + top_stderr (fnl()); + if !print_emacs then top_stderr (str (top_buffer.prompt())); resynch_buffer top_buffer; try Vernac.eval_expr (read_sentence ()) with | End_of_input | Errors.Quit -> - msgerrnl (mt ()); pp_flush(); raise Errors.Quit + top_stderr (fnl ()); raise Errors.Quit | Errors.Drop -> (* Last chance *) if Mltop.is_ocaml_top() then raise Errors.Drop - else ppnl (str"Error: There is no ML toplevel." ++ fnl ()) + else Feedback.msg_error (str"There is no ML toplevel.") | any -> let any = Errors.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; - pp_flush () + flush_all () (** Main coq loop : read vernacular expressions until Drop is entered. Ctrl-C is handled internally as Sys.Break instead of aborting Coq. @@ -354,7 +356,7 @@ let rec loop () = | Errors.Drop -> () | Errors.Quit -> exit 0 | any -> - msgerrnl (str"Anomaly: main loop exited with exception: " ++ + Feedback.msg_error (str"Anomaly: main loop exited with exception: " ++ str (Printexc.to_string any) ++ fnl() ++ str"Please report."); loop () diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 379a96b89e..a820008d2e 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -31,10 +31,10 @@ let get_version_date () = let print_header () = let (ver,rev) = get_version_date () in - ppnl (str "Welcome to Coq " ++ str ver ++ str " (" ++ str rev ++ str ")"); - pp_flush () + Feedback.msg_notice (str "Welcome to Coq " ++ str ver ++ str " (" ++ str rev ++ str ")"); + flush_all () -let warning s = with_option Flags.warn msg_warning (strbrk s) +let warning s = with_option Flags.warn Feedback.msg_warning (strbrk s) let toploop = ref None @@ -61,7 +61,8 @@ let init_color () = match colors with | None -> (** Default colors *) - Ppstyle.init_color_output () + Ppstyle.init_color_output (); + Feedback.set_logger Feedback.color_terminal_logger | Some "" -> (** No color output *) () @@ -69,7 +70,8 @@ let init_color () = (** Overwrite all colors *) Ppstyle.clear_styles (); Ppstyle.parse_config s; - Ppstyle.init_color_output () + Ppstyle.init_color_output (); + Feedback.set_logger Feedback.color_terminal_logger end let toploop_init = ref begin fun x -> @@ -95,8 +97,8 @@ let memory_stat = ref false let print_memory_stat () = begin (* -m|--memory from the command-line *) if !memory_stat then - ppnl - (str "total heap size = " ++ int (CObj.heap_size_kb ()) ++ str " kbytes"); + Feedback.msg_notice + (str "total heap size = " ++ int (CObj.heap_size_kb ()) ++ str " kbytes" ++ fnl ()); end; begin (* operf-macro interface: @@ -141,7 +143,7 @@ let remove_top_ml () = Mltop.remove () let inputstate = ref "" let set_inputstate s = - let () = msg_warning (str "The inputstate option is deprecated and discouraged.") in + let () = Feedback.msg_warning (str "The inputstate option is deprecated and discouraged.") in inputstate:=s let inputstate () = if not (String.is_empty !inputstate) then @@ -150,7 +152,7 @@ let inputstate () = let outputstate = ref "" let set_outputstate s = - let () = msg_warning (str "The outputstate option is deprecated and discouraged.") in + let () = Feedback.msg_warning (str "The outputstate option is deprecated and discouraged.") in outputstate:=s let outputstate () = if not (String.is_empty !outputstate) then @@ -243,7 +245,7 @@ let set_emacs () = if not (Option.is_empty !toploop) then error "Flag -emacs is incompatible with a custom toplevel loop"; Flags.print_emacs := true; - Pp.make_pp_emacs (); + Feedback.(set_logger emacs_logger); Vernacentries.qed_display_script := false; color := `OFF @@ -368,6 +370,11 @@ let get_int opt n = with Failure _ -> prerr_endline ("Error: integer expected after option "^opt); exit 1 +let get_float opt n = + try float_of_string n + with Failure _ -> + prerr_endline ("Error: float expected after option "^opt); exit 1 + let get_host_port opt s = match CString.split ':' s with | [host; portr; portw] -> @@ -377,6 +384,11 @@ let get_host_port opt s = prerr_endline ("Error: host:port or stdfds expected after option "^opt); exit 1 +let get_error_resilience opt = function + | "on" | "all" | "yes" -> `All + | "off" | "no" -> `None + | s -> `Only (String.split ',' s) + let get_task_list s = List.map int_of_string (Str.split (Str.regexp ",") s) let vio_tasks = ref [] @@ -490,6 +502,12 @@ let parse_args arglist = Flags.async_proofs_worker_priority := get_priority opt (next ()) |"-async-proofs-private-flags" -> Flags.async_proofs_private_flags := Some (next ()); + |"-async-proofs-tactic-error-resilience" -> + Flags.async_proofs_tac_error_resilience := get_error_resilience opt (next ()) + |"-async-proofs-command-error-resilience" -> + Flags.async_proofs_cmd_error_resilience := get_bool opt (next ()) + |"-async-proofs-delegation-threshold" -> + Flags.async_proofs_delegation_threshold:= get_float opt (next ()) |"-worker-id" -> set_worker_id opt (next ()) |"-compat" -> let v = get_compat_version (next ()) in Flags.compat_version := v; add_compat_require v |"-compile" -> add_compile false (next ()) @@ -548,6 +566,7 @@ let parse_args arglist = else native_compiler := true |"-notop" -> unset_toplevel_name () |"-output-context" -> output_context := true + |"-profile-ltac" -> Flags.profile_ltac := true |"-q" -> no_load_rc () |"-quiet"|"-silent" -> Flags.make_silent true; Flags.make_warn false |"-quick" -> Flags.compilation_mode := BuildVio @@ -647,7 +666,7 @@ let init_toplevel arglist = if !batch_mode then begin flush_all(); if !output_context then - Pp.ppnl (with_option raw_print Prettyp.print_full_pure_context ()); + Feedback.msg_notice (with_option raw_print Prettyp.print_full_pure_context () ++ fnl ()); Profile.print_profile (); exit 0 end diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index ad848ccfc8..e17cd20863 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -69,12 +69,12 @@ let rec contract3' env a b c = function let (env',t1,t2) = contract2 env' t1 t2 in contract3 env a b c, ConversionFailed (env',t1,t2) | NotSameArgSize | NotSameHead | NoCanonicalStructure - | MetaOccurInBody _ | InstanceNotSameType _ + | MetaOccurInBody _ | InstanceNotSameType _ | ProblemBeyondCapabilities | UnifUnivInconsistency _ as x -> contract3 env a b c, x - | CannotSolveConstraint ((pb,env,t,u),x) -> - let env,t,u = contract2 env t u in + | CannotSolveConstraint ((pb,env',t,u),x) -> + let env',t,u = contract2 env' t u in let y,x = contract3' env a b c x in - y,CannotSolveConstraint ((pb,env,t,u),x) + y,CannotSolveConstraint ((pb,env',t,u),x) (** Ad-hoc reductions *) @@ -323,6 +323,8 @@ let explain_unification_error env sigma p1 p2 = function (strbrk "cannot satisfy constraint " ++ pr_lconstr_env env sigma t ++ str " == " ++ pr_lconstr_env env sigma u) :: aux t u e + | ProblemBeyondCapabilities -> + [] in match aux p1 p2 e with | [] -> mt () diff --git a/toplevel/indschemes.ml b/toplevel/indschemes.ml index 367425546f..f995a390cf 100644 --- a/toplevel/indschemes.ml +++ b/toplevel/indschemes.ml @@ -150,7 +150,7 @@ let alarm what internal msg = | UserAutomaticRequest | InternalTacticRequest -> (if debug then - msg_warning + Feedback.msg_warning (hov 0 msg ++ fnl () ++ what ++ str " not defined.")); None | _ -> Some msg @@ -303,7 +303,7 @@ let declare_congr_scheme ind = then ignore (define_individual_scheme congr_scheme_kind UserAutomaticRequest None ind) else - msg_warning (strbrk "Cannot build congruence scheme because eq is not found") + Feedback.msg_warning (strbrk "Cannot build congruence scheme because eq is not found") end let declare_sym_scheme ind = diff --git a/toplevel/locality.ml b/toplevel/locality.ml index ef789aa5c5..c4c891b89c 100644 --- a/toplevel/locality.ml +++ b/toplevel/locality.ml @@ -35,7 +35,7 @@ let enforce_locality_full locality_flag local = Errors.error "Use only prefix \"Local\"." | None -> if local then begin - Pp.msg_warning (Pp.str "Obsolete syntax: use \"Local\" as a prefix."); + Feedback.msg_warning (Pp.str "Obsolete syntax: use \"Local\" as a prefix."); Some true end else None diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index d60c739399..b22d53f546 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -568,7 +568,7 @@ let is_not_small_constr = function let rec define_keywords_aux = function | GramConstrNonTerminal(e,Some _) as n1 :: GramConstrTerminal(IDENT k) :: l when is_not_small_constr e -> - Flags.if_verbose msg_info (str "Identifier '" ++ str k ++ str "' now a keyword"); + Flags.if_verbose Feedback.msg_info (str "Identifier '" ++ str k ++ str "' now a keyword"); CLexer.add_keyword k; n1 :: GramConstrTerminal(KEYWORD k) :: define_keywords_aux l | n :: l -> n :: define_keywords_aux l @@ -577,7 +577,7 @@ let rec define_keywords_aux = function (* Ensure that IDENT articulation terminal symbols are keywords *) let define_keywords = function | GramConstrTerminal(IDENT k)::l -> - Flags.if_verbose msg_info (str "Identifier '" ++ str k ++ str "' now a keyword"); + Flags.if_verbose Feedback.msg_info (str "Identifier '" ++ str k ++ str "' now a keyword"); CLexer.add_keyword k; GramConstrTerminal(KEYWORD k) :: define_keywords_aux l | l -> define_keywords_aux l @@ -827,7 +827,7 @@ let make_interpretation_type isrec isonlybinding = function | NtnInternTypeConstr | NtnInternTypeIdent -> if isonlybinding then NtnTypeOnlyBinder else NtnTypeConstr | NtnInternTypeBinder when isrec -> NtnTypeBinderList - | NtnInternTypeBinder -> error "Type not allowed in recursive notation." + | NtnInternTypeBinder -> error "Type binder is only for use in recursive notations for binders." let make_interpretation_vars recvars allvars = let eq_subscope (sc1, l1) (sc2, l2) = @@ -855,12 +855,12 @@ let check_rule_productivity l = let is_not_printable onlyparse noninjective = function | NVar _ -> let () = if not onlyparse then - msg_warning (strbrk "This notation will not be used for printing as it is bound to a single variable.") + Feedback.msg_warning (strbrk "This notation will not be used for printing as it is bound to a single variable.") in true | _ -> if not onlyparse && noninjective then - let () = msg_warning (strbrk "This notation will not be used for printing as it is not reversible.") in + let () = Feedback.msg_warning (strbrk "This notation will not be used for printing as it is not reversible.") in true else onlyparse @@ -886,7 +886,7 @@ let find_precedence lev etyps symbols = | ETName | ETBigint | ETReference -> begin match lev with | None -> - ([msg_info,strbrk "Setting notation at level 0."],0) + ([Feedback.msg_info,strbrk "Setting notation at level 0."],0) | Some 0 -> ([],0) | _ -> @@ -904,7 +904,7 @@ let find_precedence lev etyps symbols = else [],Option.get lev) | Terminal _ when last_is_terminal () -> if Option.is_empty lev then - ([msg_info,strbrk "Setting notation at level 0."], 0) + ([Feedback.msg_info,strbrk "Setting notation at level 0."], 0) else [],Option.get lev | _ -> if Option.is_empty lev then error "Cannot determine the level."; @@ -931,7 +931,7 @@ let remove_curly_brackets l = (match next' with | Terminal "}" as t2 :: l'' as l1 -> if not (List.equal Notation.symbol_eq l l0) || not (List.equal Notation.symbol_eq l' l1) then - msg_warning (strbrk "Skipping spaces inside curly brackets"); + Feedback.msg_warning (strbrk "Skipping spaces inside curly brackets"); if deb && List.is_empty l'' then [t1;x;t2] else begin check_curly_brackets_notation_exists (); x :: aux false l'' @@ -976,7 +976,7 @@ let compute_pure_syntax_data df mods = let (msgs,(onlyparse,_,_,_),_,sy_data,extra) = compute_syntax_data df mods in let msgs = if onlyparse then - (msg_warning, + (Feedback.msg_warning, strbrk "The only parsing modifier has no effect in Reserved Notation.")::msgs else msgs in msgs, sy_data, extra diff --git a/toplevel/mltop.ml b/toplevel/mltop.ml index d0fa7a80c2..36c16208c5 100644 --- a/toplevel/mltop.ml +++ b/toplevel/mltop.ml @@ -146,7 +146,7 @@ let dir_ml_load s = let dir_ml_use s = match !load with | WithTop t -> t.use_file s - | _ -> msg_warning (str "Cannot access the ML compiler") + | _ -> Feedback.msg_warning (str "Cannot access the ML compiler") (* Adds a path to the ML paths *) let add_ml_dir s = @@ -164,7 +164,7 @@ let add_rec_ml_dir unix_path = let convert_string d = try Names.Id.of_string d with UserError _ -> - msg_warning (str "Directory " ++ str d ++ str " cannot be used as a Coq identifier (skipped)"); + Feedback.msg_warning (str "Directory " ++ str d ++ str " cannot be used as a Coq identifier (skipped)"); raise Exit let add_rec_path ~unix_path ~coq_root ~implicit = @@ -184,7 +184,7 @@ let add_rec_path ~unix_path ~coq_root ~implicit = let () = List.iter add dirs in Loadpath.add_load_path unix_path ~implicit coq_root else - msg_warning (str "Cannot open " ++ str unix_path) + Feedback.msg_warning (str "Cannot open " ++ str unix_path) (* convertit un nom quelconque en nom de fichier ou de module *) let mod_of_name name = @@ -324,10 +324,10 @@ let if_verbose_load verb f name ?path fname = let info = str "[Loading ML file " ++ str fname ++ str " ..." in try let path = f name ?path fname in - msg_info (info ++ str " done]"); + Feedback.msg_info (info ++ str " done]"); path with reraise -> - msg_info (info ++ str " failed]"); + Feedback.msg_info (info ++ str " failed]"); raise reraise (** Load a module for the first time (i.e. dynlink it) diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml index 54baa5e3c1..dbc3ccaac4 100644 --- a/toplevel/obligations.ml +++ b/toplevel/obligations.ml @@ -24,7 +24,7 @@ let declare_fix_ref = ref (fun ?opaque _ _ _ _ _ _ -> assert false) let declare_definition_ref = ref (fun _ _ _ _ _ -> assert false) let trace s = - if !Flags.debug then msg_debug s + if !Flags.debug then Feedback.msg_debug s else () let succfix (depth, fixrels) = @@ -731,11 +731,11 @@ type progress = let obligations_message rem = if rem > 0 then if Int.equal rem 1 then - Flags.if_verbose msg_info (int rem ++ str " obligation remaining") + Flags.if_verbose Feedback.msg_info (int rem ++ str " obligation remaining") else - Flags.if_verbose msg_info (int rem ++ str " obligations remaining") + Flags.if_verbose Feedback.msg_info (int rem ++ str " obligations remaining") else - Flags.if_verbose msg_info (str "No more obligations remaining") + Flags.if_verbose Feedback.msg_info (str "No more obligations remaining") let update_obls prg obls rem = let prg' = { prg with prg_obligations = (obls, rem) } in @@ -992,7 +992,7 @@ and try_solve_obligations n tac = try ignore (solve_obligations n tac) with NoObligations _ -> () and auto_solve_obligations n ?oblset tac : progress = - Flags.if_verbose msg_info (str "Solving obligations automatically..."); + Flags.if_verbose Feedback.msg_info (str "Solving obligations automatically..."); try solve_prg_obligations (get_prog_err n) ?oblset tac with NoObligations _ -> Dependent open Pp @@ -1000,13 +1000,13 @@ let show_obligations_of_prg ?(msg=true) prg = let n = prg.prg_name in let obls, rem = prg.prg_obligations in let showed = ref 5 in - if msg then msg_info (int rem ++ str " obligation(s) remaining: "); + if msg then Feedback.msg_info (int rem ++ str " obligation(s) remaining: "); Array.iteri (fun i x -> match x.obl_body with | None -> if !showed > 0 then ( decr showed; - msg_info (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++ + Feedback.msg_info (str "Obligation" ++ spc() ++ int (succ i) ++ spc () ++ str "of" ++ spc() ++ Id.print n ++ str ":" ++ spc () ++ hov 1 (Printer.pr_constr_env (Global.env ()) Evd.empty x.obl_type ++ str "." ++ fnl ()))) @@ -1035,12 +1035,12 @@ let add_definition n ?term t ctx ?pl ?(implicits=[]) ?(kind=Global,false,Definit let prg = init_prog_info sign ~opaque n pl term t ctx [] None [] obls implicits kind reduce hook in let obls,_ = prg.prg_obligations in if Int.equal (Array.length obls) 0 then ( - Flags.if_verbose msg_info (info ++ str "."); + Flags.if_verbose Feedback.msg_info (info ++ str "."); let cst = declare_definition prg in Defined cst) else ( let len = Array.length obls in - let _ = Flags.if_verbose msg_info (info ++ str ", generating " ++ int len ++ str " obligation(s)") in + let _ = Flags.if_verbose Feedback.msg_info (info ++ str ", generating " ++ int len ++ str " obligation(s)") in progmap_add n (CEphemeron.create prg); let res = auto_solve_obligations (Some n) tactic in match res with diff --git a/toplevel/record.ml b/toplevel/record.ml index d12b5ee8e4..0c3bd953c0 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -196,7 +196,7 @@ let warning_or_error coe indsp err = (pr_id fi ++ strbrk " cannot be defined because it is not typable.") in if coe then errorlabstrm "structure" st; - Flags.if_verbose msg_warning (hov 0 st) + Flags.if_verbose Feedback.msg_warning (hov 0 st) type field_status = | NoProjection of Name.t @@ -262,7 +262,7 @@ let declare_projections indsp ?(kind=StructureComponent) binder_name coers field | Some None | None -> false in if not is_primitive then - Flags.if_verbose msg_warning + Flags.if_verbose Feedback.msg_warning (hov 0 (str "The record " ++ Printer.pr_inductive env indsp ++ str" could not be defined as a primitive record")); is_primitive diff --git a/toplevel/search.ml b/toplevel/search.ml index 646e2e08ac..e670b59b79 100644 --- a/toplevel/search.ml +++ b/toplevel/search.ml @@ -257,10 +257,10 @@ let search_about gopt items mods = format_display !ans type search_constraint = - | Name_Pattern of string - | Type_Pattern of string - | SubType_Pattern of string - | In_Module of string list + | Name_Pattern of Str.regexp + | Type_Pattern of Pattern.constr_pattern + | SubType_Pattern of Pattern.constr_pattern + | In_Module of Names.DirPath.t | Include_Blacklist type 'a coq_object = { @@ -269,40 +269,21 @@ type 'a coq_object = { coq_object_object : 'a; } -let interface_search flags = - let env = Global.env () in +let interface_search = let rec extract_flags name tpe subtpe mods blacklist = function | [] -> (name, tpe, subtpe, mods, blacklist) - | (Name_Pattern s, b) :: l -> - let regexp = - try Str.regexp s - with e when Errors.noncritical e -> - Errors.errorlabstrm "Search.interface_search" - (str "Invalid regexp: " ++ str s) - in + | (Name_Pattern regexp, b) :: l -> extract_flags ((regexp, b) :: name) tpe subtpe mods blacklist l - | (Type_Pattern s, b) :: l -> - let constr = Pcoq.parse_string Pcoq.Constr.lconstr_pattern s in - let (_, pat) = Constrintern.intern_constr_pattern env constr in + | (Type_Pattern pat, b) :: l -> extract_flags name ((pat, b) :: tpe) subtpe mods blacklist l - | (SubType_Pattern s, b) :: l -> - let constr = Pcoq.parse_string Pcoq.Constr.lconstr_pattern s in - let (_, pat) = Constrintern.intern_constr_pattern env constr in + | (SubType_Pattern pat, b) :: l -> extract_flags name tpe ((pat, b) :: subtpe) mods blacklist l - | (In_Module m, b) :: l -> - let path = String.concat "." m in - let m = Pcoq.parse_string Pcoq.Constr.global path in - let (_, qid) = Libnames.qualid_of_reference m in - let id = - try Nametab.full_name_module qid - with Not_found -> - Errors.errorlabstrm "Search.interface_search" - (str "Module " ++ str path ++ str " not found.") - in + | (In_Module id, b) :: l -> extract_flags name tpe subtpe ((id, b) :: mods) blacklist l | (Include_Blacklist, b) :: l -> extract_flags name tpe subtpe mods b l in + fun ?glnum flags -> let (name, tpe, subtpe, mods, blacklist) = extract_flags [] [] [] [] false flags in @@ -359,5 +340,5 @@ let interface_search flags = let iter ref env typ = if filter_function ref env typ then print_function ref env typ in - let () = generic_search None iter in (* TODO: chose a goal number? *) + let () = generic_search glnum iter in !ans diff --git a/toplevel/search.mli b/toplevel/search.mli index 78b0c45c01..9f209a17e7 100644 --- a/toplevel/search.mli +++ b/toplevel/search.mli @@ -47,13 +47,13 @@ val search_about : int option -> (bool * glob_search_about_item) list type search_constraint = (** Whether the name satisfies a regexp (uses Ocaml Str syntax) *) - | Name_Pattern of string + | Name_Pattern of Str.regexp (** Whether the object type satisfies a pattern *) - | Type_Pattern of string + | Type_Pattern of Pattern.constr_pattern (** Whether some subtype of object type satisfies a pattern *) - | SubType_Pattern of string + | SubType_Pattern of Pattern.constr_pattern (** Whether the object pertains to a module *) - | In_Module of string list + | In_Module of Names.DirPath.t (** Bypass the Search blacklist *) | Include_Blacklist @@ -63,7 +63,7 @@ type 'a coq_object = { coq_object_object : 'a; } -val interface_search : (search_constraint * bool) list -> +val interface_search : ?glnum:int -> (search_constraint * bool) list -> string coq_object list (** {6 Generic search function} *) diff --git a/toplevel/usage.ml b/toplevel/usage.ml index 9026b8f8f5..ffbbe7ed4a 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -78,6 +78,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 -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 c47fde7888..0a32c88d64 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -119,8 +119,7 @@ let verbose_phrase verbch loc = let s = String.create len in seek_in ch (fst loc); really_input ch s 0 len; - ppnl (str s); - pp_flush() + Feedback.msg_notice (str s ++ fnl ()) | None -> () exception End_of_input @@ -152,9 +151,9 @@ let pr_new_syntax loc ocom = | Some com -> Ppvernac.pr_vernac com | None -> mt() in if !beautify_file then - msg (hov 0 (comment (fst loc) ++ com ++ comment (snd loc))) + Feedback.msg_notice (hov 0 (comment (fst loc) ++ com ++ comment (snd loc))) else - msg_info (hov 4 (str"New Syntax:" ++ fnl() ++ (hov 0 com))); + Feedback.msg_info (hov 4 (str"New Syntax:" ++ fnl() ++ (hov 0 com))); States.unfreeze fs; Format.set_formatter_out_channel stdout @@ -193,14 +192,15 @@ let display_cmd_header loc com = with e -> str (Printexc.to_string e) in let cmd = noblank (shorten (string_of_ppcmds (safe_pr_vernac com))) in - Pp.pp (str "Chars " ++ int start ++ str " - " ++ int stop ++ - str " [" ++ str cmd ++ str "] "); - Pp.flush_all () + Feedback.msg_notice + (str "Chars " ++ int start ++ str " - " ++ int stop ++ + str " [" ++ str cmd ++ str "] ") + let rec vernac_com verbose checknav (loc,com) = let interp = function | VernacLoad (verbosely, fname) -> - let fname = Envars.expand_path_macros ~warn:(fun x -> msg_warning (str x)) fname in + let fname = Envars.expand_path_macros ~warn:(fun x -> Feedback.msg_warning (str x)) fname in let fname = CUnix.make_suffix fname ".v" in let f = Loadpath.locate_file fname in let st = save_translator_coqdoc () in @@ -248,8 +248,7 @@ and read_vernac_file verbosely s = * raised, which means that we raised the end of the file being loaded *) while true do let loc_ast = parse_sentence input in - vernac_com verbosely checknav loc_ast; - pp_flush () + vernac_com verbosely checknav loc_ast done with any -> (* whatever the exception *) let (e, info) = Errors.push any in @@ -294,7 +293,7 @@ let load_vernac verb file = let ensure_ext ext f = if Filename.check_suffix f ext then f else begin - msg_warning (str "File \"" ++ str f ++ strbrk "\" has been implicitly \ + Feedback.msg_warning (str "File \"" ++ str f ++ strbrk "\" has been implicitly \ expanded to \"" ++ str f ++ str ext ++ str "\""); f ^ ext end @@ -303,9 +302,9 @@ let ensure_bname src tgt = let src, tgt = Filename.basename src, Filename.basename tgt in let src, tgt = Filename.chop_extension src, Filename.chop_extension tgt in if src <> tgt then begin - msg_error (str "Source and target file names must coincide, directories can differ"); - msg_error (str "Source: " ++ str src); - msg_error (str "Target: " ++ str tgt); + Feedback.msg_error (str "Source and target file names must coincide, directories can differ"); + Feedback.msg_error (str "Source: " ++ str src); + Feedback.msg_error (str "Target: " ++ str tgt); flush_all (); exit 1 end @@ -318,7 +317,7 @@ let ensure_vio v vio = ensure ".vio" v vio let ensure_exists f = if not (Sys.file_exists f) then begin - msg_error (hov 0 (str "Can't find file" ++ spc () ++ str f)); + Feedback.msg_error (hov 0 (str "Can't find file" ++ spc () ++ str f)); exit 1 end @@ -327,7 +326,7 @@ let compile verbosely f = let check_pending_proofs () = let pfs = Pfedit.get_all_proof_names () in if not (List.is_empty pfs) then - (msg_error (str "There are pending proofs"); flush_all (); exit 1) in + (Feedback.msg_error (str "There are pending proofs"); flush_all (); exit 1) in match !Flags.compilation_mode with | BuildVo -> let long_f_dot_v = ensure_v f in diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index 23755dac1d..222b7d3df1 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -57,7 +57,7 @@ let show_proof () = (* spiwack: this would probably be cooler with a bit of polishing. *) let p = Proof_global.give_me_the_proof () in let pprf = Proof.partial_proof p in - msg_notice (Pp.prlist_with_sep Pp.fnl Printer.pr_constr pprf) + Feedback.msg_notice (Pp.prlist_with_sep Pp.fnl Printer.pr_constr pprf) let show_node () = (* spiwack: I'm have little clue what this function used to do. I deactivated it, @@ -65,22 +65,22 @@ let show_node () = () let show_thesis () = - msg_error (anomaly (Pp.str "TODO") ) + Feedback.msg_error (anomaly (Pp.str "TODO") ) let show_top_evars () = (* spiwack: new as of Feb. 2010: shows goal evars in addition to non-goal evars. *) let pfts = get_pftreestate () in let gls = Proof.V82.subgoals pfts in let sigma = gls.Evd.sigma in - msg_notice (pr_evars_int sigma 1 (Evarutil.non_instantiated sigma)) + Feedback.msg_notice (pr_evars_int sigma 1 (Evarutil.non_instantiated sigma)) let show_universes () = let pfts = get_pftreestate () in let gls = Proof.V82.subgoals pfts in let sigma = gls.Evd.sigma in let ctx = Evd.universe_context_set (Evd.nf_constraints sigma) in - msg_notice (Evd.pr_evar_universe_context (Evd.evar_universe_context sigma)); - msg_notice (str"Normalized constraints: " ++ Univ.pr_universe_context_set (Evd.pr_evd_level sigma) ctx) + Feedback.msg_notice (Evd.pr_evar_universe_context (Evd.evar_universe_context sigma)); + Feedback.msg_notice (str"Normalized constraints: " ++ Univ.pr_universe_context_set (Evd.pr_evd_level sigma) ctx) let show_prooftree () = (* Spiwack: proof tree is currently not working *) @@ -91,11 +91,10 @@ let enable_goal_printing = ref true let print_subgoals () = if !enable_goal_printing && is_verbose () then begin - msg_notice (pr_open_subgoals ()) + Feedback.msg_notice (pr_open_subgoals ()) end let try_print_subgoals () = - Pp.flush_all(); try print_subgoals () with Proof_global.NoCurrentProof | UserError _ -> () @@ -109,10 +108,10 @@ let show_intro all = let l,_= decompose_prod_assum (strip_outer_cast (pf_concl gl)) in if all then let lid = Tactics.find_intro_names l gl in - msg_notice (hov 0 (prlist_with_sep spc pr_id lid)) + Feedback.msg_notice (hov 0 (prlist_with_sep spc pr_id lid)) else if not (List.is_empty l) then let n = List.last l in - msg_notice (pr_id (List.hd (Tactics.find_intro_names [n] gl))) + Feedback.msg_notice (pr_id (List.hd (Tactics.find_intro_names [n] gl))) end (** Prepare a "match" template for a given inductive type. @@ -153,7 +152,7 @@ let show_match id = let pr_branch l = str "| " ++ hov 1 (prlist_with_sep spc str l) ++ str " =>" in - msg_notice (v 1 (str "match # with" ++ fnl () ++ + Feedback.msg_notice (v 1 (str "match # with" ++ fnl () ++ prlist_with_sep fnl pr_branch patterns ++ fnl () ++ str "end" ++ fnl ())) (* "Print" commands *) @@ -194,23 +193,23 @@ let print_module r = let globdir = Nametab.locate_dir qid in match globdir with DirModule (dirpath,(mp,_)) -> - msg_notice (Printmod.print_module (Printmod.printable_body dirpath) mp) + Feedback.msg_notice (Printmod.print_module (Printmod.printable_body dirpath) mp) | _ -> raise Not_found with - Not_found -> msg_error (str"Unknown Module " ++ pr_qualid qid) + Not_found -> Feedback.msg_error (str"Unknown Module " ++ pr_qualid qid) let print_modtype r = let (loc,qid) = qualid_of_reference r in try let kn = Nametab.locate_modtype qid in - msg_notice (Printmod.print_modtype kn) + Feedback.msg_notice (Printmod.print_modtype kn) with Not_found -> (* Is there a module of this name ? If yes we display its type *) try let mp = Nametab.locate_module qid in - msg_notice (Printmod.print_module false mp) + Feedback.msg_notice (Printmod.print_module false mp) with Not_found -> - msg_error (str"Unknown Module Type or Module " ++ pr_qualid qid) + Feedback.msg_error (str"Unknown Module Type or Module " ++ pr_qualid qid) let print_namespace ns = let ns = List.rev (Names.DirPath.repr ns) in @@ -279,7 +278,7 @@ let print_namespace ns = acc ) constants (str"") in - msg_notice ((print_list pr_id ns)++str":"++fnl()++constants_in_namespace) + Feedback.msg_notice ((print_list pr_id ns)++str":"++fnl()++constants_in_namespace) let print_strategy r = let open Conv_oracle in @@ -309,7 +308,7 @@ let print_strategy r = else str "Constant strategies" ++ fnl () ++ hov 0 (prlist_with_sep fnl pr_strategy cst_lvl) in - msg_notice (var_msg ++ cst_msg) + Feedback.msg_notice (var_msg ++ cst_msg) | Some r -> let r = Smartlocate.smart_global r in let key = match r with @@ -318,7 +317,7 @@ let print_strategy r = | IndRef _ | ConstructRef _ -> error "The reference is not unfoldable" in let lvl = get_strategy oracle key in - msg_notice (pr_strategy (r, lvl)) + Feedback.msg_notice (pr_strategy (r, lvl)) let dump_universes_gen g s = let output = open_out s in @@ -352,7 +351,7 @@ let dump_universes_gen g s = try UGraph.dump_universes output_constraint g; close (); - msg_info (str "Universes written to file \"" ++ str s ++ str "\".") + Feedback.msg_info (str "Universes written to file \"" ++ str s ++ str "\".") with reraise -> let reraise = Errors.push reraise in close (); @@ -367,11 +366,11 @@ let locate_file f = let msg_found_library = function | Library.LibLoaded, fulldir, file -> - msg_info (hov 0 + Feedback.msg_info (hov 0 (pr_dirpath fulldir ++ strbrk " has been loaded from file " ++ str file)) | Library.LibInPath, fulldir, file -> - msg_info (hov 0 + Feedback.msg_info (hov 0 (pr_dirpath fulldir ++ strbrk " is bound to file " ++ str file)) let err_unmapped_library loc ?from qid = @@ -506,7 +505,7 @@ let vernac_exact_proof c = called only at the begining of a proof. *) let status = by (Tactics.exact_proof c) in save_proof (Vernacexpr.(Proved(Opaque None,None))); - if not status then Pp.feedback Feedback.AddedAxiom + if not status then Feedback.feedback Feedback.AddedAxiom let vernac_assumption locality poly (local, kind) l nl = let local = enforce_locality_exp locality local in @@ -518,7 +517,7 @@ let vernac_assumption locality poly (local, kind) l nl = if global then Dumpglob.dump_definition lid false "ax" else Dumpglob.dump_definition lid true "var") idl) l; let status = do_assumptions kind nl l in - if not status then Pp.feedback Feedback.AddedAxiom + if not status then Feedback.feedback Feedback.AddedAxiom let vernac_record k poly finite struc binders sort nameopt cfs = let const = match nameopt with @@ -636,7 +635,7 @@ let vernac_declare_module export (loc, id) binders_ast mty_ast = id binders_ast (Enforce mty_ast) [] in Dumpglob.dump_moddef loc mp "mod"; - if_verbose msg_info (str "Module " ++ pr_id id ++ str " is declared"); + if_verbose Feedback.msg_info (str "Module " ++ pr_id id ++ str " is declared"); Option.iter (fun export -> vernac_import export [Ident (Loc.ghost,id)]) export let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l = @@ -657,7 +656,7 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l = export id binders_ast mty_ast_o in Dumpglob.dump_moddef loc mp "mod"; - if_verbose msg_info + if_verbose Feedback.msg_info (str "Interactive Module " ++ pr_id id ++ str " started"); List.iter (fun (export,id) -> @@ -675,7 +674,7 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l = id binders_ast mty_ast_o mexpr_ast_l in Dumpglob.dump_moddef loc mp "mod"; - if_verbose msg_info + if_verbose Feedback.msg_info (str "Module " ++ pr_id id ++ str " is defined"); Option.iter (fun export -> vernac_import export [Ident (Loc.ghost,id)]) export @@ -683,7 +682,7 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l = let vernac_end_module export (loc,id as lid) = let mp = Declaremods.end_module () in Dumpglob.dump_modref loc mp "mod"; - if_verbose msg_info (str "Module " ++ pr_id id ++ str " is defined"); + if_verbose Feedback.msg_info (str "Module " ++ pr_id id ++ str " is defined"); Option.iter (fun export -> vernac_import export [Ident lid]) export let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l = @@ -704,7 +703,7 @@ let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l = id binders_ast mty_sign in Dumpglob.dump_moddef loc mp "modtype"; - if_verbose msg_info + if_verbose Feedback.msg_info (str "Interactive Module Type " ++ pr_id id ++ str " started"); List.iter (fun (export,id) -> @@ -723,13 +722,13 @@ let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l = id binders_ast mty_sign mty_ast_l in Dumpglob.dump_moddef loc mp "modtype"; - if_verbose msg_info + if_verbose Feedback.msg_info (str "Module Type " ++ pr_id id ++ str " is defined") let vernac_end_modtype (loc,id) = let mp = Declaremods.end_modtype () in Dumpglob.dump_modref loc mp "modtype"; - if_verbose msg_info (str "Module Type " ++ pr_id id ++ str " is defined") + if_verbose Feedback.msg_info (str "Module Type " ++ pr_id id ++ str " is defined") let vernac_include l = Declaremods.declare_include Modintern.interp_module_ast l @@ -797,7 +796,7 @@ let vernac_coercion locality poly local ref qids qidt = let source = cl_of_qualid qids in let ref' = smart_global ref in Class.try_add_new_coercion_with_target ref' ~local poly ~source ~target; - if_verbose msg_info (pr_global ref' ++ str " is now a coercion") + if_verbose Feedback.msg_info (pr_global ref' ++ str " is now a coercion") let vernac_identity_coercion locality poly local id qids qidt = let local = enforce_locality locality local in @@ -813,7 +812,7 @@ let vernac_instance abst locality poly sup inst props pri = ignore(Classes.new_instance ~abstract:abst ~global poly sup inst props pri) let vernac_context poly l = - if not (Classes.context poly l) then Pp.feedback Feedback.AddedAxiom + if not (Classes.context poly l) then Feedback.feedback Feedback.AddedAxiom let vernac_declare_instances locality ids pri = let glob = not (make_section_locality locality) in @@ -869,7 +868,7 @@ let vernac_set_used_variables e = (* Auxiliary file management *) let expand filename = - Envars.expand_path_macros ~warn:(fun x -> msg_warning (str x)) filename + Envars.expand_path_macros ~warn:(fun x -> Feedback.msg_warning (str x)) filename let vernac_add_loadpath implicit pdir ldiropt = let pdir = expand pdir in @@ -889,13 +888,13 @@ let vernac_declare_ml_module locality l = Mltop.declare_ml_modules local (List.map expand l) let vernac_chdir = function - | None -> msg_notice (str (Sys.getcwd())) + | None -> Feedback.msg_notice (str (Sys.getcwd())) | Some path -> begin try Sys.chdir (expand path) - with Sys_error err -> msg_warning (str "Cd failed: " ++ str err) + with Sys_error err -> Feedback.msg_warning (str "Cd failed: " ++ str err) end; - if_verbose msg_info (str (Sys.getcwd())) + if_verbose Feedback.msg_info (str (Sys.getcwd())) (********************) @@ -1068,7 +1067,7 @@ let vernac_declare_arguments locality r l nargs flags = some_scopes_specified || some_simpl_flags_specified) && no_flags then - msg_warning (strbrk "This command is just asserting the number and names of arguments of " ++ pr_global sr ++ strbrk". 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'") + Feedback.msg_warning (strbrk "This command is just asserting the number and names of arguments of " ++ pr_global sr ++ strbrk". 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'") let default_env () = { @@ -1423,7 +1422,7 @@ let vernac_check_may_eval redexp glopt rc = | None -> let l = Evar.Set.union (Evd.evars_of_term j.Environ.uj_val) (Evd.evars_of_term j.Environ.uj_type) in let j = { j with Environ.uj_type = Reductionops.nf_betaiota sigma' j.Environ.uj_type } in - msg_notice (print_judgment env sigma' j ++ + Feedback.msg_notice (print_judgment env sigma' j ++ pr_ne_evar_set (fnl () ++ str "where" ++ fnl ()) (mt ()) sigma' l ++ Printer.pr_universe_ctx sigma uctx) | Some r -> @@ -1434,7 +1433,7 @@ let vernac_check_may_eval redexp glopt rc = let Sigma (c, _, _) = redfun.Reductionops.e_redfun env evm c in c in - msg_notice (print_eval redfun env sigma' rc j) + Feedback.msg_notice (print_eval redfun env sigma' rc j) let vernac_declare_reduction locality s r = let local = make_locality locality in @@ -1450,7 +1449,7 @@ let vernac_global_check c = let senv = Safe_typing.add_constraints cstrs senv in let j = Safe_typing.typing senv c in let env = Safe_typing.env_of_safe_env senv in - msg_notice (print_safe_judgment env sigma j) + Feedback.msg_notice (print_safe_judgment env sigma j) let get_nth_goal n = @@ -1487,7 +1486,7 @@ let print_about_hyp_globs ref_or_by_not glnumopt = | NoHyp | Not_found -> print_about ref_or_by_not -let vernac_print = function +let vernac_print = let open Feedback in function | PrintTables -> msg_notice (print_tables ()) | PrintFullContext-> msg_notice (print_full_context_typ ()) | PrintSectionContext qid -> msg_notice (print_sec_context_typ qid) @@ -1586,6 +1585,7 @@ 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 match s with | SearchPattern c -> msg_notice (Search.search_pattern gopt (get_pattern c) r) @@ -1596,8 +1596,8 @@ let vernac_search s gopt r = | SearchAbout sl -> msg_notice (Search.search_about gopt (List.map (on_snd (interp_search_about_item env)) sl) r) -let vernac_locate = function - | LocateAny (AN qid) -> msg_notice (print_located_qualid qid) +let vernac_locate = let open Feedback in function + | LocateAny (AN qid) -> msg_notice (print_located_qualid qid) | LocateTerm (AN qid) -> msg_notice (print_located_term qid) | LocateAny (ByNotation (_, ntn, sc)) (** TODO : handle Ltac notations *) | LocateTerm (ByNotation (_, ntn, sc)) -> @@ -1640,7 +1640,7 @@ let vernac_unfocus () = let vernac_unfocused () = let p = Proof_global.give_me_the_proof () in if Proof.unfocused p then - msg_notice (str"The proof is indeed fully unfocused.") + Feedback.msg_notice (str"The proof is indeed fully unfocused.") else error "The proof is not fully unfocused." @@ -1668,7 +1668,7 @@ let vernac_bullet (bullet:Proof_global.Bullet.t) = Proof_global.simple_with_current_proof (fun _ p -> Proof_global.Bullet.put p bullet) -let vernac_show = function +let vernac_show = let open Feedback in function | ShowGoal goalref -> let info = match goalref with | OpenSubgoals -> pr_open_subgoals () @@ -1706,7 +1706,7 @@ let vernac_check_guard () = with UserError(_,s) -> (str ("Condition violated: ") ++s) in - msg_notice message + Feedback.msg_notice message exception End_of_input @@ -1717,7 +1717,7 @@ let vernac_load interp fname = | Some x -> x | None -> raise End_of_input) in let fname = - Envars.expand_path_macros ~warn:(fun x -> msg_warning (str x)) fname in + Envars.expand_path_macros ~warn:(fun x -> Feedback.msg_warning (str x)) fname in let fname = CUnix.make_suffix fname ".v" in let input = let longfname = Loadpath.locate_file fname in @@ -1849,15 +1849,15 @@ let interp ?proof ~loc locality poly c = | VernacSearch (s,g,r) -> vernac_search s g r | VernacLocate l -> vernac_locate l | VernacRegister (id, r) -> vernac_register id r - | VernacComments l -> if_verbose msg_info (str "Comments ok\n") + | VernacComments l -> if_verbose Feedback.msg_info (str "Comments ok\n") (* The STM should handle that, but LOAD bypasses the STM... *) - | VernacAbort id -> msg_warning (str "VernacAbort not handled by Stm") - | VernacAbortAll -> msg_warning (str "VernacAbortAll not handled by Stm") - | VernacRestart -> msg_warning (str "VernacRestart not handled by Stm") - | VernacUndo _ -> msg_warning (str "VernacUndo not handled by Stm") - | VernacUndoTo _ -> msg_warning (str "VernacUndoTo not handled by Stm") - | VernacBacktrack _ -> msg_warning (str "VernacBacktrack not handled by Stm") + | VernacAbort id -> Feedback.msg_warning (str "VernacAbort not handled by Stm") + | VernacAbortAll -> Feedback.msg_warning (str "VernacAbortAll not handled by Stm") + | VernacRestart -> Feedback.msg_warning (str "VernacRestart not handled by Stm") + | VernacUndo _ -> Feedback.msg_warning (str "VernacUndo not handled by Stm") + | VernacUndoTo _ -> Feedback.msg_warning (str "VernacUndoTo not handled by Stm") + | VernacBacktrack _ -> Feedback.msg_warning (str "VernacBacktrack not handled by Stm") (* Proof management *) | VernacGoal t -> vernac_start_proof locality poly Theorem [None,([],t,None)] false @@ -1991,7 +1991,7 @@ let with_fail b f = | HasNotFailed -> errorlabstrm "Fail" (str "The command has not failed!") | HasFailed msg -> - if is_verbose () || !test_mode || !ide_slave then msg_info + if is_verbose () || !test_mode || !ide_slave then Feedback.msg_info (str "The command has indeed failed with message:" ++ fnl () ++ msg) | _ -> assert false end @@ -2016,7 +2016,7 @@ let interp ?(verbosely=true) ?proof (loc,c) = current_timeout := Some n; aux ?locality ?polymorphism isprogcmd v | VernacRedirect (s, (_,v)) -> - Pp.with_output_to_file s (aux false) v + Feedback.with_output_to_file s (aux false) v | VernacTime (_,v) -> System.with_time !Flags.time (aux ?locality ?polymorphism isprogcmd) v; diff --git a/toplevel/vernacinterp.ml b/toplevel/vernacinterp.ml index 7fbd2b1196..1116a31046 100644 --- a/toplevel/vernacinterp.ml +++ b/toplevel/vernacinterp.ml @@ -55,7 +55,7 @@ let call ?locality (opn,converted_args) = | Egramml.GramNonTerminal _ -> str "_" in let pr = pr_sequence pr_gram rules in - msg_warning (str "Deprecated vernacular command: " ++ pr) + Feedback.msg_warning (str "Deprecated vernacular command: " ++ pr) in loc:= "Checking arguments"; let hunk = callback converted_args in @@ -68,5 +68,5 @@ let call ?locality (opn,converted_args) = | reraise -> let reraise = Errors.push reraise in if !Flags.debug then - msg_debug (str"Vernac Interpreter " ++ str !loc); + Feedback.msg_debug (str"Vernac Interpreter " ++ str !loc); iraise reraise |