diff options
187 files changed, 3940 insertions, 2623 deletions
diff --git a/.gitignore b/.gitignore index 116f88dd7e..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 @@ -114,7 +113,7 @@ tools/ocamllibdep.ml tools/coqdoc/cpretty.ml ide/xml_lexer.ml -# .ml4 files +# .ml4 / .mlp files g_*.ml @@ -128,6 +127,7 @@ parsing/cLexer.ml ltac/coretactics.ml ltac/extratactics.ml ltac/extraargs.ml +ltac/profile_ltac_tactics.ml ide/coqide_main.ml # other auto-generated files @@ -138,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 @@ -31,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 ============================ @@ -66,7 +66,7 @@ endef ## Files in the source tree LEXFILES := $(call find, '*.mll') -export MLLIBFILES := $(call find, '*.mllib') +export MLLIBFILES := $(call find, '*.mllib') $(call find, '*.mlpack') export ML4FILES := $(call find, '*.ml4') export CFILES := $(call find, '*.c') @@ -80,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) @@ -153,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 @@ -173,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) @@ -206,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: @@ -236,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 fc92507e69..2a2eb8796d 100644 --- a/Makefile.build +++ b/Makefile.build @@ -10,30 +10,40 @@ # 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 ########################################################################### -include Makefile.common -include Makefile.doc - +# 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) -DEPENDENCIES := \ - $(addsuffix .d, $(MLFILES) $(MLIFILES) $(MLLIBFILES) $(CFILES) $(VFILES)) -# This include below will lauch the build of all concerned .d. +include Makefile.common +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 + +# 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). +DEPENDENCIES := \ + $(addsuffix .d, $(MLFILES) $(MLIFILES) $(MLLIBFILES) $(CFILES) $(VFILES)) + -include $(DEPENDENCIES) # All dependency includes must be declared secondary, otherwise make will @@ -43,7 +53,6 @@ DEPENDENCIES := \ .SECONDARY: $(DEPENDENCIES) $(GENFILES) $(ML4FILES:.ml4=.ml) - ########################################################################### # Compilation options ########################################################################### @@ -56,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) @@ -75,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 @@ -104,12 +112,32 @@ LINKMETADATA= 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),\ $(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) $(LINKMETADATA) -o $@ $(1) $(addsuffix .cmxa,$(2)) $^ && $(STRIP) $@ && $(CODESIGN) $@,\ $(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) $(CUSTOM) -o $@ $(1) $(addsuffix .cma,$(2)) $^) endef +# 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) @@ -172,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 @@ -186,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) @@ -195,6 +220,17 @@ 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) ########################################################################### # grammar/grammar.cma @@ -207,8 +243,7 @@ kernel/copcodes.ml: kernel/byterun/coq_instruct.h ## Explicit dependencies for grammar stuff GRAMBASEDEPS := grammar/gramCompat.cmo grammar/q_util.cmi -GRAMCMO := \ - grammar/gramCompat.cmo grammar/q_util.cmo \ +GRAMCMO := grammar/gramCompat.cmo grammar/q_util.cmo \ grammar/argextend.cmo grammar/tacextend.cmo grammar/vernacextend.cmo grammar/q_util.cmi : grammar/gramCompat.cmo @@ -227,10 +262,9 @@ GRAMC := $(OCAMLFIND) ocamlc $(CAMLFLAGS) $(CAMLDEBUG) $(USERFLAGS) \ grammar/grammar.cma : $(GRAMCMO) $(SHOW)'Testing $@' - @touch test.mlp - $(HIDE)$(CAMLP4O) -I $(MYCAMLP4LIB) $^ -impl test.mlp -o test.ml - $(HIDE)$(GRAMC) test.ml -o test-grammar - @rm -f test-grammar test.* + @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 $@ @@ -266,25 +300,16 @@ grammar/%.cmi: grammar/%.mli # Main targets (coqmktop, coqtop.opt, coqtop.byte) ########################################################################### -.PHONY: coqbinaries coq coqlib coqlight states - -coqbinaries: ${COQBINARIES} ${CSDPCERT} ${FAKEIDE} +.PHONY: coqbinaries -coq: coqlib tools coqbinaries +coqbinaries: $(COQMKTOP) $(COQTOPEXE) $(COQTOPBYTE) \ + $(CHICKEN) $(CHICKENBYTE) $(CSDPCERT) $(FAKEIDE) -coqlib: theories plugins - -coqlight: theories-light tools coqbinaries - -states: theories/Init/Prelude.vo - -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 @@ -294,28 +319,13 @@ endif $(COQTOPBYTE): $(COQMKTOP) $(LINKCMO) $(LIBCOQRUN) $(TOPLOOPCMA) $(SHOW)'COQMKTOP -o $@' - $(HIDE)$(COQMKTOP) -boot -top $(BYTEFLAGS) -thread -o $@ - -LOCALCHKLIBS:=$(addprefix -I , $(CHKSRCDIRS) ) -CHKLIBS:=$(LOCALCHKLIBS) -I $(MYCAMLP4LIB) + $(HIDE)$(COQMKTOP) -boot -top $(BYTEFLAGS) -o $@ -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)) @@ -326,351 +336,19 @@ tools/tolink.ml: Makefile.build Makefile.common $(HIDE)echo "let core_objs = \""$(OBJSMOD)"\"" >> $@ # coqc -$(COQC): $(patsubst %.cma,%$(BESTLIB),$(COQCCMO:.cmo=$(BESTOBJ))) - $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml, $(OSDEPLIBS), $(SYSMOD)) - -# Target for libraries .cma and .cmxa - -# 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. - -%.cma: %.mllib - $(SHOW)'OCAMLC -a -o $@' - $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -a -o $@ $(filter-out %.mllib, $^) - -%.cmxa: %.mllib - $(SHOW)'OCAMLOPT -a -o $@' - $(HIDE)$(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) -a -o $@ $(filter-out %.mllib, $^) -# For the checker, different flags may be used +COQCCMO:=lib/clib.cma lib/errors.cmo toplevel/usage.cmo tools/coqc.cmo -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, $^) - -########################################################################### -# Csdp to micromega special targets -########################################################################### - -plugins/micromega/csdpcert$(EXE): $(CSDPCERTCMO:.cmo=$(BESTOBJ)) \ - $(addsuffix $(BESTLIB), lib/clib) +$(COQC): $(call bestobj, $(COQCCMO)) $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml,,nums unix clib) - -########################################################################### -# 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 - -COQIDEFLAGS=$(addprefix -I , $(IDESRCDIRS)) $(COQIDEINCLUDES) - -.SUFFIXES:.vo - -IDEFILES=$(wildcard ide/*.lang) ide/coq_style.xml ide/coq.png ide/MacOS/default_accel_map - -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) $^ - -# 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) $@ - -########################################################################### -# 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 - -VALIDOPTS=$(if $(VERBOSE),,-silent) -o -m - -validate: $(CHICKEN) | $(ALLVO) - $(SHOW)'COQCHK <theories & plugins>' - $(HIDE)$(CHICKEN) -boot $(VALIDOPTS) $(ALLMODS) - -$(ALLSTDLIB).v: - $(SHOW)'MAKE $(notdir $@)' - $(HIDE)echo "Require $(ALLMODS)." > $@ - -MAKE_TSOPTS=-C test-suite -s VERBOSE=$(VERBOSE) - -check: validate test-suite - -test-suite: world $(ALLSTDLIB).v - $(MAKE) $(MAKE_TSOPTS) clean - $(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 -########################################################################### - -.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) - $(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) + $(HIDE)$(call bestocaml, $(OSDEPLIBS), $(SYSMOD)) ########################################################################### -# tools +# other tools ########################################################################### -.PHONY: printers tools - -printers: $(DEBUGPRINTERS) - -tools: $(TOOLS) $(DEBUGPRINTERS) $(OCAMLLIBDEP) +.PHONY: tools +tools: $(TOOLS) $(OCAMLLIBDEP) $(COQDEPBOOT) # coqdep_boot : a basic version of coqdep, with almost no dependencies. @@ -696,355 +374,149 @@ $(OCAMLLIBDEP): tools/ocamllibdep.ml # The full coqdep (unused by this build, but distributed by make install) -$(COQDEP): $(patsubst %.cma,%$(BESTLIB),$(COQDEPCMO:.cmo=$(BESTOBJ))) +COQDEPCMO:=lib/clib.cma lib/errors.cmo lib/minisys.cmo lib/system.cmo \ + tools/coqdep_lexer.cmo tools/coqdep_common.cmo tools/coqdep.cmo + +$(COQDEP): $(call bestobj, $(COQDEPCMO)) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml, $(OSDEPLIBS), $(SYSMOD)) -$(GALLINA): $(addsuffix $(BESTOBJ), tools/gallina_lexer tools/gallina) +$(GALLINA): $(call bestobj, tools/gallina_lexer.cmo tools/gallina.cmo) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml,,) -$(COQMAKEFILE): $(patsubst %.cma,%$(BESTLIB),$(COQMAKEFILECMO:.cmo=$(BESTOBJ))) +COQMAKEFILECMO:=lib/clib.cma ide/project_file.cmo tools/coq_makefile.cmo + +$(COQMAKEFILE): $(call bestobj,$(COQMAKEFILECMO)) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml,,str unix threads) -$(COQTEX): tools/coq_tex$(BESTOBJ) +$(COQTEX): $(call bestobj, tools/coq_tex.cmo) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml,,str) -$(COQWC): tools/coqwc$(BESTOBJ) +$(COQWC): $(call bestobj, tools/coqwc.cmo) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml,,) -$(COQDOC): $(patsubst %.cma,%$(BESTLIB),$(COQDOCCMO:.cmo=$(BESTOBJ))) +COQDOCCMO:=lib/clib.cma $(addprefix tools/coqdoc/, \ + cdglobals.cmo alpha.cmo index.cmo tokens.cmo output.cmo cpretty.cmo main.cmo ) + +$(COQDOC): $(call bestobj, $(COQDOCCMO)) $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml,,str unix) -$(COQWORKMGR): $(addsuffix $(BESTOBJ), stm/coqworkmgrApi tools/coqworkmgr) \ - $(addsuffix $(BESTLIB), lib/clib) +$(COQWORKMGR): $(call bestobj, lib/clib.cma stm/coqworkmgrApi.cmo tools/coqworkmgr.cmo) $(SHOW)'OCAMLBEST -o $@' - $(HIDE)$(call bestocaml,, $(SYSMOD) clib) + $(HIDE)$(call bestocaml,, $(SYSMOD)) # fake_ide : for debugging or test-suite purpose, a fake ide simulating # a connection to coqtop -ideslave -$(FAKEIDE): lib/clib$(BESTLIB) lib/errors$(BESTOBJ) \ - lib/spawn$(BESTOBJ) ide/document$(BESTOBJ) \ - ide/serialize$(BESTOBJ) ide/xml_lexer$(BESTOBJ) \ - ide/xml_parser$(BESTOBJ) ide/xml_printer$(BESTOBJ) \ - ide/xmlprotocol$(BESTOBJ) tools/fake_ide$(BESTOBJ) | \ - $(IDETOPLOOPCMA:.cma=$(BESTDYN)) +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 + +$(FAKEIDE): $(call bestobj, $(FAKEIDECMO)) | $(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 +bin/votour: $(call bestobj, lib/cObj.cmo checker/analyze.cmo checker/values.cmo) checker/votour.ml $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml, -I checker,) -# Special rule for the compatibility-with-camlp5 extension for camlp4 - -ifeq ($(CAMLP4),camlp4) -tools/compat5.cmo: tools/compat5.mlp - $(OCAMLC) -c -I $(MYCAMLP4LIB) -pp '$(CAMLP4O) $(CAMLP4FLAGS) -impl' -impl $< -tools/compat5b.cmo: tools/compat5b.mlp - $(OCAMLC) -c -I $(MYCAMLP4LIB) -pp '$(CAMLP4O) $(CAMLP4FLAGS) -impl' -impl $< -else -tools/compat5.cmo: tools/compat5.ml - $(OCAMLC) -c $< -endif - ########################################################################### -# Documentation : cf Makefile.doc +# Csdp to micromega special targets ########################################################################### -documentation: doc-$(WITHDOC) -doc-all: doc -doc-no: +CSDPCERTCMO:=lib/clib.cma $(addprefix plugins/micromega/, \ + mutils.cmo micromega.cmo \ + sos_types.cmo sos_lib.cmo sos.cmo csdpcert.cmo ) -.PHONY: documentation doc-all doc-no +$(CSDPCERT): $(call bestobj, $(CSDPCERTCMO)) + $(SHOW)'OCAMLBEST -o $@' + $(HIDE)$(call bestocaml,,nums unix) ########################################################################### -# Installation +# tests ########################################################################### -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: validate check test-suite $(ALLSTDLIB).v -.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 +VALIDOPTS=$(if $(VERBOSE),,-silent) -o -m -install-coq: install-binaries install-library install-coq-info install-devfiles -install-coqlight: install-binaries install-library-light +validate: $(CHICKEN) | $(ALLVO) + $(SHOW)'COQCHK <theories & plugins>' + $(HIDE)$(CHICKEN) -boot $(VALIDOPTS) $(ALLMODS) -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 +$(ALLSTDLIB).v: + $(SHOW)'MAKE $(notdir $@)' + $(HIDE)echo "Require $(ALLMODS)." > $@ +MAKE_TSOPTS=-C test-suite -s VERBOSE=$(VERBOSE) -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) +check: validate test-suite -# The list of .cmi to install, including the ones obtained -# from .mli without .ml, and the ones obtained from .ml without .mli +test-suite: world $(ALLSTDLIB).v + $(MAKE) $(MAKE_TSOPTS) clean + $(MAKE) $(MAKE_TSOPTS) all + $(MAKE) $(MAKE_TSOPTS) report -INSTALLCMI = $(sort \ - $(filter-out checker/% ide/% tools/%, $(MLIFILES:.mli=.cmi)) \ - $(foreach lib,$(CORECMA) $(PLUGINSCMA), $(addsuffix .cmi,$($(lib:.cma=_MLLIB_DEPENDENCIES))))) +########################################################################### +### Special rules (Camlp5 / Camlp4) +########################################################################### -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 +# Special rule for the compatibility-with-camlp5 extension for camlp4 -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) +ifeq ($(CAMLP4),camlp4) +tools/compat5.cmo: tools/compat5.mlp + $(OCAMLC) -c -I $(MYCAMLP4LIB) -pp '$(CAMLP4O) $(CAMLP4FLAGS) -impl' -impl $< +tools/compat5b.cmo: tools/compat5b.mlp + $(OCAMLC) -c -I $(MYCAMLP4LIB) -pp '$(CAMLP4O) $(CAMLP4FLAGS) -impl' -impl $< +else +tools/compat5.cmo: tools/compat5.ml + $(OCAMLC) -c $< 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) +# Default rules for compiling ML code ########################################################################### -.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 $@ $< +# Target for libraries .cma and .cmxa -$(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) +# 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. -########################################################################### -### Special rules -########################################################################### +%.cma: %.mllib + $(SHOW)'OCAMLC -a -o $@' + $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -a -o $@ $(filter-out %.mllib, $^) -dev/printers.cma: dev/printers.mllib - $(SHOW)'Testing $@' - $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -thread $(SYSCMA) $(P4CMA) $(filter-out %.mllib, $^) -o test-printer - @rm -f test-printer - $(SHOW)'OCAMLC -a $@' - $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -thread $(SYSCMA) $(P4CMA) $(filter-out %.mllib, $^) -linkall -a -o $@ +%.cmxa: %.mllib + $(SHOW)'OCAMLOPT -a -o $@' + $(HIDE)$(OCAMLOPT) $(MLINCLUDES) $(OPTFLAGS) -a -o $@ $(filter-out %.mllib, $^) -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 +# For plugin packs : -########################################################################### -# Default rules -########################################################################### +%.cmo: %.mlpack + $(SHOW)'OCAMLC -pack -o $@' + $(HIDE)$(OCAMLC) $(MLINCLUDES) $(BYTEFLAGS) -pack -o $@ $(filter-out %.mlpack, $^) -## 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 $(SHOW)'OCAMLC $<' @@ -1075,10 +547,26 @@ $(MLWITHOUTMLI:.ml=.cmx): %.cmx: %.cmi # for .ml with .mli this is already the $(MLWITHOUTMLI:.ml=.cmi): %.cmi: %.cmo +# 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) $($(@:.cmx=_FORPACK)) -c $< + %.cmx: %.ml $(SHOW)'OCAMLOPT $<' $(HIDE)$(OCAMLOPT) $(COND_OPTFLAGS) $(HACKMLI) -c $< +%.cmxs: %.cmx + $(SHOW)'OCAMLOPT -shared -o $@' + $(HIDE)$(OCAMLOPT) -shared -o $@ $< + %.cmxs: %.cmxa $(SHOW)'OCAMLOPT -shared -o $@' ifeq ($(HASNATDYNLINK),os5fixme) @@ -1087,105 +575,96 @@ else $(HIDE)$(OCAMLOPT) -linkall -shared -o $@ $< endif -%.cmxs: %.cmx - $(SHOW)'OCAMLOPT -shared -o $@' - $(HIDE)$(OCAMLOPT) -shared -o $@ $< - %.ml: %.mll $(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 $*)\"" >> $@ - %.ml: %.ml4 | $(CAMLP4DEPS) $(SHOW)'CAMLP4O $<' $(HIDE)$(CAMLP4O) $(CAMLP4FLAGS) $(PR_O) \ $(CAMLP4DEPS) $(CAMLP4USE) $(CAMLP4COMPAT) -impl $< -o $@ -%.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 +# Dependencies of ML code ########################################################################### -# 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) - -checker/%.mllib.d: $(D_DEPEND_BEFORE_SRC) checker/%.mllib $(D_DEPEND_AFTER_SRC) $(OCAMLLIBDEP) $(GENFILES) - $(SHOW)'OCAMLLIBDEP $<' - $(HIDE)$(OCAMLLIBDEP) $(LOCALCHKLIBS) "$<" $(TOTARGET) + $(HIDE)$(OCAMLDEP) $(DEPFLAGS) "$<" $(TOTARGET) -dev/%.mllib.d: $(D_DEPEND_BEFORE_SRC) dev/%.mllib $(D_DEPEND_AFTER_SRC) $(OCAMLLIBDEP) $(GENFILES) +%.mllib.d: $(D_DEPEND_BEFORE_SRC) %.mllib $(D_DEPEND_AFTER_SRC) $(OCAMLLIBDEP) $(GENFILES) $(SHOW)'OCAMLLIBDEP $<' - $(HIDE)$(OCAMLLIBDEP) $(DEPFLAGS) -I dev "$<" $(TOTARGET) + $(HIDE)$(OCAMLLIBDEP) $(DEPFLAGS) "$<" $(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) $(COQDEPBOOT) $(GENVFILES) - $(SHOW)'COQDEP $<' - $(HIDE)$(COQDEPBOOT) -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: coqlib theories plugins -.PHONY: devel otags -devel: $(DEBUGPRINTERS) +# One of the .v files is macro-generated -# 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))) +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 : ; + +# Final catch-all rule. +# Usually, 'make' would display such an error itself. +# But if the target has some declared dependencies (e.g. in a .d) +# but no building rule, 'make' succeeds silently (see bug #4812). +%: + @echo "Error: no rule to make target $@ (or missing .PHONY)" && false # 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 86a7ea8476..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,27 +52,6 @@ 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 \ @@ -76,82 +68,6 @@ SRCDIRS:=\ tools tools/coqdoc \ $(addprefix plugins/, $(PLUGINS)) -IDESRCDIRS:= $(CORESRCDIRS) ide ide/utils - -CHKSRCDIRS:= config lib checker - -########################################################################### -# Tools -########################################################################### - -COQDEP:=bin/coqdep$(EXE) -COQDEPBOOT:=bin/coqdep_boot$(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) $(COQDEPBOOT) - -########################################################################### -# 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) @@ -173,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) \ @@ -207,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:= @@ -228,43 +152,7 @@ endif endif LINKCMO:=$(CORECMA) $(STATICPLUGINS) -LINKCMX:=$(CORECMA:.cma=.cmxa) $(STATICPLUGINS:.cma=.cmxa) - -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 - -# 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/minisys.cmo 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 @@ -272,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..c50e42341e --- /dev/null +++ b/Makefile.ide @@ -0,0 +1,255 @@ +####################################################################### +# 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 +.PHONY: ide-toploop + +# 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 9f77416a02..0000000000 --- a/_tags +++ /dev/null @@ -1,75 +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/tacextend.ml4": use_compat5b -"grammar/vernacextend.ml4": use_compat5b - -<tactics/*.ml4>: use_grammar - -<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 -"stm": 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 93eb2a0d25..da3cd03161 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -303,7 +303,7 @@ let intern_from_file (dir, f) = 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 diff --git a/checker/check_stat.ml b/checker/check_stat.ml index a26c93a30d..a63705adcd 100644 --- a/checker/check_stat.ml +++ b/checker/check_stat.ml @@ -18,7 +18,7 @@ let print_memory_stat () = if !memory_stat then begin Format.printf "total heap size = %d kbytes\n" (CObj.heap_size_kb ()); Format.print_newline(); - flush_all() + Format.print_flush() end let output_context = ref false diff --git a/checker/checker.ml b/checker/checker.ml index 61b13c60bb..9d76fb09e6 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -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\ diff --git a/checker/esubst.ml b/checker/esubst.ml deleted file mode 120000 index b82bd24f1e..0000000000 --- a/checker/esubst.ml +++ /dev/null @@ -1 +0,0 @@ -../kernel/esubst.ml
\ No newline at end of file diff --git a/checker/esubst.mli b/checker/esubst.mli deleted file mode 120000 index e30eaae5d3..0000000000 --- a/checker/esubst.mli +++ /dev/null @@ -1 +0,0 @@ -../kernel/esubst.mli
\ No newline at end of file diff --git a/checker/names.ml b/checker/names.ml deleted file mode 120000 index f0bf2f83f6..0000000000 --- a/checker/names.ml +++ /dev/null @@ -1 +0,0 @@ -../kernel/names.ml
\ No newline at end of file diff --git a/checker/names.mli b/checker/names.mli deleted file mode 120000 index 10459f3b29..0000000000 --- a/checker/names.mli +++ /dev/null @@ -1 +0,0 @@ -../kernel/names.mli
\ No newline at end of file diff --git a/configure.ml b/configure.ml index ade43810b2..71502058fe 100644 --- a/configure.ml +++ b/configure.ml @@ -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/changes.txt b/dev/doc/changes.txt index 4a0130bef0..4135ddd2db 100644 --- a/dev/doc/changes.txt +++ b/dev/doc/changes.txt @@ -148,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 74b42842c3..e39b780723 100644 --- a/dev/printers.mllib +++ b/dev/printers.mllib @@ -189,7 +189,6 @@ Logic Refiner Clenv Evar_refiner -Proof_errors Refine Proof Proof_global 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/Extraction.tex b/doc/refman/Extraction.tex index a963662f64..9da23b54ed 100644 --- a/doc/refman/Extraction.tex +++ b/doc/refman/Extraction.tex @@ -3,7 +3,7 @@ \aauthor{Jean-Christophe Filliâtre and Pierre Letouzey} \index{Extraction} -We present here the \Coq\ extraction commands, used to build certified +\noindent We present here the \Coq\ extraction commands, used to build certified and relatively efficient functional programs, extracting them from either \Coq\ functions or \Coq\ proofs of specifications. The functional languages available as output are currently \ocaml{}, @@ -30,7 +30,7 @@ The next two commands are meant to be used for rapid preview of extraction. They both display extracted term(s) inside \Coq. \begin{description} -\item {\tt Extraction \qualid.} ~\par +\item {\tt Extraction \qualid{}.} ~\par Extraction of a constant or module in the \Coq\ toplevel. \item {\tt Recursive Extraction} \qualid$_1$ \dots\ \qualid$_n$. ~\par @@ -40,7 +40,7 @@ extraction. They both display extracted term(s) inside \Coq. %% TODO error messages -All the following commands produce real ML files. User can choose to produce +\noindent All the following commands produce real ML files. User can choose to produce one monolithic file or one file per \Coq\ library. \begin{description} @@ -76,7 +76,7 @@ one monolithic file or one file per \Coq\ library. using prefixes \verb!coq_! or \verb!Coq_!. \end{description} -The list of globals \qualid$_i$ does not need to be +\noindent The list of globals \qualid$_i$ does not need to be exhaustive: it is automatically completed into a complete and minimal environment. @@ -215,7 +215,7 @@ arguments. In fact, an argument can also be referred by a number indicating its position, starting from 1. \end{description} -When an actual extraction takes place, an error is normally raised if the +\noindent When an actual extraction takes place, an error is normally raised if the {\tt Extraction Implicit} declarations cannot be honored, that is if any of the implicited variables still occurs in the final code. This behavior can be relaxed @@ -260,7 +260,7 @@ what ML term corresponds to a given axiom. be inlined everywhere instead of being declared via a let. \end{description} -Note that the {\tt Extract Inlined Constant} command is sugar +\noindent Note that the {\tt Extract Inlined Constant} command is sugar for an {\tt Extract Constant} followed by a {\tt Extraction Inline}. Hence a {\tt Reset Extraction Inline} will have an effect on the realized and inlined axiom. @@ -279,7 +279,7 @@ Extract Constant X => "int". Extract Constant x => "0". \end{coq_example*} -Notice that in the case of type scheme axiom (i.e. whose type is an +\noindent Notice that in the case of type scheme axiom (i.e. whose type is an arity, that is a sequence of product finished by a sort), then some type variables have to be given. The syntax is then: @@ -287,7 +287,7 @@ variables have to be given. The syntax is then: \item{\tt Extract Constant \qualid\ \str$_1$ \dots\ \str$_n$ => \str.} \end{description} -The number of type variables is checked by the system. +\noindent The number of type variables is checked by the system. \Example \begin{coq_example*} @@ -295,7 +295,7 @@ Axiom Y : Set -> Set -> Set. Extract Constant Y "'a" "'b" => " 'a*'b ". \end{coq_example*} -Realizing an axiom via {\tt Extract Constant} is only useful in the +\noindent Realizing an axiom via {\tt Extract Constant} is only useful in the case of an informative axiom (of sort Type or Set). A logical axiom have no computational content and hence will not appears in extracted terms. But a warning is nonetheless issued if extraction encounters a @@ -325,7 +325,7 @@ native boolean type instead of \Coq\ one. The syntax is the following: pattern-matching of the language will be used. \end{description} -For an inductive type with $k$ constructor, the function used to +\noindent For an inductive type with $k$ constructor, the function used to emulate the match should expect $(k+1)$ arguments, first the $k$ branches in functional form, and then the inductive element to destruct. For instance, the match branch \verb$| S n => foo$ gives the @@ -365,7 +365,7 @@ Extract Inductive bool => "bool" [ "true" "false" ]. Extract Inductive sumbool => "bool" [ "true" "false" ]. \end{coq_example} -If an inductive constructor or type has arity 2 and the corresponding +\noindent If an inductive constructor or type has arity 2 and the corresponding string is enclosed by parenthesis, then the rest of the string is used as infix constructor or type. \begin{coq_example} @@ -373,7 +373,7 @@ Extract Inductive list => "list" [ "[]" "(::)" ]. Extract Inductive prod => "(*)" [ "(,)" ]. \end{coq_example} -As an example of translation to a non-inductive datatype, let's turn +\noindent As an example of translation to a non-inductive datatype, let's turn {\tt nat} into Ocaml's {\tt int} (see caveat above): \begin{coq_example} Extract Inductive nat => int [ "0" "succ" ] @@ -402,7 +402,7 @@ It is possible to instruct the extraction not to use particular filenames. Allow the extraction to use any filename. \end{description} -For Ocaml, a typical use of these commands is +\noindent For Ocaml, a typical use of these commands is {\tt Extraction Blacklist String List}. \asection{Differences between \Coq\ and ML type systems} @@ -456,7 +456,7 @@ In Ocaml, we must cast any argument of the constructor dummy. \end{itemize} -Even with those unsafe castings, you should never get error like +\noindent Even with those unsafe castings, you should never get error like ``segmentation fault''. In fact even if your program may seem ill-typed to the Ocaml type-checker, it can't go wrong: it comes from a Coq well-typed terms, so for example inductives will always @@ -489,7 +489,7 @@ Inductive nat : Set := | S : nat -> nat. \end{coq_example*} -This module contains a theorem {\tt eucl\_dev}, whose type is +\noindent This module contains a theorem {\tt eucl\_dev}, whose type is \begin{verbatim} forall b:nat, b > 0 -> forall a:nat, diveucl a b \end{verbatim} @@ -506,7 +506,7 @@ Extraction Inline gt_wf_rec lt_wf_rec induction_ltof2. Recursive Extraction eucl_dev. \end{coq_example} -The inlining of {\tt gt\_wf\_rec} and others is not +\noindent The inlining of {\tt gt\_wf\_rec} and others is not mandatory. It only enhances readability of extracted code. You can then copy-paste the output to a file {\tt euclid.ml} or let \Coq\ do it for you with the following command: @@ -515,7 +515,7 @@ You can then copy-paste the output to a file {\tt euclid.ml} or let Extraction "euclid" eucl_dev. \end{verbatim} -Let us play the resulting program: +\noindent Let us play the resulting program: \begin{verbatim} # #use "euclid.ml";; @@ -543,7 +543,7 @@ val div : int -> int -> int * int = <fun> - : int * int = (11, 8) \end{verbatim} -Note that these {\tt nat\_of\_int} and {\tt int\_of\_nat} are now +\noindent Note that these {\tt nat\_of\_int} and {\tt int\_of\_nat} are now available via a mere {\tt Require Import ExtrOcamlIntConv} and then adding these functions to the list of functions to extract. This file {\tt ExtrOcamlIntConv.v} and some others in {\tt plugins/extraction/} @@ -551,7 +551,7 @@ are meant to help building concrete program via extraction. \asubsection{Extraction's horror museum} -Some pathological examples of extraction are grouped in the file +Some pathological examples of extraction are grouped in the file\\ {\tt test-suite/success/extraction.v} of the sources of \Coq. \asubsection{Users' Contributions} @@ -579,7 +579,7 @@ extraction test: \item {\tt stalmarck} \end{itemize} -{\tt continuations} and {\tt multiplier} are a bit particular. They are +\noindent {\tt continuations} and {\tt multiplier} are a bit particular. They are examples of developments where {\tt Obj.magic} are needed. This is probably due to an heavy use of impredicativity. After compilation, those two examples run nonetheless, thanks to the correction of the diff --git a/doc/refman/RefMan-ltac.tex b/doc/refman/RefMan-ltac.tex index 12dea9a306..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 @@ -1196,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} @@ -1229,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} @@ -1555,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. @@ -1575,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/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.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.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/grammar.mllib b/grammar/grammar.mllib deleted file mode 100644 index 6c3ce7f034..0000000000 --- a/grammar/grammar.mllib +++ /dev/null @@ -1,5 +0,0 @@ -GramCompat -Q_util -Argextend -Tacextend -Vernacextend diff --git a/ide/coqOps.ml b/ide/coqOps.ml index 9301359957..6ffe771da3 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -741,7 +741,7 @@ object(self) self#cleanup (Doc.cut_at document to_id); conclusion () | Fail (safe_id, loc, msg) -> - if loc <> None then messages#push Feedback.Error (Richpp.richpp_of_string "Fixme LOC"); +(* 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 diff --git a/ide/coqide.ml b/ide/coqide.ml index 758a5a4c99..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) @@ -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/ide_slave.ml b/ide/ide_slave.ml index 9071410e5b..79affb36f5 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -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, _ = 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/interp/constrextern.ml b/interp/constrextern.ml index e5ccb76b46..57091ca898 100644 --- a/interp/constrextern.ml +++ b/interp/constrextern.ml @@ -481,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 @@ -516,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 @@ -538,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) @@ -647,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; @@ -683,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 @@ -696,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, @@ -916,7 +919,8 @@ and extern_notation (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_notation allscopes vars t rules diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index 0e37f5268e..cfa30a4d54 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -455,7 +455,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 @@ -477,6 +477,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/closure.ml b/kernel/closure.ml index 65123108fd..960bdb649a 100644 --- a/kernel/closure.ml +++ b/kernel/closure.ml @@ -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/names.mli b/kernel/names.mli index 56f0f8c60d..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 } *) diff --git a/lib/aux_file.ml b/lib/aux_file.ml index d06d4b3768..096305b987 100644 --- a/lib/aux_file.ml +++ b/lib/aux_file.ml @@ -25,9 +25,9 @@ let mk_absolute vfile = if Filename.is_relative vfile then CUnix.correct_path vfile (Sys.getcwd ()) else vfile -let start_aux_file_for vfile = - let vfile = mk_absolute vfile in - oc := Some (open_out (aux_file_name_for vfile)); +let start_aux_file ~aux_file:output_file ~v_file = + let vfile = mk_absolute v_file in + oc := Some (open_out output_file); Printf.fprintf (Option.get !oc) "COQAUX%d %s %s\n" version (Digest.to_hex (Digest.file vfile)) vfile diff --git a/lib/aux_file.mli b/lib/aux_file.mli index 127827ab6a..86e322b71d 100644 --- a/lib/aux_file.mli +++ b/lib/aux_file.mli @@ -17,7 +17,8 @@ module H : Map.S with type key = int * int module M : Map.S with type key = string val contents : aux_file -> string M.t H.t -val start_aux_file_for : string -> unit +val aux_file_name_for : string -> string +val start_aux_file : aux_file:string -> v_file:string -> unit val stop_aux_file : unit -> unit val recording : unit -> bool diff --git a/lib/errors.ml b/lib/errors.ml index 8982dde148..1459141d1e 100644 --- a/lib/errors.ml +++ b/lib/errors.ml @@ -144,5 +144,5 @@ let handled e = let fatal_error info anomaly = let msg = info ++ fnl () in pp_with ~pp_tag:Ppstyle.pp_tag !Pp_control.err_ft msg; - flush_all (); + Format.pp_print_flush !Pp_control.err_ft (); exit (if anomaly then 129 else 1) diff --git a/lib/flags.ml b/lib/flags.ml index c1ec9738ca..ba19c7a63b 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -47,6 +47,7 @@ let batch_mode = ref false type compilation_mode = BuildVo | BuildVio | Vio2Vo let compilation_mode = ref BuildVo +let compilation_output_name = ref None let test_mode = ref false @@ -68,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 @@ -220,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 24780f0dcc..8fe64d24fa 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -14,6 +14,7 @@ val load_init : bool ref val batch_mode : bool ref type compilation_mode = BuildVo | BuildVio | Vio2Vo val compilation_mode : compilation_mode ref +val compilation_output_name : string option ref val test_mode : bool ref @@ -34,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 @@ -143,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/stateid.ml b/lib/stateid.ml index c17df2b321..500581a39e 100644 --- a/lib/stateid.ml +++ b/lib/stateid.ml @@ -29,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 516ad891ff..cd8fddf0ce 100644 --- a/lib/stateid.mli +++ b/lib/stateid.mli @@ -11,7 +11,8 @@ 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 diff --git a/lib/unicode.ml b/lib/unicode.ml index 7aa8d9d513..dc852d9819 100644 --- a/lib/unicode.ml +++ b/lib/unicode.ml @@ -261,3 +261,73 @@ let ascii_of_ident s = (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 aaf455dec5..1f8bd44eee 100644 --- a/lib/unicode.mli +++ b/lib/unicode.mli @@ -40,3 +40,9 @@ 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 b0df32b8de..84284fd182 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -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/library.ml b/library/library.ml index 192700be79..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]. *) @@ -427,23 +427,23 @@ 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) @@ -628,17 +628,14 @@ let check_module_name s = done | c -> err c -let start_library f = - let () = if not (Sys.file_exists f) then - errorlabstrm "" (hov 0 (str "Can't find file" ++ spc () ++ str f)) - in +let start_library fo = let ldir0 = try - let lp = Loadpath.find_load_path (Filename.dirname f) in + let lp = Loadpath.find_load_path (Filename.dirname fo) in Loadpath.logical lp with Not_found -> Nameops.default_root_prefix in - let file = Filename.chop_extension (Filename.basename f) in + let file = Filename.chop_extension (Filename.basename fo) in let id = Id.of_string file in check_module_name file; check_coq_overwriting ldir0 id; @@ -693,12 +690,13 @@ let error_recursively_dependent_library dir = writing the content and computing the checksum... *) let save_library_to ?todo dir f otab = - let f, except = match todo with + let except = match todo with | None -> assert(!Flags.compilation_mode = Flags.BuildVo); - f ^ "o", Future.UUIDSet.empty + assert(Filename.check_suffix f ".vo"); + Future.UUIDSet.empty | Some (l,_) -> - f ^ "io", + assert(Filename.check_suffix f ".vio"); List.fold_left (fun e (r,_) -> Future.UUIDSet.add r.Stateid.uuid e) Future.UUIDSet.empty l in let cenv, seg, ast = Declaremods.end_library ~except dir in diff --git a/library/library.mli b/library/library.mli index 8f5b775d8d..b9044b60dd 100644 --- a/library/library.mli +++ b/library/library.mli @@ -37,9 +37,9 @@ type seg_proofs = Term.constr Future.computation array an export otherwise just a simple import *) val import_module : bool -> qualid located list -> unit -(** Start the compilation of a file as a library. The argument must be an - existing file on the system, and the returned path is the associated - absolute logical path of the library. *) +(** Start the compilation of a file as a library. The first argument must be + output file, and the + returned path is the associated absolute logical path of the library. *) val start_library : CUnix.physical_path -> DirPath.t (** End the compilation of a library and save it to a ".vo" file *) 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/extratactics.ml4 b/ltac/extratactics.ml4 index 5d3c149ab9..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 diff --git a/ltac/g_ltac.ml4 b/ltac/g_ltac.ml4 index 3579fc10f6..7c161e5cdc 100644 --- a/ltac/g_ltac.ml4 +++ b/ltac/g_ltac.ml4 @@ -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 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/ltac/profile_ltac.mli b/ltac/profile_ltac.mli new file mode 100644 index 0000000000..7bbdca9425 --- /dev/null +++ b/ltac/profile_ltac.mli @@ -0,0 +1,25 @@ +(************************************************************************) +(* 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 *) +(************************************************************************) + +(** Ltac profiling primitives *) + +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/tacintern.ml b/ltac/tacintern.ml index d39f835528..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, [], [] @@ -564,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) @@ -666,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 5ee9b0fc4d..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 @@ -1169,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) []) @@ -1251,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 @@ -1276,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 @@ -1302,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) @@ -1408,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 diff --git a/myocamlbuild.ml b/myocamlbuild.ml deleted file mode 100644 index b81b280fff..0000000000 --- a/myocamlbuild.ml +++ /dev/null @@ -1,482 +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_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/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/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/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/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 0a8cb0ccd3..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 diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4 index a78532e339..cec3505a97 100644 --- a/plugins/firstorder/g_ground.ml4 +++ b/plugins/firstorder/g_ground.ml4 @@ -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_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/recdef.ml b/plugins/funind/recdef.ml index 80866e8b8c..95b4967faa 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -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); 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/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/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/refl_omega.ml b/plugins/romega/refl_omega.ml index 007a9ec673..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} *) 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/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/newring.ml b/plugins/setoid_ring/newring.ml index 154ec6e1bf..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()) 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 fe9386039f..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*) 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/evarconv.ml b/pretyping/evarconv.ml index 89cb723bc7..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 -> @@ -506,10 +504,13 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty 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/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 efc42aab76..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 diff --git a/pretyping/unification.ml b/pretyping/unification.ml index cdd543d255..21cf5548f2 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -1058,8 +1058,10 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb 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 diff --git a/printing/pptactic.ml b/printing/pptactic.ml index 3d1e3e054f..5356cdee8a 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -366,7 +366,6 @@ module Make in str "<" ++ name ++ str ">" ++ args - let pr_alias_key key = try let prods = (KNmap.find key !prnotation_tab).pptac_prods in @@ -383,7 +382,7 @@ module Make 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 diff --git a/printing/pptacticsig.mli b/printing/pptacticsig.mli index f02785a554..c08d6044db 100644 --- a/printing/pptacticsig.mli +++ b/printing/pptacticsig.mli @@ -50,6 +50,8 @@ module type Pp = sig 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/printing.mllib b/printing/printing.mllib index 52102e1d3b..bc8f0750e1 100644 --- a/printing/printing.mllib +++ b/printing/printing.mllib @@ -2,11 +2,8 @@ Genprint Pputils Ppannotation Ppconstr -Ppconstrsig Printer Pptactic -Pptacticsig Printmod Prettyp Ppvernac -Ppvernacsig 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.mli b/proofs/pfedit.mli index cfab8bd630..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 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.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.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.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/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/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 e2acb10293..c0813827de 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -76,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 @@ -99,7 +105,7 @@ 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 " ^ Pp.string_of_ppcmds(pr_vernac expr)) @@ -114,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 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 @@ -140,7 +160,7 @@ 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 @@ -150,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 @@ -177,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 (* {{{ *) @@ -274,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 @@ -288,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 @@ -327,7 +383,6 @@ end = struct (* {{{ *) include Vcs_ exception Expired = Vcs_aux.Expired - module StateidSet = Set.Make(Stateid) open Printf let print_dag vcs () = @@ -345,11 +400,11 @@ end = struct (* {{{ *) | 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 = @@ -369,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 -> "" @@ -383,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 = @@ -452,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 ()) @@ -508,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 -> @@ -518,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 } @@ -596,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 @@ -616,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 @@ -661,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 @@ -714,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) = @@ -753,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 (* }}} *) @@ -842,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 @@ -941,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 *********************************) (******************************************************************************) @@ -1117,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; @@ -1133,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 = @@ -1151,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 @@ -1258,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 @@ -1411,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 } @@ -1428,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 } @@ -1437,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 } @@ -1467,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 ((),[]) @@ -1496,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 @@ -1504,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) @@ -1523,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 @@ -1546,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; @@ -1580,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" @@ -1635,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 (* {{{ *) @@ -1672,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); @@ -1724,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 @@ -1760,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 @@ -1790,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 *) @@ -1808,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 @@ -1820,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; @@ -1859,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) -> @@ -2102,20 +2379,21 @@ let handle_failure (e, info) vcs tty = VCS.print (); iraise (e, info) -let snapshot_vio ldir long_f_dot_v = +let snapshot_vio ldir long_f_dot_vo = finish (); if List.length (VCS.branches ()) > 1 then Errors.errorlabstrm "stm" (str"Cannot dump a vio with open proofs"); - Library.save_library_to ~todo:(dump_snapshot ()) ldir long_f_dot_v + Library.save_library_to ~todo:(dump_snapshot ()) ldir long_f_dot_vo (Global.opaque_tables ()) 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 @@ -2170,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 @@ -2189,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") @@ -2213,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 } -> () @@ -2229,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 @@ -2250,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 @@ -2286,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 (); @@ -2299,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; @@ -2324,19 +2601,30 @@ let get_ast id = 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 @@ -2351,15 +2639,15 @@ let query ~at ?(report_with=(Stateid.dummy,default_route)) 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 = @@ -2384,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 @@ -2399,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 (); @@ -2419,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 @@ -2441,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 @@ -2491,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 6ffe0beb44..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 ] @@ -96,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 @@ -122,7 +200,8 @@ 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 ****************************** **) diff --git a/stm/stm.mllib b/stm/stm.mllib index bd792b01f6..939ee187ae 100644 --- a/stm/stm.mllib +++ b/stm/stm.mllib @@ -8,4 +8,5 @@ Lemmas CoqworkmgrApi AsyncTaskQueue 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.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.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/tactics.ml b/tactics/tactics.ml index 75273e4b7b..991922d909 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1661,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) = @@ -2453,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] 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..d779d1f9a4 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-resilience off -async-proofs-command-error-resilience off" 2>&1; \ if [ $$? = 0 ]; then \ echo $(log_success); \ echo " $<...Ok"; \ 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/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..b75170179b --- /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 }. +Fail 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/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/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 f957200ab5..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" @@ -107,6 +107,7 @@ let parse_args () = |"-load-ml-source"|"-require"|"-load-ml-object" |"-init-file"|"-dump-glob"|"-compat"|"-coqlib"|"-top" |"-async-proofs-j" |"-async-proofs-private-flags" |"-async-proofs" |"-w" + |"-o" as o) :: rem -> begin match rem with diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml index 0f7937d729..cc63c13d7b 100644 --- a/tools/coqdep_common.ml +++ b/tools/coqdep_common.ml @@ -445,7 +445,7 @@ let mL_dependencies () = 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.cmxa:$(addsuffix .cmx,$(%s_MLLIB_DEPENDENCIES))\n" efullname efullname; flush stdout) (List.rev !mllibAccu); List.iter @@ -455,7 +455,7 @@ let mL_dependencies () = let efullname = escape fullname in printf "%s_MLPACK_DEPENDENCIES:=%s\n" efullname dep; 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; + printf "%s.cmx:$(addsuffix .cmx,$(%s_MLPACK_DEPENDENCIES))\n" efullname efullname; flush stdout) (List.rev !mlpackAccu) diff --git a/tools/ocamllibdep.mll b/tools/ocamllibdep.mll index 670ff487c5..bf82be09f1 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:$(addsuffix .cmx,$(%s_MLLIB_DEPENDENCIES))\n" + 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:$(addsuffix .cmx,$(%s_MLPACK_DEPENDENCIES))\n" + 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/coqloop.ml b/toplevel/coqloop.ml index c8879963e5..1fe30217dd 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -328,7 +328,7 @@ let do_vernac () = 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; - flush_all () + Format.pp_print_flush !Pp_control.std_ft () (** Main coq loop : read vernacular expressions until Drop is entered. Ctrl-C is handled internally as Sys.Break instead of aborting Coq. @@ -345,13 +345,21 @@ let feed_emacs = function | _ -> () *) +(* Flush in a compatible order with 8.5 *) +(* This mimics the semantics of the old Pp.flush_all *) +let loop_flush_all () = + Pervasives.flush stderr; + Pervasives.flush stdout; + Format.pp_print_flush !Pp_control.std_ft (); + Format.pp_print_flush !Pp_control.err_ft () + let rec loop () = Sys.catch_break true; if !Flags.print_emacs then Vernacentries.qed_display_script := false; Flags.coqtop_ui := true; try reset_input_buffer stdin top_buffer; - while true do do_vernac(); flush_all() done + while true do do_vernac(); loop_flush_all () done with | Errors.Drop -> () | Errors.Quit -> exit 0 diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index 869f6bb931..a820008d2e 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -370,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] -> @@ -379,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 [] @@ -492,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 ()) @@ -516,6 +532,7 @@ let parse_args arglist = |"-vio2vo" -> add_compile false (next ()); Flags.compilation_mode := Vio2Vo |"-toploop" -> set_toploop (next ()) |"-w" -> set_warning (next ()) + |"-o" -> Flags.compilation_output_name := Some (next()) (* Options with zero arg *) |"-async-queries-always-delegate" @@ -549,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 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/metasyntax.ml b/toplevel/metasyntax.ml index 9fa55adfa1..7d8c670259 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -839,7 +839,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) = 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 f855c096e3..ffbbe7ed4a 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -45,6 +45,7 @@ let print_usage_channel co command = \n -require path load Coq library path and import it (Require Import path.)\ \n -compile f.v compile Coq file f.v (implies -batch)\ \n -compile-verbose f.v verbosely compile Coq file f.v (implies -batch)\ +\n -o f.vo use f.vo as the output file name\ \n -quick quickly compile .v files to .vio files (skip proofs)\ \n -schedule-vio2vo j f1..fn run up to j instances of Coq to turn each fi.vio\ \n into fi.vo\ @@ -77,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 1c3f0d9976..0a32c88d64 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -290,12 +290,35 @@ let load_vernac verb file = if !Flags.beautify_file then close_out !chan_beautify; raise_with_file file (disable_drop e, info) -let ensure_v f = - if Filename.check_suffix f ".v" then f +let ensure_ext ext f = + if Filename.check_suffix f ext then f else begin Feedback.msg_warning (str "File \"" ++ str f ++ strbrk "\" has been implicitly \ - expanded to \"" ++ str f ++ str ".v\""); - f ^ ".v" + expanded to \"" ++ str f ++ str ext ++ str "\""); + f ^ ext + end + +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 + 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 + +let ensure ext src tgt = ensure_bname src tgt; ensure_ext ext tgt + +let ensure_v v = ensure ".v" v v +let ensure_vo v vo = ensure ".vo" v vo +let ensure_vio v vio = ensure ".vio" v vio + +let ensure_exists f = + if not (Sys.file_exists f) then begin + Feedback.msg_error (hov 0 (str "Can't find file" ++ spc () ++ str f)); + exit 1 end (* Compile a vernac file *) @@ -307,9 +330,16 @@ let compile verbosely f = match !Flags.compilation_mode with | BuildVo -> let long_f_dot_v = ensure_v f in - let ldir = Flags.verbosely Library.start_library long_f_dot_v in - Stm.set_compilation_hints long_f_dot_v; - Aux_file.start_aux_file_for long_f_dot_v; + ensure_exists long_f_dot_v; + let long_f_dot_vo = + match !Flags.compilation_output_name with + | None -> long_f_dot_v ^ "o" + | Some f -> ensure_vo long_f_dot_v f in + let ldir = Flags.verbosely Library.start_library long_f_dot_vo in + Stm.set_compilation_hints long_f_dot_vo; + Aux_file.(start_aux_file + ~aux_file:(aux_file_name_for long_f_dot_vo) + ~v_file:long_f_dot_v); Dumpglob.start_dump_glob long_f_dot_v; Dumpglob.dump_string ("F" ^ Names.DirPath.to_string ldir ^ "\n"); if !Flags.xml_export then Hook.get f_xml_start_library (); @@ -318,7 +348,7 @@ let compile verbosely f = Stm.join (); let wall_clock2 = Unix.gettimeofday () in check_pending_proofs (); - Library.save_library_to ldir long_f_dot_v (Global.opaque_tables ()); + Library.save_library_to ldir long_f_dot_vo (Global.opaque_tables ()); Aux_file.record_in_aux_at Loc.ghost "vo_compile_time" (Printf.sprintf "%.3f" (wall_clock2 -. wall_clock1)); Aux_file.stop_aux_file (); @@ -326,13 +356,18 @@ let compile verbosely f = Dumpglob.end_dump_glob () | BuildVio -> let long_f_dot_v = ensure_v f in - let ldir = Flags.verbosely Library.start_library long_f_dot_v in + ensure_exists long_f_dot_v; + let long_f_dot_vio = + match !Flags.compilation_output_name with + | None -> long_f_dot_v ^ "io" + | Some f -> ensure_vio long_f_dot_v f in + let ldir = Flags.verbosely Library.start_library long_f_dot_vio in Dumpglob.noglob (); - Stm.set_compilation_hints long_f_dot_v; + Stm.set_compilation_hints long_f_dot_vio; let _ = load_vernac verbosely long_f_dot_v in Stm.finish (); check_pending_proofs (); - Stm.snapshot_vio ldir long_f_dot_v; + Stm.snapshot_vio ldir long_f_dot_vio; Stm.reset_task_queue () | Vio2Vo -> let open Filename in |