diff options
| author |  Enrico Tassi <gareuselesinge@debian.org> | 2015-11-13 11:43:34 +0100 |
|---|---|---|
| committer | Enrico Tassi <gareuselesinge@debian.org> | 2015-11-13 11:43:34 +0100 |
| commit | 4e76c4f01b69b77f40686e06c4544aa156efaa5a (patch) | |
| tree | aefad2e3de35f75c46729f9310d33b56d3821961 | |
| parent | 64fa31c7ee53e79b112507fb2eea27dc7648328d (diff) | |
| parent | 91dbeab8eef959c3f64960909ca69d4e68c8198d (diff) | |
Imported Upstream version 8.5~beta3+dfsg
564 files changed, 12837 insertions, 7058 deletions
diff --git a/.gitattributes b/.gitattributes new file mode 100644 index 00000000..6af0a106 --- /dev/null +++ b/.gitattributes @@ -0,0 +1,5 @@ +.dir-locals.el export-ignore +.gitattributes export-ignore +.gitignore export-ignore +.mailmap export-ignore +TODO export-ignore diff --git a/.mailmap b/.mailmap new file mode 100644 index 00000000..13c71558 --- /dev/null +++ b/.mailmap @@ -0,0 +1,89 @@ +## Coq contributors +## +## This file allows joining the different accounts of a same person. +## Cf for instance: git shortlog -nse. More details via: man git shortlog +## +## To avoid spam issues, we use by default a pseudo-email <login@gforge> +## for all persons that haven't made commits with real emails +## +## If you're mentionned here and want to update your information, +## either amend this file and commit it, or contact the coqdev list + +Jim Apple <github.public@jbapple.com> jbapple <github.public@jbapple.com> +Bruno Barras <bruno.barras@inria.fr> barras <barras@85f007b7-540e-0410-9357-904b9bb8a0f7> +Bruno Barras <bruno.barras@inria.fr> barras-local <barras-local@85f007b7-540e-0410-9357-904b9bb8a0f7> +Yves Bertot <bertot@inria.fr> bertot <bertot@85f007b7-540e-0410-9357-904b9bb8a0f7> +Frédéric Besson <frederic.besson@inria.fr> fbesson <fbesson@85f007b7-540e-0410-9357-904b9bb8a0f7> +Pierre Boutillier <pierre.boutillier@ens-lyon.org> pboutill <pboutill@85f007b7-540e-0410-9357-904b9bb8a0f7> +Pierre Boutillier <pierre.boutillier@ens-lyon.org> Pierre <pierre.boutillier@ens-lyon.org> +Pierre Boutillier <pierre.boutillier@ens-lyon.org> Pierre Boutillier <pierre.boutillier@pps.univ-paris-diderot.fr> +Xavier Clerc <xavier.clerc@inria.fr> xclerc <xclerc@85f007b7-540e-0410-9357-904b9bb8a0f7> +Xavier Clerc <xavier.clerc@inria.fr> xclerc <xavier.clerc@inria.fr> +Pierre Corbineau <Pierre.Corbineau@NOSPAM@imag.fr> corbinea <corbinea@85f007b7-540e-0410-9357-904b9bb8a0f7> +Judicaël Courant <courant@gforge> courant <courant@85f007b7-540e-0410-9357-904b9bb8a0f7> +Pierre Courtieu <Pierre.Courtieu@cnam.fr> courtieu <courtieu@85f007b7-540e-0410-9357-904b9bb8a0f7> +David Delahaye <delahaye@gforge> delahaye <delahaye@85f007b7-540e-0410-9357-904b9bb8a0f7> +Maxime Dénès <mail@maximedenes.fr> mdenes <mdenes@85f007b7-540e-0410-9357-904b9bb8a0f7> +Daniel De Rauglaudre <ddr@gforge> ddr <ddr@85f007b7-540e-0410-9357-904b9bb8a0f7> +Olivier Desmettre <desmettr@gforge> desmettr <desmettr@85f007b7-540e-0410-9357-904b9bb8a0f7> +Damien Doligez <doligez@gforge> doligez <doligez@85f007b7-540e-0410-9357-904b9bb8a0f7> +Jean-Christophe Filliâtre <Jean-Christophe.Filliatre@lri.fr> filliatr <filliatr@85f007b7-540e-0410-9357-904b9bb8a0f7> +Jean-Christophe Filliâtre <Jean-Christophe.Filliatre@lri.fr> Jean-Christophe Filliatre <Jean-Christophe.Filliatre@lri.fr> +Julien Forest <julien.forest@ensiie.fr> jforest <jforest@85f007b7-540e-0410-9357-904b9bb8a0f7> +Julien Forest <julien.forest@ensiie.fr> forest <jforest@mourvedre.ensiie.fr> +Julien Forest <julien.forest@ensiie.fr> jforest <jforest@thune> +Julien Forest <julien.forest@ensiie.fr> jforest <jforest@daneel.lan.home> +Stéphane Glondu <steph@glondu.net> glondu <glondu@85f007b7-540e-0410-9357-904b9bb8a0f7> +Stéphane Glondu <steph@glondu.net> Stephane Glondu <steph@glondu.net> +Benjamin Grégoire <benjamin.gregoire@inria.fr> Benjamin Gregoire <Benjamin.Gregoire@inria.fr> +Benjamin Grégoire <benjamin.gregoire@inria.fr> bgregoir <bgregoir@85f007b7-540e-0410-9357-904b9bb8a0f7> +Benjamin Grégoire <benjamin.gregoire@inria.fr> gregoire <gregoire@85f007b7-540e-0410-9357-904b9bb8a0f7> +Jason Gross <jgross@mit.edu> Jason Gross <t-jagro@microsoft.com> +Jason Gross <jgross@mit.edu> Jason Gross <jasongross9@gmail.com> +Vincent Gross <vgross@gforge> vgross <vgross@85f007b7-540e-0410-9357-904b9bb8a0f7> +Huang Guan-Shieng <huang@gforge> huang <huang@85f007b7-540e-0410-9357-904b9bb8a0f7> +Hugo Herbelin <Hugo.Herbelin@inria.fr> herbelin <herbelin@85f007b7-540e-0410-9357-904b9bb8a0f7> +Tom Hutchinson <thutchin@gforge> thutchin <thutchin@85f007b7-540e-0410-9357-904b9bb8a0f7> +Cezary Kaliszyk <cek@gforge> cek <cek@85f007b7-540e-0410-9357-904b9bb8a0f7> +Florent Kirchner <fkirchne@gforge> fkirchne <fkirchne@85f007b7-540e-0410-9357-904b9bb8a0f7> +Florent Kirchner <fkirchne@gforge> kirchner <kirchner@85f007b7-540e-0410-9357-904b9bb8a0f7> +Marc Lasson <marc.lasson@gmail.com> mlasson <marc.lasson@gmail.com> +Pierre Letouzey <pierre.letouzey@inria.fr> letouzey <letouzey@85f007b7-540e-0410-9357-904b9bb8a0f7> +Assia Mahboubi <assia.mahboubi@inria.fr> amahboub <amahboub@85f007b7-540e-0410-9357-904b9bb8a0f7> +Evgeny Makarov <emakarov@gforge> emakarov <emakarov@85f007b7-540e-0410-9357-904b9bb8a0f7> +Gregory Malecha <gmalecha@eecs.harvard.edu> Gregory Malecha <gmalecha@cs.harvard.edu> +Lionel Elie Mamane <lmamane@gforge> lmamane <lmamane@85f007b7-540e-0410-9357-904b9bb8a0f7> +Claude Marché <marche@gforge> marche <marche@85f007b7-540e-0410-9357-904b9bb8a0f7> +Micaela Mayero <mayero@gforge> mayero <mayero@85f007b7-540e-0410-9357-904b9bb8a0f7> +Guillaume Melquiond <guillaume.melquiond@inria.fr> gmelquio <gmelquio@85f007b7-540e-0410-9357-904b9bb8a0f7> +Alexandre Miquel <miquel@gforge> miquel <miquel@85f007b7-540e-0410-9357-904b9bb8a0f7> +Benjamin Monate <monate@gforge> monate <monate@85f007b7-540e-0410-9357-904b9bb8a0f7> +Julien Narboux <jnarboux@gforge> jnarboux <jnarboux@85f007b7-540e-0410-9357-904b9bb8a0f7> +Julien Narboux <jnarboux@gforge> narboux <narboux@85f007b7-540e-0410-9357-904b9bb8a0f7> +Jean-Marc Notin <notin@gforge> notin,no-port-forwarding,no-agent-forwarding,no-X11-forwarding,no-pty <notin,no-port-forwarding,no-agent-forwarding,no-X11-forwarding,no-pty@85f007b7-540e-0410-9357-904b9bb8a0f7> +Jean-Marc Notin <notin@gforge> notin <notin@85f007b7-540e-0410-9357-904b9bb8a0f7> +Russel O'Connor <roconnor@gforge> roconnor <roconnor@85f007b7-540e-0410-9357-904b9bb8a0f7> +Christine Paulin <cpaulin@gforge> cpaulin <cpaulin@85f007b7-540e-0410-9357-904b9bb8a0f7> +Christine Paulin <cpaulin@gforge> mohring <mohring@85f007b7-540e-0410-9357-904b9bb8a0f7> +Pierre-Marie Pédrot <pierre-marie.pedrot@inria.fr> ppedrot <ppedrot@85f007b7-540e-0410-9357-904b9bb8a0f7> +Loïc Pottier <pottier@gforge> pottier <pottier@85f007b7-540e-0410-9357-904b9bb8a0f7> +Matthias Puech <puech@gforge> puech <puech@85f007b7-540e-0410-9357-904b9bb8a0f7> +Yann Régis-Gianas <yrg@pps.univ-paris-diderot.fr> regisgia <regisgia@85f007b7-540e-0410-9357-904b9bb8a0f7> +Clément Renard <clrenard@gforge> clrenard <clrenard@85f007b7-540e-0410-9357-904b9bb8a0f7> +Claudio Sacerdoti Coen <sacerdot@gforge> sacerdot <sacerdot@85f007b7-540e-0410-9357-904b9bb8a0f7> +Vincent Siles <vsiles@gforge> vsiles <vsiles@85f007b7-540e-0410-9357-904b9bb8a0f7> +Elie Soubiran <soubiran@gforge> soubiran <soubiran@85f007b7-540e-0410-9357-904b9bb8a0f7> +Matthieu Sozeau <mattam@mattam.org> msozeau <msozeau@85f007b7-540e-0410-9357-904b9bb8a0f7> +Matthieu Sozeau <mattam@mattam.org> Matthieu Sozeau <matthieu.sozeau@inria.fr> +Arnaud Spiwack <arnaud@spiwack.net> aspiwack <aspiwack@85f007b7-540e-0410-9357-904b9bb8a0f7> +Enrico Tassi <Enrico.Tassi@inria.fr> gareuselesinge <gareuselesinge@85f007b7-540e-0410-9357-904b9bb8a0f7> +Enrico Tassi <Enrico.Tassi@inria.fr> Enrico Tassi <enrico.tassi@inria.fr> +Enrico Tassi <Enrico.Tassi@inria.fr> Enrico Tassi <gares@fettunta.org> +Laurent Théry <thery@gforge> thery <thery@85f007b7-540e-0410-9357-904b9bb8a0f7> +Benjamin Werner <werner@gforge> werner <werner@85f007b7-540e-0410-9357-904b9bb8a0f7> + +# Anonymous accounts + +anonymous < > coq <coq@85f007b7-540e-0410-9357-904b9bb8a0f7> +anonymous < > (no author) <(no author)@85f007b7-540e-0410-9357-904b9bb8a0f7> +anonymous < > serpyc <serpyc@85f007b7-540e-0410-9357-904b9bb8a0f7> @@ -1,3 +1,108 @@ +Changes from V8.5beta2 to V8.5beta3 +=================================== + +Vernacular commands + +- New command "Redirect" to redirect the output of a command to a file. +- New command "Undelimit Scope" to remove the delimiter of a scope. +- New option "Strict Universe Declaration", set by default. It enforces the + declaration of all polymorphic universes appearing in a definition when + introducing it. +- New command "Show id" to show goal named id. + +Tactics + +- New flag "Regular Subst Tactic" which fixes "subst" in situations where + it failed to substitute all substitutable equations or failed to simplify + cycles, or accidentally unfolded local definitions (flag is off by default). +- New flag "Loose Hint Behavior" to handle hints loaded but not imported in a + special way. It accepts three distinct flags: + * "Lax", which is the default one, sets the old behavior, i.e. a non-imported + hint behaves the same as an imported one. + * "Warn" outputs a warning when a non-imported hint is used. Note that this is + an over-approximation, because a hint may be triggered by an eauto run that + will eventually fail and backtrack. + * "Strict" changes the behavior of an unloaded hint to the one of the fail + tactic, allowing to emulate the hopefully future import-scoped hint mechanism. +- New compatibility flag "Universal Lemma Under Conjunction" which + let tactics working under conjunctions apply sublemmas of the form + "forall A, ... -> A". +- New compatibility flag "Bracketing Last Introduction Pattern" which can be + set so that the last disjunctive-conjunctive introduction pattern given to + "intros" automatically complete the introduction of its subcomponents, as the + the disjunctive-conjunctive introduction patterns in non-terminal position + already do. +- Importing Program no longer overrides the "exists" tactic (potential source + of incompatibilities). +- Hints costs are now correctly taken into account (potential source of + incompatibilities). +- Documented the Hint Cut command that allows control of the + proof-search during typeclass resolution (see reference manual). + +API + +- Some functions from pretyping/typing.ml and their derivatives were potential + source of evarmap leaks, as they dropped their resulting evarmap. The + situation was clarified by renaming them according to a unsafe_* scheme. Their + sound variant is likewise renamed to their old name. The following renamings + were made. + * Typing.type_of -> unsafe_type_of + * Typing.e_type_of -> type_of + * A new e_type_of function that matches the e_ prefix policy + * Tacmach.pf_type_of -> pf_unsafe_type_of + * A new safe pf_type_of function. + All uses of unsafe_* functions should be eventually eliminated. + +Tools + +- Added an option -w to control the output of coqtop warnings. +- Configure now takes an optional -native-compiler (yes|no) flag replacing + -no-native-compiler. The new flag is set to no by default under Windows. +- Flag -no-native-compiler was removed and became the default for coqc. If + precompilation of files for native conversion test is desired, use + -native-compiler. +- The -compile command-line option now takes the full path of the considered + file, including the ".v" extension, and outputs a warning if such an extension + is lacking. +- The -require and -load-vernac-object command-line options now take a logical + path of a given library rather than a physical path, thus they behave like + Require [Import] path. + +Changes from V8.5beta1 to V8.5beta2 +=================================== + +Logic + +- The VM now supports inductive types with up to 8388851 non-constant + constructors and up to 8388607 constant ones. + +Tactics + +- A script using the admit tactic can no longer be concluded by either + Qed or Defined. In the first case, Admitted can be used instead. In + the second case, a subproof should be used. +- The easy tactic and the now tactical now have a more predictable + behavior, but they might now discharge some previously unsolved goals. + +Extraction + +- Definitions extracted to Haskell GHC should no longer randomly + segfault when some Coq types cannot be represented by Haskell types. +- Definitions can now be extracted to Json for post-processing. + +Tools + +- Option -I -as has been removed, and option -R -as has been + deprecated. In both cases, option -R can be used instead. +- coq_makefile now generates double-colon rules for rules such as clean. + +API + +- The interface of [change] has changed to take a [change_arg], which + can be built from a [constr] using [make_change_arg]. +- [pattern_of_constr] now returns a triplet including the cleaned-up + [evar_map], removing the evars that were turned into metas. + Changes from V8.4 to V8.5beta1 ============================== @@ -84,12 +189,13 @@ Specification Language break user notations using "$(", fixable by inserting a space or rewriting the notation). - Constructors in pattern-matching patterns now respect the same rules - regarding implicit arguments than in applicative position. The old + regarding implicit arguments as in applicative position. The old behavior can be recovered by the command "Set Asymmetric - Patterns". As a side effect, Much more notations can be used in - patterns. Considering that the pattern language is rich enough like - that, definitions are now always forbidden in patterns. (source of - incompatibilities for definitions that delta-reduce to a constructor) + Patterns". As a side effect, notations for constructors explicitly + mentioning non-implicit parameters can now be used in patterns. + Considering that the pattern language is already rich enough, binding + local definitions is however now forbidden in patterns (source of + incompatibilities for local definitions that delta-reduce to a constructor). - Type inference algorithm now granting opacity of constants. This might also affect behavior of tactics (source of incompatibilities, solvable by re-declaring transparent constants which were set opaque). @@ -110,10 +216,12 @@ Tactics during the execution of c, it can backtrack and try b instead of a. * New tactical (once a) removes all the backtracking points from a (i.e. it selects the first success of a). - * Tactic "constructor" is now fully backtracking, thus deprecating - the need of the undocumented "constructor <tac>" syntax which is - now equivalent to "[> once (constructor; tac) ..]". (potential - source of rare incompatibilities). + * Tactic "constructor" is now fully backtracking. In case of + incompatibilities (e.g. combinatoric explosion), the former + behavior of "constructor" can be retrieved by using instead + "[> once constructor ..]". Thanks to backtracking, undocumented + "constructor <tac>" syntax is now equivalent to + "[> once (constructor; tac) ..]". * New "multimatch" variant of "match" tactic which backtracks to new branches in case of a later failure. The "match" tactic is equivalent to "once multimatch". @@ -279,6 +387,10 @@ Tactics trace anymore. Use "Info 1 auto" instead. The same goes for "info_trivial". On the other hand "info_eauto" still works fine, while "Info 1 eauto" prints a trivial trace. +- When using a lemma of the prototypical form "forall A, {a:A & P a}", + "apply" and "apply in" do not instantiate anymore "A" with the + current goal and use "a" as the proof, as they were sometimes doing, + now considering that it is a too powerful decision. Program @@ -342,7 +454,7 @@ Interfaces - Many CoqIDE windows, including the query one, are now detachable to improve usability on multi screen work stations. -- Coqtop outputs highlighted syntax. Colors can be configured thanks +- Coqtop/coqc outputs highlighted syntax. Colors can be configured thanks to the COQ_COLORS environment variable, and their current state can be displayed with the -list-tags command line option. @@ -2076,7 +2188,7 @@ Changes from V7.3.1 to V7.4 Symbolic notations - Introduction of a notion of scope gathering notations in a consistent set; - a notation sets has been developped for nat, Z and R (undocumented) + a notation sets has been developed for nat, Z and R (undocumented) - New command "Notation" for declaring notations simultaneously for parsing and printing (see chap 10 of the reference manual) - Declarations with only implicit arguments now handled (e.g. the @@ -55,10 +55,12 @@ QUICK INSTALLATION PROCEDURE. INSTALLATION PROCEDURE IN DETAILS (NORMAL USERS). ================================================= -1- Check that you have the Objective Caml compiler version 3.12.1 (or later) - installed on your computer and that "ocamlc" (or its native code version - "ocamlc.opt") lie in a directory which is present in your $PATH environment - variable. +1- Check that you have the Objective Caml compiler installed on your + computer and that "ocamlc" (or, better, its native code version + "ocamlc.opt") lies in a directory which is present in your $PATH + environment variable. At the time of writing this sentence, all + versions of Objective Caml later or equal to 3.12.1 are + supported to the exception of Objective Caml 4.02.0. To get Coq in native-code, (it runs 4 to 10 times faster than bytecode, but it takes more time to get compiled and the binary is diff --git a/INSTALL.doc b/INSTALL.doc index 96918b49..76588005 100644 --- a/INSTALL.doc +++ b/INSTALL.doc @@ -1,7 +1,7 @@ The Coq documentation ===================== -The Coq documentation includes +The Coq documentation includes - A Reference Manual - A Tutorial @@ -15,31 +15,25 @@ html files are generated. Prerequisite ------------ -To produce the PostScript documents, the following tools -are needed: +To produce all the documents, the following tools are needed: - latex (latex2e) + - pdflatex - dvips - bibtex - makeindex - - pngtopnm and pnmtops (for the Reference Manual and the FAQ) - -To produce the PDF documents, the following tools are needed: - - - pdflatex - - bibtex - -To produce the html documents, the following tools are needed: - - - hevea (e.g. 1.07 works) + - fig2dev + - convert + - hevea + - hacha Under Debian based operating systems (Debian, Ubuntu, ...) a working set of packages for compiling the documentation for Coq is: texlive texlive-latex-extra texlive-math-extra texlive-fonts-extra - texlive-lang-french texlive-humanities texlive-pictures latex-xcolor - hevea netpbm + texlive-humanities texlive-pictures latex-xcolor hevea transfig + imagemagick Compilation @@ -52,7 +46,7 @@ To produce all documentation about Coq, just run: Alternatively, you can use some specific targets: - make doc-ps + make doc-ps to produce all PostScript documents make doc-pdf @@ -74,7 +68,7 @@ Alternatively, you can use some specific targets: to produce all formats of the FAQ make stdlib - to produce all formats of the Coq standard library + to produce all formats of the Coq standard library Installation diff --git a/INSTALL.ide b/INSTALL.ide index 13e741e3..6e41b2d0 100644 --- a/INSTALL.ide +++ b/INSTALL.ide @@ -119,5 +119,5 @@ TROUBLESHOOTING rid of the problem is to edit by hand your coqiderc (either /home/<user>/.config/coq/coqiderc under Linux, or C:\Documents and Settings\<user>\.config\coq\coqiderc under Windows) - and replace any occurence of MOD4 by MOD1. + and replace any occurrence of MOD4 by MOD1. @@ -202,7 +202,8 @@ docclean: rm -f doc/stdlib/index-list.html doc/stdlib/index-body.html \ doc/stdlib/*Library.coqdoc.tex doc/stdlib/library.files \ doc/stdlib/library.files.ls doc/stdlib/FullLibrary.tex - rm -f doc/*/*.ps doc/*/*.pdf + rm -f doc/*/*.ps doc/*/*.pdf doc/*/*.eps doc/*/*.pdf_t doc/*/*.eps_t + rm -f doc/faq/axioms.png rm -rf doc/refman/html doc/stdlib/html doc/faq/html doc/tutorial/tutorial.v.html rm -f doc/refman/euclid.ml doc/refman/euclid.mli rm -f doc/refman/heapsort.ml doc/refman/heapsort.mli diff --git a/Makefile.build b/Makefile.build index 018471b6..0455a247 100644 --- a/Makefile.build +++ b/Makefile.build @@ -69,7 +69,7 @@ TIMED= # non-empty will activate a default time command TIMECMD= # if you prefer a specific time command instead of $(STDTIME) # e.g. "'time -p'" - +CAMLFLAGS:=${CAMLFLAGS} -w -3 # NB: if you want to collect compilation timings of .v and import them # in a spreadsheet, I suggest something like: # make TIMED=1 2> timings.csv @@ -81,7 +81,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) +COQOPTS=$(COQ_XML) $(VM) $(NATIVECOMPUTE) BOOTCOQC=$(TIMER) $(COQTOPEXE) -boot $(COQOPTS) -compile # The SHOW and HIDE variables control whether make will echo complete commands @@ -101,7 +101,7 @@ BYTEFLAGS=-thread $(CAMLDEBUG) $(USERFLAGS) OPTFLAGS=-thread $(CAMLDEBUGOPT) $(CAMLTIMEPROF) $(USERFLAGS) DEPFLAGS= $(LOCALINCLUDES) -I ide -I ide/utils -ifeq ($(shell which codesign > /dev/null && echo $(ARCH)),Darwin) +ifeq ($(shell which codesign > /dev/null 2>&1 && echo $(ARCH)),Darwin) LINKMETADATA=-ccopt "-sectcreate __TEXT __info_plist config/Info-$(notdir $@).plist" CODESIGN:=codesign -s - else @@ -282,11 +282,11 @@ $(COQC): $(patsubst %.cma,%$(BESTLIB),$(COQCCMO:.cmo=$(BESTOBJ))) # For the checker, different flags may be used -checker/check.cma: | checker/check.mllib.d +checker/check.cma: | md5chk checker/check.mllib.d $(SHOW)'OCAMLC -a -o $@' $(HIDE)$(OCAMLC) $(CHKLIBS) $(BYTEFLAGS) -a -o $@ $^ -checker/check.cmxa: | checker/check.mllib.d +checker/check.cmxa: | md5chk checker/check.mllib.d $(SHOW)'OCAMLOPT -a -o $@' $(HIDE)$(OCAMLOPT) $(CHKLIBS) $(OPTFLAGS) -a -o $@ $^ @@ -479,7 +479,7 @@ md5chk: VALIDOPTS=$(if $(VERBOSE),,-silent) -o -m -validate: $(CHICKEN) md5chk | $(ALLVO) +validate: $(CHICKEN) | $(ALLVO) $(SHOW)'COQCHK <theories & plugins>' $(HIDE)$(CHICKEN) -boot $(VALIDOPTS) $(ALLMODS) @@ -524,6 +524,7 @@ hightactics: tactics/hightactics.cma .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) @@ -551,6 +552,9 @@ classes: $(CLASSESVO) program: $(PROGRAMVO) structures: $(STRUCTURESVO) vectors: $(VECTORSVO) +msets: $(MSETSVO) +mmaps: $(MMAPSVO) +compat: $(COMPATVO) noreal: unicode logic arith bool zarith qarith lists sets fsets \ relations wellfounded setoids sorting @@ -584,7 +588,7 @@ pluginsbyte: $(PLUGINS) theories/Init/%.vo theories/Init/%.glob: theories/Init/%.v $(VO_TOOLS_DEP) | theories/Init/%.v.d $(SHOW)'COQC -noinit $<' $(HIDE)rm -f theories/Init/$*.glob - $(HIDE)$(BOOTCOQC) theories/Init/$* -noinit -R theories Coq + $(HIDE)$(BOOTCOQC) $< -noinit -R theories Coq theories/Numbers/Natural/BigN/NMake_gen.v: theories/Numbers/Natural/BigN/NMake_gen.ml $(OCAML) $< $(TOTARGET) @@ -654,7 +658,7 @@ $(FAKEIDE): lib/clib$(BESTLIB) lib/xml_lexer$(BESTOBJ) lib/xml_parser$(BESTOBJ) # votour: a small vo explorer (based on the checker) -bin/votour: lib/cObj$(BESTOBJ) checker/values$(BESTOBJ) checker/votour.ml +bin/votour: lib/cObj$(BESTOBJ) checker/analyze$(BESTOBJ) checker/values$(BESTOBJ) checker/votour.ml $(SHOW)'OCAMLBEST -o $@' $(HIDE)$(call bestocaml, -I checker,) @@ -1035,7 +1039,7 @@ plugins/%_mod.ml: plugins/%.mllib %.vo %.glob: %.v theories/Init/Prelude.vo $(VO_TOOLS_DEP) | %.v.d $(SHOW)'COQC $<' $(HIDE)rm -f $*.glob - $(HIDE)$(BOOTCOQC) $* + $(HIDE)$(BOOTCOQC) $< ifdef VALIDATE $(SHOW)'COQCHK $(call vo_to_mod,$@)' $(HIDE)$(CHICKEN) -boot -silent -norec $(call vo_to_mod,$@) \ diff --git a/Makefile.common b/Makefile.common index 07df8bb1..92a48cd6 100644 --- a/Makefile.common +++ b/Makefile.common @@ -109,7 +109,11 @@ 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 @@ -127,13 +131,14 @@ REFMANCOQTEXFILES:=$(addprefix doc/refman/, \ 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 AsyncProofs.v.tex Universes.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 ) \ + 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 @@ -297,6 +302,7 @@ 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) \ @@ -306,7 +312,8 @@ THEORIESVO:=\ $(PARITHVO) $(NARITHVO) $(ZARITHVO) \ $(SETSVO) $(FSETSVO) $(MSETSVO) $(MMAPSVO) \ $(REALSVO) $(SORTINGVO) $(QARITHVO) \ - $(NUMBERSVO) $(STRUCTURESVO) $(VECTORSVO) + $(NUMBERSVO) $(STRUCTURESVO) $(VECTORSVO) \ + $(COMPATVO) THEORIESLIGHTVO:= $(INITVO) $(LOGICVO) $(UNICODEVO) $(ARITHVO) diff --git a/Makefile.doc b/Makefile.doc index 1f350935..b7251ce5 100644 --- a/Makefile.doc +++ b/Makefile.doc @@ -58,7 +58,21 @@ else endif %.ps: %.dvi - (cd `dirname $<`; dvips -q -o `basename $@` `basename $<`) + (cd `dirname $<`; $(DVIPS) -q -o `basename $@` `basename $<`) + +%.png: %.fig + $(FIG2DEV) -m 2 -L png $< $@ + +%.pdf: %.fig + $(FIG2DEV) -L pdftex $< $@ + $(FIG2DEV) -L pdftex_t -p `basename $@` $< $@_t + +%.eps: %.fig + $(FIG2DEV) -L pstex $< $@ + $(FIG2DEV) -L pstex_t -p `basename $@` $< $@_t + +%.eps: %.png + $(CONVERT) $< $@ ###################################################################### # Macros for filtering outputs @@ -107,7 +121,7 @@ doc/refman/Reference-Manual.dvi: $(REFMANFILES) doc/refman/Reference-Manual.tex $(LATEX) -interaction=batchmode Reference-Manual > /dev/null;\ ../tools/show_latex_messages -no-overfull Reference-Manual.log) -doc/refman/Reference-Manual.pdf: doc/refman/Reference-Manual.dvi +doc/refman/Reference-Manual.pdf: doc/refman/Reference-Manual.dvi $(REFMANPNGFILES) (cd doc/refman;\ $(PDFLATEX) -interaction=batchmode Reference-Manual.tex;\ ../tools/show_latex_messages -no-overfull Reference-Manual.log) @@ -133,7 +147,7 @@ refman-html-dir: doc/refman/Reference-Manual.html $(REFMANPNGFILES) \ - rm -rf doc/refman/html $(MKDIR) doc/refman/html $(INSTALLLIB) $(REFMANPNGFILES) doc/refman/html - (cd doc/refman/html; hacha -nolinks -tocbis -o toc.html ../styles.hva ../Reference-Manual.html) + (cd doc/refman/html; $(HACHA) -nolinks -tocbis -o toc.html ../styles.hva ../Reference-Manual.html) $(INSTALLLIB) doc/refman/cover.html doc/refman/html/index.html -$(INSTALLLIB) doc/common/styles/html/$(HTMLSTYLE)/*.css doc/refman/html @@ -173,7 +187,7 @@ doc/tutorial/Tutorial.v.html: $(DOCCOMMON) doc/tutorial/Tutorial.v.tex # FAQ ###################################################################### -doc/faq/FAQ.v.dvi: doc/common/version.tex doc/common/title.tex doc/faq/FAQ.v.tex +doc/faq/FAQ.v.dvi: doc/common/version.tex doc/common/title.tex doc/faq/FAQ.v.tex doc/faq/axioms.eps (cd doc/faq;\ $(LATEX) -interaction=batchmode FAQ.v;\ $(BIBTEX) -terse FAQ.v;\ @@ -181,12 +195,12 @@ doc/faq/FAQ.v.dvi: doc/common/version.tex doc/common/title.tex doc/faq/FAQ.v.tex $(LATEX) -interaction=batchmode FAQ.v > /dev/null;\ ../tools/show_latex_messages FAQ.v.log) -doc/faq/FAQ.v.pdf: doc/common/version.tex doc/common/title.tex doc/faq/FAQ.v.dvi doc/faq/axioms.png +doc/faq/FAQ.v.pdf: doc/common/version.tex doc/common/title.tex doc/faq/FAQ.v.dvi doc/faq/axioms.pdf (cd doc/faq;\ $(PDFLATEX) -interaction=batchmode FAQ.v.tex;\ ../tools/show_latex_messages FAQ.v.log) -doc/faq/FAQ.v.html: doc/faq/FAQ.v.dvi # to ensure FAQ.v.bbl +doc/faq/FAQ.v.html: doc/faq/FAQ.v.dvi doc/faq/axioms.png # to ensure FAQ.v.bbl (cd doc/faq; ($(HEVEA) $(HEVEAOPTS) FAQ.v.tex $(HEVEAFAQFILTER))) doc/faq/html/index.html: doc/faq/FAQ.v.html diff --git a/README.doc b/README.doc index 4e72c894..4e72c894 100755..100644 --- a/README.doc +++ b/README.doc diff --git a/checker/analyze.ml b/checker/analyze.ml new file mode 100644 index 00000000..c48b8301 --- /dev/null +++ b/checker/analyze.ml @@ -0,0 +1,350 @@ +(** Headers *) + +let prefix_small_block = 0x80 +let prefix_small_int = 0x40 +let prefix_small_string = 0x20 + +let code_int8 = 0x00 +let code_int16 = 0x01 +let code_int32 = 0x02 +let code_int64 = 0x03 +let code_shared8 = 0x04 +let code_shared16 = 0x05 +let code_shared32 = 0x06 +let code_double_array32_little = 0x07 +let code_block32 = 0x08 +let code_string8 = 0x09 +let code_string32 = 0x0A +let code_double_big = 0x0B +let code_double_little = 0x0C +let code_double_array8_big = 0x0D +let code_double_array8_little = 0x0E +let code_double_array32_big = 0x0F +let code_codepointer = 0x10 +let code_infixpointer = 0x11 +let code_custom = 0x12 +let code_block64 = 0x13 + +type code_descr = +| CODE_INT8 +| CODE_INT16 +| CODE_INT32 +| CODE_INT64 +| CODE_SHARED8 +| CODE_SHARED16 +| CODE_SHARED32 +| CODE_DOUBLE_ARRAY32_LITTLE +| CODE_BLOCK32 +| CODE_STRING8 +| CODE_STRING32 +| CODE_DOUBLE_BIG +| CODE_DOUBLE_LITTLE +| CODE_DOUBLE_ARRAY8_BIG +| CODE_DOUBLE_ARRAY8_LITTLE +| CODE_DOUBLE_ARRAY32_BIG +| CODE_CODEPOINTER +| CODE_INFIXPOINTER +| CODE_CUSTOM +| CODE_BLOCK64 + +let code_max = 0x13 + +let magic_number = "\132\149\166\190" + +(** Memory reification *) + +type repr = +| RInt of int +| RBlock of (int * int) (* tag × len *) +| RString of string +| RPointer of int +| RCode of int + +type data = +| Int of int (* value *) +| Ptr of int (* pointer *) +| Atm of int (* tag *) +| Fun of int (* address *) + +type obj = +| Struct of int * data array (* tag × data *) +| String of string + +module type Input = +sig + type t + val input_byte : t -> int + val input_binary_int : t -> int +end + +module type S = +sig + type input + val parse : input -> (data * obj array) +end + +module Make(M : Input) = +struct + +open M + +type input = M.t + +let current_offset = ref 0 + +let input_byte chan = + let () = incr current_offset in + input_byte chan + +let input_binary_int chan = + let () = current_offset := !current_offset + 4 in + input_binary_int chan + +let input_char chan = Char.chr (input_byte chan) + +let parse_header chan = + let () = current_offset := 0 in + let magic = String.create 4 in + let () = for i = 0 to 3 do magic.[i] <- input_char chan done in + let length = input_binary_int chan in + let objects = input_binary_int chan in + let size32 = input_binary_int chan in + let size64 = input_binary_int chan in + (magic, length, size32, size64, objects) + +let input_int8s chan = + let i = input_byte chan in + if i land 0x80 = 0 + then i + else i lor ((-1) lsl 8) + +let input_int8u = input_byte + +let input_int16s chan = + let i = input_byte chan in + let j = input_byte chan in + let ans = (i lsl 8) lor j in + if i land 0x80 = 0 + then ans + else ans lor ((-1) lsl 16) + +let input_int16u chan = + let i = input_byte chan in + let j = input_byte chan in + (i lsl 8) lor j + +let input_int32s chan = + let i = input_byte chan in + let j = input_byte chan in + let k = input_byte chan in + let l = input_byte chan in + let ans = (i lsl 24) lor (j lsl 16) lor (k lsl 8) lor l in + if i land 0x80 = 0 + then ans + else ans lor ((-1) lsl 31) + +let input_int32u chan = + let i = input_byte chan in + let j = input_byte chan in + let k = input_byte chan in + let l = input_byte chan in + (i lsl 24) lor (j lsl 16) lor (k lsl 8) lor l + +let input_int64s chan = + let i = input_byte chan in + let j = input_byte chan in + let k = input_byte chan in + let l = input_byte chan in + let m = input_byte chan in + let n = input_byte chan in + let o = input_byte chan in + let p = input_byte chan in + let ans = + (i lsl 56) lor (j lsl 48) lor (k lsl 40) lor (l lsl 32) lor + (m lsl 24) lor (n lsl 16) lor (o lsl 8) lor p + in + if i land 0x80 = 0 + then ans + else ans lor ((-1) lsl 63) + +let input_int64u chan = + let i = input_byte chan in + let j = input_byte chan in + let k = input_byte chan in + let l = input_byte chan in + let m = input_byte chan in + let n = input_byte chan in + let o = input_byte chan in + let p = input_byte chan in + (i lsl 56) lor (j lsl 48) lor (k lsl 40) lor (l lsl 32) lor + (m lsl 24) lor (n lsl 16) lor (o lsl 8) lor p + +let input_header32 chan = + let i = input_byte chan in + let j = input_byte chan in + let k = input_byte chan in + let l = input_byte chan in + let tag = l in + let len = (i lsl 14) lor (j lsl 6) lor (k lsr 2) in + (tag, len) + +let input_header64 chan = + let i = input_byte chan in + let j = input_byte chan in + let k = input_byte chan in + let l = input_byte chan in + let m = input_byte chan in + let n = input_byte chan in + let o = input_byte chan in + let p = input_byte chan in + let tag = p in + let len = + (i lsl 46) lor (j lsl 38) lor (k lsl 30) lor (l lsl 22) lor + (m lsl 14) lor (n lsl 6) lor (o lsr 2) + in + (tag, len) + +let input_string len chan = + let ans = String.create len in + for i = 0 to pred len do + ans.[i] <- input_char chan; + done; + ans + +let parse_object chan = + let data = input_byte chan in + if prefix_small_block <= data then + let tag = data land 0x0F in + let len = (data lsr 4) land 0x07 in + RBlock (tag, len) + else if prefix_small_int <= data then + RInt (data land 0x3F) + else if prefix_small_string <= data then + let len = data land 0x1F in + RString (input_string len chan) + else if data > code_max then + assert false + else match (Obj.magic data) with + | CODE_INT8 -> + RInt (input_int8s chan) + | CODE_INT16 -> + RInt (input_int16s chan) + | CODE_INT32 -> + RInt (input_int32s chan) + | CODE_INT64 -> + RInt (input_int64s chan) + | CODE_SHARED8 -> + RPointer (input_int8u chan) + | CODE_SHARED16 -> + RPointer (input_int16u chan) + | CODE_SHARED32 -> + RPointer (input_int32u chan) + | CODE_BLOCK32 -> + RBlock (input_header32 chan) + | CODE_BLOCK64 -> + RBlock (input_header64 chan) + | CODE_STRING8 -> + let len = input_int8u chan in + RString (input_string len chan) + | CODE_STRING32 -> + let len = input_int32u chan in + RString (input_string len chan) + | CODE_CODEPOINTER -> + let addr = input_int32u chan in + for i = 0 to 15 do ignore (input_byte chan); done; + RCode addr + | CODE_DOUBLE_ARRAY32_LITTLE + | CODE_DOUBLE_BIG + | CODE_DOUBLE_LITTLE + | CODE_DOUBLE_ARRAY8_BIG + | CODE_DOUBLE_ARRAY8_LITTLE + | CODE_DOUBLE_ARRAY32_BIG + | CODE_INFIXPOINTER + | CODE_CUSTOM -> + Printf.eprintf "Unhandled code %04x\n%!" data; assert false + +let parse chan = + let (magic, len, _, _, size) = parse_header chan in + let () = assert (magic = magic_number) in + let memory = Array.make size (Struct ((-1), [||])) in + let current_object = ref 0 in + let fill_obj = function + | RPointer n -> + let data = Ptr (!current_object - n) in + data, None + | RInt n -> + let data = Int n in + data, None + | RString s -> + let data = Ptr !current_object in + let () = memory.(!current_object) <- String s in + let () = incr current_object in + data, None + | RBlock (tag, 0) -> + (* Atoms are never shared *) + let data = Atm tag in + data, None + | RBlock (tag, len) -> + let data = Ptr !current_object in + let nblock = Array.make len (Atm (-1)) in + let () = memory.(!current_object) <- Struct (tag, nblock) in + let () = incr current_object in + data, Some nblock + | RCode addr -> + let data = Fun addr in + data, None + in + + let rec fill block off accu = + if Array.length block = off then + match accu with + | [] -> () + | (block, off) :: accu -> fill block off accu + else + let data, nobj = fill_obj (parse_object chan) in + let () = block.(off) <- data in + let block, off, accu = match nobj with + | None -> block, succ off, accu + | Some nblock -> nblock, 0, ((block, succ off) :: accu) + in + fill block off accu + in + let ans = [|Atm (-1)|] in + let () = fill ans 0 [] in + (ans.(0), memory) + +end + +module IChannel = +struct + type t = in_channel + let input_byte = Pervasives.input_byte + let input_binary_int = Pervasives.input_binary_int +end + +module IString = +struct + type t = (string * int ref) + + let input_byte (s, off) = + let ans = Char.code (s.[!off]) in + let () = incr off in + ans + + let input_binary_int chan = + let i = input_byte chan in + let j = input_byte chan in + let k = input_byte chan in + let l = input_byte chan in + let ans = (i lsl 24) lor (j lsl 16) lor (k lsl 8) lor l in + if i land 0x80 = 0 + then ans + else ans lor ((-1) lsl 31) + +end + +module PChannel = Make(IChannel) +module PString = Make(IString) + +let parse_channel = PChannel.parse +let parse_string s = PString.parse (s, ref 0) diff --git a/checker/analyze.mli b/checker/analyze.mli new file mode 100644 index 00000000..42efcf01 --- /dev/null +++ b/checker/analyze.mli @@ -0,0 +1,35 @@ +type data = +| Int of int +| Ptr of int +| Atm of int (* tag *) +| Fun of int (* address *) + +type obj = +| Struct of int * data array (* tag × data *) +| String of string + +val parse_channel : in_channel -> (data * obj array) +val parse_string : string -> (data * obj array) + +(** {6 Functorized version} *) + +module type Input = +sig + type t + val input_byte : t -> int + (** Input a single byte *) + val input_binary_int : t -> int + (** Input a big-endian 31-bits signed integer *) +end +(** Type of inputs *) + +module type S = +sig + type input + val parse : input -> (data * obj array) + (** Return the entry point and the reification of the memory out of a + marshalled structure. *) +end + +module Make (M : Input) : S with type input = M.t +(** Functorized version of the previous code. *) diff --git a/checker/check.ml b/checker/check.ml index 3e22c4b1..21c8f1c5 100644 --- a/checker/check.ml +++ b/checker/check.ml @@ -46,7 +46,7 @@ type library_t = { library_opaques : Cic.opaque_table; library_deps : Cic.library_deps; library_digest : Cic.vodigest; - library_extra_univs : Univ.constraints } + library_extra_univs : Univ.ContextSet.t } module LibraryOrdered = struct @@ -97,7 +97,7 @@ let access_opaque_univ_table dp i = let t = LibraryMap.find dp !opaque_univ_tables in assert (i < Array.length t); Future.force t.(i) - with Not_found -> Univ.empty_constraint + with Not_found -> Univ.ContextSet.empty let _ = Declarations.indirect_opaque_access := access_opaque_table @@ -271,32 +271,22 @@ let try_locate_qualified_library qid = | LibNotFound -> error_lib_not_found qid (************************************************************************) -(*s Low-level interning/externing of libraries to files *) +(*s Low-level interning of libraries from files *) -(*s Loading from disk to cache (preparation phase) *) - -let raw_intern_library = - snd (System.raw_extern_intern Coq_config.vo_magic_number) - -let with_magic_number_check f a = - try f a - with System.Bad_magic_number fname -> - errorlabstrm "with_magic_number_check" - (str"file " ++ str fname ++ spc () ++ str"has bad magic number." ++ - spc () ++ str"It is corrupted" ++ spc () ++ - str"or was compiled with another version of Coq.") +let raw_intern_library f = + System.raw_intern_state Coq_config.vo_magic_number f (************************************************************************) (* Internalise libraries *) open Cic -let mk_library md f table digest cst = { - library_name = md.md_name; +let mk_library sd md f table digest cst = { + library_name = sd.md_name; library_filename = f; library_compiled = md.md_compiled; library_opaques = table; - library_deps = md.md_deps; + library_deps = sd.md_deps; library_digest = digest; library_extra_univs = cst } @@ -310,10 +300,11 @@ let depgraph = ref LibraryMap.empty let intern_from_file (dir, f) = Flags.if_verbose pp (str"[intern "++str f++str" ..."); pp_flush (); - let (md,table,opaque_csts,digest) = + let (sd,md,table,opaque_csts,digest) = try - let ch = with_magic_number_check raw_intern_library f in - let (md:Cic.library_disk), _, digest = System.marshal_in_segment f ch in + 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 (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 @@ -325,9 +316,9 @@ let intern_from_file (dir, f) = if not (String.equal (Digest.channel ch pos) checksum) then errorlabstrm "intern_from_file" (str "Checksum mismatch"); let () = close_in ch in - if dir <> md.md_name then + if dir <> sd.md_name then errorlabstrm "intern_from_file" - (name_clash_message dir md.md_name f); + (name_clash_message dir sd.md_name f); if tasks <> None || discharging <> None then errorlabstrm "intern_from_file" (str "The file "++str f++str " contains unfinished tasks"); @@ -340,25 +331,25 @@ let intern_from_file (dir, f) = Validate.validate !Flags.debug Values.v_univopaques opaque_csts; end; (* Verification of the unmarshalled values *) + Validate.validate !Flags.debug Values.v_libsum sd; Validate.validate !Flags.debug Values.v_lib md; Validate.validate !Flags.debug Values.v_opaques table; Flags.if_verbose ppnl (str" done]"); pp_flush (); let digest = if opaque_csts <> None then Cic.Dviovo (digest,udg) else (Cic.Dvo digest) in - md,table,opaque_csts,digest + sd,md,table,opaque_csts,digest with e -> Flags.if_verbose ppnl (str" failed!]"); raise e in - depgraph := LibraryMap.add md.md_name md.md_deps !depgraph; - opaque_tables := LibraryMap.add md.md_name table !opaque_tables; + depgraph := LibraryMap.add sd.md_name sd.md_deps !depgraph; + opaque_tables := LibraryMap.add sd.md_name table !opaque_tables; Option.iter (fun (opaque_csts,_,_) -> opaque_univ_tables := - LibraryMap.add md.md_name opaque_csts !opaque_univ_tables) + LibraryMap.add sd.md_name opaque_csts !opaque_univ_tables) opaque_csts; let extra_cst = - Option.default Univ.empty_constraint - (Option.map (fun (_,cs,_) -> - Univ.ContextSet.constraints cs) opaque_csts) in - mk_library md f table digest extra_cst + Option.default Univ.ContextSet.empty + (Option.map (fun (_,cs,_) -> cs) opaque_csts) in + mk_library sd md f table digest extra_cst let get_deps (dir, f) = try LibraryMap.find dir !depgraph diff --git a/checker/check.mllib b/checker/check.mllib index 22df3756..49ca6bf0 100644 --- a/checker/check.mllib +++ b/checker/check.mllib @@ -1,6 +1,7 @@ Coq_config Hook +Terminal Canary Hashset Hashcons @@ -23,13 +24,14 @@ Pp Segmenttree Unicodetable Unicode -Errors CObj CList CString CArray CStack Util +Ppstyle +Errors Ephemeron Future CUnix diff --git a/checker/check_stat.ml b/checker/check_stat.ml index 05a2a1b9..d041f1b7 100644 --- a/checker/check_stat.ml +++ b/checker/check_stat.ml @@ -23,11 +23,17 @@ let print_memory_stat () = let output_context = ref false -let pr_engt = function - Some ImpredicativeSet -> - str "Theory: Set is impredicative" - | None -> - str "Theory: Set is predicative" +let pr_engagement (impr_set,type_in_type) = + begin + match impr_set with + | ImpredicativeSet -> str "Theory: Set is impredicative" + | PredicativeSet -> str "Theory: Set is predicative" + end ++ + begin + match type_in_type with + | StratifiedType -> str "Theory: Stratified type hierarchy" + | TypeInType -> str "Theory: Type is of type Type" + end let cst_filter f csts = Cmap_env.fold @@ -54,7 +60,7 @@ let print_context env = ppnl(hov 0 (fnl() ++ str"CONTEXT SUMMARY" ++ fnl() ++ str"===============" ++ fnl() ++ fnl() ++ - str "* " ++ hov 0 (pr_engt engt ++ fnl()) ++ fnl() ++ + str "* " ++ hov 0 (pr_engagement engt ++ fnl()) ++ fnl() ++ str "* " ++ hov 0 (pr_ax csts) ++ fnl())); pp_flush() end diff --git a/checker/checker.ml b/checker/checker.ml index 9a1007ac..d5d9b9e3 100644 --- a/checker/checker.ml +++ b/checker/checker.ml @@ -67,13 +67,13 @@ let add_path ~unix_path:dir ~coq_root:coq_dirpath = Check.add_load_path (dir,coq_dirpath) end else - msg_warning (str ("Cannot open " ^ dir)) + msg_warning (str "Cannot open " ++ str dir) let convert_string d = try Id.of_string d with Errors.UserError _ -> if_verbose msg_warning - (str ("Directory "^d^" cannot be used as a Coq identifier (skipped)")); + (str "Directory " ++ str d ++ str " cannot be used as a Coq identifier (skipped)"); raise Exit let add_rec_path ~unix_path ~coq_root = @@ -90,7 +90,7 @@ let add_rec_path ~unix_path ~coq_root = List.iter Check.add_load_path dirs; Check.add_load_path (unix_path, coq_root) else - msg_warning (str ("Cannot open " ^ unix_path)) + msg_warning (str "Cannot open " ++ str unix_path) (* By the option -include -I or -R of the command line *) let includes = ref [] @@ -138,10 +138,11 @@ let init_load_path () = let set_debug () = Flags.debug := true -let engagement = ref None -let set_engagement c = engagement := Some c -let engage () = - match !engagement with Some c -> Safe_typing.set_engagement c | None -> () +let impredicative_set = ref Cic.PredicativeSet +let set_impredicative_set () = impredicative_set := Cic.ImpredicativeSet +let type_in_type = ref Cic.StratifiedType +let set_type_in_type () = type_in_type := Cic.TypeInType +let engage () = Safe_typing.set_engagement (!impredicative_set,!type_in_type) let admit_list = ref ([] : section_path list) @@ -194,6 +195,7 @@ let print_usage_channel co command = \n -silent disable trace of constants being checked\ \n\ \n -impredicative-set set sort Set impredicative\ +\n -type-in-type collapse type hierarchy\ \n\ \n -h, --help print this list of options\ \n" @@ -221,7 +223,7 @@ let print_loc loc = else let loc = Loc.unloc loc in (int (fst loc) ++ str"-" ++ int (snd loc)) -let guill s = "\""^s^"\"" +let guill s = str "\"" ++ str s ++ str "\"" let where s = if !Flags.debug then (str"in " ++ str s ++ str":" ++ spc ()) else (mt ()) @@ -232,7 +234,7 @@ let rec explain_exn = function | Stream.Error txt -> hov 0 (str "Syntax error: " ++ str txt) | Sys_error msg -> - hov 0 (anomaly_string () ++ str "uncaught exception Sys_error " ++ str (guill msg) ++ report() ) + hov 0 (anomaly_string () ++ str "uncaught exception Sys_error " ++ guill msg ++ report() ) | UserError(s,pps) -> hov 1 (str "User error: " ++ where s ++ pps) | Out_of_memory -> @@ -241,14 +243,14 @@ let rec explain_exn = function hov 0 (str "Stack overflow") | Match_failure(filename,pos1,pos2) -> hov 1 (anomaly_string () ++ str "Match failure in file " ++ - str (guill filename) ++ str " at line " ++ int pos1 ++ + guill filename ++ str " at line " ++ int pos1 ++ str " character " ++ int pos2 ++ report ()) | Not_found -> hov 0 (anomaly_string () ++ str "uncaught exception Not_found" ++ report ()) | Failure s -> hov 0 (str "Failure: " ++ str s ++ report ()) | Invalid_argument s -> - hov 0 (anomaly_string () ++ str "uncaught exception Invalid_argument " ++ str (guill s) ++ report ()) + hov 0 (anomaly_string () ++ str "uncaught exception Invalid_argument " ++ guill s ++ report ()) | Sys.Break -> hov 0 (fnl () ++ str "User interrupt.") | Univ.UniverseInconsistency (o,u,v) -> @@ -294,7 +296,7 @@ let rec explain_exn = function Format.printf "@\n====== universes ====@\n"; Pp.pp (Univ.pr_universes (ctx.Environ.env_stratification.Environ.env_universes)); - str("\nCantApplyBadType at argument " ^ string_of_int n) + str "\nCantApplyBadType at argument " ++ int n | CantApplyNonFunctional _ -> str"CantApplyNonFunctional" | IllFormedRecBody _ -> str"IllFormedRecBody" | IllTypedRecBody _ -> str"IllTypedRecBody" @@ -309,7 +311,7 @@ let rec explain_exn = function hov 0 (anomaly_string () ++ str "assert failure" ++ spc () ++ (if s = "" then mt () else - (str ("(file \"" ^ s ^ "\", line ") ++ int b ++ + (str "(file \"" ++ str s ++ str "\", line " ++ int b ++ str ", characters " ++ int e ++ str "-" ++ int (e+6) ++ str ")")) ++ report ()) @@ -319,11 +321,13 @@ let parse_args argv = let rec parse = function | [] -> () | "-impredicative-set" :: rem -> - set_engagement Cic.ImpredicativeSet; parse rem + set_impredicative_set (); parse rem + | "-type-in-type" :: rem -> + set_type_in_type (); parse rem | "-coqlib" :: s :: rem -> if not (exists_dir s) then - fatal_error (str ("Directory '"^s^"' does not exist")) false; + fatal_error (str "Directory '" ++ str s ++ str "' does not exist") false; Flags.coqlib := s; Flags.coqlib_spec := true; parse rem diff --git a/checker/cic.mli b/checker/cic.mli index 90a0e9fe..bd75111a 100644 --- a/checker/cic.mli +++ b/checker/cic.mli @@ -102,7 +102,7 @@ type constr = | Case of case_info * constr * constr * constr array | Fix of constr pfixpoint | CoFix of constr pcofixpoint - | Proj of constant * constr + | Proj of projection * constr type existential = constr pexistential type rec_declaration = constr prec_declaration @@ -165,7 +165,10 @@ type action (** Engagements *) -type engagement = ImpredicativeSet +type set_predicativity = ImpredicativeSet | PredicativeSet +type type_hierarchy = TypeInType | StratifiedType + +type engagement = set_predicativity * type_hierarchy (** {6 Representation of constants (Definition/Axiom) } *) @@ -377,7 +380,7 @@ and module_body = (** algebraic type, kept if it's relevant for extraction *) mod_type_alg : module_expression option; (** set of all constraints in the module *) - mod_constraints : Univ.constraints; + mod_constraints : Univ.ContextSet.t; (** quotiented set of equivalent constants and inductive names *) mod_delta : delta_resolver; mod_retroknowledge : action list } @@ -407,7 +410,7 @@ type compiled_library = { comp_name : compilation_unit_name; comp_mod : module_body; comp_deps : library_deps; - comp_enga : engagement option; + comp_enga : engagement; comp_natsymbs : nativecode_symb_array } @@ -417,12 +420,16 @@ type compiled_library = { type library_objects -type library_disk = { +type summary_disk = { md_name : compilation_unit_name; + md_imports : compilation_unit_name array; + md_deps : library_deps; +} + +type library_disk = { md_compiled : compiled_library; md_objects : library_objects; - md_deps : library_deps; - md_imports : compilation_unit_name array } +} type opaque_table = constr Future.computation array type univ_table = diff --git a/checker/closure.ml b/checker/closure.ml index 356b683f..c6cc2185 100644 --- a/checker/closure.ml +++ b/checker/closure.ml @@ -276,7 +276,7 @@ and fterm = | FInd of pinductive | FConstruct of pconstructor | FApp of fconstr * fconstr array - | FProj of constant * fconstr + | FProj of projection * fconstr | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs | FCase of case_info * fconstr * fconstr * fconstr array @@ -308,7 +308,7 @@ type stack_member = | Zapp of fconstr array | Zcase of case_info * fconstr * fconstr array | ZcaseT of case_info * constr * constr array * fconstr subs - | Zproj of int * int * constant + | Zproj of int * int * projection | Zfix of fconstr * stack | Zshift of int | Zupdate of fconstr @@ -678,8 +678,9 @@ let eta_expand_ind_stack env ind m s (f, s') = let (depth, args, s) = strip_update_shift_app m s in (** Try to drop the params, might fail on partially applied constructors. *) let argss = try_drop_parameters depth pars args in - let hstack = Array.map (fun p -> { norm = Red; (* right can't be a constructor though *) - term = FProj (p, right) }) projs in + let hstack = + Array.map (fun p -> { norm = Red; (* right can't be a constructor though *) + term = FProj (Projection.make p false, right) }) projs in argss, [Zapp hstack] | _ -> raise Not_found (* disallow eta-exp for non-primitive records *) @@ -738,7 +739,7 @@ let rec knh info m stk = | FCast(t,_,_) -> knh info t stk | FProj (p,c) -> - if red_set info.i_flags (fCONST p) then + if red_set info.i_flags (fCONST (Projection.constant p)) then (let pb = lookup_projection p (info.i_env) in knh info c (Zproj (pb.proj_npars, pb.proj_arg, p) :: zupdate m stk)) diff --git a/checker/closure.mli b/checker/closure.mli index e6b39250..376e9fef 100644 --- a/checker/closure.mli +++ b/checker/closure.mli @@ -95,7 +95,7 @@ type fterm = | FInd of pinductive | FConstruct of pconstructor | FApp of fconstr * fconstr array - | FProj of constant * fconstr + | FProj of projection * fconstr | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs | FCase of case_info * fconstr * fconstr * fconstr array @@ -117,7 +117,7 @@ type stack_member = | Zapp of fconstr array | Zcase of case_info * fconstr * fconstr array | ZcaseT of case_info * constr * constr array * fconstr subs - | Zproj of int * int * constant + | Zproj of int * int * projection | Zfix of fconstr * stack | Zshift of int | Zupdate of fconstr diff --git a/checker/declarations.ml b/checker/declarations.ml index 8d913475..32d1713a 100644 --- a/checker/declarations.ml +++ b/checker/declarations.ml @@ -206,14 +206,15 @@ let rec map_kn f f' c = let func = map_kn f f' in match c with | Const (kn, u) -> (try snd (f' kn u) with No_subst -> c) - | Proj (kn,t) -> - let kn' = - try fst (f' kn Univ.Instance.empty) - with No_subst -> kn + | Proj (p,t) -> + let p' = + Projection.map (fun kn -> + try fst (f' kn Univ.Instance.empty) + with No_subst -> kn) p in let t' = func t in - if kn' == kn && t' == t then c - else Proj (kn', t') + if p' == p && t' == t then c + else Proj (p', t') | Ind ((kn,i),u) -> let kn' = f kn in if kn'==kn then c else Ind ((kn',i),u) @@ -425,7 +426,7 @@ let subst_lazy_constr sub = function let indirect_opaque_access = ref ((fun dp i -> assert false) : DirPath.t -> int -> constr) let indirect_opaque_univ_access = - ref ((fun dp i -> assert false) : DirPath.t -> int -> Univ.constraints) + ref ((fun dp i -> assert false) : DirPath.t -> int -> Univ.ContextSet.t) let force_lazy_constr = function | Indirect (l,dp,i) -> @@ -434,7 +435,7 @@ let force_lazy_constr = function let force_lazy_constr_univs = function | OpaqueDef (Indirect (l,dp,i)) -> !indirect_opaque_univ_access dp i - | _ -> Univ.empty_constraint + | _ -> Univ.ContextSet.empty let subst_constant_def sub = function | Undef inl -> Undef inl @@ -456,6 +457,8 @@ let is_opaque cb = match cb.const_body with | OpaqueDef _ -> true | Def _ | Undef _ -> false +let opaque_univ_context cb = force_lazy_constr_univs cb.const_body + let subst_rel_declaration sub (id,copt,t as x) = let copt' = Option.smartmap (subst_mps sub) copt in let t' = subst_mps sub t in diff --git a/checker/declarations.mli b/checker/declarations.mli index 3c6db6ab..456df836 100644 --- a/checker/declarations.mli +++ b/checker/declarations.mli @@ -2,17 +2,18 @@ open Names open Cic val force_constr : constr_substituted -> constr -val force_lazy_constr_univs : Cic.constant_def -> Univ.constraints +val force_lazy_constr_univs : Cic.constant_def -> Univ.ContextSet.t val from_val : constr -> constr_substituted val indirect_opaque_access : (DirPath.t -> int -> constr) ref -val indirect_opaque_univ_access : (DirPath.t -> int -> Univ.constraints) ref +val indirect_opaque_univ_access : (DirPath.t -> int -> Univ.ContextSet.t) ref (** Constant_body *) val body_of_constant : constant_body -> constr option val constant_has_body : constant_body -> bool val is_opaque : constant_body -> bool +val opaque_univ_context : constant_body -> Univ.ContextSet.t (* Mutual inductives *) diff --git a/checker/environ.ml b/checker/environ.ml index 710ebc71..f8f5c29b 100644 --- a/checker/environ.ml +++ b/checker/environ.ml @@ -14,7 +14,7 @@ type globals = { type stratification = { env_universes : Univ.universes; - env_engagement : engagement option + env_engagement : engagement } type env = { @@ -33,19 +33,28 @@ let empty_env = { env_rel_context = []; env_stratification = { env_universes = Univ.initial_universes; - env_engagement = None}; + env_engagement = (PredicativeSet,StratifiedType)}; env_imports = MPmap.empty } let engagement env = env.env_stratification.env_engagement let universes env = env.env_stratification.env_universes let rel_context env = env.env_rel_context -let set_engagement c env = - match env.env_stratification.env_engagement with - | Some c' -> if c=c' then env else error "Incompatible engagement" - | None -> - { env with env_stratification = - { env.env_stratification with env_engagement = Some c } } +let set_engagement (impr_set,type_in_type as c) env = + let expected_impr_set,expected_type_in_type = + env.env_stratification.env_engagement in + begin + match impr_set,expected_impr_set with + | PredicativeSet, ImpredicativeSet -> error "Incompatible engagement" + | _ -> () + end; + begin + match type_in_type,expected_type_in_type with + | StratifiedType, TypeInType -> error "Incompatible engagement" + | _ -> () + end; + { env with env_stratification = + { env.env_stratification with env_engagement = c } } (* Digests *) @@ -75,13 +84,20 @@ let push_rec_types (lna,typarray,_) env = Array.fold_left (fun e assum -> push_rel assum e) env ctxt (* Universe constraints *) -let add_constraints c env = - if c == Univ.Constraint.empty then - env - else - let s = env.env_stratification in +let map_universes f env = + let s = env.env_stratification in { env with env_stratification = - { s with env_universes = Univ.merge_constraints c s.env_universes } } + { s with env_universes = f s.env_universes } } + +let add_constraints c env = + if c == Univ.Constraint.empty then env + else map_universes (Univ.merge_constraints c) env + +let push_context ?(strict=false) ctx env = + map_universes (Univ.merge_context strict ctx) env + +let push_context_set ?(strict=false) ctx env = + map_universes (Univ.merge_context_set strict ctx) env let check_constraints cst env = Univ.check_constraints cst env.env_stratification.env_universes @@ -147,8 +163,8 @@ let evaluable_constant cst env = let is_projection cst env = not (Option.is_empty (lookup_constant cst env).const_proj) -let lookup_projection cst env = - match (lookup_constant cst env).const_proj with +let lookup_projection p env = + match (lookup_constant (Projection.constant p) env).const_proj with | Some pb -> pb | None -> anomaly ("lookup_projection: constant is not a projection") diff --git a/checker/environ.mli b/checker/environ.mli index d3448b12..87f143d1 100644 --- a/checker/environ.mli +++ b/checker/environ.mli @@ -11,7 +11,7 @@ type globals = { env_modtypes : module_type_body MPmap.t} type stratification = { env_universes : Univ.universes; - env_engagement : engagement option; + env_engagement : engagement; } type env = { env_globals : globals; @@ -22,7 +22,7 @@ type env = { val empty_env : env (* Engagement *) -val engagement : env -> Cic.engagement option +val engagement : env -> Cic.engagement val set_engagement : Cic.engagement -> env -> env (* Digests *) @@ -39,6 +39,8 @@ val push_rec_types : name array * constr array * 'a -> env -> env (* Universes *) val universes : env -> Univ.universes val add_constraints : Univ.constraints -> env -> env +val push_context : ?strict:bool -> Univ.universe_context -> env -> env +val push_context_set : ?strict:bool -> Univ.universe_context_set -> env -> env val check_constraints : Univ.constraints -> env -> bool (* Constants *) @@ -51,7 +53,7 @@ val constant_value : env -> constant puniverses -> constr val evaluable_constant : constant -> env -> bool val is_projection : constant -> env -> bool -val lookup_projection : constant -> env -> projection_body +val lookup_projection : projection -> env -> projection_body (* Inductives *) val mind_equiv : env -> inductive -> inductive -> bool diff --git a/checker/indtypes.ml b/checker/indtypes.ml index 050c33e6..f02f03dc 100644 --- a/checker/indtypes.ml +++ b/checker/indtypes.ml @@ -176,7 +176,7 @@ let typecheck_arity env params inds = (* Allowed eliminations *) let check_predicativity env s small level = - match s, engagement env with + match s, fst (engagement env) with Type u, _ -> (* let u' = fresh_local_univ () in *) (* let cst = *) @@ -184,7 +184,7 @@ let check_predicativity env s small level = (* (universes env) in *) if not (Univ.check_leq (universes env) level u) then failwith "impredicative Type inductive type" - | Prop Pos, Some ImpredicativeSet -> () + | Prop Pos, ImpredicativeSet -> () | Prop Pos, _ -> if not small then failwith "impredicative Set inductive type" | Prop Null,_ -> () @@ -269,7 +269,7 @@ type ill_formed_ind = | LocalNonPos of int | LocalNotEnoughArgs of int | LocalNotConstructor - | LocalNonPar of int * int + | LocalNonPar of int * int * int exception IllFormedInd of ill_formed_ind @@ -291,9 +291,9 @@ let explain_ind_err ntyp env0 nbpar c err = | LocalNotConstructor -> raise (InductiveError (NotConstructor (env,c',Rel (ntyp+nbpar)))) - | LocalNonPar (n,l) -> + | LocalNonPar (n,i,l) -> raise (InductiveError - (NonPar (env,c',n,Rel (nbpar-n+1), Rel (l+nbpar)))) + (NonPar (env,c',n,Rel i,Rel (l+nbpar)))) let failwith_non_pos n ntypes c = for k = n to n + ntypes - 1 do @@ -323,7 +323,7 @@ let check_correct_par (env,n,ntypes,_) hyps l largs = | _::hyps -> match whd_betadeltaiota env lpar.(k) with | Rel w when w = index -> check (k-1) (index+1) hyps - | _ -> raise (IllFormedInd (LocalNonPar (k+1,l))) + | _ -> raise (IllFormedInd (LocalNonPar (k+1,index,l))) in check (nparams-1) (n-nhyps) hyps; if not (Array.for_all (noccur_between n ntypes) largs') then failwith_non_pos_vect n ntypes largs' diff --git a/checker/inductive.ml b/checker/inductive.ml index 59d1a645..21b80f32 100644 --- a/checker/inductive.ml +++ b/checker/inductive.ml @@ -103,13 +103,12 @@ let instantiate_params full t u args sign = let full_inductive_instantiate mib u params sign = let dummy = Prop Null in - let t = mkArity (sign,dummy) in + let t = mkArity (subst_instance_context u sign,dummy) in fst (destArity (instantiate_params true t u params mib.mind_params_ctxt)) -let full_constructor_instantiate ((mind,_),u,(mib,_),params) = - let inst_ind = constructor_instantiate mind u mib in - (fun t -> - instantiate_params true (inst_ind t) u params mib.mind_params_ctxt) +let full_constructor_instantiate ((mind,_),u,(mib,_),params) t = + let inst_ind = constructor_instantiate mind u mib t in + instantiate_params true inst_ind u params mib.mind_params_ctxt (************************************************************************) (************************************************************************) @@ -142,53 +141,60 @@ let sort_as_univ = function | Prop Null -> Univ.type0m_univ | Prop Pos -> Univ.type0_univ +(* cons_subst add the mapping [u |-> su] in subst if [u] is not *) +(* in the domain or add [u |-> sup x su] if [u] is already mapped *) +(* to [x]. *) let cons_subst u su subst = - Univ.LMap.add u su subst - -let actualize_decl_level env lev t = - let sign,s = dest_arity env t in - mkArity (sign,lev) - -let polymorphism_on_non_applied_parameters = false + try + Univ.LMap.add u (Univ.sup (Univ.LMap.find u subst) su) subst + with Not_found -> Univ.LMap.add u su subst + +(* remember_subst updates the mapping [u |-> x] by [u |-> sup x u] *) +(* if it is presents and returns the substitution unchanged if not.*) +let remember_subst u subst = + try + let su = Universe.make u in + Univ.LMap.add u (Univ.sup (Univ.LMap.find u subst) su) subst + with Not_found -> subst (* Bind expected levels of parameters to actual levels *) (* Propagate the new levels in the signature *) -let rec make_subst env = function - | (_,Some _,_ as t)::sign, exp, args -> - let ctx,subst = make_subst env (sign, exp, args) in - t::ctx, subst - | d::sign, None::exp, args -> - let args = match args with _::args -> args | [] -> [] in - let ctx,subst = make_subst env (sign, exp, args) in - d::ctx, subst - | d::sign, Some u::exp, a::args -> - (* We recover the level of the argument, but we don't change the *) - (* level in the corresponding type in the arity; this level in the *) - (* arity is a global level which, at typing time, will be enforce *) - (* to be greater than the level of the argument; this is probably *) - (* a useless extra constraint *) - let s = sort_as_univ (snd (dest_arity env a)) in - let ctx,subst = make_subst env (sign, exp, args) in - d::ctx, cons_subst u s subst - | (na,None,t as d)::sign, Some u::exp, [] -> - (* No more argument here: we instantiate the type with a fresh level *) - (* which is first propagated to the corresponding premise in the arity *) - (* (actualize_decl_level), then to the conclusion of the arity (via *) - (* the substitution) *) - let ctx,subst = make_subst env (sign, exp, []) in - d::ctx, subst - | sign, [], _ -> - (* Uniform parameters are exhausted *) - sign,Univ.LMap.empty - | [], _, _ -> - assert false - +let rec make_subst env = + let rec make subst = function + | (_,Some _,_)::sign, exp, args -> + make subst (sign, exp, args) + | d::sign, None::exp, args -> + let args = match args with _::args -> args | [] -> [] in + make subst (sign, exp, args) + | d::sign, Some u::exp, a::args -> + (* We recover the level of the argument, but we don't change the *) + (* level in the corresponding type in the arity; this level in the *) + (* arity is a global level which, at typing time, will be enforce *) + (* to be greater than the level of the argument; this is probably *) + (* a useless extra constraint *) + let s = sort_as_univ (snd (dest_arity env a)) in + make (cons_subst u s subst) (sign, exp, args) + | (na,None,t)::sign, Some u::exp, [] -> + (* No more argument here: we add the remaining universes to the *) + (* substitution (when [u] is distinct from all other universes in the *) + (* template, it is identity substitution otherwise (ie. when u is *) + (* already in the domain of the substitution) [remember_subst] will *) + (* update its image [x] by [sup x u] in order not to forget the *) + (* dependency in [u] that remains to be fullfilled. *) + make (remember_subst u subst) (sign, exp, []) + | sign, [], _ -> + (* Uniform parameters are exhausted *) + subst + | [], _, _ -> + assert false + in + make Univ.LMap.empty exception SingletonInductiveBecomesProp of Id.t let instantiate_universes env ctx ar argsorts = let args = Array.to_list argsorts in - let ctx,subst = make_subst env (ctx,ar.template_param_levels,args) in + let subst = make_subst env (ctx,ar.template_param_levels,args) in let level = Univ.subst_univs_universe (Univ.make_subst subst) ar.template_level in let ty = (* Singleton type not containing types are interpretable in Prop *) diff --git a/checker/mod_checking.ml b/checker/mod_checking.ml index 998e23c6..3ea5ed0d 100644 --- a/checker/mod_checking.ml +++ b/checker/mod_checking.ml @@ -18,19 +18,27 @@ let refresh_arity ar = let ctxt, hd = decompose_prod_assum ar in match hd with Sort (Type u) when not (Univ.is_univ_variable u) -> - let u' = Univ.Universe.make (Univ.Level.make empty_dirpath 1) in - mkArity (ctxt,Prop Null), - Univ.enforce_leq u u' Univ.empty_constraint - | _ -> ar, Univ.empty_constraint + let ul = Univ.Level.make empty_dirpath 1 in + let u' = Univ.Universe.make ul in + let cst = Univ.enforce_leq u u' Univ.empty_constraint in + let ctx = Univ.ContextSet.make (Univ.LSet.singleton ul) cst in + mkArity (ctxt,Prop Null), ctx + | _ -> ar, Univ.ContextSet.empty let check_constant_declaration env kn cb = Flags.if_verbose ppnl (str " checking cst: " ++ prcon kn); pp_flush (); - let env' = add_constraints (Univ.UContext.constraints cb.const_universes) env in + let env' = + if cb.const_polymorphic then + let inst = Univ.make_abstract_instance cb.const_universes in + let ctx = Univ.UContext.make (inst, Univ.UContext.constraints cb.const_universes) in + push_context ~strict:false ctx env + else push_context ~strict:true cb.const_universes env + in let envty, ty = match cb.const_type with RegularArity ty -> let ty', cu = refresh_arity ty in - let envty = add_constraints cu env' in + let envty = push_context_set cu env' in let _ = infer_type envty ty' in envty, ty | TemplateArity(ctxt,par) -> let _ = check_ctxt env' ctxt in @@ -69,7 +77,7 @@ let mk_mtb mp sign delta = mod_expr = Abstract; mod_type = sign; mod_type_alg = None; - mod_constraints = Univ.Constraint.empty; + mod_constraints = Univ.ContextSet.empty; mod_delta = delta; mod_retroknowledge = []; } diff --git a/checker/modops.ml b/checker/modops.ml index 8ccf118d..7f07f8bf 100644 --- a/checker/modops.ml +++ b/checker/modops.ml @@ -83,12 +83,13 @@ let strengthen_const mp_from l cb resolver = | Def _ -> cb | _ -> let con = Constant.make2 mp_from l in - (* let con = constant_of_delta resolver con in*) let u = - if cb.const_polymorphic then Univ.UContext.instance cb.const_universes + if cb.const_polymorphic then + Univ.make_abstract_instance cb.const_universes else Univ.Instance.empty in - { cb with const_body = Def (Declarations.from_val (Const (con,u))) } + { cb with + const_body = Def (Declarations.from_val (Const (con,u))) } let rec strengthen_mod mp_from mp_to mb = if Declarations.mp_in_delta mb.mod_mp mb.mod_delta then mb diff --git a/checker/print.ml b/checker/print.ml index 1cc48ff7..7624fd32 100644 --- a/checker/print.ml +++ b/checker/print.ml @@ -100,7 +100,7 @@ let print_pure_constr csr = done in print_string"{"; print_fix (); print_string"}" | Proj (p, c) -> - print_string "Proj("; sp_con_display p; print_string ","; + print_string "Proj("; sp_con_display (Projection.constant p); print_string ","; box_display c; print_string ")" and box_display c = open_hovbox 1; term_display c; close_box() diff --git a/checker/reduction.ml b/checker/reduction.ml index 28fdb130..384d883e 100644 --- a/checker/reduction.ml +++ b/checker/reduction.ml @@ -52,7 +52,7 @@ let compare_stack_shape stk1 stk2 = type lft_constr_stack_elt = Zlapp of (lift * fconstr) array - | Zlproj of Names.constant * lift + | Zlproj of Names.projection * lift | Zlfix of (lift * fconstr) * lft_constr_stack | Zlcase of case_info * lift * fconstr * fconstr array and lft_constr_stack = lft_constr_stack_elt list @@ -137,7 +137,9 @@ let compare_stacks f fmind lft1 stk1 lft2 stk2 = | (Zlfix(fx1,a1),Zlfix(fx2,a2)) -> f fx1 fx2; cmp_rec a1 a2 | (Zlproj (c1,l1),Zlproj (c2,l2)) -> - if not (Names.eq_con_chk c1 c2) then + if not (Names.eq_con_chk + (Names.Projection.constant c1) + (Names.Projection.constant c2)) then raise NotConvertible | (Zlcase(ci1,l1,p1,br1),Zlcase(ci2,l2,p2,br2)) -> if not (fmind ci1.ci_ind ci2.ci_ind) then @@ -156,7 +158,7 @@ type conv_pb = | CONV | CUMUL -let sort_cmp univ pb s0 s1 = +let sort_cmp env univ pb s0 s1 = match (s0,s1) with | (Prop c1, Prop c2) when pb = CUMUL -> if c1 = Pos && c2 = Null then raise NotConvertible | (Prop c1, Prop c2) -> if c1 <> c2 then raise NotConvertible @@ -165,14 +167,15 @@ let sort_cmp univ pb s0 s1 = CUMUL -> () | _ -> raise NotConvertible) | (Type u1, Type u2) -> - if not + if snd (engagement env) == StratifiedType + && not (match pb with | CONV -> Univ.check_eq univ u1 u2 | CUMUL -> Univ.check_leq univ u1 u2) then begin if !Flags.debug then begin let op = match pb with CONV -> "=" | CUMUL -> "<=" in - Printf.eprintf "cort_cmp: %s\n%!" Pp.(string_of_ppcmds + Printf.eprintf "sort_cmp: %s\n%!" Pp.(string_of_ppcmds (str"Error: " ++ Univ.pr_uni u1 ++ str op ++ Univ.pr_uni u2 ++ str ":" ++ cut() ++ Univ.pr_universes univ)) end; @@ -259,7 +262,7 @@ and eqappr univ cv_pb infos (lft1,st1) (lft2,st2) = (match a1, a2 with | (Sort s1, Sort s2) -> assert (is_empty_stack v1 && is_empty_stack v2); - sort_cmp univ cv_pb s1 s2 + sort_cmp (infos_env infos) univ cv_pb s1 s2 | (Meta n, Meta m) -> if n=m then convert_stacks univ infos lft1 lft2 v1 v2 diff --git a/checker/safe_typing.ml b/checker/safe_typing.ml index 810d6e0b..81a3cc03 100644 --- a/checker/safe_typing.ml +++ b/checker/safe_typing.ml @@ -27,18 +27,26 @@ let set_engagement c = (* full_add_module adds module with universes and constraints *) let full_add_module dp mb univs digest = let env = !genv in - let env = add_constraints mb.mod_constraints env in - let env = add_constraints univs env in + let env = push_context_set ~strict:true mb.mod_constraints env in + let env = push_context_set ~strict:true univs env in let env = Modops.add_module mb env in genv := add_digest env dp digest -(* Check that the engagement expected by a library matches the initial one *) -let check_engagement env c = - match engagement env, c with - | Some ImpredicativeSet, Some ImpredicativeSet -> () - | _, None -> () - | _, Some ImpredicativeSet -> - error "Needs option -impredicative-set" +(* Check that the engagement expected by a library extends the initial one *) +let check_engagement env (expected_impredicative_set,expected_type_in_type) = + let impredicative_set,type_in_type = Environ.engagement env in + begin + match impredicative_set, expected_impredicative_set with + | PredicativeSet, ImpredicativeSet -> + Errors.error "Needs option -impredicative-set." + | _ -> () + end; + begin + match type_in_type, expected_type_in_type with + | StratifiedType, TypeInType -> + Errors.error "Needs option -type-in-type." + | _ -> () + end (* Libraries = Compiled modules *) @@ -75,8 +83,8 @@ let import file clib univs digest = check_engagement env clib.comp_enga; let mb = clib.comp_mod in Mod_checking.check_module - (add_constraints univs - (add_constraints mb.mod_constraints env)) mb.mod_mp mb; + (push_context_set ~strict:true univs + (push_context_set ~strict:true mb.mod_constraints env)) mb.mod_mp mb; stamp_library file digest; full_add_module clib.comp_name mb univs digest diff --git a/checker/safe_typing.mli b/checker/safe_typing.mli index e16e64e6..892a8d2c 100644 --- a/checker/safe_typing.mli +++ b/checker/safe_typing.mli @@ -15,6 +15,6 @@ val get_env : unit -> env val set_engagement : engagement -> unit val import : - CUnix.physical_path -> compiled_library -> Univ.constraints -> Cic.vodigest -> unit + CUnix.physical_path -> compiled_library -> Univ.ContextSet.t -> Cic.vodigest -> unit val unsafe_import : - CUnix.physical_path -> compiled_library -> Univ.constraints -> Cic.vodigest -> unit + CUnix.physical_path -> compiled_library -> Univ.ContextSet.t -> Cic.vodigest -> unit diff --git a/checker/term.ml b/checker/term.ml index 93540276..430be495 100644 --- a/checker/term.ml +++ b/checker/term.ml @@ -392,7 +392,7 @@ let compare_constr f t1 t2 = Array.equal f tl1 tl2 && Array.equal f bl1 bl2 | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> Int.equal ln1 ln2 && Array.equal f tl1 tl2 && Array.equal f bl1 bl2 - | Proj (p1,c1), Proj(p2,c2) -> eq_con_chk p1 p2 && f c1 c2 + | Proj (p1,c1), Proj(p2,c2) -> Projection.equal p1 p2 && f c1 c2 | _ -> false let rec eq_constr m n = diff --git a/checker/typeops.ml b/checker/typeops.ml index 9bc4b269..21819992 100644 --- a/checker/typeops.ml +++ b/checker/typeops.ml @@ -128,7 +128,7 @@ let sort_of_product env domsort rangsort = | (Prop _, Prop Pos) -> rangsort (* Product rule (Type,Set,?) *) | (Type u1, Prop Pos) -> - if engagement env = Some ImpredicativeSet then + if fst (engagement env) = ImpredicativeSet then (* Rule is (Type,Set,Set) in the Set-impredicative calculus *) rangsort else diff --git a/checker/univ.ml b/checker/univ.ml index 3bcb3bc9..648e4781 100644 --- a/checker/univ.ml +++ b/checker/univ.ml @@ -244,7 +244,8 @@ module Level = struct let set = make Set let prop = make Prop - + let var i = make (Var i) + let is_small x = match data x with | Level _ -> false @@ -281,8 +282,8 @@ module Level = struct end (** Level sets and maps *) -module LSet = Set.Make (Level) -module LMap = Map.Make (Level) +module LMap = HMap.Make (Level) +module LSet = LMap.Set type 'a universe_map = 'a LMap.t @@ -559,20 +560,26 @@ let repr g u = in repr_rec u -(* [safe_repr] also search for the canonical representative, but - if the graph doesn't contain the searched universe, we add it. *) - -let safe_repr g u = - let rec safe_repr_rec u = - match UMap.find u g with - | Equiv v -> safe_repr_rec v - | Canonical arc -> arc - in - try g, safe_repr_rec u - with Not_found -> - let can = terminal u in - enter_arc can g, can +let get_set_arc g = repr g Level.set +exception AlreadyDeclared + +let add_universe vlev strict g = + try + let _arcv = UMap.find vlev g in + raise AlreadyDeclared + with Not_found -> + let v = terminal vlev in + let arc = + let arc = get_set_arc g in + if strict then + { arc with lt=vlev::arc.lt} + else + { arc with le=vlev::arc.le} + in + let g = enter_arc arc g in + enter_arc v g + (* reprleq : canonical_arc -> canonical_arc list *) (* All canonical arcv such that arcu<=arcv with arcv#arcu *) let reprleq g arcu = @@ -739,8 +746,8 @@ let is_lt g arcu arcv = (** First, checks on universe levels *) let check_equal g u v = - let g, arcu = safe_repr g u in - let _, arcv = safe_repr g v in + let arcu = repr g u in + let arcv = repr g v in arcu == arcv let check_eq_level g u v = u == v || check_equal g u v @@ -749,8 +756,8 @@ let is_set_arc u = Level.is_set u.univ let is_prop_arc u = Level.is_prop u.univ let check_smaller g strict u v = - let g, arcu = safe_repr g u in - let g, arcv = safe_repr g v in + let arcu = repr g u in + let arcv = repr g v in if strict then is_lt g arcu arcv else @@ -900,8 +907,8 @@ let error_inconsistency o u v = (* enforc_univ_eq u v will force u=v if possible, will fail otherwise *) let enforce_univ_eq u v g = - let g,arcu = safe_repr g u in - let g,arcv = safe_repr g v in + let arcu = repr g u in + let arcv = repr g v in match fast_compare g arcu arcv with | FastEQ -> g | FastLT -> error_inconsistency Eq v u @@ -916,8 +923,8 @@ let enforce_univ_eq u v g = (* enforce_univ_leq : Level.t -> Level.t -> unit *) (* enforce_univ_leq u v will force u<=v if possible, will fail otherwise *) let enforce_univ_leq u v g = - let g,arcu = safe_repr g u in - let g,arcv = safe_repr g v in + let arcu = repr g u in + let arcv = repr g v in if is_leq g arcu arcv then g else match fast_compare g arcv arcu with @@ -928,8 +935,8 @@ let enforce_univ_leq u v g = (* enforce_univ_lt u v will force u<v if possible, will fail otherwise *) let enforce_univ_lt u v g = - let g,arcu = safe_repr g u in - let g,arcv = safe_repr g v in + let arcu = repr g u in + let arcv = repr g v in match fast_compare g arcu arcv with | FastLT -> g | FastLE -> fst (setlt g arcu arcv) @@ -941,7 +948,10 @@ let enforce_univ_lt u v g = | FastLE | FastLT -> error_inconsistency Lt u v (* Prop = Set is forbidden here. *) -let initial_universes = enforce_univ_lt Level.prop Level.set UMap.empty +let initial_universes = + let g = enter_arc (terminal Level.set) UMap.empty in + let g = enter_arc (terminal Level.prop) g in + enforce_univ_lt Level.prop Level.set g (* Constraints and sets of constraints. *) @@ -970,7 +980,7 @@ module Constraint = Set.Make(UConstraintOrd) let empty_constraint = Constraint.empty let merge_constraints c g = Constraint.fold enforce_constraint c g - + type constraints = Constraint.t (** A value with universe constraints. *) @@ -1146,7 +1156,7 @@ struct (** Universe contexts (variables as a list) *) let empty = (Instance.empty, Constraint.empty) - + let make x = x let instance (univs, cst) = univs let constraints (univs, cst) = cst end @@ -1158,6 +1168,8 @@ struct type t = LSet.t constrained let empty = LSet.empty, Constraint.empty let constraints (_, cst) = cst + let levels (ctx, _) = ctx + let make ctx cst = (ctx, cst) end type universe_context_set = ContextSet.t @@ -1207,6 +1219,9 @@ let subst_instance_constraints s csts = (fun c csts -> Constraint.add (subst_instance_constraint s c) csts) csts Constraint.empty +let make_abstract_instance (ctx, _) = + Array.mapi (fun i l -> Level.var i) ctx + (** Substitute instance inst for ctx in csts *) let instantiate_univ_context (ctx, csts) = (ctx, subst_instance_constraints ctx csts) @@ -1238,6 +1253,20 @@ let subst_univs_universe fn ul = List.fold_left (fun acc u -> Universe.merge_univs acc (Universe.Huniv.tip u)) substs nosubst +let merge_context strict ctx g = + let g = Array.fold_left + (* Be lenient, module typing reintroduces universes and + constraints due to includes *) + (fun g v -> try add_universe v strict g with AlreadyDeclared -> g) + g (UContext.instance ctx) + in merge_constraints (UContext.constraints ctx) g + +let merge_context_set strict ctx g = + let g = LSet.fold + (fun v g -> try add_universe v strict g with AlreadyDeclared -> g) + (ContextSet.levels ctx) g + in merge_constraints (ContextSet.constraints ctx) g + (** Pretty-printing *) let pr_arc = function diff --git a/checker/univ.mli b/checker/univ.mli index 742ef91a..02c1bbdb 100644 --- a/checker/univ.mli +++ b/checker/univ.mli @@ -74,6 +74,13 @@ val check_eq : universe check_function (** The initial graph of universes: Prop < Set *) val initial_universes : universes +(** Adds a universe to the graph, ensuring it is >= or > Set. + @raises AlreadyDeclared if the level is already declared in the graph. *) + +exception AlreadyDeclared + +val add_universe : universe_level -> bool -> universes -> universes + (** {6 Constraints. } *) type constraint_type = Lt | Le | Eq @@ -117,14 +124,14 @@ type univ_inconsistency = constraint_type * universe * universe exception UniverseInconsistency of univ_inconsistency val merge_constraints : constraints -> universes -> universes - + val check_constraints : constraints -> universes -> bool (** {6 Support for universe polymorphism } *) (** Polymorphic maps from universe levels to 'a *) module LMap : Map.S with type key = universe_level - +module LSet : CSig.SetS with type elt = universe_level type 'a universe_map = 'a LMap.t (** {6 Substitution} *) @@ -177,7 +184,7 @@ sig type t val empty : t - + val make : universe_instance constrained -> t val instance : t -> Instance.t val constraints : t -> constraints @@ -186,6 +193,7 @@ end module ContextSet : sig type t + val make : LSet.t -> constraints -> t val empty : t val constraints : t -> constraints end @@ -193,6 +201,9 @@ module ContextSet : type universe_context = UContext.t type universe_context_set = ContextSet.t +val merge_context : bool -> universe_context -> universes -> universes +val merge_context_set : bool -> universe_context_set -> universes -> universes + val empty_level_subst : universe_level_subst val is_empty_level_subst : universe_level_subst -> bool @@ -219,6 +230,9 @@ val subst_instance_constraints : universe_instance -> constraints -> constraints val instantiate_univ_context : universe_context -> universe_context val instantiate_univ_constraints : universe_instance -> universe_context -> constraints +(** Build the relative instance corresponding to the context *) +val make_abstract_instance : universe_context -> universe_instance + (** {6 Pretty-printing of universes. } *) val pr_universes : universes -> Pp.std_ppcmds diff --git a/checker/values.ml b/checker/values.ml index cf93466b..34de511c 100644 --- a/checker/values.ml +++ b/checker/values.ml @@ -13,7 +13,7 @@ To ensure this file is up-to-date, 'make' now compares the md5 of cic.mli with a copy we maintain here: -MD5 0a174243f8b06535c9eecbbe8d339fe1 checker/cic.mli +MD5 76312d06933f47498a1981a6261c9f75 checker/cic.mli *) @@ -126,6 +126,7 @@ let v_caseinfo = v_tuple "case_info" [|v_ind;Int;Array Int;Array Int;v_cprint|] let v_cast = v_enum "cast_kind" 4 +let v_proj = v_tuple "projection" [|v_cst; v_bool|] let rec v_constr = Sum ("constr",0,[| @@ -145,7 +146,7 @@ let rec v_constr = [|v_caseinfo;v_constr;v_constr;Array v_constr|]; (* Case *) [|v_fix|]; (* Fix *) [|v_cofix|]; (* CoFix *) - [|v_cst;v_constr|] (* Proj *) + [|v_proj;v_constr|] (* Proj *) |]) and v_prec = Tuple ("prec_declaration", @@ -192,7 +193,9 @@ let v_lazy_constr = (** kernel/declarations *) -let v_engagement = v_enum "eng" 1 +let v_impredicative_set = v_enum "impr-set" 2 +let v_type_in_type = v_enum "type-in-type" 2 +let v_engagement = v_tuple "eng" [|v_impredicative_set; v_type_in_type|] let v_pol_arity = v_tuple "polymorphic_arity" [|List(Opt v_level);v_univ|] @@ -205,8 +208,10 @@ let v_cst_def = [|[|Opt Int|]; [|v_cstr_subst|]; [|v_lazy_constr|]|] let v_projbody = - v_tuple "projection_body" [|v_cst;Int;Int;v_constr;v_tuple "proj_eta" [|v_constr;v_constr|]; - v_constr|] + v_tuple "projection_body" + [|v_cst;Int;Int;v_constr; + v_tuple "proj_eta" [|v_constr;v_constr|]; + v_constr|] let v_cb = v_tuple "constant_body" [|v_section_ctxt; @@ -302,17 +307,17 @@ and v_impl = and v_noimpl = v_enum "no_impl" 1 (* Abstract is mandatory for mtb *) and v_module = Tuple ("module_body", - [|v_mp;v_impl;v_sign;Opt v_mexpr;v_cstrs;v_resolver;Any|]) + [|v_mp;v_impl;v_sign;Opt v_mexpr;v_context_set;v_resolver;Any|]) and v_modtype = Tuple ("module_type_body", - [|v_mp;v_noimpl;v_sign;Opt v_mexpr;v_cstrs;v_resolver;Any|]) + [|v_mp;v_noimpl;v_sign;Opt v_mexpr;v_context_set;v_resolver;Any|]) (** kernel/safe_typing *) let v_vodigest = Sum ("module_impl",0, [| [|String|]; [|String;String|] |]) let v_deps = Array (v_tuple "dep" [|v_dp;v_vodigest|]) let v_compiled_lib = - v_tuple "compiled" [|v_dp;v_module;v_deps;Opt v_engagement;Any|] + v_tuple "compiled" [|v_dp;v_module;v_deps;v_engagement;Any|] (** Library objects *) @@ -350,8 +355,11 @@ let v_stm_seg = v_pair v_tasks v_counters (** Toplevel structures in a vo (see Cic.mli) *) +let v_libsum = + Tuple ("summary", [|v_dp;Array v_dp;v_deps|]) + let v_lib = - Tuple ("library",[|v_dp;v_compiled_lib;v_libraryobjs;v_deps;Array v_dp|]) + Tuple ("library",[|v_compiled_lib;v_libraryobjs|]) let v_opaques = Array (v_computation v_constr) let v_univopaques = diff --git a/checker/votour.ml b/checker/votour.ml index 7c954d6f..4aecb28f 100644 --- a/checker/votour.ml +++ b/checker/votour.ml @@ -21,32 +21,91 @@ sig type obj val input : in_channel -> obj val repr : obj -> obj repr - val size : int list -> int + val size : obj -> int end -module Repr : S = +module ReprObj : S = struct - type obj = Obj.t + type obj = Obj.t * int list let input chan = let obj = input_value chan in let () = CObj.register_shared_size obj in - obj + (obj, []) - let repr obj = + let repr (obj, pos) = if Obj.is_block obj then let tag = Obj.tag obj in if tag = Obj.string_tag then STRING (Obj.magic obj) else if tag < Obj.no_scan_tag then - let data = Obj.dup obj in - let () = Obj.set_tag data 0 in + let init i = (Obj.field obj i, i :: pos) in + let data = Array.init (Obj.size obj) init in BLOCK (tag, Obj.magic data) else OTHER else INT (Obj.magic obj) - let size p = CObj.shared_size_of_pos p + let size (_, p) = CObj.shared_size_of_pos p +end + +module ReprMem : S = +struct + open Analyze + + type obj = data + + let memory = ref [||] + let sizes = ref [||] + (** size, in words *) + + let ws = Sys.word_size / 8 + + let rec init_size seen = function + | Int _ | Atm _ | Fun _ -> 0 + | Ptr p -> + if seen.(p) then 0 + else + let () = seen.(p) <- true in + match (!memory).(p) with + | Struct (tag, os) -> + let fold accu o = accu + 1 + init_size seen o in + let size = Array.fold_left fold 1 os in + let () = (!sizes).(p) <- size in + size + | String s -> + let size = 2 + (String.length s / ws) in + let () = (!sizes).(p) <- size in + size + + let size = function + | Int _ | Atm _ | Fun _ -> 0 + | Ptr p -> (!sizes).(p) + + let repr = function + | Int i -> INT i + | Atm t -> BLOCK (t, [||]) + | Fun _ -> OTHER + | Ptr p -> + match (!memory).(p) with + | Struct (tag, os) -> BLOCK (tag, os) + | String s -> STRING s + + let input ch = + let obj, mem = parse_channel ch in + let () = memory := mem in + let () = sizes := Array.make (Array.length mem) (-1) in + let seen = Array.make (Array.length mem) false in + let _ = init_size seen obj in + obj + end +module Visit (Repr : S) : +sig + val init : unit -> unit + val visit : Values.value -> Repr.obj -> int list -> unit +end = +struct + (** Name of a value *) let rec get_name ?(extra=false) = function @@ -92,7 +151,7 @@ let rec get_details v o = match v, Repr.repr o with let node_info (v,o,p) = get_name ~extra:true v ^ get_details v o ^ - " (size "^ string_of_int (Repr.size p)^"w)" + " (size "^ string_of_int (Repr.size o)^"w)" (** Children of a block : type, object, position. For lists, we collect all elements of the list at once *) @@ -201,14 +260,49 @@ let rec visit v o pos = | Failure "forbidden" -> let info = pop () in visit info.typ info.obj info.pos | Failure _ | Invalid_argument _ -> visit v o pos +end + (** Loading the vo *) +type header = { + magic : string; + (** Magic number of the marshaller *) + length : int; + (** Size on disk in bytes *) + size32 : int; + (** Size in words when loaded on 32-bit systems *) + size64 : int; + (** Size in words when loaded on 64-bit systems *) + objects : int; + (** Number of blocks defined in the marshalled structure *) +} + +let dummy_header = { + magic = "\000\000\000\000"; + length = 0; + size32 = 0; + size64 = 0; + objects = 0; +} + +let parse_header chan = + let magic = String.create 4 in + let () = for i = 0 to 3 do magic.[i] <- input_char chan done in + let length = input_binary_int chan in + let objects = input_binary_int chan in + let size32 = input_binary_int chan in + let size64 = input_binary_int chan in + { magic; length; size32; size64; objects } + type segment = { name : string; mutable pos : int; typ : Values.value; + mutable header : header; } +let make_seg name typ = { name; typ; pos = 0; header = dummy_header } + let visit_vo f = Printf.printf "\nWelcome to votour !\n"; Printf.printf "Enjoy your guided tour of a Coq .vo or .vi file\n"; @@ -216,12 +310,19 @@ let visit_vo f = Printf.printf "At prompt, <n> enters the <n>-th child, u goes up 1 level, x exits\n\n%!"; let segments = [| - {name="library"; pos=0; typ=Values.v_lib}; - {name="univ constraints of opaque proofs"; pos=0;typ=Values.v_univopaques}; - {name="discharging info"; pos=0; typ=Opt Any}; - {name="STM tasks"; pos=0; typ=Opt Values.v_stm_seg}; - {name="opaque proofs"; pos=0; typ=Values.v_opaques}; + make_seg "summary" Values.v_libsum; + make_seg "library" Values.v_lib; + make_seg "univ constraints of opaque proofs" Values.v_univopaques; + make_seg "discharging info" (Opt Any); + make_seg "STM tasks" (Opt Values.v_stm_seg); + make_seg "opaque proofs" Values.v_opaques; |] in + let repr = + if Sys.word_size = 64 then (module ReprMem : S) else (module ReprObj : S) + (** On 32-bit machines, representation may exceed the max size of arrays *) + in + let module Repr = (val repr : S) in + let module Visit = Visit(Repr) in while true do let ch = open_in_bin f in let magic = input_binary_int ch in @@ -229,21 +330,24 @@ let visit_vo f = for i=0 to Array.length segments - 1 do let pos = input_binary_int ch in segments.(i).pos <- pos_in ch; + let header = parse_header ch in + segments.(i).header <- header; seek_in ch pos; ignore(Digest.input ch); done; Printf.printf "The file has %d segments, choose the one to visit:\n" (Array.length segments); - Array.iteri (fun i { name; pos } -> - Printf.printf " %d: %s, starting at byte %d\n" i name pos) + Array.iteri (fun i { name; pos; header } -> + let size = if Sys.word_size = 64 then header.size64 else header.size32 in + Printf.printf " %d: %s, starting at byte %d (size %iw)\n" i name pos size) segments; Printf.printf "# %!"; let l = read_line () in let seg = int_of_string l in seek_in ch segments.(seg).pos; let o = Repr.input ch in - let () = init () in - visit segments.(seg).typ o [] + let () = Visit.init () in + Visit.visit segments.(seg).typ o [] done let main = diff --git a/configure.ml b/configure.ml index bbe43520..51033c3d 100644 --- a/configure.ml +++ b/configure.ml @@ -11,11 +11,11 @@ #load "str.cma" open Printf -let coq_version = "8.5beta2" -let coq_macos_version = "8.4.92" (** "[...] should be a string comprised of +let coq_version = "8.5beta3" +let coq_macos_version = "8.4.93" (** "[...] should be a string comprised of three non-negative, period-separed integers [...]" *) -let vo_magic = 8591 -let state_magic = 58501 +let vo_magic = 8493 +let state_magic = 58503 let distributed_exec = ["coqtop";"coqc";"coqchk";"coqdoc";"coqmktop";"coqworkmgr"; "coqdoc";"coq_makefile";"coq-tex";"gallina";"coqwc";"csdpcert";"coqdep"] @@ -252,7 +252,7 @@ module Prefs = struct let profile = ref false let annotate = ref false let makecmd = ref "make" - let nativecompiler = ref true + let nativecompiler = ref (not (os_type_win32 || os_type_cygwin)) let coqwebsite = ref "http://coq.inria.fr/" let force_caml_version = ref false end @@ -331,12 +331,12 @@ let args_options = Arg.align [ " Dumps ml annotation files while compiling Coq"; "-makecmd", Arg.Set_string Prefs.makecmd, "<command> Name of GNU Make command"; - "-no-native-compiler", Arg.Clear Prefs.nativecompiler, - " No compilation to native code for conversion and normalization"; + "-native-compiler", arg_bool Prefs.nativecompiler, + "(yes|no) Compilation to native code for conversion and normalization"; "-coqwebsite", Arg.Set_string Prefs.coqwebsite, " URL of the coq website"; - "-force-caml-version", arg_bool Prefs.force_caml_version, - " Force OCaml version"; + "-force-caml-version", Arg.Set Prefs.force_caml_version, + "Force OCaml version"; ] let parse_args () = @@ -396,8 +396,7 @@ let coq_annotate_flag = then if program_in_path "ocamlmerlin" then "-bin-annot" else "-dtypes" else "" -let cflags = "-Wall -Wno-unused" - +let cflags = "-Wall -Wno-unused -g -O2" (** * Architecture *) @@ -477,7 +476,10 @@ let camlbin, caml_version, camllib = rebase_camlexec dir camlexec; Filename.dirname camlexec.byte, camlexec.byte | None -> - try let camlc = which camlexec.byte in Filename.dirname camlc, camlc + try let camlc = which camlexec.byte in + let dir = Filename.dirname camlc in + if not arch_win32 then rebase_camlexec dir camlexec; (* win32: TOCHECK *) + dir, camlc with Not_found -> die (sprintf "Error: cannot find '%s' in your path!\n" camlexec.byte ^ "Please adjust your path or use the -camldir option of ./configure") @@ -514,7 +516,12 @@ let caml_version_nums = let check_caml_version () = if caml_version_nums >= [3;12;1] then - printf "You have OCaml %s. Good!\n" caml_version + if caml_version_nums = [4;2;0] && not !Prefs.force_caml_version then + die ("Your version of OCaml is 4.02.0 which suffers from a bug inducing\n" ^ + "very slow compilation times. If you still want to use it, use \n" ^ + "option -force-caml-version.\n") + else + printf "You have OCaml %s. Good!\n" caml_version else let () = printf "Your version of OCaml is %s.\n" caml_version in if !Prefs.force_caml_version then @@ -839,12 +846,6 @@ let md5sum = if arch = "Darwin" then "md5 -q" else "md5sum" -(** * md5sum command *) - -let md5sum = - if arch = "Darwin" then "md5 -q" else "md5sum" - - (** * Documentation : do we have latex, hevea, ... *) let check_doc () = @@ -856,6 +857,9 @@ let check_doc () = if not !Prefs.withdoc then raise Not_found; if not (program_in_path "latex") then err "latex"; if not (program_in_path "hevea") then err "hevea"; + if not (program_in_path "hacha") then err "hacha"; + if not (program_in_path "fig2dev") then err "fig2dev"; + if not (program_in_path "convert") then err "convert"; true with Not_found -> false @@ -1200,7 +1204,9 @@ let write_makefile f = pr "# Defining REVISION\n"; pr "CHECKEDOUT=%s\n\n" vcs; pr "# Option to control compilation and installation of the documentation\n"; - pr "WITHDOC=%s\n" (if withdoc then "all" else "no"); + pr "WITHDOC=%s\n\n" (if withdoc then "all" else "no"); + pr "# Option to produce precompiled files for native_compute\n"; + pr "NATIVECOMPUTE=%s\n" (if !Prefs.nativecompiler then "-native-compiler" else ""); close_out o; Unix.chmod f 0o444 diff --git a/dev/TODO b/dev/TODO new file mode 100644 index 00000000..e62ee6e5 --- /dev/null +++ b/dev/TODO @@ -0,0 +1,22 @@ + + o options de la ligne de commande + - reporter les options de l'ancien script coqtop sur le nouveau coqtop.ml + + o arguments implicites + - les calculer une fois pour toutes à la déclaration (dans Declare) + et stocker cette information dans le in_variable, in_constant, etc. + + o Environnements compilés (type Environ.compiled_env) + - pas de timestamp mais plutôt un checksum avec Digest (mais comment ?) + + o Efficacité + - utiliser DOPL plutôt que DOPN (sauf pour Case) + - batch mode => pas de undo, ni de reset + - conversion : déplier la constante la plus récente + - un cache pour type_of_const, type_of_inductive, type_of_constructor, + lookup_mind_specif + + o Toplevel + - parsing de la ligne de commande : utiliser Arg ??? + + diff --git a/dev/base_include b/dev/base_include index de63c557..dac1f609 100644 --- a/dev/base_include +++ b/dev/base_include @@ -86,6 +86,7 @@ open Cbv open Classops open Clenv open Clenvtac +open Constr_matching open Glob_term open Glob_ops open Coercion @@ -147,6 +148,7 @@ open Tactic_debug open Decl_proof_instr open Decl_mode +open Hints open Auto open Autorewrite open Contradiction diff --git a/dev/doc/README-V1-V5 b/dev/doc/README-V1-V5 new file mode 100644 index 00000000..2ca62e3d --- /dev/null +++ b/dev/doc/README-V1-V5 @@ -0,0 +1,293 @@ + + Notes on the prehistory of Coq + +This archive contains the sources of the CONSTR ancestor of the Coq proof +assistant. CONSTR, then Coq, was designed and implemented in the Formel team, +joint between the INRIA Rocquencourt laboratory and the Ecole Normale Supérieure +of Paris, from 1984 onwards. + +Version 1 + +This software is a prototype type-checker for a higher-order logical formalism +known as the Theory of Constructions, presented in his PhD thesis by +Thierry Coquand, with influences from Girard's system F and de Bruijn's Automath. +The metamathematical analysis of the system is the +PhD work of Thierry Coquand. The software is mostly the work of Gérard Huet. +Most of the mathematical examples verified with the software are due +to Thierry Coquand. + +The programming language of the CONSTR software (as it was called at the time) +is a version of ML issued from the Edinburgh LCF system and running on +a LISP backend. The main improvements from the original LCF ML are that ML +is compiled rather than interpreted (Gérard Huet building on the original +translator by Lockwood Morris), and that it is enriched by recursively +defined types (work of Guy Cousineau). This ancestor of CAML was used +and improved by Larry Paulson for his implementation of Cambridge LCF. + +Software developments of this prototype occurred from late 1983 to early 1985. + +Version 1.10 was frozen on December 22nd 1984. It is the version used for the +examples in Thierry Coquand's thesis, defended on January 31st 1985. +There was a unique binding operator, used both for universal quantification +(dependent product) at the level of types and functional abstraction (lambda) +at the level of terms/proofs, in the manner of Automath. Substitution +(lambda reduction) was implemented using de Bruijn's indexes. + +Version 1.11 was frozen on February 19th, 1985. It is the version used for the +examples in the paper: +Th. Coquand, G. Huet. Constructions: A Higher Order Proof System for Mechanizing +Mathematics. Invited paper, EUROCAL85, April 1985, Linz, Austria. Springer Verlag +LNCS 203, pp. 151-184. + +Christine Paulin joined the team at this point, for her DEA research internship. +In her DEA memoir (August 1985) she presents developments for the lambo function +computing the minimal m such that f(m) is greater than n, for f an increasing +integer function, a challenge for constructive mathematics. She also encoded +the majority voting algorithm of Boyer and Moore. + +Version 2 + +The formal system, now renamed as the "Calculus of Constructions", was presented +with a proof of consistency and comparisons with proof systems of Per +Martin Löf, Girard, and the Automath family of N. de Bruijn, in the paper: +T. Coquand and G. Huet. The Calculus of Constructions. +Submitted on June 30th 1985, accepted on December 5th, 1985, +Information and Computation. Preprint as Rapport de Recherche Inria n°530, +Mai 1986. Final version in Information and Computation 76,2/3, Feb. 88. + +An abstraction of the software design, in the form of an abstract machine +for proof checking, and a fuller sequence of mathematical developments was +presented in: +Th. Coquand, G. Huet. Concepts Mathématiques et Informatiques Formalisés dans le Calcul des Constructions. Invited paper, European Logic Colloquium, Orsay, +July 1985. Preprint as Rapport de recherche INRIA n°463, Dec. 85. +Published in Logic Colloquium 1985, North-Holland, 1987. + +Version 2.8 was frozen on December 16th, 1985, and served for developing +the exemples in the above papers. + +This calculus was then enriched in version 2.9 with a cumulative hierarchy of +universes. Universe levels were initially explicit natural numbers. +Another improvement was the possibility of automatic synthesis of implicit +type arguments, relieving the user of tedious redundant declarations. + +Christine Paulin wrote an article "Algorithm development in the Calculus of +Constructions", preprint as Rapport de recherche INRIA n°497, March 86. +Final version in Proceedings Symposium on Logic in Computer Science, Cambridge, +MA, 1986 (IEEE Computer Society Press). Besides lambo and majority, +she presents quicksort and a text formatting algorithm. + +Version 2.13 of the calculus of constructions with universes was frozen +on June 25th, 1986. + +A synthetic presentation of type theory along constructive lines with ML +algorithms was given by Gérard Huet in his May 1986 CMU course notes +"Formal Structures for Computation and Deduction". Its chapter +"Induction and Recursion in the Theory of Constructions" was presented +as an invited paper at the Joint Conference on Theory and Practice of Software +Development TAPSOFT’87 at Pise in March 1987, and published as +"Induction Principles Formalized in the Calculus of Constructions" in +Programming of Future Generation Computers, Ed. K. Fuchi and M. Nivat, +North-Holland, 1988. + +Version 3 + +This version saw the beginning of proof automation, with a search algorithm +inspired from PROLOG and the applicative logic programming programs +of the course notes "Formal structures for computation and deduction". +The search algorithm was implemented in ML by Thierry Coquand. +The proof system could thus be used in two modes: proof verification and +proof synthesis, with tactics such as "AUTO". + +The implementation language was now called CAML, for "categorical abstract +machine language". It used as backend the LLM3 virtual machine of Le Lisp +by Jérôme Chailloux. The main developers of CAML were Michel Mauny, +Ascander Suarez and Pierre Weis. + +V3.1 was started in the summer of 1986, V3.2 was frozen at the end of November +1986. V3.4 was developed in the first half of 1987. + +Thierry Coquand held a post-doctoral position in Cambrige University in 1986-87, +where he developed a variant implementation in SML, with which he wrote +some developments on fixpoints in Scott's domains. + +Version 4 + +This version saw the beginning of program extraction from proofs, with +two varieties of the type Prop of propositions, indicating constructive intent. +The proof extraction algorithms were implemented by Christine Paulin-Mohring. + +V4.1 was frozen on July 24th, 1987. It had a first identified library of +mathematical developments (directory exemples), with libraries Logic +(containing impredicative encodings of intuitionistic logic and algebraic +primitives for booleans, natural numbers and list), Peano developing second-order +Peano arithmetic, Arith defining addition, multiplication, euclidean division +and factorial. Typical developments were the Knaster-Tarski theorem +and Newman's lemma from rewriting theory. + +V4.2 was a joint development of a team consisting of Thierry Coquand, Gérard +Huet and Christine Paulin-Mohring. A file V4.2.log records the log of changes. +It was frozen on September 1987 as the last version implemented in CAML 2.3, +and V4.3 followed on CAML 2.5, a more stable development system. + +V4.3 saw the first top-level of the system. Instead of evaluating explicit +quotations, the user could develop his mathematics in a high-level language +called the mathematical vernacular (following Automath terminology). +The user could develop files in the vernacular notation (with .v extension) +which were now separate from the ml sources of the implementation. +Gilles Dowek joined the team to develop the vernacular language as his +DEA internship research. + +A notion of sticky constant was introduced, in order to keep names of lemmas +when local hypotheses of proofs were discharged. This gave a notion +of global mathematical environment with local sections. + +Another significant practical change was that the system, originally developped +on the VAX central computer of our lab, was transferred on SUN personal +workstations, allowing a level of distributed development. +The extraction algorithm was modified, with three annotations Pos, Null and +Typ decorating the sorts Prop and Type. + +Version 4.3 was frozen at the end of November 1987, and was distributed to an +early community of users (among those were Hugo Herbelin and Loic Colson). + +V4.4 saw the first version of (encoded) inductive types. +Now natural numbers could be defined as: +Inductive NAT : Prop = O : NAT | Succ : NAT->NAT. +These inductive types were encoded impredicatively in the calculus, +using a subsystem "rec" due to Christine Paulin. +V4.4 was frozen on March 6th 1988. + +Version 4.5 was the first one to support inductive types and program extraction. +Its banner was "Calcul des Constructions avec Realisations et Synthese". +The vernacular language was enriched to accommodate extraction commands. + +The verification engine design was presented as: +G. Huet. The Constructive Engine. Version 4.5. Invited Conference, 2nd European +Symposium on Programming, Nancy, March 88. +The final paper, describing the V4.9 implementation, appeared in: +A perspective in Theoretical Computer Science, Commemorative Volume in memory +of Gift Siromoney, Ed. R. Narasimhan, World Scientific Publishing, 1989. + +Version 4.5 was demonstrated in June 1988 at the YoP Institute on Logical +Foundations of Functional Programming organized by Gérard Huet at Austin, Texas. + +Version 4.6 was started during summer 1988. Its main improvement was the +complete rehaul of the proof synthesis engine by Thierry Coquand, with +a tree structure of goals. + +Its source code was communicated to Randy Pollack on September 2nd 1988. +It evolved progressively into LEGO, proof system for Luo's formalism +of Extended Calculus of Constructions. + +The discharge tactic was modified by G. Huet to allow for inter-dependencies +in discharged lemmas. Christine Paulin improved the inductive definition scheme +in order to accommodate predicates of any arity. + +Version 4.7 was started on September 6th, 1988. + +This version starts exploiting the CAML notion of module in order to improve the +modularity of the implementation. Now the term verifier is identified as +a proper module Machine, which the structure of its internal data structures +being hidden and thus accessible only through the legitimate operations. +This machine (the constructive engine) was the trusted core of the +implementation. The proof synthesis mechanism was a separate proof term +generator. Once a complete proof term was synthesized with the help of tactics, +it was entirely re-checked by the engine. Thus there was no need to certify +the tactics, and the system took advantage of this fact by having tactics ignore +the universe levels, universe consistency check being relegated to the final +type-checking pass. This induced a certain puzzlement of early users who saw +their successful proof search ended with QED, followed by silence, followed by +a failure message of universe inconsistency rejection... + +The set of examples comprise set theory experiments by Hugo Herbelin, +and notably the Schroeder-Bernstein theorem. + +Version 4.8, started on October 8th, 1988, saw a major re-implementation of the +abstract syntax type constr, separating variables of the formalism and +metavariables denoting incomplete terms managed by the search mechanism. +A notion of level (with three values TYPE, OBJECT and PROOF) is made explicit +and a type judgement clarifies the constructions, whose implementation is now +fully explicit. Structural equality is speeded up by using pointer equality, +yielding spectacular improvements. Thierry Coquand adapts the proof synthesis +to the new representation, and simplifies pattern matching to 1st order +predicate calculus matching, with important performance gain. + +A new representation of the universe hierarchy is then defined by G. Huet. +Universe levels are now implemented implicitly, through a hidden graph +of abstract levels constrained with an order relation. +Checking acyclicity of the graph insures well-foundedness of the ordering, +and thus consistency. This was documented in a memo +"Adding Type:Type to the Calculus of Constructions" which was never published. + +The development version is released as a stable 4.8 at the end of 1988. + +Version 4.9 is released on March 1st 1989, with the new "elastic" +universe hierarchy. + +The spring 89 saw the first attempt at documenting the system usage, +with a number of papers describing the formalism: +- Metamathematical Investigations of a Calculus of Constructions, by +Thierry Coquand (INRIA Research Report N°1088, Sept. 1989, published in +Logic and Computer Science, ed. P.G. Odifreddi, Academic Press, 1990) +- Inductive definitions in the Calculus of Constructions, by +Christine Paulin-Mohring, +- Extracting Fomega's programs from proofs in the Calculus of Constructions, by +Christine Paulin-Mohring (published in POPL'89) +- The Constructive Engine, by Gérard Huet +as well as a number of user guides: +- A short user's guide for the Constructions Version 4.10, by Gérard Huet +- A Vernacular Syllabus, by Gilles Dowek. +- The Tactics Theorem Prover, User's guide, Version 4.10, by Thierry Coquand. + +Stable V4.10, released on May 1st, 1989, was then a mature system, +distributed with CAML V2.6. + +In the mean time, Thierry Coquand and Christine Paulin-Mohring +had been investigating how to add native inductive types to the +Calculus of Constructions, in the manner of Per Martin-Löf's Intuitionistic +Type Theory. The impredicative encoding had already been presented in: +F. Pfenning and C. Paulin-Mohring. Inductively defined types in the Calculus +of Constructions. Preprint technical report CMU-CS-89-209, final version in +Proceedings of Mathematical Foundations of Programming Semantics, +volume 442, Lecture Notes in Computer Science. Springer-Verlag, 1990. +An extension of the calculus with primitive inductive types appeared in: +Th. Coquand and C. Paulin-Mohring. Inductively defined types. +In P. Martin-Löf and G. Mints, editors, Proceedings of Colog'88, volume 417, +Lecture Notes in Computer Science. Springer-Verlag, 1990. + +This lead to the Calculus of Inductive Constructions, logical formalism +implemented in Versions 5 upward of the system, and documented in: +C. Paulin-Mohring. Inductive Definitions in the System Coq - Rules and +Properties. In M. Bezem and J.-F. Groote, editors, Proceedings of the conference +Typed Lambda Calculi and Applications, volume 664, Lecture Notes in Computer +Science, 1993. + +The last version of CONSTR is Version 4.11, which was last distributed +in Spring 1990. It was demonstrated at the first workshop of the European +Basic Research Action Logical Frameworks In Sophia Antipolis in May 1990. + +At the end of 1989, Version 5.1 was started, and renamed as the system Coq +for the Calculus of Inductive Constructions. It was then ported to the new +stand-alone implementation of ML called Caml-light. + +In 1990 many changes occurred. Thierry Coquand left for Chalmers University +in Göteborg. Christine Paulin-Mohring took a CNRS researcher position +at the LIP laboratory of Ecole Normale Supérieure de Lyon. Project Formel +was terminated, and gave rise to two teams: Cristal at INRIA-Roquencourt, +that continued developments in functional programming with Caml-light then +Ocaml, and Coq, continuing the type theory research, with a joint team +headed by Gérard Huet at INRIA-Rocquencourt and Christine Paulin-Mohring +at the LIP laboratory of CNRS-ENS Lyon. + +Chetan Murthy joined the team in 1991 and became the main software architect +of Version 5. He completely rehauled the implementation for efficiency. +Versions 5.6 and 5.8 were major distributed versions, with complete +documentation and a library of users' developements. The use of the RCS +revision control system, and systematic ChangeLog files, allow a more +precise tracking of the software developments. + +Developments from Version 6 upwards are documented in the credits section of +Coq's Reference Manual. + +September 2015 +Thierry Coquand, Gérard Huet and Christine Paulin-Mohring. diff --git a/dev/doc/univpoly.txt b/dev/doc/univpoly.txt index 4c89af01..6a69c579 100644 --- a/dev/doc/univpoly.txt +++ b/dev/doc/univpoly.txt @@ -1,5 +1,5 @@ -Notes on universe polymorphism and primitive projections, M. Sozeau - WIP -========================================================================= +Notes on universe polymorphism and primitive projections, M. Sozeau +=================================================================== The new implementation of universe polymorphism and primitive projections introduces a few changes to the API of Coq. First and @@ -46,15 +46,16 @@ universes and constraints to the global universe context when it is put in the environment. No other universes than the global ones and the declared local ones are needed to check a declaration, hence the kernel does not produce any constraints anymore, apart from module -subtyping.... There are hance two conversion functions now: check_conv -and infer_conv: the former just checks the definition in the current env +subtyping.... There are hence two conversion functions now: [check_conv] +and [infer_conv]: the former just checks the definition in the current env (in which we usually push_universe_context of the associated context), -and infer_conv which produces constraints that were not implied by the +and [infer_conv] which produces constraints that were not implied by the ambient constraints. Ideally, that one could be put out of the kernel, -but again, module subtyping needs it. +but currently module subtyping needs it. Inference of universes is now done during refinement, and the evar_map -carries the incrementally built universe context. [Evd.conversion] is a +carries the incrementally built universe context, starting from the +global universe constraints (see [Evd.from_env]). [Evd.conversion] is a wrapper around [infer_conv] that will do the bookkeeping for you, it uses [evar_conv_x]. There is a universe substitution being built incrementally according to the constraints, so one should normalize at @@ -72,7 +73,7 @@ val pf_constr_of_global : Globnames.global_reference -> (constr -> tactic) -> ta Is the way to make a constr out of a global reference in the new API. If they constr is polymorphic, it will add the necessary constraints to the evar_map. Even if a constr is not polymorphic, we have to take care -of keeping track of it's universes. Typically, using: +of keeping track of its universes. Typically, using: mkApp (coq_id_function, [| A; a |]) @@ -81,11 +82,11 @@ show that A's type is in cumululativity relation with id's type argument, incurring a universe constraint. To do this, one can simply call Typing.resolve_evars env evdref c which will do some infer_conv to produce the right constraints and put them in the evar_map. Of course in -some cases you might now from an invariant that no new constraint would +some cases you might know from an invariant that no new constraint would be produced and get rid of it. Anyway the kernel will tell you if you forgot some. As a temporary way out, [Universes.constr_of_global] allows -you to make a constr from any non-polymorphic constant, but it might -forget constraints. +you to make a constr from any non-polymorphic constant, but it will fail +on polymorphic ones. Other than that, unification (w_unify and evarconv) now take account of universes and produce only well-typed evar_maps. @@ -157,6 +158,30 @@ this is the only solution I found. In the case of global_references only, it's just a matter of using [Evd.fresh_global] / [pf_constr_of_global] to let the system take care of universes. + +The universe graph +================== + +To accomodate universe polymorphic definitions, the graph structure in +kernel/univ.ml was modified. The new API forces every universe to be +declared before it is mentionned in any constraint. This forces to +declare every universe to be >= Set or > Set. Every universe variable +introduced during elaboration is >= Set. Every _global_ universe is now +declared explicitly > Set, _after_ typechecking the definition. In +polymorphic definitions Type@{i} ranges over Set and any other universe +j. However, at instantiation time for polymorphic references, one can +try to instantiate a universe parameter with Prop as well, if the +instantiated constraints allow it. The graph invariants ensure that +no universe i can be set lower than Set, so the chain of universes +always bottoms down at Prop < Set. + +Modules +======= + +One has to think of universes in modules as being globally declared, so +when including a module (type) which declares a type i (e.g. through a +parameter), we get back a copy of i and not some fresh universe. + Projections =========== @@ -208,8 +233,7 @@ constants left (the most common case). E.g. Ring with Set Universe Polymorphism and Set Primitive Projections work (at least it did at some point, I didn't recheck yet). -- [native_compute] is untested: it should deal with primitive -projections right but not universes. +- [native_compute] works with universes and projections. Incompatibilities diff --git a/dev/doc/versions-history.tex b/dev/doc/versions-history.tex index 9892a441..1b1d3500 100644 --- a/dev/doc/versions-history.tex +++ b/dev/doc/versions-history.tex @@ -10,55 +10,76 @@ \begin{center} \begin{huge} -An history of Coq versions +A history of Coq versions \end{huge} \end{center} \bigskip \centerline{\large 1984-1989: The Calculus of Constructions} + +\bigskip +\centerline{\large (see README.V1-V5 for details)} \mbox{}\\ \mbox{}\\ \begin{tabular}{l|l|l} version & date & comments \\ \hline -CoC V1.10& mention of dates from 6 December & implementation language is Caml\\ - & 1984 to 13 February 1985 \\ -CoC V1.11& mention of dates from 6 December\\ - & 1984 to 19 February 1985\\ +CONSTR V1.10& mention of dates from 6 December & \feature{type-checker for Coquand's Calculus }\\ + & 1984 to 13 February 1985 & \feature{of Constructions}, implementation \\ + & frozen 22 December 1984 & language is a predecessor of CAML\\ + +CONSTR V1.11& mention of dates from 6 December\\ + & 1984 to 19 February 1985 (freeze date) &\\ + +CoC V2.8& dated 16 December 1985 (freeze date)\\ -CoC V2.13& dated 16 December 1985\\ +CoC V2.9& & \feature{cumulative hierarchy of universes}\\ -CoC V2.13& dated 25 June 1986\\ +CoC V2.13& dated 25 June 1986 (freeze date)\\ -CoC V3.1& dated 20 November 1986 & \feature{auto}\\ +CoC V3.1& started summer 1986 & \feature{AUTO tactic}\\ + & dated 20 November 1986 & implementation language now named CAML\\ CoC V3.2& dated 27 November 1986\\ -CoC V3.3 and V3.4& dated 1 January 1987 & creation of a directory for examples\\ +CoC V3.3& dated 1 January 1987 & creation of a directory for examples\\ -CoC V4.1& dated 24 July 1987\\ +CoC V3.4& dated 1 January 1987 & \feature{lambda and product distinguished in the syntax}\\ + +CoC V4.1& dated 24 July 1987 (freeze date)\\ CoC V4.2& dated 10 September 1987\\ -CoC V4.3& dated 15 September 1987\\ +CoC V4.3& dated 15 September 1987 & \feature{mathematical vernacular toplevel}\\ + & frozen November 1987 & \feature{section mechanism}\\ + & & \feature{logical vs computational content (sorte Spec)}\\ + & & \feature{LCF engine}\\ + +CoC V4.4& dated 27 January 1988 & \feature{impredicatively encoded inductive types}\\ + & frozen March 1988\\ -CoC V4.4& dated 27 January 1988\\ +CoC V4.5 and V4.5.5& dated 15 March 1988 & \feature{program extraction}\\ + & demonstrated in June 1988\\ -CoC V4.5 and V4.5.5& dated 15 March 1988\\ +CoC V4.6& dated 1 September 1988 & start of LEGO fork\\ -CoC V4.6 and V4.7& dated 1 September 1988\\ +CoC V4.7& started 6 September 1988 \\ -CoC V4.8& dated 1 December 1988\\ +CoC V4.8& dated 1 December 1988 (release time) & \feature{floating universes}\\ -CoC V4.8.5& dated 1 February 1989\\ +CoC V4.8.5& dated 1 February 1989 & \\ -CoC V4.9& dated 1 March 1989\\ +CoC V4.9& dated 1 March 1989 (release date)\\ -CoC V4.10 and 4.10.1& dated 1 May 1989 & first public release - in English\\ +CoC V4.10 and 4.10.1& dated 1 May 1989 & released with documentation in English\\ \end{tabular} \bigskip + +\noindent Note: CoC above stands as an abbreviation for {\em Calculus of + Constructions}, official name of the system. +\bigskip \bigskip \newpage @@ -80,7 +101,7 @@ Coq V5.2 & log dated 4 October 1990 & internal use \\ Coq V5.3 & log dated 12 October 1990 & internal use \\ -Coq V5.4 & headers dated 24 October 1990 & internal use, \feature{extraction} (version 1) [3-12-90]\\ +Coq V5.4 & headers dated 24 October 1990 & internal use, new \feature{extraction} (version 1) [3-12-90]\\ Coq V5.5 & started 6 December 1990 & internal use \\ @@ -265,7 +286,17 @@ Coq V7.3.1& released 5 October 2002 & \feature{module system} [2-8-2002]\\ & & \feature{pattern-matching compilation} (version 2) [13-6-2002]\\ Coq V7.4& released 6 February 2003 & \feature{notation}, \feature{scopes} [13-10-2002]\\ +\end{tabular} +\medskip +\bigskip + +\centerline{V- New concrete syntax} +\mbox{}\\ +\mbox{}\\ +\begin{tabular}{l|l|l} +version & date & comments \\ +\hline Coq V8.0& released 21 April 2004 & \feature{new concrete syntax}, \feature{Set predicative}, \feature{CoqIDE} [from 4-2-2003]\\ Coq V8.0pl1& released 18 July 2004\\ @@ -307,6 +338,46 @@ Coq V8.2 & released 17 February 2009 & \feature{type classes} [10-12-2007], \fea & & a first package released on February 11 was incomplete\\ +Coq V8.2pl1& released 4 July 2009 & \\ +Coq V8.2pl2& released 29 June 2010 & \\ +\end{tabular} + +\medskip +\bigskip + +\newpage +\mbox{}\\ +\mbox{}\\ +\begin{tabular}{l|l|l} +Coq V8.3 beta & released 16 February 2010 & \feature{MSets library} [13-10-2009] \\ +Coq V8.3 & released 14 October 2010 & \feature{nsatz} [3-6-2010] \\ +Coq V8.3pl1& released 23 December 2010 & \\ +Coq V8.3pl2& released 19 April 2011 & \\ +Coq V8.3pl3& released 19 December 2011 & \\ +Coq V8.3pl3& released 26 March 2012 & \\ +Coq V8.3pl5& released 28 September 2012 & \\ +Coq V8.4 beta & released 27 December 2011 & \feature{modular arithmetic library} [2010-2012]\\ +&& \feature{vector library} [10-12-2010]\\ +&& \feature{structured scripts} [22-4-2010]\\ +&& \feature{eta-conversion} [20-9-2010]\\ +&& \feature{new proof engine available} [10-12-2010]\\ +Coq V8.4 beta2 & released 21 May 2012 & \\ +Coq V8.4 & released 12 August 2012 &\\ +Coq V8.4pl1& released 22 December 2012 & \\ +Coq V8.4pl2& released 4 April 2013 & \\ +Coq V8.4pl3& released 21 December 2013 & \\ +Coq V8.4pl4& released 24 April 2014 & \\ +Coq V8.4pl5& released 22 October 2014 & \\ +Coq V8.4pl6& released 9 April 2015 & \\ + +Coq V8.5 beta1 & released 21 January 2015 & \feature{computation via compilation to OCaml} [22-1-2013]\\ +&& \feature{asynchonous evaluation} [8-8-2013]\\ +&& \feature{new proof engine deployed} [2-11-2013]\\ +&& \feature{universe polymorphism} [6-5-2014]\\ +&& \feature{primitive projections} [6-5-2014]\\ + +Coq V8.5 beta2 & released 22 April 2015 & \feature{MMaps library} [4-3-2015]\\ + \end{tabular} \medskip diff --git a/dev/make-installer-win32.sh b/dev/make-installer-win32.sh index ec7cd577..d405e66c 100755 --- a/dev/make-installer-win32.sh +++ b/dev/make-installer-win32.sh @@ -1,11 +1,13 @@ #!/bin/sh +set -e + NSIS="$BASE/NSIS/makensis" ZIP=_make.zip URL1=http://sourceforge.net/projects/gnuwin32/files/make/3.81/make-3.81-bin.zip/download URL2=http://sourceforge.net/projects/gnuwin32/files/make/3.81/make-3.81-dep.zip/download -[ -e config/Makefile ] || ./configure -prefix ./ -with-doc no +[ -e config/Makefile ] || ./configure -debug -prefix ./ -with-doc no make -j2 if [ ! -e bin/make.exe ]; then wget -O $ZIP $URL1 && 7z x $ZIP "bin/*" diff --git a/dev/make-installer-win64.sh b/dev/make-installer-win64.sh new file mode 100755 index 00000000..2f765c1a --- /dev/null +++ b/dev/make-installer-win64.sh @@ -0,0 +1,28 @@ +#!/bin/sh + +set -e + +NSIS="$BASE/NSIS/makensis" +ZIP=_make.zip +URL1=http://sourceforge.net/projects/gnuwin32/files/make/3.81/make-3.81-bin.zip/download +URL2=http://sourceforge.net/projects/gnuwin32/files/make/3.81/make-3.81-dep.zip/download + +[ -e config/Makefile ] || ./configure -debug -prefix ./ -with-doc no +make -j2 coqide +mkdir -p bin32 +cp bin/* bin32/ +make clean +make archclean +( . ${BASE}_64/environ && ./configure -debug -prefix ./ -with-doc no && make -j2 && make ide/coqidetop.cmxs ) +cp bin32/coqide* bin/ +if [ ! -e bin/make.exe ]; then + wget -O $ZIP $URL1 && 7z x $ZIP "bin/*" + wget -O $ZIP $URL2 && 7z x $ZIP "bin/*" + rm -rf $ZIP +fi +VERSION=`grep ^VERSION= config/Makefile | cut -d = -f 2` +cd dev/nsis +"$NSIS" -DVERSION=$VERSION -DGTK_RUNTIME="`cygpath -w $BASE`" coq.nsi +echo Installer: +ls -h $PWD/*exe +cd ../.. diff --git a/dev/nsis/coq.nsi b/dev/nsis/coq.nsi index 5b421e49..67649051 100755 --- a/dev/nsis/coq.nsi +++ b/dev/nsis/coq.nsi @@ -95,8 +95,8 @@ Section "Coq" Sec1 File /r ${COQ_SRC_PATH}\theories\*.vo File /r ${COQ_SRC_PATH}\theories\*.v File /r ${COQ_SRC_PATH}\theories\*.glob - File /r ${COQ_SRC_PATH}\theories\*.cmi - File /r ${COQ_SRC_PATH}\theories\*.cmxs + ; File /r ${COQ_SRC_PATH}\theories\*.cmi + ; File /r ${COQ_SRC_PATH}\theories\*.cmxs SetOutPath "$INSTDIR\lib\plugins" File /r ${COQ_SRC_PATH}\plugins\*.vo File /r ${COQ_SRC_PATH}\plugins\*.v diff --git a/dev/printers.mllib b/dev/printers.mllib index 2f78c2e9..07b48ed5 100644 --- a/dev/printers.mllib +++ b/dev/printers.mllib @@ -27,13 +27,14 @@ Pp Segmenttree Unicodetable Unicode -Errors CObj CList CString CArray CStack Util +Ppstyle +Errors Bigint Dyn CUnix @@ -109,7 +110,6 @@ Loadpath Goptions Decls Heads -Assumptions Keys Locusops Miscops @@ -154,7 +154,6 @@ Tok Lexer Ppextend Pputils -Ppstyle Ppannotation Stdarg Constrarg @@ -204,6 +203,7 @@ Hints Himsg Cerrors Locality +Assumptions Vernacinterp Dischargedhypsmap Discharge diff --git a/dev/top_printers.ml b/dev/top_printers.ml index f969f013..f9f2e1b0 100644 --- a/dev/top_printers.ml +++ b/dev/top_printers.ml @@ -229,6 +229,11 @@ let ppenv e = pp (str "[" ++ pr_named_context_of e Evd.empty ++ str "]" ++ spc() ++ str "[" ++ pr_rel_context e Evd.empty (rel_context e) ++ str "]") +let ppenvwithcst e = pp + (str "[" ++ pr_named_context_of e Evd.empty ++ str "]" ++ spc() ++ + str "[" ++ pr_rel_context e Evd.empty (rel_context e) ++ str "]" ++ spc() ++ + str "{" ++ Cmap_env.fold (fun a _ s -> pr_con a ++ spc () ++ s) (Obj.magic e).Pre_env.env_globals.Pre_env.env_constants (mt ()) ++ str "}") + let pptac = (fun x -> pp(Pptactic.pr_glob_tactic (Global.env()) x)) let ppobj obj = Format.print_string (Libobject.object_tag obj) diff --git a/dev/v8-syntax/memo-v8.tex b/dev/v8-syntax/memo-v8.tex index 8d116de2..ae4b569b 100644 --- a/dev/v8-syntax/memo-v8.tex +++ b/dev/v8-syntax/memo-v8.tex @@ -253,7 +253,7 @@ became \TERM{context}. Syntax is unified with subterm matching. \subsection{Occurrences} To avoid ambiguity between a numeric literal and the optionnal -occurence numbers of this term, the occurence numbers are put after +occurrence numbers of this term, the occurrence numbers are put after the term itself. This applies to tactic \TERM{pattern} and also \TERM{unfold} \begin{transbox} diff --git a/dev/vm_printers.ml b/dev/vm_printers.ml index 4578a3b3..1c501df8 100644 --- a/dev/vm_printers.ml +++ b/dev/vm_printers.ml @@ -13,7 +13,7 @@ let ppripos (ri,pos) = ("annot : MutInd("^(string_of_mind sp)^","^(string_of_int i)^")\n") | Reloc_const _ -> print_string "structured constant\n" - | Reloc_getglobal (kn,_) -> + | Reloc_getglobal kn -> print_string ("getglob "^(string_of_con kn)^"\n")); print_flush () @@ -30,7 +30,7 @@ let ppsort = function let print_idkey idk = match idk with - | ConstKey (sp,_) -> + | ConstKey sp -> print_string "Cons("; print_string (string_of_con sp); print_string ")" @@ -49,6 +49,7 @@ let rec ppzipper z = close_box() | Zfix _ -> print_string "Zfix" | Zswitch _ -> print_string "Zswitch" + | Zproj _ -> print_string "Zproj" and ppstack s = open_hovbox 0; @@ -60,8 +61,8 @@ and ppstack s = and ppatom a = match a with | Aid idk -> print_idkey idk - | Aiddef(idk,_) -> print_string "&";print_idkey idk - | Aind((sp,i),_) -> print_string "Ind("; + | Atype u -> print_string "Type(...)" + | Aind(sp,i) -> print_string "Ind("; print_string (string_of_mind sp); print_string ","; print_int i; print_string ")" @@ -78,6 +79,7 @@ and ppwhd whd = | Vatom_stk(a,s) -> open_hbox();ppatom a;close_box(); print_string"@";ppstack s + | Vuniv_level lvl -> Pp.pp (Univ.Level.pr lvl) and ppvblock b = open_hbox(); diff --git a/doc/stdlib/Library.tex b/doc/stdlib/Library.tex index 44a0b1d3..44a0b1d3 100755..100644 --- a/doc/stdlib/Library.tex +++ b/doc/stdlib/Library.tex diff --git a/doc/stdlib/index-list.html.template b/doc/stdlib/index-list.html.template index 024e1341..866193ff 100644 --- a/doc/stdlib/index-list.html.template +++ b/doc/stdlib/index-list.html.template @@ -591,7 +591,7 @@ through the <tt>Require Import</tt> command.</p> </dd> <dt> <b>Program</b>: - Support for dependently-typed programming. + Support for dependently-typed programming </dt> <dd> theories/Program/Basics.v @@ -612,4 +612,12 @@ through the <tt>Require Import</tt> command.</p> theories/Unicode/Utf8_core.v theories/Unicode/Utf8.v </dd> + + <dt> <b>Compat</b>: + Compatibility wrappers for previous versions of Coq + </dt> + <dd> + theories/Compat/Coq84.v + theories/Compat/Coq85.v + </dd> </dl> diff --git a/grammar/grammar.mllib b/grammar/grammar.mllib index 0b168377..60ea0df0 100644 --- a/grammar/grammar.mllib +++ b/grammar/grammar.mllib @@ -1,6 +1,7 @@ Coq_config Hook +Terminal Canary Hashset Hashcons @@ -19,12 +20,14 @@ Serialize Stateid Feedback Pp -Errors + CList CString CArray CStack Util +Ppstyle +Errors Bigint Predicate Segmenttree diff --git a/grammar/tacextend.ml4 b/grammar/tacextend.ml4 index 0421ad7c..66f82fcd 100644 --- a/grammar/tacextend.ml4 +++ b/grammar/tacextend.ml4 @@ -8,6 +8,8 @@ (*i camlp4deps: "tools/compat5b.cmo" i*) +(** Implementation of the TACTIC EXTEND macro. *) + open Util open Pp open Names @@ -172,17 +174,17 @@ let is_constr_gram = function | Aentry ("constr", "constr") -> true | _ -> false -let make_vars len = - (** We choose names unlikely to be written by a human, even though that - does not matter at all. *) - List.init len (fun i -> Some (Id.of_string (Printf.sprintf "_%i" i))) +let make_var = function + | GramNonTerminal(loc',_,_,Some p) -> Some p + | GramNonTerminal(loc',_,_,None) -> Some (Id.of_string "_") + | _ -> assert false let declare_tactic loc s c cl = match cl with | [(GramTerminal name) :: rem, _, tac] when List.for_all is_constr_gram rem -> (** The extension is only made of a name followed by constr entries: we do not add any grammar nor printing rule and add it as a true Ltac definition. *) let patt = make_patt rem in - let vars = make_vars (List.length rem) in + let vars = List.map make_var rem in let vars = mlexpr_of_list (mlexpr_of_option mlexpr_of_ident) vars in let entry = mlexpr_of_string s in let se = <:expr< { Tacexpr.mltac_tactic = $entry$; Tacexpr.mltac_plugin = $plugin_name$ } >> in diff --git a/grammar/vernacextend.ml4 b/grammar/vernacextend.ml4 index 9db89308..03061d8b 100644 --- a/grammar/vernacextend.ml4 +++ b/grammar/vernacextend.ml4 @@ -8,6 +8,8 @@ (*i camlp4deps: "tools/compat5b.cmo" i*) +(** Implementation of the VERNAC EXTEND macro. *) + open Pp open Util open Q_util diff --git a/ide/config_lexer.mll b/ide/config_lexer.mll index 87cc6d06..36715356 100644 --- a/ide/config_lexer.mll +++ b/ide/config_lexer.mll @@ -17,7 +17,7 @@ let space = [' ' '\010' '\013' '\009' '\012'] let char = ['A'-'Z' 'a'-'z' '_' '0'-'9'] -let ident = char+ +let ident = (char | '.')+ let ignore = space | ('#' [^ '\n']*) rule prefs m = parse diff --git a/ide/coq-ssreflect.lang b/ide/coq-ssreflect.lang index 4c488ae8..7cfc1670 100644 --- a/ide/coq-ssreflect.lang +++ b/ide/coq-ssreflect.lang @@ -190,6 +190,7 @@ <keyword>Eval</keyword> <keyword>Load</keyword> <keyword>Undo</keyword> + <keyword>Restart</keyword> <keyword>Goal</keyword> <keyword>Print</keyword> <keyword>Save</keyword> diff --git a/ide/coq.lang b/ide/coq.lang index 65150d6a..e25eedbc 100644 --- a/ide/coq.lang +++ b/ide/coq.lang @@ -5,7 +5,7 @@ <property name="block-comment-start">\(\*</property> <property name="block-comment-stop">\*\)</property> </metadata> - + <styles> <style id="comment" _name="Comment" map-to="def:comment"/> <style id="coqdoc" _name="Coqdoc text" map-to="def:note"/> @@ -20,201 +20,214 @@ <style id="safe" _name="Checked Part"/> <style id="sentence" _name="Sentence terminator"/> </styles> - + <definitions> <define-regex id="space">\s+</define-regex> <define-regex id="first_ident_char">[_\p{L}]</define-regex> <define-regex id="ident_char">[_\p{L}'\pN]</define-regex> <define-regex id="ident">\%{first_ident_char}\%{ident_char}*</define-regex> <define-regex id="qualit">(\%{ident}\.)*\%{ident}</define-regex> - <define-regex id="undotted_sep">[-+*{}]</define-regex> <define-regex id="dot_sep">\.(\s|\z)</define-regex> - <define-regex id="single_decl">Definition|Let|Example|SubClass|(Co)?Fixpoint|Function|Conjecture|(Co)?Inductive|Record|Structure|Ltac|Instance|Class|Existing\%{space}Instance|Canonical\%{space}Structure|Coercion</define-regex> + <define-regex id="bullet">([-+*]+|{)(\s|\z)|}(\s*})*</define-regex> + <define-regex id="single_decl">Definition|Let|Example|SubClass|(Co)?Fixpoint|Function|Conjecture|(Co)?Inductive|Record|Structure|Ltac|Instance|Class|Existing\%{space}Instance|Canonical\%{space}Structure|Coercion|Universe</define-regex> <define-regex id="mult_decl">Hypothes[ie]s|Axiom(s)?|Variable(s)?|Parameter(s)?|Context|Implicit\%{space}Type(s)?</define-regex> <define-regex id="locality">((Local|Global)\%{space})?</define-regex> <define-regex id="begin_proof">Theorem|Lemma|Fact|Remark|Corollary|Proposition|Property</define-regex> <define-regex id="end_proof">Qed|Defined|Admitted|Abort|Save</define-regex> <define-regex id="decl_head">((?'gal'\%{locality}(Program\%{space})?(\%{single_decl}|\%{begin_proof}))\%{space}(?'id'\%{ident}))|((?'gal4list'\%{mult_decl})(?'id_list'(\%{space}\%{ident})*))|(?'gal2'Goal)</define-regex> - <context id="escape-seq" style-ref="escape"> - <match>""</match> - </context> - <context id="string" style-ref="string"> + <!-- Strings, with '""' an escape sequence --> + <context id="string" style-ref="string" class="string"> <start>"</start> <end>"</end> <include> - <context ref="escape-seq"/> + <context id="string-escape" style-ref="escape"> + <match>""</match> + </context> + </include> + </context> + + <!-- Coqdoc comments --> + <context id="coqdoc" style-ref="coqdoc" class="comment" class-disabled="no-spell-check"> + <start>\(\*\*(\s|\z)</start> + <end>\*\)</end> + <include> + <context ref="comment"/> + <context ref="string"/> + <context ref="def:in-comment"/> </include> </context> + + <!-- Regular comments, possibly nested --> + <context id="comment" style-ref="comment" class="comment" class-disabled="no-spell-check"> + <start>\(\*</start> + <end>\*\)</end> + <include> + <context ref="comment"/> + <context ref="string"/> + <context ref="def:in-comment"/> + </include> + </context> + + <!-- Keywords for constr --> + <context id="constr-keyword" style-ref="constr-keyword"> + <keyword>forall</keyword> + <keyword>fun</keyword> + <keyword>match</keyword> + <keyword>fix</keyword> + <keyword>cofix</keyword> + <keyword>with</keyword> + <keyword>for</keyword> + <keyword>end</keyword> + <keyword>as</keyword> + <keyword>let</keyword> + <keyword>in</keyword> + <keyword>if</keyword> + <keyword>then</keyword> + <keyword>else</keyword> + <keyword>return</keyword> + </context> + + <!-- Sort keywords --> + <context id="constr-sort" style-ref="constr-sort"> + <keyword>Prop</keyword> + <keyword>Set</keyword> + <keyword>Type</keyword> + </context> + <context id="coq" class="no-spell-check"> <include> <context ref="string"/> - <context id="coqdoc" style-ref="coqdoc" class-disabled="no-spell-check"> - <start>\(\*\*(\s|\z)</start> - <end>\*\)</end> - <include> - <context ref="comment-in-comment"/> - <context ref="string"/> - </include> - </context> - <context id="comment" style-ref="comment" class="comment" class-disabled="no-spell-check"> - <start>\(\*</start> - <end>\*\)</end> - <include> - <context id="comment-in-comment" style-ref="comment" class="comment" class-disabled="no-spell-check"> - <start>\(\*</start> - <end>\*\)</end> - <include> - <context ref="comment-in-comment"/> - <context ref="string"/> - </include> - </context> - <context ref="string"/> - </include> - </context> - <context id="declaration"> - <start>\%{decl_head}</start> - <end>\%{dot_sep}</end> - <include> - <context sub-pattern="id" where="start" style-ref="identifier"/> - <context sub-pattern="gal" where="start" style-ref="gallina-keyword"/> - <context sub-pattern="gal2" where="start" style-ref="gallina-keyword"/> - <context sub-pattern="id_list" where="start" style-ref="identifier"/> - <context sub-pattern="gal4list" where="start" style-ref="gallina-keyword"/> - <context id="constr-keyword" style-ref="constr-keyword"> - <keyword>forall</keyword> - <keyword>fun</keyword> - <keyword>match</keyword> - <keyword>fix</keyword> - <keyword>cofix</keyword> - <keyword>with</keyword> - <keyword>for</keyword> - <keyword>end</keyword> - <keyword>as</keyword> - <keyword>let</keyword> - <keyword>in</keyword> - <keyword>if</keyword> - <keyword>then</keyword> - <keyword>else</keyword> - <keyword>return</keyword> - </context> - <context id="constr-sort" style-ref="constr-sort"> - <keyword>Prop</keyword> - <keyword>Set</keyword> - <keyword>Type</keyword> - </context> - <context id="dot-nosep"> - <match>\.\.</match> - </context> - <context ref="comment"/> - <context ref="string"/> - <context ref="coqdoc"/> - </include> - </context> - <context id="proof"> - <start>Proof(\%{dot_sep}|\%{space}using|\%{space}with)</start> - <end>\%{end_proof}\%{dot_sep}</end> - <include> - <context sub-pattern="0" where="start" style-ref="vernac-keyword"/> - <context sub-pattern="0" where="end" style-ref="vernac-keyword"/> - <context ref="command"/> - <context ref="scope-command"/> - <context ref="hint-command"/> - <context ref="command-for-qualit"/> - <context ref="declaration"/> - <context ref="comment"/> - <context ref="string"/> - <context ref="coqdoc"/> - <context ref="proof"/> - <context ref="undotted-sep"/> - <context id="tactic" extend-parent="false"> - <start>\b[^-+*{}]</start> - <end>\%{dot_sep}</end> - <include> - <context ref="dot-nosep"/> - <context ref="constr-keyword"/> - <context ref="constr-sort"/> - </include> - </context> - </include> - </context> - <context id="exact-proof"> - <start>Proof</start> - <end>\%{dot_sep}</end> - <include> - <context sub-pattern="0" where="start" style-ref="vernac-keyword"/> - <context ref="constr-keyword"/> - <context ref="constr-sort"/> - </include> - </context> - <context id="undotted-sep" style-ref="vernac-keyword"> - <match>\%{undotted_sep}</match> - </context> - <context id="command" style-ref="vernac-keyword"> - <keyword>Add</keyword> - <keyword>Check</keyword> - <keyword>Eval</keyword> - <keyword>Load</keyword> - <keyword>Undo</keyword> - <keyword>(Print|Reset)\%{space}+Extraction\%{space}+(Inline|Blacklist)</keyword> - <keyword>Print</keyword> - <keyword>Comments</keyword> - <keyword>Solve\%{space}Obligation</keyword> - <keyword>(Uns|S)et(\%{space}\%{ident})+</keyword> - <keyword>(\%{locality}|(Reserved|Tactic)\%{space})?Notation</keyword> - <keyword>\%{locality}Infix</keyword> - <keyword>Declare\%{space}ML\%{space}Module</keyword> - <keyword>Extraction\%{space}Language\%{space}(Ocaml|Haskell|Scheme|JSON)</keyword> - </context> - <context id="hint-command" style-ref="vernac-keyword"> - <prefix>\%{locality}Hint\%{space}</prefix> - <keyword>Resolve</keyword> - <keyword>Immediate</keyword> - <keyword>Constructors</keyword> - <keyword>Unfold</keyword> - <keyword>Opaque</keyword> - <keyword>Transparent</keyword> - <keyword>Extern</keyword> - <keyword>Rewrite</keyword> - </context> - <context id="scope-command" style-ref="vernac-keyword"> - <suffix>\%{space}Scope</suffix> - <keyword>\%{locality}Open</keyword> - <keyword>\%{locality}Close</keyword> - <keyword>Bind</keyword> - <keyword>Delimit</keyword> - </context> - <context id="command-for-qualit"> - <suffix>\%{space}(?'qua'\%{qualit})</suffix> - <keyword>Chapter</keyword> - <keyword>Combined\%{space}Scheme</keyword> - <keyword>Scheme\%{space}(Induction|Minimality|Elimination|Case|Equality)\%{space}for</keyword> - <keyword>End</keyword> - <keyword>Section</keyword> - <keyword>Module(\%{space}Type)?</keyword> - <keyword>Declare\%{space}Module(\%{space}(Import|Export))?</keyword> - <keyword>About</keyword> - <keyword>Arguments</keyword> - <keyword>Implicit\%{space}Arguments</keyword> - <keyword>Include</keyword> - <keyword>Extract\%{space}((Inlined\%{space})?Constant|Inductive)</keyword> - <include> - <context sub-pattern="1" style-ref="vernac-keyword"/> - <context sub-pattern="qua" style-ref="identifier"/> - </include> - </context> - <context id="command-for-qualit-list"> - <suffix>(?'qua_list'(\%{space}\%{qualit})+)</suffix> - <keyword>Typeclasses (Transparent|Opaque)</keyword> - <keyword>Require(\%{space}(Import|Export))?</keyword> - <keyword>Import</keyword> - <keyword>Export</keyword> - <keyword>((Recursive|Separate)\%{space})?Extraction(\%{space}(Library|(No)?Inline|Blacklist))?</keyword> - <include> - <context sub-pattern="1" style-ref="vernac-keyword"/> - <context sub-pattern="qua_list" style-ref="identifier"/> - </include> - </context> + <context ref="coqdoc"/> + <context ref="comment"/> + + <context id="declaration"> + <start>\%{decl_head}</start> + <end>\%{dot_sep}</end> + <include> + <context sub-pattern="id" where="start" style-ref="identifier"/> + <context sub-pattern="gal" where="start" style-ref="gallina-keyword"/> + <context sub-pattern="gal2" where="start" style-ref="gallina-keyword"/> + <context sub-pattern="id_list" where="start" style-ref="identifier"/> + <context sub-pattern="gal4list" where="start" style-ref="gallina-keyword"/> + <context ref="constr-keyword"/> + <context ref="constr-sort"/> + <context id="dot-nosep"> + <match>\.\.</match> + </context> + <context ref="string"/> + <context ref="coqdoc"/> + <context ref="comment"/> + </include> + </context> + + <context id="proof"> + <start>(Proof(\%{dot_sep}|\%{space}using|\%{space}with))|Next Obligation</start> + <end>\%{end_proof}\%{dot_sep}</end> + <include> + <context sub-pattern="0" where="start" style-ref="vernac-keyword"/> + <context sub-pattern="0" where="end" style-ref="vernac-keyword"/> + <context ref="command-in-proof"/> + <context ref="string"/> + <context ref="coqdoc"/> + <context ref="comment"/> + <context ref="constr-keyword"/> + <context ref="constr-sort"/> + <context id="bullet" extend-parent="false"> + <match>\%{dot_sep}\s*(?'bul'\%{bullet})</match> + <include> + <context sub-pattern="bul" style-ref="vernac-keyword"/> + </include> + </context> + <context id="bullet-sol" style-ref="vernac-keyword"> + <match>^\s*\%{bullet}</match> + </context> + </include> + </context> + + <context id="exact-proof"> + <start>Proof</start> + <end>\%{dot_sep}</end> + <include> + <context sub-pattern="0" where="start" style-ref="vernac-keyword"/> + <context ref="constr-keyword"/> + <context ref="constr-sort"/> + </include> + </context> + + <context id="command-in-proof" style-ref="vernac-keyword"> + <keyword>About</keyword> + <keyword>Check</keyword> + <keyword>Print</keyword> + <keyword>Eval</keyword> + <keyword>Undo</keyword> + <keyword>Restart</keyword> + <keyword>Opaque</keyword> + <keyword>Transparent</keyword> + </context> + + <context id="command" style-ref="vernac-keyword"> + <keyword>Add</keyword> + <keyword>Load</keyword> + <keyword>(Print|Reset)\%{space}+Extraction\%{space}+(Inline|Blacklist)</keyword> + <keyword>Comments</keyword> + <keyword>Solve\%{space}Obligation</keyword> + <keyword>(Uns|S)et(\%{space}\%{ident})+</keyword> + <keyword>(\%{locality}|(Reserved|Tactic)\%{space})?Notation</keyword> + <keyword>\%{locality}Infix</keyword> + <keyword>Declare\%{space}ML\%{space}Module</keyword> + <keyword>Extraction\%{space}Language\%{space}(Ocaml|Haskell|Scheme|JSON)</keyword> + </context> + + <context id="hint-command" style-ref="vernac-keyword"> + <prefix>\%{locality}Hint\%{space}</prefix> + <keyword>Resolve</keyword> + <keyword>Immediate</keyword> + <keyword>Constructors</keyword> + <keyword>Unfold</keyword> + <keyword>Extern</keyword> + <keyword>Rewrite</keyword> + </context> + + <context id="scope-command" style-ref="vernac-keyword"> + <suffix>\%{space}Scope</suffix> + <keyword>\%{locality}Open</keyword> + <keyword>\%{locality}Close</keyword> + <keyword>Bind</keyword> + <keyword>Delimit</keyword> + </context> + + <context id="command-for-qualit"> + <suffix>\%{space}(?'qua'\%{qualit})</suffix> + <keyword>Chapter</keyword> + <keyword>Combined\%{space}Scheme</keyword> + <keyword>Scheme\%{space}(Induction|Minimality|Elimination|Case|Equality)\%{space}for</keyword> + <keyword>End</keyword> + <keyword>Section</keyword> + <keyword>Module(\%{space}Type)?</keyword> + <keyword>Declare\%{space}Module(\%{space}(Import|Export))?</keyword> + <keyword>Arguments</keyword> + <keyword>Implicit\%{space}Arguments</keyword> + <keyword>Include</keyword> + <keyword>Extract\%{space}((Inlined\%{space})?Constant|Inductive)</keyword> + <include> + <context sub-pattern="1" style-ref="vernac-keyword"/> + <context sub-pattern="qua" style-ref="identifier"/> + </include> + </context> + + <context id="command-for-qualit-list"> + <suffix>(?'qua_list'(\%{space}\%{qualit})+)</suffix> + <keyword>Typeclasses (Transparent|Opaque)</keyword> + <keyword>Require(\%{space}(Import|Export))?</keyword> + <keyword>Import</keyword> + <keyword>Export</keyword> + <keyword>((Recursive|Separate)\%{space})?Extraction(\%{space}(Library|(No)?Inline|Blacklist))?</keyword> + <include> + <context sub-pattern="1" style-ref="vernac-keyword"/> + <context sub-pattern="qua_list" style-ref="identifier"/> + </include> + </context> </include> </context> </definitions> diff --git a/ide/coq.mli b/ide/coq.mli index a72c67b4..2dc5ad30 100644 --- a/ide/coq.mli +++ b/ide/coq.mli @@ -16,7 +16,7 @@ type coqtop Liveness management of coqtop is automatic. Whenever a coqtop dies abruptly, this module is responsible for relaunching the whole process. The reset handler set through [set_reset_handler] will be called after such an - abrupt failure. It is also called when explicitely requesting coqtop to + abrupt failure. It is also called when explicitly requesting coqtop to reset. *) type 'a task @@ -29,7 +29,7 @@ type 'a task ([is_computing] will answer [true]), and any other task submission will be rejected by [try_grab]. - Any exception occuring within the task will trigger a coqtop reset. + Any exception occurring within the task will trigger a coqtop reset. Beware, because of the GTK scheduler, you never know when a task will actually be executed. If you need to sequentialize imperative actions, you @@ -43,7 +43,7 @@ val bind : 'a task -> ('a -> 'b task) -> 'b task (** Monadic binding of tasks *) val lift : (unit -> 'a) -> 'a task -(** Return the impertative computation waiting to be processed. *) +(** Return the imperative computation waiting to be processed. *) val seq : unit task -> 'a task -> 'a task (** Sequential composition *) diff --git a/ide/coqOps.ml b/ide/coqOps.ml index af728471..c7e0810f 100644 --- a/ide/coqOps.ml +++ b/ide/coqOps.ml @@ -204,7 +204,7 @@ object(self) let on_changed (i, f) = segment#add i (flags_to_color f) in let on_push s = set_index s document_length; - (SentenceId.connect s)#changed on_changed; + ignore ((SentenceId.connect s)#changed on_changed); document_length <- succ document_length; segment#set_length document_length; let flags = List.map mem_flag_of_flag s.flags in @@ -559,7 +559,7 @@ object(self) if Queue.is_empty queue then conclude topstack else match Queue.pop queue, topstack with | `Skip(start,stop), [] -> - logger Pp.Error "You muse close the proof with Qed or Admitted"; + logger Pp.Error "You must close the proof with Qed or Admitted"; self#discard_command_queue queue; conclude [] | `Skip(start,stop), (_,s) :: topstack -> @@ -655,8 +655,6 @@ object(self) buffer#remove_tag Tags.Script.unjustified ~start ~stop; buffer#remove_tag Tags.Script.tooltip ~start ~stop; buffer#remove_tag Tags.Script.to_process ~start ~stop; - buffer#remove_tag Tags.Script.error ~start ~stop; - buffer#remove_tag Tags.Script.error_bg ~start ~stop; buffer#move_mark ~where:start (`NAME "start_of_input") end; List.iter (fun { start } -> buffer#delete_mark start) seg; @@ -671,7 +669,10 @@ object(self) push_info "Coq is undoing" in let conclusion () = pop_info (); - if move_insert then buffer#place_cursor ~where:self#get_start_of_input; + if move_insert then begin + buffer#place_cursor ~where:self#get_start_of_input; + script#recenter_insert; + end; let start = self#get_start_of_input in let stop = self#get_end_of_input in Minilib.log(Printf.sprintf "cleanup tags %d %d" start#offset stop#offset); diff --git a/ide/coqide.ml b/ide/coqide.ml index 0f4cb7b0..f15e5fa3 100644 --- a/ide/coqide.ml +++ b/ide/coqide.ml @@ -253,14 +253,14 @@ let newfile _ = !refresh_editor_hook (); notebook#goto_page index -let load sn = - let filename = sn.fileops#filename in +let load _ = + let filename = + try notebook#current_term.fileops#filename + with Invalid_argument _ -> None in match select_file_for_open ~title:"Load file" ?filename () with | None -> () | Some f -> FileAux.load_file f -let load = cb_on_current_term load - let save _ = on_current_term (FileAux.check_save ~saveas:false) let saveas sn = @@ -1125,10 +1125,10 @@ let build_ui () = ~accel:(prefs.modifier_for_navigation^"h");*) item "Previous" ~label:"_Previous" ~stock:`GO_BACK ~callback:Nav.previous_occ - ~tooltip:"Previous occurence" + ~tooltip:"Previous occurrence" ~accel:(prefs.modifier_for_navigation^"less"); item "Next" ~label:"_Next" ~stock:`GO_FORWARD ~callback:Nav.next_occ - ~tooltip:"Next occurence" + ~tooltip:"Next occurrence" ~accel:(prefs.modifier_for_navigation^"greater"); item "Force" ~label:"_Force" ~stock:`EXECUTE ~callback:Nav.join_document ~tooltip:"Fully check the document" diff --git a/ide/ide_slave.ml b/ide/ide_slave.ml index dc52ea9a..041f2f83 100644 --- a/ide/ide_slave.ml +++ b/ide/ide_slave.ml @@ -185,13 +185,15 @@ let process_goal sigma g = let ccl = let norm_constr = Reductionops.nf_evar sigma (Goal.V82.concl sigma g) in string_of_ppcmds (pr_goal_concl_style_env env sigma norm_constr) in - let process_hyp d = + let process_hyp d (env,l) = let d = Context.map_named_list_declaration (Reductionops.nf_evar sigma) d in - (string_of_ppcmds (pr_var_list_decl min_env sigma d)) in - let hyps = - List.map process_hyp - (Termops.compact_named_context_reverse (Environ.named_context env)) in - { Interface.goal_hyp = hyps; Interface.goal_ccl = ccl; Interface.goal_id = id; } + let d' = List.map (fun x -> (x, pi2 d, pi3 d)) (pi1 d) in + (List.fold_right Environ.push_named d' env, + (string_of_ppcmds (pr_var_list_decl env sigma d)) :: l) in + let (_env, hyps) = + Context.fold_named_list_context process_hyp + (Termops.compact_named_context (Environ.named_context env)) ~init:(min_env,[]) in + { Interface.goal_hyp = List.rev hyps; Interface.goal_ccl = ccl; Interface.goal_id = id; } let export_pre_goals pgs = { @@ -289,11 +291,13 @@ let export_option_value = function | Goptions.BoolValue b -> Interface.BoolValue b | Goptions.IntValue x -> Interface.IntValue x | Goptions.StringValue s -> Interface.StringValue s + | Goptions.StringOptValue s -> Interface.StringOptValue s let import_option_value = function | Interface.BoolValue b -> Goptions.BoolValue b | Interface.IntValue x -> Goptions.IntValue x | Interface.StringValue s -> Goptions.StringValue s + | Interface.StringOptValue s -> Goptions.StringOptValue s let export_option_state s = { Interface.opt_sync = s.Goptions.opt_sync; @@ -312,6 +316,8 @@ let set_options options = | BoolValue b -> Goptions.set_bool_option_value name b | IntValue i -> Goptions.set_int_option_value name i | StringValue s -> Goptions.set_string_option_value name s + | StringOptValue (Some s) -> Goptions.set_string_option_value name s + | StringOptValue None -> Goptions.unset_option_value_gen None name in List.iter iter options diff --git a/ide/ideutils.ml b/ide/ideutils.ml index 67e4bdb0..5892fb3d 100644 --- a/ide/ideutils.ml +++ b/ide/ideutils.ml @@ -311,7 +311,7 @@ let read_buffer = Buffer.create maxread I/O Exceptions are propagated. *) let read_file name buf = - let ic = open_in name in + let ic = Util.open_utf8_file_in name in let len = ref 0 in try while len := input ic read_string 0 maxread; !len > 0 do diff --git a/ide/interface.mli b/ide/interface.mli index 464e851f..767c49d2 100644 --- a/ide/interface.mli +++ b/ide/interface.mli @@ -61,6 +61,7 @@ type option_value = | BoolValue of bool | IntValue of int option | StringValue of string + | StringOptValue of string option (** Summary of an option status *) type option_state = { diff --git a/ide/preferences.ml b/ide/preferences.ml index c59642d3..90862d06 100644 --- a/ide/preferences.ml +++ b/ide/preferences.ml @@ -190,7 +190,7 @@ let current = { automatic_tactics = ["trivial"; "tauto"; "auto"; "omega"; "auto with *"; "intuition" ]; - modifier_for_navigation = "<Control><Alt>"; + modifier_for_navigation = "<Control>"; modifier_for_templates = "<Control><Shift>"; modifier_for_tactics = "<Control><Alt>"; modifier_for_display = "<Alt><Shift>"; @@ -711,38 +711,61 @@ let configure ?(apply=(fun () -> ())) () = ~f:(fun s -> current.project_file_name <- s) current.project_file_name in + let update_modifiers prefix mds = + let change ~path ~key ~modi ~changed = + if CString.is_sub prefix path 0 then + ignore (GtkData.AccelMap.change_entry ~key ~modi:mds ~replace:true path) + in + GtkData.AccelMap.foreach change + in let help_string = "restart to apply" in let the_valid_mod = str_to_mod_list current.modifiers_valid in let modifier_for_tactics = + let cb l = + current.modifier_for_tactics <- mod_list_to_str l; + update_modifiers "<Actions>/Tactics/" l + in modifiers ~allow:the_valid_mod - ~f:(fun l -> current.modifier_for_tactics <- mod_list_to_str l) + ~f:cb ~help:help_string "Modifiers for Tactics Menu" (str_to_mod_list current.modifier_for_tactics) in let modifier_for_templates = + let cb l = + current.modifier_for_templates <- mod_list_to_str l; + update_modifiers "<Actions>/Templates/" l + in modifiers ~allow:the_valid_mod - ~f:(fun l -> current.modifier_for_templates <- mod_list_to_str l) + ~f:cb ~help:help_string "Modifiers for Templates Menu" (str_to_mod_list current.modifier_for_templates) in let modifier_for_navigation = + let cb l = + current.modifier_for_navigation <- mod_list_to_str l; + update_modifiers "<Actions>/Navigation/" l + in modifiers ~allow:the_valid_mod - ~f:(fun l -> current.modifier_for_navigation <- mod_list_to_str l) + ~f:cb ~help:help_string "Modifiers for Navigation Menu" (str_to_mod_list current.modifier_for_navigation) in let modifier_for_display = + let cb l = + current.modifier_for_display <- mod_list_to_str l; + update_modifiers "<Actions>/View/" l + in modifiers ~allow:the_valid_mod - ~f:(fun l -> current.modifier_for_display <- mod_list_to_str l) + ~f:cb ~help:help_string "Modifiers for View Menu" (str_to_mod_list current.modifier_for_display) diff --git a/ide/session.ml b/ide/session.ml index 12b77966..a795f633 100644 --- a/ide/session.ml +++ b/ide/session.ml @@ -239,7 +239,7 @@ let find_int_col s l = let find_string_col s l = match List.assoc s l with `StringC c -> c | _ -> assert false -let make_table_widget cd cb = +let make_table_widget ?sort cd cb = let frame = GBin.scrolled_window ~hpolicy:`NEVER ~vpolicy:`AUTOMATIC () in let columns, store = let cols = new GTree.column_list in @@ -253,6 +253,7 @@ let make_table_widget cd cb = ~rules_hint:true ~headers_visible:false ~model:store ~packing:frame#add () in let () = data#set_headers_visible true in + let () = data#set_headers_clickable true in let refresh () = let clr = Tags.color_of_string current.background_color in data#misc#modify_base [`NORMAL, `COLOR clr] @@ -268,21 +269,34 @@ let make_table_widget cd cb = c#set_sizing `AUTOSIZE; c) columns cd in + let make_sorting i (_, c) = + let sort (store : GTree.model) it1 it2 = match c with + | `IntC c -> + Pervasives.compare (store#get ~row:it1 ~column:c) (store#get ~row:it2 ~column:c) + | `StringC c -> + Pervasives.compare (store#get ~row:it1 ~column:c) (store#get ~row:it2 ~column:c) + in + store#set_sort_func i sort + in + CList.iteri make_sorting columns; + CList.iteri (fun i c -> c#set_sort_column_id i) cols; List.iter (fun c -> ignore(data#append_column c)) cols; ignore( data#connect#row_activated ~callback:(fun tp vc -> cb columns store tp vc) ); + let () = match sort with None -> () | Some (i, t) -> store#set_sort_column_id i t in frame, (fun f -> f columns store), refresh let create_errpage (script : Wg_ScriptView.script_view) : errpage = let table, access, refresh = - make_table_widget + make_table_widget ~sort:(0, `ASCENDING) [`Int,"Line",true; `String,"Error message",true] (fun columns store tp vc -> let row = store#get_iter tp in let lno = store#get ~row ~column:(find_int_col "Line" columns) in let where = script#buffer#get_iter (`LINE (lno-1)) in script#buffer#place_cursor ~where; + script#misc#grab_focus (); ignore (script#scroll_to_iter ~use_align:false ~yalign:0.75 ~within_margin:0.25 where)) in let tip = GMisc.label ~text:"Double click to jump to error line" () in @@ -311,7 +325,7 @@ let create_errpage (script : Wg_ScriptView.script_view) : errpage = let create_jobpage coqtop coqops : jobpage = let table, access, refresh = - make_table_widget + make_table_widget ~sort:(0, `ASCENDING) [`String,"Worker",true; `String,"Job name",true] (fun columns store tp vc -> let row = store#get_iter tp in diff --git a/ide/utf8_convert.mll b/ide/utf8_convert.mll index 621833dd..4ebf9a62 100644 --- a/ide/utf8_convert.mll +++ b/ide/utf8_convert.mll @@ -12,7 +12,7 @@ } -(* Replace all occurences of \x{iiii} and \x{iiiiiiii} by UTF-8 valid chars *) +(* Replace all occurrences of \x{iiii} and \x{iiiiiiii} by UTF-8 valid chars *) let digit = ['0'-'9''A'-'Z''a'-'z'] let short = digit digit digit digit diff --git a/ide/wg_ProofView.ml b/ide/wg_ProofView.ml index b12d29d6..69d460b0 100644 --- a/ide/wg_ProofView.ml +++ b/ide/wg_ProofView.ml @@ -6,6 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Util + class type proof_view = object inherit GObj.widget @@ -138,20 +140,22 @@ let display mode (view : #GText.view_skel) goals hints evars = view#buffer#insert "No more subgoals." | [], [], [], _ :: _ -> (* A proof has been finished, but not concluded *) - view#buffer#insert "No more subgoals but non-instantiated existential variables:\n\n"; + view#buffer#insert "No more subgoals, but there are non-instantiated existential variables:\n\n"; let iter evar = let msg = Printf.sprintf "%s\n" evar.Interface.evar_info in view#buffer#insert msg in - List.iter iter evars + List.iter iter evars; + view#buffer#insert "\nYou can use Grab Existential Variables." | [], [], _, _ -> (* The proof is finished, with the exception of given up goals. *) - view#buffer#insert "No more, however there are goals you gave up. You need to go back and solve them:\n\n"; + view#buffer#insert "No more subgoals, but there are some goals you gave up:\n\n"; let iter goal = let msg = Printf.sprintf "%s\n" goal.Interface.goal_ccl in view#buffer#insert msg in - List.iter iter given_up_goals + List.iter iter given_up_goals; + view#buffer#insert "\nYou need to go back and solve them." | [], _, _, _ -> (* All the goals have been resolved but those on the shelf. *) view#buffer#insert "All the remaining goals are on the shelf:\n\n"; @@ -162,12 +166,17 @@ let display mode (view : #GText.view_skel) goals hints evars = List.iter iter shelved_goals | _, _, _, _ -> (* No foreground proofs, but still unfocused ones *) - view#buffer#insert "This subproof is complete, but there are still unfocused goals:\n\n"; - let iter goal = + let total = List.length bg in + let goal_str index = Printf.sprintf + "______________________________________(%d/%d)\n" index total + in + view#buffer#insert "This subproof is complete, but there are some unfocused goals:\n\n"; + let iter i goal = + let () = view#buffer#insert (goal_str (succ i)) in let msg = Printf.sprintf "%s\n" goal.Interface.goal_ccl in view#buffer#insert msg in - List.iter iter bg + List.iteri iter bg end | Some { Interface.fg_goals = fg } -> mode view fg hints diff --git a/ide/wg_ScriptView.ml b/ide/wg_ScriptView.ml index 8298d995..ae50b283 100644 --- a/ide/wg_ScriptView.ml +++ b/ide/wg_ScriptView.ml @@ -139,7 +139,7 @@ object(self) (** We don't care about atomicity. Return: 1. `OK when there was no error, `FAIL otherwise - 2. `NOOP if no write occured, `WRITE otherwise + 2. `NOOP if no write occurred, `WRITE otherwise *) method private process_action = function | Insert ins -> diff --git a/ide/xmlprotocol.ml b/ide/xmlprotocol.ml index d337a911..84fd8929 100644 --- a/ide/xmlprotocol.ml +++ b/ide/xmlprotocol.ml @@ -62,10 +62,12 @@ let of_option_value = function | IntValue i -> constructor "option_value" "intvalue" [of_option of_int i] | BoolValue b -> constructor "option_value" "boolvalue" [of_bool b] | StringValue s -> constructor "option_value" "stringvalue" [of_string s] + | StringOptValue s -> constructor "option_value" "stringoptvalue" [of_option of_string s] let to_option_value = do_match "option_value" (fun s args -> match s with | "intvalue" -> IntValue (to_option to_int (singleton args)) | "boolvalue" -> BoolValue (to_bool (singleton args)) | "stringvalue" -> StringValue (to_string (singleton args)) + | "stringoptvalue" -> StringOptValue (to_option to_string (singleton args)) | _ -> raise Marshal_error) let of_option_state s = @@ -337,6 +339,8 @@ end = struct | IntValue None -> "none" | IntValue (Some i) -> string_of_int i | StringValue s -> s + | StringOptValue None -> "none" + | StringOptValue (Some s) -> s | BoolValue b -> if b then "true" else "false" let pr_option_state (s : option_state) = Printf.sprintf "sync := %b; depr := %b; name := %s; value := %s\n" diff --git a/interp/constrintern.ml b/interp/constrintern.ml index 5151d2a1..c754f191 100644 --- a/interp/constrintern.ml +++ b/interp/constrintern.ml @@ -1120,7 +1120,7 @@ let drop_notations_pattern looked_for = let (argscs,_) = find_remaining_scopes pats [] g in Some (g, List.map2 (in_pat_sc env) argscs pats, []) | NApp (NRef g,args) -> - ensure_kind top loc g; + test_kind top g; let nvars = List.length vars in if List.length pats < nvars then error_not_enough_arguments loc; let pats1,pats2 = List.chop nvars pats in @@ -1142,7 +1142,11 @@ let drop_notations_pattern looked_for = sort_fields false loc l (fun _ l -> (CPatAtom (loc, None))::l) in begin match sorted_fields with | None -> RCPatAtom (loc, None) - | Some (_, head, pl) -> + | Some (n, head, pl) -> + let pl = + if !oldfashion_patterns then pl else + let pars = List.make n (CPatAtom (loc, None)) in + List.rev_append pars pl in match drop_syndef top env head pl with |Some (a,b,c) -> RCPatCstr(loc, a, b, c) |None -> raise (InternalizationError (loc,NotAConstructor head)) @@ -1214,7 +1218,8 @@ let drop_notations_pattern looked_for = List.map2 (fun x -> in_not false loc {env with tmp_scope = x} fullsubst []) argscs1 pl, List.map2 (in_pat_sc env) argscs2 args) | NList (x,_,iter,terminator,lassoc) -> - let () = assert (List.is_empty args) in + if not (List.is_empty args) then user_err_loc + (loc,"",strbrk "Application of arguments to a recursive notation not supported in patterns."); (try (* All elements of the list are in scopes (scopt,subscopes) *) let (l,(scopt,subscopes)) = Id.Map.find x substlist in @@ -1893,7 +1898,7 @@ let intern_context global_level env impl_env binders = with InternalizationError (loc,e) -> user_err_loc (loc,"internalize", explain_internalization_error e) -let interp_rawcontext_evars env evdref bl = +let interp_rawcontext_evars env evdref k bl = let (env, par, _, impls) = List.fold_left (fun (env,params,n,impls) (na, k, b, t) -> @@ -1913,12 +1918,12 @@ let interp_rawcontext_evars env evdref bl = | Some b -> let c = understand_judgment_tcc env evdref b in let d = (na, Some c.uj_val, c.uj_type) in - (push_rel d env, d::params, succ n, impls)) - (env,[],1,[]) (List.rev bl) + (push_rel d env, d::params, n, impls)) + (env,[],k+1,[]) (List.rev bl) in (env, par), impls -let interp_context_evars ?(global_level=false) ?(impl_env=empty_internalization_env) env evdref params = +let interp_context_evars ?(global_level=false) ?(impl_env=empty_internalization_env) ?(shift=0) env evdref params = let int_env,bl = intern_context global_level env impl_env params in - let x = interp_rawcontext_evars env evdref bl in + let x = interp_rawcontext_evars env evdref shift bl in int_env, x diff --git a/interp/constrintern.mli b/interp/constrintern.mli index 0d33d433..b671c988 100644 --- a/interp/constrintern.mli +++ b/interp/constrintern.mli @@ -95,7 +95,8 @@ val intern_context : bool -> env -> internalization_env -> local_binder list -> (** {6 Composing internalization with type inference (pretyping) } *) -(** Main interpretation functions expecting evars to be all resolved *) +(** Main interpretation functions, using type class inference, + expecting evars and pending problems to be all resolved *) val interp_constr : env -> evar_map -> ?impls:internalization_env -> constr_expr -> constr Evd.in_evar_universe_context @@ -106,9 +107,10 @@ val interp_casted_constr : env -> evar_map -> ?impls:internalization_env -> val interp_type : env -> evar_map -> ?impls:internalization_env -> constr_expr -> types Evd.in_evar_universe_context -(** Main interpretation function expecting evars to be all resolved *) +(** Main interpretation function expecting all postponed problems to + be resolved, but possibly leaving evars. *) -val interp_open_constr : env -> evar_map -> constr_expr -> evar_map * constr +val interp_open_constr : env -> evar_map -> constr_expr -> evar_map * constr (** Accepting unresolved evars *) @@ -157,7 +159,7 @@ val interp_binder_evars : env -> evar_map ref -> Name.t -> constr_expr -> types (** Interpret contexts: returns extended env and context *) val interp_context_evars : - ?global_level:bool -> ?impl_env:internalization_env -> + ?global_level:bool -> ?impl_env:internalization_env -> ?shift:int -> env -> evar_map ref -> local_binder list -> internalization_env * ((env * rel_context) * Impargs.manual_implicits) diff --git a/interp/coqlib.ml b/interp/coqlib.ml index 02504c92..5ac718e3 100644 --- a/interp/coqlib.ml +++ b/interp/coqlib.ml @@ -54,15 +54,15 @@ let gen_reference_in_modules locstr dirs s = match these with | [x] -> x | [] -> - anomaly ~label:locstr (str ("cannot find "^s^ - " in module"^(if List.length dirs > 1 then "s " else " ")) ++ + anomaly ~label:locstr (str "cannot find " ++ str s ++ + str " in module" ++ str (if List.length dirs > 1 then "s " else " ") ++ prlist_with_sep pr_comma pr_dirpath dirs) | l -> anomaly ~label:locstr - (str ("ambiguous name "^s^" can represent ") ++ + (str "ambiguous name " ++ str s ++ str " can represent " ++ prlist_with_sep pr_comma (fun x -> Libnames.pr_path (Nametab.path_of_global x)) l ++ - str (" in module"^(if List.length dirs > 1 then "s " else " ")) ++ + str " in module" ++ str (if List.length dirs > 1 then "s " else " ") ++ prlist_with_sep pr_comma pr_dirpath dirs) let gen_constant_in_modules locstr dirs s = @@ -86,7 +86,8 @@ let check_required_library d = (Loc.ghost,make_qualid (DirPath.make (List.rev prefix)) m) *) (* or failing ...*) - error ("Library "^(DirPath.to_string dir)^" has to be required first.") + errorlabstrm "Coqlib.check_required_library" + (str "Library " ++ str (DirPath.to_string dir) ++ str " has to be required first.") (************************************************************************) (* Specific Coq objects *) diff --git a/interp/implicit_quantifiers.ml b/interp/implicit_quantifiers.ml index e304725d..87f7a6d6 100644 --- a/interp/implicit_quantifiers.ml +++ b/interp/implicit_quantifiers.ml @@ -245,21 +245,21 @@ let combine_params_freevar = let destClassApp cl = match cl with - | CApp (loc, (None, CRef (ref,_)), l) -> loc, ref, List.map fst l - | CAppExpl (loc, (None, ref,_), l) -> loc, ref, l - | CRef (ref,_) -> loc_of_reference ref, ref, [] + | CApp (loc, (None, CRef (ref, inst)), l) -> loc, ref, List.map fst l, inst + | CAppExpl (loc, (None, ref, inst), l) -> loc, ref, l, inst + | CRef (ref, inst) -> loc_of_reference ref, ref, [], inst | _ -> raise Not_found let destClassAppExpl cl = match cl with - | CApp (loc, (None, CRef (ref,_)), l) -> loc, ref, l - | CRef (ref,_) -> loc_of_reference ref, ref, [] + | CApp (loc, (None, CRef (ref, inst)), l) -> loc, ref, l, inst + | CRef (ref, inst) -> loc_of_reference ref, ref, [], inst | _ -> raise Not_found let implicit_application env ?(allow_partial=true) f ty = let is_class = try - let (loc, r, _ as clapp) = destClassAppExpl ty in + let (_, r, _, _ as clapp) = destClassAppExpl ty in let (loc, qid) = qualid_of_reference r in let gr = Nametab.locate qid in if Typeclasses.is_class gr then Some (clapp, gr) else None @@ -267,7 +267,7 @@ let implicit_application env ?(allow_partial=true) f ty = in match is_class with | None -> ty, env - | Some ((loc, id, par), gr) -> + | Some ((loc, id, par, inst), gr) -> let avoid = Id.Set.union env (ids_of_list (free_vars_of_constr_expr ty ~bound:env [])) in let c, avoid = let c = class_info gr in @@ -285,7 +285,7 @@ let implicit_application env ?(allow_partial=true) f ty = end; let pars = List.rev (List.combine ci rd) in let args, avoid = combine_params avoid f par pars in - CAppExpl (loc, (None, id, None), args), avoid + CAppExpl (loc, (None, id, inst), args), avoid in c, avoid let implicits_of_glob_constr ?(with_products=true) l = diff --git a/interp/implicit_quantifiers.mli b/interp/implicit_quantifiers.mli index 818f7e9a..eee92898 100644 --- a/interp/implicit_quantifiers.mli +++ b/interp/implicit_quantifiers.mli @@ -16,8 +16,8 @@ open Globnames val declare_generalizable : Vernacexpr.locality_flag -> (Id.t located) list option -> unit val ids_of_list : Id.t list -> Id.Set.t -val destClassApp : constr_expr -> Loc.t * reference * constr_expr list -val destClassAppExpl : constr_expr -> Loc.t * reference * (constr_expr * explicitation located option) list +val destClassApp : constr_expr -> Loc.t * reference * constr_expr list * instance_expr option +val destClassAppExpl : constr_expr -> Loc.t * reference * (constr_expr * explicitation located option) list * instance_expr option (** Fragile, should be used only for construction a set of identifiers to avoid *) @@ -28,7 +28,7 @@ val free_vars_of_binders : ?bound:Id.Set.t -> Id.t list -> local_binder list -> Id.Set.t * Id.t list (** Returns the generalizable free ids in left-to-right - order with the location of their first occurence *) + order with the location of their first occurrence *) val generalizable_vars_of_glob_constr : ?bound:Id.Set.t -> ?allowed:Id.Set.t -> glob_constr -> (Id.t * Loc.t) list diff --git a/interp/modintern.ml b/interp/modintern.ml index bf0b2f98..35e73113 100644 --- a/interp/modintern.ml +++ b/interp/modintern.ml @@ -62,7 +62,7 @@ let transl_with_decl env = function WithMod (fqid,lookup_module qid) | CWith_Definition ((_,fqid),c) -> let c, ectx = interp_constr env (Evd.from_env env) c in - let ctx = Univ.ContextSet.to_context (Evd.evar_universe_context_set ectx) in + let ctx = Evd.evar_context_universe_context ectx in WithDef (fqid,(c,ctx)) let loc_of_module = function diff --git a/interp/notation.ml b/interp/notation.ml index 80db2cb3..d18b804b 100644 --- a/interp/notation.ml +++ b/interp/notation.ml @@ -91,7 +91,9 @@ let declare_scope scope = (* Flags.if_warn message ("Creating scope "^scope);*) scope_map := String.Map.add scope empty_scope !scope_map -let error_unknown_scope sc = error ("Scope "^sc^" is not declared.") +let error_unknown_scope sc = + errorlabstrm "Notation" + (str "Scope " ++ str sc ++ str " is not declared.") let find_scope scope = try String.Map.find scope !scope_map @@ -186,23 +188,36 @@ let declare_delimiters scope key = | Some oldkey when String.equal oldkey key -> () | Some oldkey -> msg_warning - (strbrk ("Overwriting previous delimiting key "^oldkey^" in scope "^scope)); + (str "Overwriting previous delimiting key " ++ str oldkey ++ str " in scope " ++ str scope); scope_map := String.Map.add scope newsc !scope_map end; try let oldscope = String.Map.find key !delimiters_map in if String.equal oldscope scope then () else begin - msg_warning (strbrk ("Hiding binding of key "^key^" to "^oldscope)); + msg_warning (str "Hiding binding of key " ++ str key ++ str " to " ++ str oldscope); delimiters_map := String.Map.add key scope !delimiters_map end with Not_found -> delimiters_map := String.Map.add key scope !delimiters_map +let remove_delimiters scope = + let sc = find_scope scope in + let newsc = { sc with delimiters = None } in + match sc.delimiters with + | None -> msg_warning (str "No bound key for scope " ++ str scope ++ str ".") + | Some key -> + scope_map := String.Map.add scope newsc !scope_map; + try + let _ = ignore (String.Map.find key !delimiters_map) in + delimiters_map := String.Map.remove key !delimiters_map + with Not_found -> + assert false (* A delimiter for scope [scope] should exist *) + let find_delimiters_scope loc key = try String.Map.find key !delimiters_map with Not_found -> user_err_loc - (loc, "find_delimiters", str ("Unknown scope delimiting key "^key^".")) + (loc, "find_delimiters", str "Unknown scope delimiting key " ++ str key ++ str ".") (* Uninterpretation tables *) @@ -317,8 +332,7 @@ let check_required_module loc sc (sp,d) = try let _ = Nametab.global_of_path sp in () with Not_found -> user_err_loc (loc,"prim_token_interpreter", - str ("Cannot interpret in "^sc^" without requiring first module " - ^(List.last d)^".")) + str "Cannot interpret in " ++ str sc ++ str " without requiring first module " ++ str (List.last d) ++ str ".") (* Look if some notation or numeral printer in [scope] can be used in the scope stack [scopes], and if yes, using delimiters or not *) @@ -373,10 +387,9 @@ let declare_notation_interpretation ntn scopt pat df = let () = if String.Map.mem ntn sc.notations then let which_scope = match scopt with - | None -> "" - | Some _ -> " in scope " ^ scope in - let message = "Notation " ^ ntn ^ " was already used" ^ which_scope in - msg_warning (strbrk message) + | None -> mt () + | Some _ -> str " in scope " ++ str scope in + msg_warning (str "Notation " ++ str ntn ++ str " was already used" ++ which_scope) in let sc = { sc with notations = String.Map.add ntn (pat,df) sc.notations } in let () = scope_map := String.Map.add scope sc !scope_map in @@ -452,7 +465,7 @@ let interp_notation loc ntn local_scopes = try find_interpretation ntn (find_notation ntn) scopes with Not_found -> user_err_loc - (loc,"",str ("Unknown interpretation for notation \""^ntn^"\".")) + (loc,"",str "Unknown interpretation for notation \"" ++ str ntn ++ str "\".") let uninterp_notations c = List.map_append (fun key -> keymap_find key !notations_key_table) @@ -783,9 +796,9 @@ let pr_scope_classes sc = let l = classes_of_scope sc in match l with | [] -> mt () - | _ :: l -> - let opt_s = match l with [] -> "" | _ -> "es" in - hov 0 (str ("Bound to class" ^ opt_s) ++ + | _ :: ll -> + let opt_s = match ll with [] -> mt () | _ -> str "es" in + hov 0 (str "Bound to class" ++ opt_s ++ spc() ++ prlist_with_sep spc pr_scope_class l) ++ fnl() let pr_notation_info prglob ntn c = diff --git a/interp/notation.mli b/interp/notation.mli index 854c52b2..38bd5fc7 100644 --- a/interp/notation.mli +++ b/interp/notation.mli @@ -55,6 +55,7 @@ val find_scope : scope_name -> scope (** Declare delimiters for printing *) val declare_delimiters : scope_name -> delimiters -> unit +val remove_delimiters : scope_name -> unit val find_delimiters_scope : Loc.t -> delimiters -> scope_name (** {6 Declare and uses back and forth an interpretation of primitive token } *) diff --git a/interp/syntax_def.ml b/interp/syntax_def.ml index 9be7abcf..d2709d5e 100644 --- a/interp/syntax_def.ml +++ b/interp/syntax_def.ml @@ -99,7 +99,7 @@ let verbose_compat kn def = function | [], NRef r -> str " is " ++ pr_global_env Id.Set.empty r | _ -> str " is a compatibility notation" in - let since = str (" since Coq > " ^ Flags.pr_version v ^ ".") in + let since = str " since Coq > " ++ str (Flags.pr_version v) ++ str "." in act (pr_syndef kn ++ pp_def ++ since) | _ -> () diff --git a/intf/misctypes.mli b/intf/misctypes.mli index 74e13690..5c11119e 100644 --- a/intf/misctypes.mli +++ b/intf/misctypes.mli @@ -44,8 +44,8 @@ type 'id move_location = (** Sorts *) type 'a glob_sort_gen = GProp | GSet | GType of 'a -type sort_info = string list -type level_info = string option +type sort_info = string Loc.located list +type level_info = string Loc.located option type glob_sort = sort_info glob_sort_gen type glob_level = level_info glob_sort_gen diff --git a/intf/tacexpr.mli b/intf/tacexpr.mli index ff090ca8..eb4e5ae7 100644 --- a/intf/tacexpr.mli +++ b/intf/tacexpr.mli @@ -94,8 +94,13 @@ type ('a,'t) match_rule = | Pat of 'a match_context_hyps list * 'a match_pattern * 't | All of 't +(** Extension indentifiers for the TACTIC EXTEND mechanism. *) type ml_tactic_name = { + (** Name of the plugin where the tactic is defined, typically coming from a + DECLARE PLUGIN statement in the source. *) mltac_plugin : string; + (** Name of the tactic entry where the tactic is defined, typically found + after the TACTIC EXTEND statement in the source. *) mltac_tactic : string; } @@ -109,6 +114,7 @@ type glob_constr_and_expr = Glob_term.glob_constr * constr_expr option type open_constr_expr = unit * constr_expr type open_glob_constr = unit * glob_constr_and_expr +type binding_bound_vars = Id.Set.t type glob_constr_pattern_and_expr = glob_constr_and_expr * constr_pattern type delayed_open_constr_with_bindings = @@ -320,7 +326,7 @@ constraint 'a = < type g_trm = glob_constr_and_expr type g_utrm = g_trm -type g_pat = glob_constr_and_expr * constr_pattern +type g_pat = glob_constr_pattern_and_expr type g_cst = evaluable_global_reference and_short_name or_var type g_ref = ltac_constant located or_var type g_nam = Id.t located @@ -381,7 +387,7 @@ type raw_tactic_arg = type t_trm = Term.constr type t_utrm = Glob_term.closed_glob_constr -type t_pat = glob_constr_and_expr * constr_pattern +type t_pat = glob_constr_pattern_and_expr type t_cst = evaluable_global_reference and_short_name type t_ref = ltac_constant located type t_nam = Id.t diff --git a/intf/vernacexpr.mli b/intf/vernacexpr.mli index 450b1af0..99264dbe 100644 --- a/intf/vernacexpr.mli +++ b/intf/vernacexpr.mli @@ -40,7 +40,8 @@ type scope_name = string type goal_reference = | OpenSubgoals | NthGoal of int - | GoalId of goal_identifier + | GoalId of Id.t + | GoalUid of goal_identifier type printable = | PrintTables @@ -155,11 +156,15 @@ type option_value = Goptions.option_value = | BoolValue of bool | IntValue of int option | StringValue of string + | StringOptValue of string option type option_ref_value = | StringRefValue of string | QualidRefValue of reference +(** Identifier and optional list of bound universes. *) +type plident = lident * lident list option + type sort_expr = glob_sort type definition_expr = @@ -168,10 +173,10 @@ type definition_expr = * constr_expr option type fixpoint_expr = - Id.t located * (Id.t located option * recursion_order_expr) * local_binder list * constr_expr * constr_expr option + plident * (Id.t located option * recursion_order_expr) * local_binder list * constr_expr * constr_expr option type cofixpoint_expr = - Id.t located * local_binder list * constr_expr * constr_expr option + plident * local_binder list * constr_expr * constr_expr option type local_decl_expr = | AssumExpr of lname * constr_expr @@ -190,11 +195,14 @@ type constructor_list_or_record_decl_expr = | Constructors of constructor_expr list | RecordDecl of lident option * local_decl_expr with_instance with_priority with_notation list type inductive_expr = - lident with_coercion * local_binder list * constr_expr option * inductive_kind * + plident with_coercion * local_binder list * constr_expr option * inductive_kind * constructor_list_or_record_decl_expr type one_inductive_expr = - lident * local_binder list * constr_expr option * constructor_expr list + plident * local_binder list * constr_expr option * constructor_expr list + +type proof_expr = + plident option * (local_binder list * constr_expr * (lident option * recursion_order_expr) option) type grammar_tactic_prod_item_expr = | TacTerm of string @@ -218,14 +226,21 @@ type scheme = | EqualityScheme of reference or_by_notation type section_subset_expr = - | SsSet of lident list + | SsEmpty + | SsSingl of lident | SsCompl of section_subset_expr | SsUnion of section_subset_expr * section_subset_expr | SsSubstr of section_subset_expr * section_subset_expr + | SsFwdClose of section_subset_expr -type section_subset_descr = SsAll | SsType | SsExpr of section_subset_expr - -type extend_name = string * int +(** Extension identifiers for the VERNAC EXTEND mechanism. *) +type extend_name = + (** Name of the vernac entry where the tactic is defined, typically found + after the VERNAC EXTEND statement in the source. *) + string * + (** Index of the extension in the VERNAC EXTEND statement. Each parsing branch + is given an offset, starting from zero. *) + int (* This type allows registering the inlining of constants in native compiler. It will be extended with primitive inductive types and operators *) @@ -273,6 +288,7 @@ type vernac_expr = (* Control *) | VernacLoad of verbose_flag * string | VernacTime of vernac_list + | VernacRedirect of string * vernac_list | VernacTimeout of int * vernac_expr | VernacFail of vernac_expr | VernacError of exn (* always fails *) @@ -283,7 +299,7 @@ type vernac_expr = | VernacSyntaxExtension of obsolete_locality * (lstring * syntax_modifier list) | VernacOpenCloseScope of obsolete_locality * (bool * scope_name) - | VernacDelimiters of scope_name * string + | VernacDelimiters of scope_name * string option | VernacBindScope of scope_name * reference or_by_notation list | VernacInfix of obsolete_locality * (lstring * syntax_modifier list) * constr_expr * scope_name option @@ -294,14 +310,12 @@ type vernac_expr = (* Gallina *) | VernacDefinition of - (locality option * definition_object_kind) * lident * definition_expr - | VernacStartTheoremProof of theorem_kind * - (lident option * (local_binder list * constr_expr * (lident option * recursion_order_expr) option)) list * - bool + (locality option * definition_object_kind) * plident * definition_expr + | VernacStartTheoremProof of theorem_kind * proof_expr list * bool | VernacEndProof of proof_end | VernacExactProof of constr_expr | VernacAssumption of (locality option * assumption_object_kind) * - inline * simple_binder with_coercion list + inline * (plident list * constr_expr) with_coercion list | VernacInductive of private_flag * inductive_flag * (inductive_expr * decl_notation list) list | VernacFixpoint of locality option * (fixpoint_expr * decl_notation list) list @@ -323,7 +337,7 @@ type vernac_expr = class_rawexpr * class_rawexpr | VernacIdentityCoercion of obsolete_locality * lident * class_rawexpr * class_rawexpr - | VernacNameSectionHypSet of lident * section_subset_descr + | VernacNameSectionHypSet of lident * section_subset_expr (* Type classes *) | VernacInstance of @@ -428,7 +442,7 @@ type vernac_expr = | VernacEndSubproof | VernacShow of showable | VernacCheckGuard - | VernacProof of raw_tactic_expr option * section_subset_descr option + | VernacProof of raw_tactic_expr option * section_subset_expr option | VernacProofMode of string (* Toplevel control *) | VernacToplevelControl of exn diff --git a/kernel/byterun/coq_fix_code.c b/kernel/byterun/coq_fix_code.c index 1be3e651..29e33d34 100644 --- a/kernel/byterun/coq_fix_code.c +++ b/kernel/byterun/coq_fix_code.c @@ -60,7 +60,7 @@ void init_arity () { arity[BRANCH]=arity[ISCONST]= 1; /* instruction with two operands */ arity[APPTERM]=arity[MAKEBLOCK]=arity[CLOSURE]= - arity[ARECONST]=2; + arity[ARECONST]=arity[PROJ]=2; /* instruction with four operands */ arity[MAKESWITCHBLOCK]=4; /* instruction with arbitrary operands */ diff --git a/kernel/byterun/coq_gc.h b/kernel/byterun/coq_gc.h index c7b18b90..f0627586 100644 --- a/kernel/byterun/coq_gc.h +++ b/kernel/byterun/coq_gc.h @@ -12,6 +12,7 @@ #define _COQ_CAML_GC_ #include <caml/mlvalues.h> #include <caml/alloc.h> +#include <caml/memory.h> typedef void (*scanning_action) (value, value *); @@ -24,12 +25,22 @@ CAMLextern void minor_collection (void); #define Caml_white (0 << 8) #define Caml_black (3 << 8) +#ifdef HAS_OCP_MEMPROF + +/* This code is necessary to make the OCamlPro memory profiling branch of + OCaml compile. */ + +#define Make_header(wosize, tag, color) \ + caml_make_header(wosize, tag, color) + +#else + #define Make_header(wosize, tag, color) \ (((header_t) (((header_t) (wosize) << 10) \ + (color) \ + (tag_t) (tag))) \ ) - +#endif #define Alloc_small(result, wosize, tag) do{ \ young_ptr -= Bhsize_wosize (wosize); \ diff --git a/kernel/byterun/coq_instruct.h b/kernel/byterun/coq_instruct.h index 9cbf4077..8c5ab0ec 100644 --- a/kernel/byterun/coq_instruct.h +++ b/kernel/byterun/coq_instruct.h @@ -36,6 +36,7 @@ enum instructions { SWITCH, PUSHFIELDS, GETFIELD0, GETFIELD1, GETFIELD, SETFIELD0, SETFIELD1, SETFIELD, + PROJ, CONST0, CONST1, CONST2, CONST3, CONSTINT, PUSHCONST0, PUSHCONST1, PUSHCONST2, PUSHCONST3, PUSHCONSTINT, ACCUMULATE, diff --git a/kernel/byterun/coq_interp.c b/kernel/byterun/coq_interp.c index 0ab9f89f..dc571699 100644 --- a/kernel/byterun/coq_interp.c +++ b/kernel/byterun/coq_interp.c @@ -77,9 +77,11 @@ sp is a local copy of the global variable extern_sp. */ #ifdef _COQ_DEBUG_ # define print_instr(s) /*if (drawinstr)*/ printf("%s\n",s) # define print_int(i) /*if (drawinstr)*/ printf("%d\n",i) +# define print_lint(i) /*if (drawinstr)*/ printf("%ld\n",i) # else # define print_instr(s) # define print_int(i) +# define print_lint(i) #endif /* GC interface */ @@ -339,6 +341,7 @@ value coq_interprete /* Fallthrough */ Instruct(ENVACC){ print_instr("ENVACC"); + print_int(*pc); accu = Field(coq_env, *pc++); Next; } @@ -369,6 +372,10 @@ value coq_interprete sp[1] = (value)pc; sp[2] = coq_env; sp[3] = Val_long(coq_extra_args); + print_instr("call stack="); + print_lint(sp[1]); + print_lint(sp[2]); + print_lint(sp[3]); pc = Code_val(accu); coq_env = accu; coq_extra_args = 0; @@ -456,6 +463,7 @@ value coq_interprete sp[0] = arg1; sp[1] = arg2; pc = Code_val(accu); + print_lint(accu); coq_env = accu; coq_extra_args += 1; goto check_stacks; @@ -479,11 +487,18 @@ value coq_interprete print_instr("RETURN"); print_int(*pc); sp += *pc++; + print_instr("stack="); + print_lint(sp[0]); + print_lint(sp[1]); + print_lint(sp[2]); if (coq_extra_args > 0) { + print_instr("extra args > 0"); + print_lint(coq_extra_args); coq_extra_args--; pc = Code_val(accu); coq_env = accu; } else { + print_instr("extra args = 0"); pc = (code_t)(sp[0]); coq_env = sp[1]; coq_extra_args = Long_val(sp[2]); @@ -583,7 +598,10 @@ value coq_interprete Alloc_small(accu, 1 + nvars, Closure_tag); Code_val(accu) = pc + *pc; pc++; - for (i = 0; i < nvars; i++) Field(accu, i + 1) = sp[i]; + for (i = 0; i < nvars; i++) { + print_lint(sp[i]); + Field(accu, i + 1) = sp[i]; + } sp += nvars; Next; } @@ -718,6 +736,7 @@ value coq_interprete /* Fallthrough */ Instruct(GETGLOBAL){ print_instr("GETGLOBAL"); + print_int(*pc); accu = Field(coq_global_data, *pc); pc++; Next; @@ -730,7 +749,7 @@ value coq_interprete tag_t tag = *pc++; mlsize_t i; value block; - print_instr("MAKEBLOCK"); + print_instr("MAKEBLOCK, tag="); Alloc_small(block, wosize, tag); Field(block, 0) = accu; for (i = 1; i < wosize; i++) Field(block, i) = *sp++; @@ -741,7 +760,8 @@ value coq_interprete tag_t tag = *pc++; value block; - print_instr("MAKEBLOCK1"); + print_instr("MAKEBLOCK1, tag="); + print_int(tag); Alloc_small(block, 1, tag); Field(block, 0) = accu; accu = block; @@ -751,7 +771,8 @@ value coq_interprete tag_t tag = *pc++; value block; - print_instr("MAKEBLOCK2"); + print_instr("MAKEBLOCK2, tag="); + print_int(tag); Alloc_small(block, 2, tag); Field(block, 0) = accu; Field(block, 1) = sp[0]; @@ -762,7 +783,8 @@ value coq_interprete Instruct(MAKEBLOCK3) { tag_t tag = *pc++; value block; - print_instr("MAKEBLOCK3"); + print_instr("MAKEBLOCK3, tag="); + print_int(tag); Alloc_small(block, 3, tag); Field(block, 0) = accu; Field(block, 1) = sp[0]; @@ -774,7 +796,8 @@ value coq_interprete Instruct(MAKEBLOCK4) { tag_t tag = *pc++; value block; - print_instr("MAKEBLOCK4"); + print_instr("MAKEBLOCK4, tag="); + print_int(tag); Alloc_small(block, 4, tag); Field(block, 0) = accu; Field(block, 1) = sp[0]; @@ -795,12 +818,12 @@ value coq_interprete if (Is_block(accu)) { long index = Tag_val(accu); print_instr("block"); - print_int(index); + print_lint(index); pc += pc[(sizes & 0xFFFFFF) + index]; } else { long index = Long_val(accu); print_instr("constant"); - print_int(index); + print_lint(index); pc += pc[index]; } Next; @@ -842,7 +865,6 @@ value coq_interprete } Instruct(SETFIELD1){ - int i, j, size, size_aux; print_instr("SETFIELD1"); caml_modify(&Field(accu, 1),*sp); sp++; @@ -876,8 +898,30 @@ value coq_interprete caml_modify(&Field(accu, *pc),*sp); sp++; pc++; Next; - } - + } + + + Instruct(PROJ){ + print_instr("PROJ"); + if (Is_accu (accu)) { + value block; + /* Skip over the index of projected field */ + pc++; + /* Create atom */ + Alloc_small(block, 2, ATOM_PROJ_TAG); + Field(block, 0) = Field(coq_global_data, *pc); + Field(block, 1) = accu; + /* Create accumulator */ + Alloc_small(accu, 2, Accu_tag); + Code_val(accu) = accumulate; + Field(accu, 1) = block; + } else { + accu = Field(accu, *pc++); + } + pc++; + Next; + } + /* Integer constants */ Instruct(CONST0){ @@ -917,6 +961,7 @@ value coq_interprete /* Fallthrough */ Instruct(CONSTINT) { print_instr("CONSTINT"); + print_int(*pc); accu = Val_int(*pc); pc++; Next; @@ -957,7 +1002,7 @@ value coq_interprete sp -= nargs; for (i = 0; i < nargs; i++) sp[i] = Field(accu, i + 2); *--sp = accu; - print_int(nargs); + print_lint(nargs); coq_extra_args = nargs; pc = Code_val(coq_env); goto check_stacks; @@ -1084,7 +1129,6 @@ value coq_interprete /* returns the sum plus one with a carry */ uint32_t s; s = (uint32_t)accu + (uint32_t)*sp++ + 1; - value block; if( (uint32_t)s <= (uint32_t)accu ) { /* carry */ Alloc_small(accu, 1, 2); /* ( _ , arity, tag ) */ @@ -1226,16 +1270,17 @@ value coq_interprete shiftby = uint32_of_value(accu); if (shiftby > 31) { if (shiftby < 62) { - *sp++; - accu = (value)((((*sp++)^1) << (shiftby - 31)) | 1); + sp++; + accu = (value)(((((uint32_t)*sp++)^1) << (shiftby - 31)) | 1); } else { + sp+=2; accu = (value)(1); } } else{ /* *sp = 2*x+1 --> accu = 2^(shiftby+1)*x */ - accu = (value)(((*sp++)^1) << shiftby); + accu = (value)((((uint32_t)*sp++)^1) << shiftby); /* accu = 2^(shiftby+1)*x --> 2^(shifby+1)*x+2*y/2^(31-shiftby)+1 */ accu = (value)((accu | (((uint32_t)(*sp++)) >> (31-shiftby)))|1); } @@ -1244,7 +1289,7 @@ value coq_interprete Instruct (COMPAREINT31) { /* returns Eq if equal, Lt if accu is less than *sp, Gt otherwise */ - /* assumes Inudctive _ : _ := Eq | Lt | Gt */ + /* assumes Inductive _ : _ := Eq | Lt | Gt */ print_instr("COMPAREINT31"); if ((uint32_t)accu == (uint32_t)*sp) { accu = 1; /* 2*0+1 */ diff --git a/kernel/byterun/coq_memory.c b/kernel/byterun/coq_memory.c index 8d03829a..c9bcdc32 100644 --- a/kernel/byterun/coq_memory.c +++ b/kernel/byterun/coq_memory.c @@ -26,7 +26,6 @@ asize_t coq_max_stack_size = Coq_max_stack_size; value coq_global_data; -int coq_all_transp; value coq_atom_tbl; int drawinstr; @@ -104,7 +103,6 @@ static int coq_vm_initialized = 0; value init_coq_vm(value unit) /* ML */ { - int i; if (coq_vm_initialized == 1) { fprintf(stderr,"already open \n");fflush(stderr);} else { @@ -117,7 +115,6 @@ value init_coq_vm(value unit) /* ML */ init_coq_global_data(Coq_global_data_Size); init_coq_atom_tbl(40); /* Initialing the interpreter */ - coq_all_transp = 0; init_coq_interpreter(); /* Some predefined pointer code */ @@ -137,7 +134,6 @@ void realloc_coq_stack(asize_t required_space) { asize_t size; value * new_low, * new_high, * new_sp; - value * p; size = coq_stack_high - coq_stack_low; do { size *= 2; @@ -207,18 +203,6 @@ value realloc_coq_atom_tbl(value size) /* ML */ return Val_unit; } - -value coq_set_transp_value(value transp) -{ - coq_all_transp = (transp == Val_true); - return Val_unit; -} - -value get_coq_transp_value(value unit) -{ - return Val_bool(coq_all_transp); -} - value coq_set_drawinstr(value unit) { drawinstr = 1; diff --git a/kernel/byterun/coq_values.c b/kernel/byterun/coq_values.c index 007f61b2..528babeb 100644 --- a/kernel/byterun/coq_values.c +++ b/kernel/byterun/coq_values.c @@ -21,7 +21,6 @@ value coq_kind_of_closure(value v) { opcode_t * c; - int res; int is_app = 0; c = Code_val(v); if (Is_instruction(c, GRAB)) return Val_int(0); diff --git a/kernel/byterun/coq_values.h b/kernel/byterun/coq_values.h index 1bf493e2..bb0f0eb5 100644 --- a/kernel/byterun/coq_values.h +++ b/kernel/byterun/coq_values.h @@ -17,22 +17,17 @@ #define Default_tag 0 #define Accu_tag 0 - - #define ATOM_ID_TAG 0 -#define ATOM_IDDEF_TAG 1 -#define ATOM_INDUCTIVE_TAG 2 -#define ATOM_FIX_TAG 3 -#define ATOM_SWITCH_TAG 4 -#define ATOM_COFIX_TAG 5 -#define ATOM_COFIXEVALUATED_TAG 6 - - +#define ATOM_INDUCTIVE_TAG 1 +#define ATOM_TYPE_TAG 2 +#define ATOM_PROJ_TAG 3 +#define ATOM_FIX_TAG 4 +#define ATOM_SWITCH_TAG 5 +#define ATOM_COFIX_TAG 6 +#define ATOM_COFIXEVALUATED_TAG 7 /* Les blocs accumulate */ #define Is_accu(v) (Is_block(v) && (Tag_val(v) == Accu_tag)) #define IS_EVALUATED_COFIX(v) (Is_accu(v) && Is_block(Field(v,1)) && (Tag_val(Field(v,1)) == ATOM_COFIXEVALUATED_TAG)) #endif /* _COQ_VALUES_ */ - - diff --git a/kernel/cbytecodes.ml b/kernel/cbytecodes.ml index 700de502..0a24a75d 100644 --- a/kernel/cbytecodes.ml +++ b/kernel/cbytecodes.ml @@ -17,23 +17,28 @@ open Term type tag = int -let id_tag = 0 -let iddef_tag = 1 -let ind_tag = 2 -let fix_tag = 3 -let switch_tag = 4 -let cofix_tag = 5 -let cofix_evaluated_tag = 6 -(* It could be greate if OCaml export this value, - So fixme if this occur in a new version of OCaml *) +let accu_tag = 0 + +let type_atom_tag = 2 +let max_atom_tag = 2 +let proj_tag = 3 +let fix_app_tag = 4 +let switch_tag = 5 +let cofix_tag = 6 +let cofix_evaluated_tag = 7 + +(* It would be great if OCaml exported this value, + So fixme if this happens in a new version of OCaml *) let last_variant_tag = 245 type structured_constant = | Const_sorts of sorts - | Const_ind of pinductive + | Const_ind of inductive + | Const_proj of Constant.t | Const_b0 of tag | Const_bn of tag * structured_constant array - + | Const_univ_level of Univ.universe_level + | Const_type of Univ.universe type reloc_table = (tag * int) array @@ -58,29 +63,30 @@ type instruction = | Kpush | Kpop of int | Kpush_retaddr of Label.t - | Kapply of int (* number of arguments *) - | Kappterm of int * int (* number of arguments, slot size *) - | Kreturn of int (* slot size *) + | Kapply of int + | Kappterm of int * int + | Kreturn of int | Kjump | Krestart - | Kgrab of int (* number of arguments *) - | Kgrabrec of int (* rec arg *) - | Kclosure of Label.t * int (* label, number of free variables *) + | Kgrab of int + | Kgrabrec of int + | Kclosure of Label.t * int | Kclosurerec of int * int * Label.t array * Label.t array - (* nb fv, init, lbl types, lbl bodies *) | Kclosurecofix of int * int * Label.t array * Label.t array (* nb fv, init, lbl types, lbl bodies *) - | Kgetglobal of pconstant + | Kgetglobal of constant | Kconst of structured_constant - | Kmakeblock of int * tag (* size, tag *) + | Kmakeblock of int * tag | Kmakeprod | Kmakeswitchblock of Label.t * Label.t * annot_switch * int - | Kswitch of Label.t array * Label.t array (* consts,blocks *) + | Kswitch of Label.t array * Label.t array | Kpushfields of int | Kfield of int | Ksetfield of int | Kstop | Ksequence of bytecodes * bytecodes + | Kproj of int * Constant.t (* index of the projected argument, + name of projection *) (* spiwack: instructions concerning integers *) | Kbranch of Label.t (* jump to label *) | Kaddint31 (* adds the int31 in the accu @@ -124,7 +130,10 @@ type instruction = and bytecodes = instruction list -type fv_elem = FVnamed of Id.t | FVrel of int +type fv_elem = + | FVnamed of Id.t + | FVrel of int + | FVuniv_var of int type fv = fv_elem array @@ -142,105 +151,138 @@ type vm_env = { type comp_env = { - nb_stack : int; (* nbre de variables sur la pile *) - in_stack : int list; (* position dans la pile *) - nb_rec : int; (* nbre de fonctions mutuellement *) - (* recursives = nbr *) + nb_uni_stack : int ; (* number of universes on the stack, *) + (* universes are always at the bottom. *) + nb_stack : int; (* number of variables on the stack *) + in_stack : int list; (* position in the stack *) + nb_rec : int; (* number of mutually recursive functions *) pos_rec : instruction list; (* instruction d'acces pour les variables *) (* de point fix ou de cofix *) offset : int; - in_env : vm_env ref + in_env : vm_env ref (* The free variables of the expression *) } +(* --- Pretty print *) +open Pp +open Util +let pp_sort s = + match family_of_sort s with + | InSet -> str "Set" + | InProp -> str "Prop" + | InType -> str "Type" -(* --- Pretty print *) -open Format -let rec instruction ppf = function - | Klabel lbl -> fprintf ppf "L%i:" lbl - | Kacc n -> fprintf ppf "\tacc %i" n - | Kenvacc n -> fprintf ppf "\tenvacc %i" n - | Koffsetclosure n -> fprintf ppf "\toffsetclosure %i" n - | Kpush -> fprintf ppf "\tpush" - | Kpop n -> fprintf ppf "\tpop %i" n - | Kpush_retaddr lbl -> fprintf ppf "\tpush_retaddr L%i" lbl - | Kapply n -> fprintf ppf "\tapply %i" n +let rec pp_struct_const = function + | Const_sorts s -> pp_sort s + | Const_ind (mind, i) -> pr_mind mind ++ str"#" ++ int i + | Const_proj p -> Constant.print p + | Const_b0 i -> int i + | Const_bn (i,t) -> + int i ++ surround (prvect_with_sep pr_comma pp_struct_const t) + | Const_univ_level l -> Univ.Level.pr l + | Const_type u -> str "Type@{" ++ Univ.pr_uni u ++ str "}" + +let pp_lbl lbl = str "L" ++ int lbl + +let pp_pcon (id,u) = + pr_con id ++ str "@{" ++ Univ.Instance.pr Univ.Level.pr u ++ str "}" + +let pp_fv_elem = function + | FVnamed id -> str "FVnamed(" ++ Id.print id ++ str ")" + | FVrel i -> str "Rel(" ++ int i ++ str ")" + | FVuniv_var v -> str "FVuniv(" ++ int v ++ str ")" + +let rec pp_instr i = + match i with + | Klabel _ | Ksequence _ -> assert false + | Kacc n -> str "acc " ++ int n + | Kenvacc n -> str "envacc " ++ int n + | Koffsetclosure n -> str "offsetclosure " ++ int n + | Kpush -> str "push" + | Kpop n -> str "pop " ++ int n + | Kpush_retaddr lbl -> str "push_retaddr " ++ pp_lbl lbl + | Kapply n -> str "apply " ++ int n | Kappterm(n, m) -> - fprintf ppf "\tappterm %i, %i" n m - | Kreturn n -> fprintf ppf "\treturn %i" n - | Kjump -> fprintf ppf "\tjump" - | Krestart -> fprintf ppf "\trestart" - | Kgrab n -> fprintf ppf "\tgrab %i" n - | Kgrabrec n -> fprintf ppf "\tgrabrec %i" n + str "appterm " ++ int n ++ str ", " ++ int m + | Kreturn n -> str "return " ++ int n + | Kjump -> str "jump" + | Krestart -> str "restart" + | Kgrab n -> str "grab " ++ int n + | Kgrabrec n -> str "grabrec " ++ int n | Kclosure(lbl, n) -> - fprintf ppf "\tclosure L%i, %i" lbl n + str "closure " ++ pp_lbl lbl ++ str ", " ++ int n | Kclosurerec(fv,init,lblt,lblb) -> - fprintf ppf "\tclosurerec"; - fprintf ppf "%i , %i, " fv init; - print_string "types = "; - Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblt; - print_string " bodies = "; - Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblb; + h 1 (str "closurerec " ++ + int fv ++ str ", " ++ int init ++ + str " types = " ++ + prlist_with_sep spc pp_lbl (Array.to_list lblt) ++ + str " bodies = " ++ + prlist_with_sep spc pp_lbl (Array.to_list lblb)) | Kclosurecofix (fv,init,lblt,lblb) -> - fprintf ppf "\tclosurecofix"; - fprintf ppf " %i , %i, " fv init; - print_string "types = "; - Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblt; - print_string " bodies = "; - Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblb; - | Kgetglobal (id,u) -> fprintf ppf "\tgetglobal %s" (Names.string_of_con id) - | Kconst cst -> - fprintf ppf "\tconst" + h 1 (str "closurecofix " ++ + int fv ++ str ", " ++ int init ++ + str " types = " ++ + prlist_with_sep spc pp_lbl (Array.to_list lblt) ++ + str " bodies = " ++ + prlist_with_sep spc pp_lbl (Array.to_list lblb)) + | Kgetglobal idu -> str "getglobal " ++ pr_con idu + | Kconst sc -> + str "const " ++ pp_struct_const sc | Kmakeblock(n, m) -> - fprintf ppf "\tmakeblock %i, %i" n m - | Kmakeprod -> fprintf ppf "\tmakeprod" + str "makeblock " ++ int n ++ str ", " ++ int m + | Kmakeprod -> str "makeprod" | Kmakeswitchblock(lblt,lbls,_,sz) -> - fprintf ppf "\tmakeswitchblock %i, %i, %i" lblt lbls sz + str "makeswitchblock " ++ pp_lbl lblt ++ str ", " ++ + pp_lbl lbls ++ str ", " ++ int sz | Kswitch(lblc,lblb) -> - fprintf ppf "\tswitch"; - Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblc; - Array.iter (fun lbl -> fprintf ppf " %i" lbl) lblb; - | Kpushfields n -> fprintf ppf "\tpushfields %i" n - | Ksetfield n -> fprintf ppf "\tsetfield %i" n - | Kfield n -> fprintf ppf "\tgetfield %i" n - | Kstop -> fprintf ppf "\tstop" - | Ksequence (c1,c2) -> - fprintf ppf "%a@ %a" instruction_list c1 instruction_list c2 -(* spiwack *) - | Kbranch lbl -> fprintf ppf "\tbranch %i" lbl - | Kaddint31 -> fprintf ppf "\taddint31" - | Kaddcint31 -> fprintf ppf "\taddcint31" - | Kaddcarrycint31 -> fprintf ppf "\taddcarrycint31" - | Ksubint31 -> fprintf ppf "\tsubint31" - | Ksubcint31 -> fprintf ppf "\tsubcint31" - | Ksubcarrycint31 -> fprintf ppf "\tsubcarrycint31" - | Kmulint31 -> fprintf ppf "\tmulint31" - | Kmulcint31 -> fprintf ppf "\tmulcint31" - | Kdiv21int31 -> fprintf ppf "\tdiv21int31" - | Kdivint31 -> fprintf ppf "\tdivint31" - | Kcompareint31 -> fprintf ppf "\tcompareint31" - | Khead0int31 -> fprintf ppf "\thead0int31" - | Ktail0int31 -> fprintf ppf "\ttail0int31" - | Kaddmuldivint31 -> fprintf ppf "\taddmuldivint31" - | Kisconst lbl -> fprintf ppf "\tisconst %i" lbl - | Kareconst(n,lbl) -> fprintf ppf "\tareconst %i %i" n lbl - | Kcompint31 -> fprintf ppf "\tcompint31" - | Kdecompint31 -> fprintf ppf "\tdecompint" - | Klorint31 -> fprintf ppf "\tlorint31" - | Klandint31 -> fprintf ppf "\tlandint31" - | Klxorint31 -> fprintf ppf "\tlxorint31" + h 1 (str "switch " ++ + prlist_with_sep spc pp_lbl (Array.to_list lblc) ++ + str " | " ++ + prlist_with_sep spc pp_lbl (Array.to_list lblb)) + | Kpushfields n -> str "pushfields " ++ int n + | Kfield n -> str "field " ++ int n + | Ksetfield n -> str "set field" ++ int n -(* /spiwack *) + | Kstop -> str "stop" + + | Kbranch lbl -> str "branch " ++ pp_lbl lbl + | Kproj(n,p) -> str "proj " ++ int n ++ str " " ++ Constant.print p -and instruction_list ppf = function - [] -> () - | Klabel lbl :: il -> - fprintf ppf "L%i:%a" lbl instruction_list il - | instr :: il -> - fprintf ppf "%a@ %a" instruction instr instruction_list il + | Kaddint31 -> str "addint31" + | Kaddcint31 -> str "addcint31" + | Kaddcarrycint31 -> str "addcarrycint31" + | Ksubint31 -> str "subint31" + | Ksubcint31 -> str "subcint31" + | Ksubcarrycint31 -> str "subcarrycint31" + | Kmulint31 -> str "mulint31" + | Kmulcint31 -> str "mulcint31" + | Kdiv21int31 -> str "div21int31" + | Kdivint31 -> str "divint31" + | Kcompareint31 -> str "compareint31" + | Khead0int31 -> str "head0int31" + | Ktail0int31 -> str "tail0int31" + | Kaddmuldivint31 -> str "addmuldivint31" + | Kisconst lbl -> str "isconst " ++ int lbl + | Kareconst(n,lbl) -> str "areconst " ++ int n ++ spc () ++ int lbl + | Kcompint31 -> str "compint31" + | Kdecompint31 -> str "decompint" + | Klorint31 -> str "lorint31" + | Klandint31 -> str "landint31" + | Klxorint31 -> str "lxorint31" +and pp_bytecodes c = + match c with + | [] -> str "" + | Klabel lbl :: c -> + str "L" ++ int lbl ++ str ":" ++ fnl () ++ + pp_bytecodes c + | Ksequence (l1, l2) :: c -> + pp_bytecodes l1 ++ pp_bytecodes l2 ++ pp_bytecodes c + | i :: c -> + tab () ++ pp_instr i ++ fnl () ++ pp_bytecodes c + (*spiwack: moved this type in this file because I needed it for retroknowledge which can't depend from cbytegen *) type block = @@ -253,8 +295,3 @@ type block = (* spiwack: compilation given by a function *) (* compilation function (see get_vm_constant_dynamic_info in retroknowledge.mli for more info) , argument array *) - - - -let draw_instr c = - fprintf std_formatter "@[<v 0>%a@]" instruction_list c diff --git a/kernel/cbytecodes.mli b/kernel/cbytecodes.mli index fbb40ffd..03ae6b9c 100644 --- a/kernel/cbytecodes.mli +++ b/kernel/cbytecodes.mli @@ -13,20 +13,28 @@ open Term type tag = int -val id_tag : tag -val iddef_tag : tag -val ind_tag : tag -val fix_tag : tag +val accu_tag : tag + +val type_atom_tag : tag +val max_atom_tag : tag +val proj_tag : tag +val fix_app_tag : tag val switch_tag : tag val cofix_tag : tag val cofix_evaluated_tag : tag -val last_variant_tag : tag + +val last_variant_tag : tag type structured_constant = | Const_sorts of sorts - | Const_ind of pinductive + | Const_ind of inductive + | Const_proj of Constant.t | Const_b0 of tag | Const_bn of tag * structured_constant array + | Const_univ_level of Univ.universe_level + | Const_type of Univ.universe + +val pp_struct_const : structured_constant -> Pp.std_ppcmds type reloc_table = (tag * int) array @@ -43,13 +51,13 @@ module Label : type instruction = | Klabel of Label.t - | Kacc of int - | Kenvacc of int - | Koffsetclosure of int - | Kpush - | Kpop of int - | Kpush_retaddr of Label.t - | Kapply of int (** number of arguments *) + | Kacc of int (** accu = sp[n] *) + | Kenvacc of int (** accu = coq_env[n] *) + | Koffsetclosure of int (** accu = &coq_env[n] *) + | Kpush (** sp = accu :: sp *) + | Kpop of int (** sp = skipn n sp *) + | Kpush_retaddr of Label.t (** sp = pc :: coq_env :: coq_extra_args :: sp ; coq_extra_args = 0 *) + | Kapply of int (** number of arguments (arguments on top of stack) *) | Kappterm of int * int (** number of arguments, slot size *) | Kreturn of int (** slot size *) | Kjump @@ -61,17 +69,21 @@ type instruction = (** nb fv, init, lbl types, lbl bodies *) | Kclosurecofix of int * int * Label.t array * Label.t array (** nb fv, init, lbl types, lbl bodies *) - | Kgetglobal of pconstant + | Kgetglobal of constant | Kconst of structured_constant - | Kmakeblock of int * tag (** size, tag *) + | Kmakeblock of (* size: *) int * tag (** allocate an ocaml block. Index 0 + ** is accu, all others are popped from + ** the top of the stack *) | Kmakeprod | Kmakeswitchblock of Label.t * Label.t * annot_switch * int | Kswitch of Label.t array * Label.t array (** consts,blocks *) | Kpushfields of int - | Kfield of int - | Ksetfield of int + | Kfield of int (** accu = accu[n] *) + | Ksetfield of int (** accu[n] = sp[0] ; sp = pop sp *) | Kstop | Ksequence of bytecodes * bytecodes + | Kproj of int * Constant.t (** index of the projected argument, + name of projection *) (** spiwack: instructions concerning integers *) | Kbranch of Label.t (** jump to label, is it needed ? *) @@ -115,7 +127,10 @@ type instruction = and bytecodes = instruction list -type fv_elem = FVnamed of Id.t | FVrel of int +type fv_elem = + FVnamed of Id.t +| FVrel of int +| FVuniv_var of int type fv = fv_elem array @@ -124,28 +139,28 @@ type fv = fv_elem array closed terms. *) exception NotClosed -(*spiwack: both type have been moved from Cbytegen because I needed then +(*spiwack: both type have been moved from Cbytegen because I needed them for the retroknowledge *) type vm_env = { - size : int; (** longueur de la liste [n] *) + size : int; (** length of the list [n] *) fv_rev : fv_elem list (** [fvn; ... ;fv1] *) } type comp_env = { - nb_stack : int; (** nbre de variables sur la pile *) - in_stack : int list; (** position dans la pile *) - nb_rec : int; (** nbre de fonctions mutuellement *) - (** recursives = nbr *) + nb_uni_stack : int ; (** number of universes on the stack *) + nb_stack : int; (** number of variables on the stack *) + in_stack : int list; (** position in the stack *) + nb_rec : int; (** number of mutually recursive functions *) + (** (= nbr) *) pos_rec : instruction list; (** instruction d'acces pour les variables *) (** de point fix ou de cofix *) offset : int; - in_env : vm_env ref + in_env : vm_env ref (** the variables that are accessed *) } -val draw_instr : bytecodes -> unit - - +val pp_bytecodes : bytecodes -> Pp.std_ppcmds +val pp_fv_elem : fv_elem -> Pp.std_ppcmds (*spiwack: moved this here because I needed it for retroknowledge *) type block = diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index 07fab06a..1f7cc3c7 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -91,18 +91,20 @@ open Pre_env (* In Cfxe_t accumulators, we need to store [fcofixi] for testing *) (* conversion of cofixpoints (which is intentional). *) +type argument = ArgConstr of Constr.t | ArgUniv of Univ.Level.t let empty_fv = { size= 0; fv_rev = [] } let fv r = !(r.in_env) -let empty_comp_env ()= - { nb_stack = 0; +let empty_comp_env ?(univs=0) ()= + { nb_uni_stack = univs; + nb_stack = 0; in_stack = []; nb_rec = 0; pos_rec = []; offset = 0; - in_env = ref empty_fv; + in_env = ref empty_fv } (*i Creation functions for comp_env *) @@ -110,8 +112,9 @@ let empty_comp_env ()= let rec add_param n sz l = if Int.equal n 0 then l else add_param (n - 1) sz (n+sz::l) -let comp_env_fun arity = - { nb_stack = arity; +let comp_env_fun ?(univs=0) arity = + { nb_uni_stack = univs ; + nb_stack = arity; in_stack = add_param arity 0 []; nb_rec = 0; pos_rec = []; @@ -120,8 +123,9 @@ let comp_env_fun arity = } -let comp_env_fix_type rfv = - { nb_stack = 0; +let comp_env_fix_type rfv = + { nb_uni_stack = 0; + nb_stack = 0; in_stack = []; nb_rec = 0; pos_rec = []; @@ -134,7 +138,8 @@ let comp_env_fix ndef curr_pos arity rfv = for i = ndef downto 1 do prec := Koffsetclosure (2 * (ndef - curr_pos - i)) :: !prec done; - { nb_stack = arity; + { nb_uni_stack = 0; + nb_stack = arity; in_stack = add_param arity 0 []; nb_rec = ndef; pos_rec = !prec; @@ -143,7 +148,8 @@ let comp_env_fix ndef curr_pos arity rfv = } let comp_env_cofix_type ndef rfv = - { nb_stack = 0; + { nb_uni_stack = 0; + nb_stack = 0; in_stack = []; nb_rec = 0; pos_rec = []; @@ -156,7 +162,8 @@ let comp_env_cofix ndef arity rfv = for i = 1 to ndef do prec := Kenvacc i :: !prec done; - { nb_stack = arity; + { nb_uni_stack = 0; + nb_stack = arity; in_stack = add_param arity 0 []; nb_rec = ndef; pos_rec = !prec; @@ -168,7 +175,7 @@ let comp_env_cofix ndef arity rfv = let push_param n sz r = { r with nb_stack = r.nb_stack + n; - in_stack = add_param n sz r.in_stack } + in_stack = add_param n (sz - r.nb_uni_stack) r.in_stack } (* [push_local sz r] add a new variable on the stack at position [sz] *) let push_local sz r = @@ -176,8 +183,6 @@ let push_local sz r = nb_stack = r.nb_stack + 1; in_stack = (sz + 1) :: r.in_stack } - - (*i Compilation of variables *) let find_at f l = let rec aux n = function @@ -214,6 +219,22 @@ let pos_rel i r sz = r.in_env := { size = pos+1; fv_rev = db:: env.fv_rev}; Kenvacc(r.offset + pos) +let pos_universe_var i r sz = + if i < r.nb_uni_stack then + Kacc (sz - r.nb_stack - (r.nb_uni_stack - i)) + else + let env = !(r.in_env) in + let f = function + | FVuniv_var u -> Int.equal i u + | _ -> false + in + try Kenvacc (r.offset + env.size - (find_at f env.fv_rev)) + with Not_found -> + let pos = env.size in + let db = FVuniv_var i in + r.in_env := { size = pos + 1; fv_rev = db::env.fv_rev } ; + Kenvacc(r.offset + pos) + (*i Examination of the continuation *) (* Discard all instructions up to the next label. *) @@ -459,8 +480,9 @@ let rec str_const c = end | _ -> Bconstr c end - | Ind ind -> Bstrconst (Const_ind ind) - | Construct (((kn,j),i),u) -> + | Ind (ind,u) when Univ.Instance.is_empty u -> + Bstrconst (Const_ind ind) + | Construct (((kn,j),i),_) -> begin (* spiwack: tries first to apply the run-time compilation behavior of the constructor, as in 2/ above *) @@ -513,6 +535,7 @@ let compile_fv_elem reloc fv sz cont = match fv with | FVrel i -> pos_rel i reloc sz :: cont | FVnamed id -> pos_named id reloc :: cont + | FVuniv_var i -> pos_universe_var i reloc sz :: cont let rec compile_fv reloc l sz cont = match l with @@ -524,39 +547,71 @@ let rec compile_fv reloc l sz cont = (* Compiling constants *) -let rec get_allias env (kn,u as p) = +let rec get_alias env kn = let cb = lookup_constant kn env in let tps = cb.const_body_code in match tps with - | None -> p + | None -> kn | Some tps -> (match Cemitcodes.force tps with - | BCallias (kn',u') -> get_allias env (kn', Univ.subst_instance_instance u u') - | _ -> p) - -(* Compiling expressions *) + | BCalias kn' -> get_alias env kn' + | _ -> kn) +(* sz is the size of the local stack *) let rec compile_constr reloc c sz cont = match kind_of_term c with | Meta _ -> invalid_arg "Cbytegen.compile_constr : Meta" | Evar _ -> invalid_arg "Cbytegen.compile_constr : Evar" - | Proj (p,c) -> - (* compile_const reloc p [|c|] sz cont *) - let kn = Projection.constant p in - let cb = lookup_constant kn !global_env in - (* TODO: better representation of projections *) - let pb = Option.get cb.const_proj in - let args = Array.make pb.proj_npars mkProp in - compile_const reloc kn Univ.Instance.empty (Array.append args [|c|]) sz cont + | Proj (p,c) -> + let kn = Projection.constant p in + let cb = lookup_constant kn !global_env in + let pb = Option.get cb.const_proj in + let n = pb.proj_arg in + compile_constr reloc c sz (Kproj (n,kn) :: cont) | Cast(c,_,_) -> compile_constr reloc c sz cont | Rel i -> pos_rel i reloc sz :: cont | Var id -> pos_named id reloc :: cont | Const (kn,u) -> compile_const reloc kn u [||] sz cont - | Sort _ | Ind _ | Construct _ -> + | Ind (ind,u) -> + let bcst = Bstrconst (Const_ind ind) in + if Univ.Instance.is_empty u then + compile_str_cst reloc bcst sz cont + else + comp_app compile_str_cst compile_universe reloc + bcst + (Univ.Instance.to_array u) + sz + cont + | Sort (Prop _) | Construct _ -> compile_str_cst reloc (str_const c) sz cont - + | Sort (Type u) -> + (* We separate global and local universes in [u]. The former will be part + of the structured constant, while the later (if any) will be applied as + arguments. *) + let open Univ in begin + let levels = Universe.levels u in + let global_levels = + LSet.filter (fun x -> Level.var_index x = None) levels + in + let local_levels = + List.map_filter (fun x -> Level.var_index x) + (LSet.elements levels) + in + (* We assume that [Universe.type0m] is a neutral element for [Universe.sup] *) + let uglob = + LSet.fold (fun lvl u -> Universe.sup u (Universe.make lvl)) global_levels Universe.type0m + in + if local_levels = [] then + compile_str_cst reloc (Bstrconst (Const_sorts (Type uglob))) sz cont + else + let compile_get_univ reloc idx sz cont = + compile_fv_elem reloc (FVuniv_var idx) sz cont + in + comp_app compile_str_cst compile_get_univ reloc + (Bstrconst (Const_type u)) (Array.of_list local_levels) sz cont + end | LetIn(_,xb,_,body) -> compile_constr reloc xb sz (Kpush :: @@ -665,7 +720,9 @@ let rec compile_constr reloc c sz cont = let lbl_sw = Label.create () in let sz_b,branch,is_tailcall = match branch1 with - | Kreturn k -> assert (Int.equal k sz); sz, branch1, true + | Kreturn k -> + assert (Int.equal k sz) ; + sz, branch1, true | _ -> sz+3, Kjump, false in let annot = {ci = ci; rtbl = tbl; tailcall = is_tailcall} in @@ -747,8 +804,20 @@ and compile_str_cst reloc sc sz cont = (* spiwack : compilation of constants with their arguments. Makes a special treatment with 31-bit integer addition *) -and compile_const = - fun reloc-> fun kn u -> fun args -> fun sz -> fun cont -> +and compile_get_global reloc (kn,u) sz cont = + let kn = get_alias !global_env kn in + if Univ.Instance.is_empty u then + Kgetglobal kn :: cont + else + comp_app (fun _ _ _ cont -> Kgetglobal kn :: cont) + compile_universe reloc () (Univ.Instance.to_array u) sz cont + +and compile_universe reloc uni sz cont = + match Univ.Level.var_index uni with + | None -> Kconst (Const_univ_level uni) :: cont + | Some idx -> pos_universe_var idx reloc sz :: cont + +and compile_const reloc kn u args sz cont = let nargs = Array.length args in (* spiwack: checks if there is a specific way to compile the constant if there is not, Not_found is raised, and the function @@ -758,30 +827,85 @@ and compile_const = (mkConstU (kn,u)) reloc args sz cont with Not_found -> if Int.equal nargs 0 then - Kgetglobal (get_allias !global_env (kn, u)) :: cont + compile_get_global reloc (kn,u) sz cont else - comp_app (fun _ _ _ cont -> - Kgetglobal (get_allias !global_env (kn,u)) :: cont) - compile_constr reloc () args sz cont - -let compile fail_on_error env c = + if Univ.Instance.is_empty u then + (* normal compilation *) + comp_app (fun _ _ sz cont -> + compile_get_global reloc (kn,u) sz cont) + compile_constr reloc () args sz cont + else + let compile_arg reloc constr_or_uni sz cont = + match constr_or_uni with + | ArgConstr cst -> compile_constr reloc cst sz cont + | ArgUniv uni -> compile_universe reloc uni sz cont + in + let u = Univ.Instance.to_array u in + let lu = Array.length u in + let all = + Array.init (lu + Array.length args) + (fun i -> if i < lu then ArgUniv u.(i) else ArgConstr args.(i-lu)) + in + comp_app (fun _ _ _ cont -> Kgetglobal kn :: cont) + compile_arg reloc () all sz cont + +let is_univ_copy max u = + let u = Univ.Instance.to_array u in + if Array.length u = max then + Array.fold_left_i (fun i acc u -> + if acc then + match Univ.Level.var_index u with + | None -> false + | Some l -> l = i + else false) true u + else + false + +let dump_bytecodes init code fvs = + let open Pp in + (str "code =" ++ fnl () ++ + pp_bytecodes init ++ fnl () ++ + pp_bytecodes code ++ fnl () ++ + str "fv = " ++ + prlist_with_sep (fun () -> str "; ") pp_fv_elem fvs ++ + fnl ()) + +let compile fail_on_error ?universes:(universes=0) env c = set_global_env env; init_fun_code (); Label.reset_label_counter (); - let reloc = empty_comp_env () in - try - let init_code = compile_constr reloc c 0 [Kstop] in + let cont = [Kstop] in + try + let reloc, init_code = + if Int.equal universes 0 then + let reloc = empty_comp_env () in + reloc, compile_constr reloc c 0 cont + else + (* We are going to generate a lambda, but merge the universe closure + * with the function closure if it exists. + *) + let reloc = empty_comp_env () in + let arity , body = + match kind_of_term c with + | Lambda _ -> + let params, body = decompose_lam c in + List.length params , body + | _ -> 0 , c + in + let full_arity = arity + universes in + let r_fun = comp_env_fun ~univs:universes arity in + let lbl_fun = Label.create () in + let cont_fun = + compile_constr r_fun body full_arity [Kreturn full_arity] + in + fun_code := [Ksequence(add_grab full_arity lbl_fun cont_fun,!fun_code)]; + let fv = fv r_fun in + reloc, compile_fv reloc fv.fv_rev 0 (Kclosure(lbl_fun,fv.size) :: cont) + in let fv = List.rev (!(reloc.in_env).fv_rev) in -(* draw_instr init_code; - draw_instr !fun_code; - Format.print_string "fv = "; - List.iter (fun v -> - match v with - | FVnamed id -> Format.print_string ((Id.to_string id)^"; ") - | FVrel i -> Format.print_string ((string_of_int i)^"; ")) fv; Format - .print_string "\n"; - Format.print_flush(); *) - Some (init_code,!fun_code, Array.of_list fv) + (if !Flags.dump_bytecode then + Pp.msg_debug (dump_bytecodes init_code !fun_code fv)) ; + Some (init_code,!fun_code, Array.of_list fv) with TooLargeInductive tname -> let fn = if fail_on_error then Errors.errorlabstrm "compile" else Pp.msg_warning in (Pp.(fn @@ -789,28 +913,33 @@ let compile fail_on_error env c = Id.print tname ++ str str_max_constructors)); None) -let compile_constant_body fail_on_error env = function +let compile_constant_body fail_on_error env univs = function | Undef _ | OpaqueDef _ -> Some BCconstant | Def sb -> let body = Mod_subst.force_constr sb in + let instance_size = + match univs with + | None -> 0 + | Some univ -> Univ.UContext.size univ + in match kind_of_term body with - | Const (kn',u) -> + | Const (kn',u) when is_univ_copy instance_size u -> (* we use the canonical name of the constant*) let con= constant_of_kn (canonical_con kn') in - Some (BCallias (get_allias env (con,u))) + Some (BCalias (get_alias env con)) | _ -> - let res = compile fail_on_error env body in + let res = compile fail_on_error ~universes:instance_size env body in Option.map (fun x -> BCdefined (to_memory x)) res (* Shortcut of the previous function used during module strengthening *) -let compile_alias (kn,u) = BCallias (constant_of_kn (canonical_con kn), u) +let compile_alias kn = BCalias (constant_of_kn (canonical_con kn)) (* spiwack: additional function which allow different part of compilation of the 31-bit integers *) let make_areconst n else_lbl cont = - if n <=0 then + if n <= 0 then cont else Kareconst (n, else_lbl)::cont @@ -867,7 +996,7 @@ let op2_compilation op = Kareconst(2, else_lbl):: Kacc 0:: Kpop 1:: op:: Kreturn 0:: Klabel else_lbl:: (* works as comp_app with nargs = 2 and tailcall cont [Kreturn 0]*) - (*Kgetglobal (get_allias !global_env kn):: *) + (*Kgetglobal (get_alias !global_env kn):: *) normal:: Kappterm(2, 2):: [] (* = discard_dead_code [Kreturn 0] *) in @@ -886,7 +1015,7 @@ let op2_compilation op = (*Kaddint31::escape::Klabel else_lbl::Kpush::*) (op::escape::Klabel else_lbl::Kpush:: (* works as comp_app with nargs = 2 and non-tailcall cont*) - (*Kgetglobal (get_allias !global_env kn):: *) + (*Kgetglobal (get_alias !global_env kn):: *) normal:: Kapply 2::labeled_cont))) else if nargs=0 then @@ -900,16 +1029,16 @@ let op2_compilation op = 1/ checks if all the arguments are constants (i.e. non-block values) 2/ if they are, uses the "op" instruction to execute 3/ if at least one is not, branches to the normal behavior: - Kgetglobal (get_allias !global_env kn) *) + Kgetglobal (get_alias !global_env kn) *) let op_compilation n op = - let code_construct kn cont = + let code_construct reloc kn sz cont = let f_cont = let else_lbl = Label.create () in Kareconst(n, else_lbl):: Kacc 0:: Kpop 1:: op:: Kreturn 0:: Klabel else_lbl:: (* works as comp_app with nargs = n and tailcall cont [Kreturn 0]*) - Kgetglobal (get_allias !global_env kn):: - Kappterm(n, n):: [] (* = discard_dead_code [Kreturn 0] *) + compile_get_global reloc kn sz ( + Kappterm(n, n):: []) (* = discard_dead_code [Kreturn 0] *) in let lbl = Label.create () in fun_code := [Ksequence (add_grab n lbl f_cont, !fun_code)]; @@ -926,12 +1055,11 @@ let op_compilation n op = (*Kaddint31::escape::Klabel else_lbl::Kpush::*) (op::escape::Klabel else_lbl::Kpush:: (* works as comp_app with nargs = n and non-tailcall cont*) - Kgetglobal (get_allias !global_env kn):: - Kapply n::labeled_cont))) + compile_get_global reloc kn sz (Kapply n::labeled_cont)))) else if Int.equal nargs 0 then - code_construct kn cont + code_construct reloc kn sz cont else - comp_app (fun _ _ _ cont -> code_construct kn cont) + comp_app (fun reloc _ sz cont -> code_construct reloc kn sz cont) compile_constr reloc () args sz cont let int31_escape_before_match fc cont = diff --git a/kernel/cbytegen.mli b/kernel/cbytegen.mli index 1128f0d0..c0f48641 100644 --- a/kernel/cbytegen.mli +++ b/kernel/cbytegen.mli @@ -4,17 +4,17 @@ open Term open Declarations open Pre_env - +(** Should only be used for monomorphic terms *) val compile : bool -> (* Fail on error with a nice user message, otherwise simply a warning *) - env -> constr -> (bytecodes * bytecodes * fv) option + ?universes:int -> env -> constr -> (bytecodes * bytecodes * fv) option (** init, fun, fv *) -val compile_constant_body : bool -> - env -> constant_def -> body_code option +val compile_constant_body : bool -> + env -> constant_universes option -> constant_def -> body_code option (** Shortcut of the previous function used during module strengthening *) -val compile_alias : pconstant -> body_code +val compile_alias : Names.constant -> body_code (** spiwack: this function contains the information needed to perform the static compilation of int31 (trying and obtaining diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index 2535a64d..ef0c9af4 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -19,7 +19,7 @@ open Mod_subst type reloc_info = | Reloc_annot of annot_switch | Reloc_const of structured_constant - | Reloc_getglobal of pconstant + | Reloc_getglobal of Names.constant type patch = reloc_info * int @@ -127,11 +127,11 @@ let slot_for_const c = enter (Reloc_const c); out_int 0 -and slot_for_annot a = +let slot_for_annot a = enter (Reloc_annot a); out_int 0 -and slot_for_getglobal p = +let slot_for_getglobal p = enter (Reloc_getglobal p); out_int 0 @@ -190,7 +190,7 @@ let emit_instr = function Array.iter (out_label_with_orig org) lbl_bodies | Kgetglobal q -> out opGETGLOBAL; slot_for_getglobal q - | Kconst((Const_b0 i)) -> + | Kconst (Const_b0 i) -> if i >= 0 && i <= 3 then out (opCONST0 + i) else (out opCONSTINT; out_int i) @@ -225,6 +225,7 @@ let emit_instr = function if n <= 1 then out (opSETFIELD0+n) else (out opSETFIELD;out_int n) | Ksequence _ -> invalid_arg "Cemitcodes.emit_instr" + | Kproj (n,p) -> out opPROJ; out_int n; slot_for_const (Const_proj p) (* spiwack *) | Kbranch lbl -> out opBRANCH; out_label lbl | Kaddint31 -> out opADDINT31 @@ -306,9 +307,10 @@ type to_patch = emitcodes * (patch list) * fv (* Substitution *) let rec subst_strcst s sc = match sc with - | Const_sorts _ | Const_b0 _ -> sc + | Const_sorts _ | Const_b0 _ | Const_univ_level _ | Const_type _ -> sc + | Const_proj p -> Const_proj (subst_constant s p) | Const_bn(tag,args) -> Const_bn(tag,Array.map (subst_strcst s) args) - | Const_ind(ind,u) -> let kn,i = ind in Const_ind((subst_mind s kn, i), u) + | Const_ind ind -> let kn,i = ind in Const_ind (subst_mind s kn, i) let subst_patch s (ri,pos) = match ri with @@ -317,7 +319,7 @@ let subst_patch s (ri,pos) = let ci = {a.ci with ci_ind = (subst_mind s kn,i)} in (Reloc_annot {a with ci = ci},pos) | Reloc_const sc -> (Reloc_const (subst_strcst s sc), pos) - | Reloc_getglobal kn -> (Reloc_getglobal (subst_pcon s kn), pos) + | Reloc_getglobal kn -> (Reloc_getglobal (subst_constant s kn), pos) let subst_to_patch s (code,pl,fv) = code,List.rev_map (subst_patch s) pl,fv @@ -326,36 +328,36 @@ let subst_pconstant s (kn, u) = (fst (subst_con_kn s kn), u) type body_code = | BCdefined of to_patch - | BCallias of pconstant + | BCalias of Names.constant | BCconstant type to_patch_substituted = | PBCdefined of to_patch substituted -| PBCallias of pconstant substituted +| PBCalias of Names.constant substituted | PBCconstant let from_val = function | BCdefined tp -> PBCdefined (from_val tp) -| BCallias cu -> PBCallias (from_val cu) +| BCalias cu -> PBCalias (from_val cu) | BCconstant -> PBCconstant let force = function | PBCdefined tp -> BCdefined (force subst_to_patch tp) -| PBCallias cu -> BCallias (force subst_pconstant cu) +| PBCalias cu -> BCalias (force subst_constant cu) | PBCconstant -> BCconstant let subst_to_patch_subst s = function | PBCdefined tp -> PBCdefined (subst_substituted s tp) -| PBCallias cu -> PBCallias (subst_substituted s cu) +| PBCalias cu -> PBCalias (subst_substituted s cu) | PBCconstant -> PBCconstant let repr_body_code = function | PBCdefined tp -> let (s, tp) = repr_substituted tp in (s, BCdefined tp) -| PBCallias cu -> +| PBCalias cu -> let (s, cu) = repr_substituted cu in - (s, BCallias cu) + (s, BCalias cu) | PBCconstant -> (None, BCconstant) let to_memory (init_code, fun_code, fv) = @@ -371,8 +373,3 @@ let to_memory (init_code, fun_code, fv) = | Label_undefined patchlist -> assert (patchlist = []))) !label_table; (code, reloc, fv) - - - - - diff --git a/kernel/cemitcodes.mli b/kernel/cemitcodes.mli index cec90130..10f3a608 100644 --- a/kernel/cemitcodes.mli +++ b/kernel/cemitcodes.mli @@ -4,7 +4,7 @@ open Cbytecodes type reloc_info = | Reloc_annot of annot_switch | Reloc_const of structured_constant - | Reloc_getglobal of constant Univ.puniverses + | Reloc_getglobal of constant type patch = reloc_info * int @@ -25,7 +25,7 @@ val subst_to_patch : Mod_subst.substitution -> to_patch -> to_patch type body_code = | BCdefined of to_patch - | BCallias of constant Univ.puniverses + | BCalias of constant | BCconstant diff --git a/kernel/constr.ml b/kernel/constr.ml index e823c01b..e2b1d3fd 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -475,7 +475,7 @@ let map_with_binders g f l c0 = match kind c0 with optimisation that physically equal arrays are equals (hence the calls to {!Array.equal_norefl}). *) -let compare_head_gen_with kind1 kind2 eq_universes leq_sorts eq leq t1 t2 = +let compare_head_gen_leq_with kind1 kind2 eq_universes leq_sorts eq leq t1 t2 = match kind1 t1, kind2 t2 with | Rel n1, Rel n2 -> Int.equal n1 n2 | Meta m1, Meta m2 -> Int.equal m1 m2 @@ -512,13 +512,19 @@ let compare_head_gen_with kind1 kind2 eq_universes leq_sorts eq leq t1 t2 = not taken into account *) let compare_head_gen_leq eq_universes leq_sorts eq leq t1 t2 = - compare_head_gen_with kind kind eq_universes leq_sorts eq leq t1 t2 + compare_head_gen_leq_with kind kind eq_universes leq_sorts eq leq t1 t2 -(* [compare_head_gen u s f c1 c2] compare [c1] and [c2] using [f] to compare - the immediate subterms of [c1] of [c2] if needed, [u] to compare universe - instances and [s] to compare sorts; Cast's, +(* [compare_head_gen u s f c1 c2] compare [c1] and [c2] using [f] to + compare the immediate subterms of [c1] of [c2] if needed, [u] to + compare universe instances and [s] to compare sorts; Cast's, application associativity, binders name and Cases annotations are - not taken into account *) + not taken into account. + + [compare_head_gen_with] is a variant taking kind-of-term functions, + to expose subterms of [c1] and [c2], as arguments. *) + +let compare_head_gen_with kind1 kind2 eq_universes eq_sorts eq t1 t2 = + compare_head_gen_leq_with kind1 kind2 eq_universes eq_sorts eq eq t1 t2 let compare_head_gen eq_universes eq_sorts eq t1 t2 = compare_head_gen_leq eq_universes eq_sorts eq eq t1 t2 @@ -536,14 +542,6 @@ let rec eq_constr m n = let equal m n = eq_constr m n (* to avoid tracing a recursive fun *) -let rec equal_with kind1 kind2 m n = - (* note that pointer equality is not sufficient to ensure equality - up to [eq_evars], because we may evaluates evars of [m] and [n] - in different evar contexts. *) - let req_constr m n = equal_with kind1 kind2 m n in - compare_head_gen_with kind1 kind2 - (fun _ -> Instance.equal) Sorts.equal req_constr req_constr m n - let eq_constr_univs univs m n = if m == n then true else @@ -567,7 +565,7 @@ let leq_constr_univs univs m n = let rec compare_leq m n = compare_head_gen_leq eq_universes leq_sorts eq_constr' leq_constr' m n and leq_constr' m n = m == n || compare_leq m n in - compare_leq m n + compare_leq m n let eq_constr_univs_infer univs m n = if m == n then true, Constraint.empty @@ -578,16 +576,16 @@ let eq_constr_univs_infer univs m n = if Sorts.equal s1 s2 then true else let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in - if Univ.check_eq univs u1 u2 then true - else - (cstrs := Univ.enforce_eq u1 u2 !cstrs; - true) + if Univ.check_eq univs u1 u2 then true + else + (cstrs := Univ.enforce_eq u1 u2 !cstrs; + true) in let rec eq_constr' m n = m == n || compare_head_gen eq_universes eq_sorts eq_constr' m n in let res = compare_head_gen eq_universes eq_sorts eq_constr' m n in - res, !cstrs + res, !cstrs let leq_constr_univs_infer univs m n = if m == n then true, Constraint.empty @@ -598,18 +596,18 @@ let leq_constr_univs_infer univs m n = if Sorts.equal s1 s2 then true else let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in - if Univ.check_eq univs u1 u2 then true - else (cstrs := Univ.enforce_eq u1 u2 !cstrs; - true) + if Univ.check_eq univs u1 u2 then true + else (cstrs := Univ.enforce_eq u1 u2 !cstrs; + true) in let leq_sorts s1 s2 = if Sorts.equal s1 s2 then true else let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in - if Univ.check_leq univs u1 u2 then true - else - (cstrs := Univ.enforce_leq u1 u2 !cstrs; - true) + if Univ.check_leq univs u1 u2 then true + else + (cstrs := Univ.enforce_leq u1 u2 !cstrs; + true) in let rec eq_constr' m n = m == n || compare_head_gen eq_universes eq_sorts eq_constr' m n @@ -618,7 +616,7 @@ let leq_constr_univs_infer univs m n = compare_head_gen_leq eq_universes leq_sorts eq_constr' leq_constr' m n and leq_constr' m n = m == n || compare_leq m n in let res = compare_leq m n in - res, !cstrs + res, !cstrs let always_true _ _ = true diff --git a/kernel/constr.mli b/kernel/constr.mli index 67d1aded..e6a3e71f 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -203,14 +203,6 @@ val kind : constr -> (constr, types) kind_of_term and application grouping *) val equal : constr -> constr -> bool -(** [equal_with_evars k1 k2 a b] is true when [a] equals [b] modulo - alpha, casts, application grouping, and using [k1] to expose the - head of [a] and [k2] to expose the head of [b]. *) -val equal_with : - (constr -> (constr,types) kind_of_term) -> - (constr -> (constr,types) kind_of_term) -> - constr -> constr -> bool - (** [eq_constr_univs u a b] is [true] if [a] equals [b] modulo alpha, casts, application grouping and the universe equalities in [u]. *) val eq_constr_univs : constr Univ.check_function @@ -293,6 +285,18 @@ val compare_head_gen : (bool -> Univ.Instance.t -> Univ.Instance.t -> bool) -> (constr -> constr -> bool) -> constr -> constr -> bool +(** [compare_head_gen_with k1 k2 u s f c1 c2] compares [c1] and [c2] + like [compare_head_gen u s f c1 c2], except that [k1] (resp. [k2]) + is used,rather than {!kind}, to expose the immediate subterms of + [c1] (resp. [c2]). *) +val compare_head_gen_with : + (constr -> (constr,types) kind_of_term) -> + (constr -> (constr,types) kind_of_term) -> + (bool -> Univ.Instance.t -> Univ.Instance.t -> bool) -> + (Sorts.t -> Sorts.t -> bool) -> + (constr -> constr -> bool) -> + constr -> constr -> bool + (** [compare_head_gen_leq u s f fle c1 c2] compare [c1] and [c2] using [f] to compare the immediate subterms of [c1] of [c2] for conversion, [fle] for cumulativity, [u] to compare universe diff --git a/kernel/conv_oracle.ml b/kernel/conv_oracle.ml index 3b01538b..ec2c334b 100644 --- a/kernel/conv_oracle.ml +++ b/kernel/conv_oracle.ml @@ -82,12 +82,17 @@ let fold_strategy f { var_opacity; cst_opacity; } accu = let get_transp_state { var_trstate; cst_trstate } = (var_trstate, cst_trstate) (* Unfold the first constant only if it is "more transparent" than the - second one. In case of tie, expand the second one. *) + second one. In case of tie, use the recommended default. *) let oracle_order f o l2r k1 k2 = match get_strategy o f k1, get_strategy o f k2 with - | Expand, _ -> true - | Level n1, Opaque -> true - | Level n1, Level n2 -> n1 < n2 - | _ -> l2r (* use recommended default *) + | Expand, Expand -> l2r + | Expand, (Opaque | Level _) -> true + | (Opaque | Level _), Expand -> false + | Opaque, Opaque -> l2r + | Level _, Opaque -> true + | Opaque, Level _ -> false + | Level n1, Level n2 -> + if Int.equal n1 n2 then l2r + else n1 < n2 let get_strategy o = get_strategy o (fun x -> x) diff --git a/kernel/csymtable.ml b/kernel/csymtable.ml index b29f06c6..28f0fa4f 100644 --- a/kernel/csymtable.ml +++ b/kernel/csymtable.ml @@ -57,22 +57,34 @@ let set_global v = let rec eq_structured_constant c1 c2 = match c1, c2 with | Const_sorts s1, Const_sorts s2 -> Sorts.equal s1 s2 -| Const_ind i1, Const_ind i2 -> Univ.eq_puniverses eq_ind i1 i2 +| Const_sorts _, _ -> false +| Const_ind i1, Const_ind i2 -> eq_ind i1 i2 +| Const_ind _, _ -> false +| Const_proj p1, Const_proj p2 -> Constant.equal p1 p2 +| Const_proj _, _ -> false | Const_b0 t1, Const_b0 t2 -> Int.equal t1 t2 +| Const_b0 _, _ -> false | Const_bn (t1, a1), Const_bn (t2, a2) -> Int.equal t1 t2 && Array.equal eq_structured_constant a1 a2 -| _ -> false +| Const_bn _, _ -> false +| Const_univ_level l1 , Const_univ_level l2 -> Univ.eq_levels l1 l2 +| Const_univ_level _ , _ -> false +| Const_type u1 , Const_type u2 -> Univ.Universe.equal u1 u2 +| Const_type _ , _ -> false let rec hash_structured_constant c = let open Hashset.Combine in match c with | Const_sorts s -> combinesmall 1 (Sorts.hash s) - | Const_ind (i,u) -> combinesmall 2 (combine (ind_hash i) (Univ.Instance.hash u)) - | Const_b0 t -> combinesmall 3 (Int.hash t) + | Const_ind i -> combinesmall 2 (ind_hash i) + | Const_proj p -> combinesmall 3 (Constant.hash p) + | Const_b0 t -> combinesmall 4 (Int.hash t) | Const_bn (t, a) -> let fold h c = combine h (hash_structured_constant c) in let h = Array.fold_left fold 0 a in - combinesmall 4 (combine (Int.hash t) h) + combinesmall 5 (combine (Int.hash t) h) + | Const_univ_level l -> combinesmall 6 (Univ.Level.hash l) + | Const_type u -> combinesmall 7 (Univ.Universe.hash u) module SConstTable = Hashtbl.Make (struct type t = structured_constant @@ -118,7 +130,7 @@ exception NotEvaluated let key rk = match !rk with | None -> raise NotEvaluated - | Some k -> (*Pp.msgnl (str"found at: "++int k);*) + | Some k -> try Ephemeron.get k with Ephemeron.InvalidKey -> raise NotEvaluated @@ -142,23 +154,22 @@ let slot_for_annot key = AnnotTable.add annot_tbl key n; n -let rec slot_for_getglobal env (kn,u) = +let rec slot_for_getglobal env kn = let (cb,(_,rk)) = lookup_constant_key kn env in try key rk with NotEvaluated -> (* Pp.msgnl(str"not yet evaluated");*) let pos = match cb.const_body_code with - | None -> set_global (val_of_constant (kn,u)) + | None -> set_global (val_of_constant kn) | Some code -> match Cemitcodes.force code with | BCdefined(code,pl,fv) -> - if Univ.Instance.is_empty u then - let v = eval_to_patch env (code,pl,fv) in - set_global v - else set_global (val_of_constant (kn,u)) - | BCallias kn' -> slot_for_getglobal env kn' - | BCconstant -> set_global (val_of_constant (kn,u)) in + let v = eval_to_patch env (code,pl,fv) in + set_global v + | BCalias kn' -> slot_for_getglobal env kn' + | BCconstant -> set_global (val_of_constant kn) + in (*Pp.msgnl(str"value stored at: "++int pos);*) rk := Some (Ephemeron.create pos); pos @@ -191,6 +202,8 @@ and slot_for_fv env fv = fill_fv_cache rv i val_of_rel env_of_rel b | Some (v, _) -> v end + | FVuniv_var idu -> + assert false and eval_to_patch env (buff,pl,fv) = (* copy code *before* patching because of nested evaluations: @@ -208,7 +221,6 @@ and eval_to_patch env (buff,pl,fv) = List.iter patch pl; let vm_env = Array.map (slot_for_fv env) fv in let tc = tcode_of_code buff (length buff) in -(*Pp.msgnl (str"execute code");*) eval_tcode tc vm_env and val_of_constr env c = @@ -226,5 +238,3 @@ and val_of_constr env c = let set_transparent_const kn = () (* !?! *) let set_opaque_const kn = () (* !?! *) - - diff --git a/kernel/declarations.mli b/kernel/declarations.mli index 27c1c3f3..dc5c17a7 100644 --- a/kernel/declarations.mli +++ b/kernel/declarations.mli @@ -14,7 +14,10 @@ open Context declarations. This includes global constants/axioms, mutual inductive definitions, modules and module types *) -type engagement = ImpredicativeSet +type set_predicativity = ImpredicativeSet | PredicativeSet +type type_hierarchy = TypeInType | StratifiedType + +type engagement = set_predicativity * type_hierarchy (** {6 Representation of constants (Definition/Axiom) } *) @@ -76,12 +79,6 @@ type constant_body = { const_proj : projection_body option; const_inline_code : bool } -type seff_env = [ `Nothing | `Opaque of Constr.t * Univ.universe_context_set ] - -type side_effect = - | SEsubproof of constant * constant_body * seff_env - | SEscheme of (inductive * constant * constant_body * seff_env) list * string - (** {6 Representation of mutual inductive types in the kernel } *) type recarg = @@ -142,12 +139,10 @@ type one_inductive_body = { mind_nf_lc : types array; (** Head normalized constructor types so that their conclusion exposes the inductive type *) mind_consnrealargs : int array; - (** Number of expected proper arguments of the constructors (w/o params) - (not used in the kernel) *) + (** Number of expected proper arguments of the constructors (w/o params) *) mind_consnrealdecls : int array; - (** Length of the signature of the constructors (with let, w/o params) - (not used in the kernel) *) + (** Length of the signature of the constructors (with let, w/o params) *) mind_recargs : wf_paths; (** Signature of recursive arguments in the constructors *) @@ -245,8 +240,8 @@ and module_body = mod_type : module_signature; (** expanded type *) (** algebraic type, kept if it's relevant for extraction *) mod_type_alg : module_expression option; - (** set of all constraints in the module *) - mod_constraints : Univ.constraints; + (** set of all universes constraints in the module *) + mod_constraints : Univ.ContextSet.t; (** quotiented set of equivalent constants and inductive names *) mod_delta : Mod_subst.delta_resolver; mod_retroknowledge : Retroknowledge.action list } diff --git a/kernel/declareops.ml b/kernel/declareops.ml index a7051d5c..248504c1 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -304,17 +304,7 @@ let hcons_mind mib = (** {6 Stm machinery } *) -let string_of_side_effect = function - | SEsubproof (c,_,_) -> Names.string_of_con c - | SEscheme (cl,_) -> - String.concat ", " (List.map (fun (_,c,_,_) -> Names.string_of_con c) cl) -type side_effects = side_effect list -let no_seff = ([] : side_effects) -let iter_side_effects f l = List.iter f (List.rev l) -let fold_side_effects f a l = List.fold_left f a l -let uniquize_side_effects l = List.rev (CList.uniquize (List.rev l)) -let union_side_effects l1 l2 = l1 @ l2 -let flatten_side_effects l = List.flatten l -let side_effects_of_list l = l -let cons_side_effects x l = x :: l -let side_effects_is_empty = List.is_empty +let string_of_side_effect { Entries.eff } = match eff with + | Entries.SEsubproof (c,_,_) -> "P(" ^ Names.string_of_con c ^ ")" + | Entries.SEscheme (cl,_) -> + "S(" ^ String.concat ", " (List.map (fun (_,c,_,_) -> Names.string_of_con c) cl) ^ ")" diff --git a/kernel/declareops.mli b/kernel/declareops.mli index ce65af97..1b870095 100644 --- a/kernel/declareops.mli +++ b/kernel/declareops.mli @@ -9,6 +9,7 @@ open Declarations open Mod_subst open Univ +open Entries (** Operations concerning types in [Declarations] : [constant_body], [mutual_inductive_body], [module_body] ... *) @@ -49,17 +50,6 @@ val is_opaque : constant_body -> bool val string_of_side_effect : side_effect -> string -type side_effects -val no_seff : side_effects -val iter_side_effects : (side_effect -> unit) -> side_effects -> unit -val fold_side_effects : ('a -> side_effect -> 'a) -> 'a -> side_effects -> 'a -val uniquize_side_effects : side_effects -> side_effects -val union_side_effects : side_effects -> side_effects -> side_effects -val flatten_side_effects : side_effects list -> side_effects -val side_effects_of_list : side_effect list -> side_effects -val cons_side_effects : side_effect -> side_effects -> side_effects -val side_effects_is_empty : side_effects -> bool - (** {6 Inductive types} *) val eq_recarg : recarg -> recarg -> bool diff --git a/kernel/entries.mli b/kernel/entries.mli index 303d27d3..e058519e 100644 --- a/kernel/entries.mli +++ b/kernel/entries.mli @@ -54,11 +54,11 @@ type mutual_inductive_entry = { mind_entry_private : bool option } (** {6 Constants (Definition/Axiom) } *) -type proof_output = constr Univ.in_universe_context_set * Declareops.side_effects -type const_entry_body = proof_output Future.computation +type 'a proof_output = constr Univ.in_universe_context_set * 'a +type 'a const_entry_body = 'a proof_output Future.computation -type definition_entry = { - const_entry_body : const_entry_body; +type 'a definition_entry = { + const_entry_body : 'a const_entry_body; (* List of section variables *) const_entry_secctx : Context.section_context option; (* State id on which the completion of type checking is reported *) @@ -78,8 +78,8 @@ type projection_entry = { proj_entry_ind : mutual_inductive; proj_entry_arg : int } -type constant_entry = - | DefinitionEntry of definition_entry +type 'a constant_entry = + | DefinitionEntry of 'a definition_entry | ParameterEntry of parameter_entry | ProjectionEntry of projection_entry @@ -96,3 +96,16 @@ type module_entry = | MType of module_params_entry * module_struct_entry | MExpr of module_params_entry * module_struct_entry * module_struct_entry option + +type seff_env = [ `Nothing | `Opaque of Constr.t * Univ.universe_context_set ] + +type side_eff = + | SEsubproof of constant * Declarations.constant_body * seff_env + | SEscheme of (inductive * constant * Declarations.constant_body * seff_env) list * string + +type side_effect = { + from_env : Declarations.structure_body Ephemeron.key; + eff : side_eff; +} + +type side_effects = side_effect list diff --git a/kernel/environ.ml b/kernel/environ.ml index a79abbb7..429aba4f 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -46,11 +46,14 @@ let empty_env = empty_env let engagement env = env.env_stratification.env_engagement -let type_in_type env = env.env_stratification.env_type_in_type - let is_impredicative_set env = - match engagement env with - | Some ImpredicativeSet -> true + match fst (engagement env) with + | ImpredicativeSet -> true + | _ -> false + +let type_in_type env = + match snd (engagement env) with + | TypeInType -> true | _ -> false let universes env = env.env_stratification.env_universes @@ -159,7 +162,7 @@ let reset_context = reset_with_named_context empty_named_context_val let pop_rel_context n env = let ctxt = env.env_rel_context in { env with - env_rel_context = List.firstn (List.length ctxt - n) ctxt; + env_rel_context = List.skipn n ctxt; env_nb_rel = env.env_nb_rel - n } let fold_named_context f env ~init = @@ -178,30 +181,44 @@ let fold_named_context_reverse f ~init env = (* Universe constraints *) -let add_constraints c env = - if Univ.Constraint.is_empty c then - env - else - let s = env.env_stratification in +let map_universes f env = + let s = env.env_stratification in { env with env_stratification = - { s with env_universes = Univ.merge_constraints c s.env_universes } } + { s with env_universes = f s.env_universes } } + +let add_constraints c env = + if Univ.Constraint.is_empty c then env + else map_universes (Univ.merge_constraints c) env let check_constraints c env = Univ.check_constraints c env.env_stratification.env_universes -let set_engagement c env = (* Unsafe *) - { env with env_stratification = - { env.env_stratification with env_engagement = Some c } } - -let set_type_in_type env = - { env with env_stratification = - { env.env_stratification with env_type_in_type = true } } - let push_constraints_to_env (_,univs) env = add_constraints univs env -let push_context ctx env = add_constraints (Univ.UContext.constraints ctx) env -let push_context_set ctx env = add_constraints (Univ.ContextSet.constraints ctx) env +let add_universes strict ctx g = + let g = Array.fold_left + (* Be lenient, module typing reintroduces universes and constraints due to includes *) + (fun g v -> try Univ.add_universe v strict g with Univ.AlreadyDeclared -> g) + g (Univ.Instance.to_array (Univ.UContext.instance ctx)) + in + Univ.merge_constraints (Univ.UContext.constraints ctx) g + +let push_context ?(strict=false) ctx env = + map_universes (add_universes strict ctx) env + +let add_universes_set strict ctx g = + let g = Univ.LSet.fold + (fun v g -> try Univ.add_universe v strict g with Univ.AlreadyDeclared -> g) + (Univ.ContextSet.levels ctx) g + in Univ.merge_constraints (Univ.ContextSet.constraints ctx) g + +let push_context_set ?(strict=false) ctx env = + map_universes (add_universes_set strict ctx) env + +let set_engagement c env = (* Unsafe *) + { env with env_stratification = + { env.env_stratification with env_engagement = c } } (* Global constants *) diff --git a/kernel/environ.mli b/kernel/environ.mli index ede356e6..dfe6cc85 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -50,10 +50,9 @@ val opaque_tables : env -> Opaqueproof.opaquetab val set_opaque_tables : env -> Opaqueproof.opaquetab -> env -val engagement : env -> engagement option +val engagement : env -> engagement val is_impredicative_set : env -> bool - -val type_in_type : env -> bool +val type_in_type : env -> bool (** is the local context empty *) val empty_context : env -> bool @@ -209,14 +208,12 @@ val add_constraints : Univ.constraints -> env -> env (** Check constraints are satifiable in the environment. *) val check_constraints : Univ.constraints -> env -> bool -val push_context : Univ.universe_context -> env -> env -val push_context_set : Univ.universe_context_set -> env -> env +val push_context : ?strict:bool -> Univ.universe_context -> env -> env +val push_context_set : ?strict:bool -> Univ.universe_context_set -> env -> env val push_constraints_to_env : 'a Univ.constrained -> env -> env val set_engagement : engagement -> env -> env -val set_type_in_type : env -> env - (** {6 Sets of referred section variables } [global_vars_set env c] returns the list of [id]'s occurring either directly as [Var id] in [c] or indirectly as a section variable @@ -253,7 +250,7 @@ type unsafe_type_judgment = { (** {6 Compilation of global declaration } *) -val compile_constant_body : env -> constant_def -> Cemitcodes.body_code option +val compile_constant_body : env -> constant_universes option -> constant_def -> Cemitcodes.body_code option exception Hyp_not_found diff --git a/kernel/fast_typeops.ml b/kernel/fast_typeops.ml index 86fb1b64..063c9cf1 100644 --- a/kernel/fast_typeops.ml +++ b/kernel/fast_typeops.ml @@ -182,14 +182,12 @@ let sort_of_product env domsort rangsort = | (Prop _, Prop Pos) -> rangsort (* Product rule (Type,Set,?) *) | (Type u1, Prop Pos) -> - begin match engagement env with - | Some ImpredicativeSet -> + if is_impredicative_set env then (* Rule is (Type,Set,Set) in the Set-impredicative calculus *) rangsort - | _ -> + else (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *) Type (Universe.sup Universe.type0 u1) - end (* Product rule (Prop,Type_i,Type_i) *) | (Prop Pos, Type u2) -> Type (Universe.sup Universe.type0 u2) (* Product rule (Prop,Type_i,Type_i) *) @@ -229,7 +227,7 @@ let judge_of_cast env c ct k expected_type = default_conv ~l2r:true CUMUL env ct expected_type | NATIVEcast -> let sigma = Nativelambda.empty_evars in - native_conv CUMUL sigma env ct expected_type + Nativeconv.native_conv CUMUL sigma env ct expected_type with NotConvertible -> error_actual_type env (make_judge c ct) expected_type diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 6b909824..8b03df64 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -173,38 +173,21 @@ let cumulate_arity_large_levels env sign = sign (Universe.type0m,env)) let is_impredicative env u = - is_type0m_univ u || (is_type0_univ u && engagement env = Some ImpredicativeSet) + is_type0m_univ u || (is_type0_univ u && is_impredicative_set env) +(* Returns the list [x_1, ..., x_n] of levels contributing to template + polymorphism. The elements x_k is None if the k-th parameter (starting + from the most recent and ignoring let-definitions) is not contributing + or is Some u_k if its level is u_k and is contributing. *) let param_ccls params = - let has_some_univ u = function - | Some v when Univ.Level.equal u v -> true - | _ -> false + let fold acc = function (_, None, p) -> + (let c = strip_prod_assum p in + match kind_of_term c with + | Sort (Type u) -> Univ.Universe.level u + | _ -> None) :: acc + | _ -> acc in - let remove_some_univ u = function - | Some v when Univ.Level.equal u v -> None - | x -> x - in - let fold l (_, b, p) = match b with - | None -> - (* Parameter contributes to polymorphism only if explicit Type *) - let c = strip_prod_assum p in - (* Add Type levels to the ordered list of parameters contributing to *) - (* polymorphism unless there is aliasing (i.e. non distinct levels) *) - begin match kind_of_term c with - | Sort (Type u) -> - (match Univ.Universe.level u with - | Some u -> - if List.exists (has_some_univ u) l then - None :: List.map (remove_some_univ u) l - else - Some u :: l - | None -> None :: l) - | _ -> - None :: l - end - | _ -> l - in - List.fold_left fold [] params + List.fold_left fold [] params (* Type-check an inductive definition. Does not check positivity conditions. *) @@ -302,8 +285,7 @@ let typecheck_inductive env mie = let full_polymorphic () = let defu = Term.univ_of_sort def_level in let is_natural = - type_in_type env || (check_leq (universes env') infu defu && - not (is_type0m_univ defu && not is_unit)) + type_in_type env || (check_leq (universes env') infu defu) in let _ = (** Impredicative sort, always allow *) @@ -356,7 +338,7 @@ type ill_formed_ind = | LocalNonPos of int | LocalNotEnoughArgs of int | LocalNotConstructor - | LocalNonPar of int * int + | LocalNonPar of int * int * int exception IllFormedInd of ill_formed_ind @@ -377,9 +359,9 @@ let explain_ind_err id ntyp env nbpar c nargs err = | LocalNotConstructor -> raise (InductiveError (NotConstructor (env,id,c',mkRel (ntyp+nbpar),nbpar,nargs))) - | LocalNonPar (n,l) -> + | LocalNonPar (n,i,l) -> raise (InductiveError - (NonPar (env,c',n,mkRel (nbpar-n+1), mkRel (l+nbpar)))) + (NonPar (env,c',n,mkRel i, mkRel (l+nbpar)))) let failwith_non_pos n ntypes c = for k = n to n + ntypes - 1 do @@ -408,7 +390,7 @@ let check_correct_par (env,n,ntypes,_) hyps l largs = | _::hyps -> match kind_of_term (whd_betadeltaiota env lpar.(k)) with | Rel w when Int.equal w index -> check (k-1) (index+1) hyps - | _ -> raise (IllFormedInd (LocalNonPar (k+1,l))) + | _ -> raise (IllFormedInd (LocalNonPar (k+1, index-n+nhyps+1, l))) in check (nparams-1) (n-nhyps) hyps; if not (Array.for_all (noccur_between n ntypes) largs') then failwith_non_pos_vect n ntypes largs' @@ -663,10 +645,28 @@ exception UndefinableExpansion build an expansion function. The term built is expecting to be substituted first by a substitution of the form [params, x : ind params] *) -let compute_projections ((kn, _ as ind), u as indsp) n x nparamargs params - mind_consnrealdecls mind_consnrealargs ctx = +let compute_projections ((kn, _ as ind), u as indu) n x nparamargs params + mind_consnrealdecls mind_consnrealargs paramslet ctx = let mp, dp, l = repr_mind kn in - let rp = mkApp (mkIndU indsp, rel_vect 0 nparamargs) in + (** We build a substitution smashing the lets in the record parameters so + that typechecking projections requires just a substitution and not + matching with a parameter context. *) + let indty, paramsletsubst = + let subst, inst = + List.fold_right + (fun (na, b, t) (subst, inst) -> + match b with + | None -> (mkRel 1 :: List.map (lift 1) subst, + mkRel 1 :: List.map (lift 1) inst) + | Some b -> (substl subst b) :: subst, List.map (lift 1) inst) + paramslet ([], []) + in + let subst = (* For the record parameter: *) + mkRel 1 :: List.map (lift 1) subst + in + let ty = mkApp (mkIndU indu, CArray.rev_of_list inst) in + ty, subst + in let ci = let print_info = { ind_tags = []; cstr_tags = [|rel_context_tags ctx|]; style = LetStyle } in @@ -679,34 +679,39 @@ let compute_projections ((kn, _ as ind), u as indsp) n x nparamargs params let len = List.length ctx in let x = Name x in let compat_body ccl i = - (* [ccl] is defined in context [params;x:rp] *) - (* [ccl'] is defined in context [params;x:rp;x:rp] *) + (* [ccl] is defined in context [params;x:indty] *) + (* [ccl'] is defined in context [params;x:indty;x:indty] *) let ccl' = liftn 1 2 ccl in - let p = mkLambda (x, lift 1 rp, ccl') in + let p = mkLambda (x, lift 1 indty, ccl') in let branch = it_mkLambda_or_LetIn (mkRel (len - i)) ctx in let body = mkCase (ci, p, mkRel 1, [|lift 1 branch|]) in - it_mkLambda_or_LetIn (mkLambda (x,rp,body)) params + it_mkLambda_or_LetIn (mkLambda (x,indty,body)) params in - let projections (na, b, t) (i, j, kns, pbs, subst) = + let projections (na, b, t) (i, j, kns, pbs, subst, letsubst) = match b with - | Some c -> (i, j+1, kns, pbs, substl subst c :: subst) + | Some c -> (i, j+1, kns, pbs, substl subst c :: subst, + substl letsubst c :: subst) | None -> match na with | Name id -> let kn = Constant.make1 (KerName.make mp dp (Label.of_id id)) in + let projty = substl letsubst (liftn 1 j t) in let ty = substl subst (liftn 1 j t) in let term = mkProj (Projection.make kn true, mkRel 1) in let fterm = mkProj (Projection.make kn false, mkRel 1) in let compat = compat_body ty (j - 1) in - let etab = it_mkLambda_or_LetIn (mkLambda (x, rp, term)) params in - let etat = it_mkProd_or_LetIn (mkProd (x, rp, ty)) params in + let etab = it_mkLambda_or_LetIn (mkLambda (x, indty, term)) params in + let etat = it_mkProd_or_LetIn (mkProd (x, indty, ty)) params in let body = { proj_ind = fst ind; proj_npars = nparamargs; - proj_arg = i; proj_type = ty; proj_eta = etab, etat; + proj_arg = i; proj_type = projty; proj_eta = etab, etat; proj_body = compat } in - (i + 1, j + 1, kn :: kns, body :: pbs, fterm :: subst) + (i + 1, j + 1, kn :: kns, body :: pbs, + fterm :: subst, fterm :: letsubst) | Anonymous -> raise UndefinableExpansion in - let (_, _, kns, pbs, subst) = List.fold_right projections ctx (0, 1, [], [], []) in + let (_, _, kns, pbs, subst, letsubst) = + List.fold_right projections ctx (0, 1, [], [], [], paramsletsubst) + in Array.of_list (List.rev kns), Array.of_list (List.rev pbs) @@ -792,12 +797,12 @@ let build_inductive env p prv ctx env_ar params kn isrecord isfinite inds nmr re else Univ.Instance.empty in let indsp = ((kn, 0), u) in - let rctx, _ = decompose_prod_assum (subst1 (mkIndU indsp) pkt.mind_nf_lc.(0)) in + let rctx, indty = decompose_prod_assum (subst1 (mkIndU indsp) pkt.mind_nf_lc.(0)) in (try - let fields = List.firstn pkt.mind_consnrealdecls.(0) rctx in + let fields, paramslet = List.chop pkt.mind_consnrealdecls.(0) rctx in let kns, projs = compute_projections indsp pkt.mind_typename rid nparamargs params - pkt.mind_consnrealdecls pkt.mind_consnrealargs fields + pkt.mind_consnrealdecls pkt.mind_consnrealargs paramslet fields in Some (Some (rid, kns, projs)) with UndefinableExpansion -> Some None) | Some _ -> Some None diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli index 7774e52e..01acdce5 100644 --- a/kernel/indtypes.mli +++ b/kernel/indtypes.mli @@ -43,5 +43,5 @@ val is_indices_matter : unit -> bool val compute_projections : pinductive -> Id.t -> Id.t -> int -> Context.rel_context -> int array -> int array -> - Context.rel_context -> + Context.rel_context -> Context.rel_context -> (constant array * projection_body array) diff --git a/kernel/inductive.ml b/kernel/inductive.ml index ca814f49..1f870665 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -73,7 +73,7 @@ let constructor_instantiate mind u mib c = let s = ind_subst mind mib u in substl s (subst_instance_constr u c) -let instantiate_params full t args sign = +let instantiate_params full t u args sign = let fail () = anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch") in let (rem_args, subs, ty) = @@ -81,7 +81,8 @@ let instantiate_params full t args sign = (fun (_,copt,_) (largs,subs,ty) -> match (copt, largs, kind_of_term ty) with | (None, a::args, Prod(_,_,t)) -> (args, a::subs, t) - | (Some b,_,LetIn(_,_,_,t)) -> (largs, (substl subs b)::subs, t) + | (Some b,_,LetIn(_,_,_,t)) -> + (largs, (substl subs (subst_instance_constr u b))::subs, t) | (_,[],_) -> if full then fail() else ([], subs, ty) | _ -> fail ()) sign @@ -92,15 +93,13 @@ let instantiate_params full t args sign = let full_inductive_instantiate mib u params sign = let dummy = prop_sort in - let t = mkArity (sign,dummy) in - let ar = fst (destArity (instantiate_params true t params mib.mind_params_ctxt)) in - Vars.subst_instance_context u ar - -let full_constructor_instantiate ((mind,_),u,(mib,_),params) = - let inst_ind = constructor_instantiate mind u mib in - (fun t -> - instantiate_params true (inst_ind t) params mib.mind_params_ctxt) + let t = mkArity (Vars.subst_instance_context u sign,dummy) in + fst (destArity (instantiate_params true t u params mib.mind_params_ctxt)) +let full_constructor_instantiate ((mind,_),u,(mib,_),params) t = + let inst_ind = constructor_instantiate mind u mib t in + instantiate_params true inst_ind u params mib.mind_params_ctxt + (************************************************************************) (************************************************************************) @@ -134,46 +133,60 @@ let sort_as_univ = function (* Template polymorphism *) +(* cons_subst add the mapping [u |-> su] in subst if [u] is not *) +(* in the domain or add [u |-> sup x su] if [u] is already mapped *) +(* to [x]. *) let cons_subst u su subst = - Univ.LMap.add u su subst + try + Univ.LMap.add u (Univ.sup (Univ.LMap.find u subst) su) subst + with Not_found -> Univ.LMap.add u su subst + +(* remember_subst updates the mapping [u |-> x] by [u |-> sup x u] *) +(* if it is presents and returns the substitution unchanged if not.*) +let remember_subst u subst = + try + let su = Universe.make u in + Univ.LMap.add u (Univ.sup (Univ.LMap.find u subst) su) subst + with Not_found -> subst (* Bind expected levels of parameters to actual levels *) (* Propagate the new levels in the signature *) -let rec make_subst env = function - | (_,Some _,_ as t)::sign, exp, args -> - let ctx,subst = make_subst env (sign, exp, args) in - t::ctx, subst - | d::sign, None::exp, args -> - let args = match args with _::args -> args | [] -> [] in - let ctx,subst = make_subst env (sign, exp, args) in - d::ctx, subst - | d::sign, Some u::exp, a::args -> - (* We recover the level of the argument, but we don't change the *) - (* level in the corresponding type in the arity; this level in the *) - (* arity is a global level which, at typing time, will be enforce *) - (* to be greater than the level of the argument; this is probably *) - (* a useless extra constraint *) - let s = sort_as_univ (snd (dest_arity env (Lazy.force a))) in - let ctx,subst = make_subst env (sign, exp, args) in - d::ctx, cons_subst u s subst - | (na,None,t as d)::sign, Some u::exp, [] -> - (* No more argument here: we instantiate the type with a fresh level *) - (* which is first propagated to the corresponding premise in the arity *) - (* (actualize_decl_level), then to the conclusion of the arity (via *) - (* the substitution) *) - let ctx,subst = make_subst env (sign, exp, []) in - d::ctx, subst - | sign, [], _ -> - (* Uniform parameters are exhausted *) - sign, Univ.LMap.empty - | [], _, _ -> - assert false +let rec make_subst env = + let rec make subst = function + | (_,Some _,_)::sign, exp, args -> + make subst (sign, exp, args) + | d::sign, None::exp, args -> + let args = match args with _::args -> args | [] -> [] in + make subst (sign, exp, args) + | d::sign, Some u::exp, a::args -> + (* We recover the level of the argument, but we don't change the *) + (* level in the corresponding type in the arity; this level in the *) + (* arity is a global level which, at typing time, will be enforce *) + (* to be greater than the level of the argument; this is probably *) + (* a useless extra constraint *) + let s = sort_as_univ (snd (dest_arity env (Lazy.force a))) in + make (cons_subst u s subst) (sign, exp, args) + | (na,None,t)::sign, Some u::exp, [] -> + (* No more argument here: we add the remaining universes to the *) + (* substitution (when [u] is distinct from all other universes in the *) + (* template, it is identity substitution otherwise (ie. when u is *) + (* already in the domain of the substitution) [remember_subst] will *) + (* update its image [x] by [sup x u] in order not to forget the *) + (* dependency in [u] that remains to be fullfilled. *) + make (remember_subst u subst) (sign, exp, []) + | sign, [], _ -> + (* Uniform parameters are exhausted *) + subst + | [], _, _ -> + assert false + in + make Univ.LMap.empty exception SingletonInductiveBecomesProp of Id.t let instantiate_universes env ctx ar argsorts = let args = Array.to_list argsorts in - let ctx,subst = make_subst env (ctx,ar.template_param_levels,args) in + let subst = make_subst env (ctx,ar.template_param_levels,args) in let level = Univ.subst_univs_universe (Univ.make_subst subst) ar.template_level in let ty = (* Singleton type not containing types are interpretable in Prop *) @@ -213,8 +226,8 @@ let constrained_type_of_inductive_knowing_parameters env ((mib,mip),u as pind) a let cst = instantiate_inductive_constraints mib u in (ty, cst) -let type_of_inductive_knowing_parameters env ?(polyprop=false) mip args = - type_of_inductive_gen env mip args +let type_of_inductive_knowing_parameters env ?(polyprop=true) mip args = + type_of_inductive_gen ~polyprop env mip args (* The max of an array of universes *) @@ -331,13 +344,13 @@ let is_correct_arity env c pj ind specif params = | Prod (na1,a1,a2), [] -> (* whnf of t was not needed here! *) let env' = push_rel (na1,None,a1) env in let ksort = match kind_of_term (whd_betadeltaiota env' a2) with - | Sort s -> family_of_sort s - | _ -> raise (LocalArity None) in + | Sort s -> family_of_sort s + | _ -> raise (LocalArity None) in let dep_ind = build_dependent_inductive ind specif params in let _ = try conv env a1 dep_ind with NotConvertible -> raise (LocalArity None) in - check_allowed_sort ksort specif + check_allowed_sort ksort specif | _, (_,Some _,_ as d)::ar' -> srec (push_rel d env) (lift 1 pt') ar' | _ -> diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index f7ae30e7..ba14f65d 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -122,7 +122,7 @@ let add_kn_delta_resolver kn kn' = let add_mp_delta_resolver mp1 mp2 = Deltamap.add_mp mp1 mp2 -(** Extending a [substitution] *) +(** Extending a [substitution] without sequential composition *) let add_mbid mbid mp resolve s = Umap.add_mbi mbid (mp,resolve) s let add_mp mp1 mp2 resolve s = Umap.add_mp mp1 (mp2,resolve) s diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli index fc2b0441..cd9fa792 100644 --- a/kernel/mod_subst.mli +++ b/kernel/mod_subst.mli @@ -68,8 +68,9 @@ val empty_subst : substitution val is_empty_subst : substitution -> bool -(** add_* add [arg2/arg1]\{arg3\} to the substitution with no - sequential composition *) +(** add_* add [arg2/arg1]\{arg3\} to the substitution with no sequential + composition. Most often this is not what you want. For sequential + composition, try [join (map_mbid mp delta) subs] **) val add_mbid : MBId.t -> module_path -> delta_resolver -> substitution -> substitution val add_mp : diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index 26dd45f5..bd7ee7b3 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -21,7 +21,7 @@ open Modops open Mod_subst type 'alg translation = - module_signature * 'alg option * delta_resolver * Univ.constraints + module_signature * 'alg option * delta_resolver * Univ.ContextSet.t let rec mp_from_mexpr = function | MEident mp -> mp @@ -52,7 +52,7 @@ let rec rebuild_mp mp l = | []-> mp | i::r -> rebuild_mp (MPdot(mp,Label.of_id i)) r -let (+++) = Univ.Constraint.union +let (+++) = Univ.ContextSet.union let rec check_with_def env struc (idl,(c,ctx)) mp equiv = let lab,idl = match idl with @@ -72,33 +72,71 @@ let rec check_with_def env struc (idl,(c,ctx)) mp equiv = (* In the spirit of subtyping.check_constant, we accept any implementations of parameters and opaques terms, as long as they have the right type *) - let ccst = Declareops.constraints_of_constant (opaque_tables env) cb in - let env' = Environ.add_constraints ccst env' in - let newus, cst = Univ.UContext.dest ctx in - let env' = Environ.add_constraints cst env' in - let c',cst = match cb.const_body with - | Undef _ | OpaqueDef _ -> - let j = Typeops.infer env' c in - let typ = Typeops.type_of_constant_type env' cb.const_type in - let cst' = Reduction.infer_conv_leq env' (Environ.universes env') - j.uj_type typ in - j.uj_val,cst' +++ cst - | Def cs -> - let cst' = Reduction.infer_conv env' (Environ.universes env') c - (Mod_subst.force_constr cs) in - let cst = (*FIXME MS: what to check here? subtyping of polymorphic constants... *) - if cb.const_polymorphic then cst' +++ cst - else cst' +++ cst + let uctx = Declareops.universes_of_constant (opaque_tables env) cb in + let uctx = (* Context of the spec *) + if cb.const_polymorphic then + Univ.instantiate_univ_context uctx + else uctx + in + let c', univs, ctx' = + if not cb.const_polymorphic then + let env' = Environ.push_context ~strict:true uctx env' in + let env' = Environ.push_context ~strict:true ctx env' in + let c',cst = match cb.const_body with + | Undef _ | OpaqueDef _ -> + let j = Typeops.infer env' c in + let typ = Typeops.type_of_constant_type env' cb.const_type in + let cst' = Reduction.infer_conv_leq env' (Environ.universes env') + j.uj_type typ in + j.uj_val, cst' + | Def cs -> + let c' = Mod_subst.force_constr cs in + c, Reduction.infer_conv env' (Environ.universes env') c c' + in c', ctx, Univ.ContextSet.add_constraints cst (Univ.ContextSet.of_context ctx) + else + let cus, ccst = Univ.UContext.dest uctx in + let newus, cst = Univ.UContext.dest ctx in + let () = + if not (Univ.Instance.length cus == Univ.Instance.length newus) then + error_incorrect_with_constraint lab + in + let inst = Univ.Instance.append cus newus in + let csti = Univ.enforce_eq_instances cus newus cst in + let csta = Univ.Constraint.union csti ccst in + let env' = Environ.push_context ~strict:false (Univ.UContext.make (inst, csta)) env in + let () = if not (Univ.check_constraints cst (Environ.universes env')) then + error_incorrect_with_constraint lab + in + let cst = match cb.const_body with + | Undef _ | OpaqueDef _ -> + let j = Typeops.infer env' c in + let typ = Typeops.type_of_constant_type env' cb.const_type in + let typ = Vars.subst_instance_constr cus typ in + let cst' = Reduction.infer_conv_leq env' (Environ.universes env') + j.uj_type typ in + cst' + | Def cs -> + let c' = Vars.subst_instance_constr cus (Mod_subst.force_constr cs) in + let cst' = Reduction.infer_conv env' (Environ.universes env') c c' in + cst' in - c, cst + if not (Univ.Constraint.is_empty cst) then + error_incorrect_with_constraint lab; + let subst, ctx = Univ.abstract_universes true ctx in + Vars.subst_univs_level_constr subst c, ctx, Univ.ContextSet.empty in let def = Def (Mod_subst.from_val c') in - let ctx' = Univ.UContext.make (newus, cst) in +(* let ctx' = Univ.UContext.make (newus, cst) in *) + let univs = + if cb.const_polymorphic then Some cb.const_universes + else None + in let cb' = { cb with const_body = def; - const_body_code = Option.map Cemitcodes.from_val (compile_constant_body env' def); - const_universes = ctx' } + const_universes = ctx ; + const_body_code = Option.map Cemitcodes.from_val + (compile_constant_body env' univs def) } in before@(lab,SFBconst(cb'))::after, c', ctx' else @@ -145,8 +183,7 @@ let rec check_with_mod env struc (idl,mp1) mp equiv = begin try let mtb_old = module_type_of_module old in - Subtyping.check_subtypes env' mtb_mp1 mtb_old - +++ old.mod_constraints + Univ.ContextSet.add_constraints (Subtyping.check_subtypes env' mtb_mp1 mtb_old) old.mod_constraints with Failure _ -> error_incorrect_with_constraint lab end | Algebraic (NoFunctor (MEident(mp'))) -> @@ -194,7 +231,7 @@ let rec check_with_mod env struc (idl,mp1) mp equiv = | Algebraic (NoFunctor (MEident mp0)) -> let mpnew = rebuild_mp mp0 idl in check_modpath_equiv env' mpnew mp; - before@(lab,spec)::after, equiv, Univ.Constraint.empty + before@(lab,spec)::after, equiv, Univ.ContextSet.empty | _ -> error_generative_module_expected lab end with @@ -207,8 +244,8 @@ let check_with env mp (sign,alg,reso,cst) = function |WithDef(idl,c) -> let struc = destr_nofunctor sign in let struc',c',cst' = check_with_def env struc (idl,c) mp reso in - let alg' = mk_alg_with alg (WithDef (idl,(c',cst'))) in - (NoFunctor struc'),alg',reso, cst+++(Univ.UContext.constraints cst') + let alg' = mk_alg_with alg (WithDef (idl,(c',Univ.ContextSet.to_context cst'))) in + (NoFunctor struc'),alg',reso, cst+++cst' |WithMod(idl,mp1) as wd -> let struc = destr_nofunctor sign in let struc',reso',cst' = check_with_mod env struc (idl,mp1) mp reso in @@ -238,7 +275,7 @@ let rec translate_mse env mpo inl = function let mtb = lookup_modtype mp1 env in mtb.mod_type, mtb.mod_delta in - sign,Some (MEident mp1),reso,Univ.Constraint.empty + sign,Some (MEident mp1),reso,Univ.ContextSet.empty |MEapply (fe,mp1) -> translate_apply env inl (translate_mse env mpo inl fe) mp1 (mk_alg_app mpo) |MEwith(me, with_decl) -> @@ -256,7 +293,7 @@ and translate_apply env inl (sign,alg,reso,cst1) mp1 mkalg = let body = subst_signature subst fbody_b in let alg' = mkalg alg mp1 in let reso' = subst_codom_delta_resolver subst reso in - body,alg',reso', cst1 +++ cst2 + body,alg',reso', Univ.ContextSet.add_constraints cst2 cst1 let mk_alg_funct mpo mbid mtb alg = match mpo, alg with | Some _, Some alg -> Some (MoreFunctor (mbid,mtb,alg)) @@ -301,13 +338,15 @@ let finalize_module env mp (sign,alg,reso,cst) restype = match restype with mk_mod mp impl sign None cst reso |Some (params_mte,inl) -> let res_mtb = translate_modtype env mp inl params_mte in - let auto_mtb = mk_modtype mp sign Univ.Constraint.empty reso in + let auto_mtb = mk_modtype mp sign Univ.ContextSet.empty reso in let cst' = Subtyping.check_subtypes env auto_mtb res_mtb in let impl = match alg with Some e -> Algebraic e | None -> Struct sign in { res_mtb with mod_mp = mp; mod_expr = impl; - mod_constraints = cst +++ cst' } + (** cst from module body typing, cst' from subtyping, + and constraints from module type. *) + mod_constraints = Univ.ContextSet.add_constraints cst' (cst +++ res_mtb.mod_constraints) } let translate_module env mp inl = function |MType (params,ty) -> @@ -318,12 +357,20 @@ let translate_module env mp inl = function let restype = Option.map (fun ty -> ((params,ty),inl)) oty in finalize_module env mp t restype -let rec translate_mse_incl env mp inl = function +let rec translate_mse_inclmod env mp inl = function |MEident mp1 -> let mb = strengthen_and_subst_mb (lookup_module mp1 env) mp true in let sign = clean_bounded_mod_expr mb.mod_type in - sign,None,mb.mod_delta,Univ.Constraint.empty + sign,None,mb.mod_delta,Univ.ContextSet.empty |MEapply (fe,arg) -> - let ftrans = translate_mse_incl env mp inl fe in + let ftrans = translate_mse_inclmod env mp inl fe in translate_apply env inl ftrans arg (fun _ _ -> None) - |_ -> Modops.error_higher_order_include () + |MEwith _ -> assert false (* No 'with' syntax for modules *) + +let translate_mse_incl is_mod env mp inl me = + if is_mod then + translate_mse_inclmod env mp inl me + else + let mtb = translate_modtype env mp inl ([],me) in + let sign = clean_bounded_mod_expr mtb.mod_type in + sign,None,mtb.mod_delta,mtb.mod_constraints diff --git a/kernel/mod_typing.mli b/kernel/mod_typing.mli index b39e8212..bc0e2020 100644 --- a/kernel/mod_typing.mli +++ b/kernel/mod_typing.mli @@ -30,17 +30,20 @@ val translate_modtype : *) type 'alg translation = - module_signature * 'alg option * delta_resolver * Univ.constraints + module_signature * 'alg option * delta_resolver * Univ.ContextSet.t val translate_mse : env -> module_path option -> inline -> module_struct_entry -> module_alg_expr translation -val translate_mse_incl : - env -> module_path -> inline -> module_struct_entry -> - module_alg_expr translation - val finalize_module : env -> module_path -> module_expression translation -> (module_type_entry * inline) option -> module_body + +(** [translate_mse_incl] translate the mse of a module or + module type given to an Include *) + +val translate_mse_incl : + bool -> env -> module_path -> inline -> module_struct_entry -> + module_alg_expr translation diff --git a/kernel/modops.ml b/kernel/modops.ml index d52fe611..cbb79633 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -67,7 +67,6 @@ type module_typing_error = | IncorrectWithConstraint of Label.t | GenerativeModuleExpected of Label.t | LabelMissing of Label.t * string - | HigherOrderInclude exception ModuleTypingError of module_typing_error @@ -113,9 +112,6 @@ let error_generative_module_expected l = let error_no_such_label_sub l l1 = raise (ModuleTypingError (LabelMissing (l,l1))) -let error_higher_order_include () = - raise (ModuleTypingError HigherOrderInclude) - (** {6 Operations on functors } *) let is_functor = function @@ -331,13 +327,15 @@ let strengthen_const mp_from l cb resolver = let kn = KerName.make2 mp_from l in let con = constant_of_delta_kn resolver kn in let u = - if cb.const_polymorphic then - Univ.UContext.instance cb.const_universes + if cb.const_polymorphic then + let u = Univ.UContext.instance cb.const_universes in + let s = Univ.make_instance_subst u in + Univ.subst_univs_level_instance s u else Univ.Instance.empty in { cb with const_body = Def (Mod_subst.from_val (mkConstU (con,u))); - const_body_code = Some (Cemitcodes.from_val (Cbytegen.compile_alias (con,u))) } + const_body_code = Some (Cemitcodes.from_val (Cbytegen.compile_alias con)) } let rec strengthen_mod mp_from mp_to mb = if mp_in_delta mb.mod_mp mb.mod_delta then mb diff --git a/kernel/modops.mli b/kernel/modops.mli index 6fbcd81d..a335ad9b 100644 --- a/kernel/modops.mli +++ b/kernel/modops.mli @@ -126,7 +126,6 @@ type module_typing_error = | IncorrectWithConstraint of Label.t | GenerativeModuleExpected of Label.t | LabelMissing of Label.t * string - | HigherOrderInclude exception ModuleTypingError of module_typing_error @@ -153,5 +152,3 @@ val error_incorrect_with_constraint : Label.t -> 'a val error_generative_module_expected : Label.t -> 'a val error_no_such_label_sub : Label.t->string->'a - -val error_higher_order_include : unit -> 'a diff --git a/kernel/names.ml b/kernel/names.ml index 480b37e8..ae2b3b63 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -453,6 +453,9 @@ module KNset = KNmap.Set - when user and canonical parts differ, we cannot be in a section anymore, hence the dirpath must be empty - two pairs with the same user part should have the same canonical part + in a given environment (though with backtracking, the hash-table can + contains pairs with same user part but different canonical part from + a previous state of the session) Note: since most of the time the canonical and user parts are equal, we handle this case with a particular constructor to spare some memory *) @@ -504,7 +507,7 @@ module KerPair = struct let debug_print kp = str (debug_to_string kp) (** For ordering kernel pairs, both user or canonical parts may make - sense, according to your needs : user for the environments, canonical + sense, according to your needs: user for the environments, canonical for other uses (ex: non-logical things). *) module UserOrd = struct @@ -521,16 +524,9 @@ module KerPair = struct let hash x = KerName.hash (canonical x) end - (** Default comparison is on the canonical part *) + (** Default (logical) comparison and hash is on the canonical part *) let equal = CanOrd.equal - - (** Hash-consing : we discriminate only on the user part, since having - the same user part implies having the same canonical part - (invariant of the system). *) - - let hash = function - | Same kn -> KerName.hash kn - | Dual (kn, _) -> KerName.hash kn + let hash = CanOrd.hash module Self_Hashcons = struct @@ -539,8 +535,20 @@ module KerPair = struct let hashcons hkn = function | Same kn -> Same (hkn kn) | Dual (knu,knc) -> make (hkn knu) (hkn knc) - let equal x y = (user x) == (user y) - let hash = hash + let equal x y = (* physical comparison on subterms *) + x == y || + match x,y with + | Same x, Same y -> x == y + | Dual (ux,cx), Dual (uy,cy) -> ux == uy && cx == cy + | (Same _ | Dual _), _ -> false + (** Hash-consing (despite having the same user part implies having + the same canonical part is a logical invariant of the system, it + is not necessarily an invariant in memory, so we treat kernel + names as they are syntactically for hash-consing) *) + let hash = function + | Same kn -> KerName.hash kn + | Dual (knu, knc) -> + Hashset.Combine.combine (KerName.hash knu) (KerName.hash knc) end module HashKP = Hashcons.Make(Self_Hashcons) @@ -819,6 +827,10 @@ struct let map f (c, b as x) = let c' = f c in if c' == c then x else (c', b) + + let to_string p = Constant.to_string (constant p) + let print p = Constant.print (constant p) + end type projection = Projection.t diff --git a/kernel/names.mli b/kernel/names.mli index 92ee58f2..7cc44437 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -652,6 +652,10 @@ module Projection : sig val compare : t -> t -> int val map : (constant -> constant) -> t -> t + + val to_string : t -> string + val print : t -> Pp.std_ppcmds + end type projection = Projection.t diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index ada7ae73..98b2d6d2 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -195,7 +195,11 @@ module HashtblSymbol = Hashtbl.Make(HashedTypeSymbol) let symb_tbl = HashtblSymbol.create 211 -let clear_symb_tbl () = HashtblSymbol.clear symb_tbl +let clear_symbols () = HashtblSymbol.clear symb_tbl + +type symbols = symbol array + +let empty_symbols = [||] let get_value tbl i = match tbl.(i) with @@ -250,7 +254,7 @@ let push_symbol x = let symbols_tbl_name = Ginternal "symbols_tbl" -let get_symbols_tbl () = +let get_symbols () = let tbl = Array.make (HashtblSymbol.length symb_tbl) dummy_symb in HashtblSymbol.iter (fun x i -> tbl.(i) <- x) symb_tbl; tbl @@ -477,7 +481,7 @@ and eq_mllam_branches gn1 gn2 n env1 env2 br1 br2 = in Array.equal eq_branch br1 br2 -(* hash_mllambda gn n env t computes the hash for t ignoring occurences of gn *) +(* hash_mllambda gn n env t computes the hash for t ignoring occurrences of gn *) let rec hash_mllambda gn n env t = match t with | MLlocal ln -> combinesmall 1 (LNmap.find ln env) @@ -975,7 +979,7 @@ let compile_prim decl cond paux = let args = Array.map opt_prim_aux args in app_prim (Coq_primitive(op,None)) args (* - TODO: check if this inling was useful + TODO: check if this inlining was useful begin match op with | Int31lt -> if Sys.word_size = 64 then @@ -2008,16 +2012,20 @@ let rec compile_deps env sigma prefix ~interactive init t = match kind_of_term t with | Ind ((mind,_),u) -> compile_mind_deps env prefix ~interactive init mind | Const c -> - let c,u = get_allias env c in + let c,u = get_alias env c in let cb,(nameref,_) = lookup_constant_key c env in let (_, (_, const_updates)) = init in if is_code_loaded ~interactive nameref || (Cmap_env.mem c const_updates) then init else - let comp_stack, (mind_updates, const_updates) = match cb.const_body with - | Def t -> + let comp_stack, (mind_updates, const_updates) = + match cb.const_proj, cb.const_body with + | None, Def t -> compile_deps env sigma prefix ~interactive init (Mod_subst.force_constr t) + | Some pb, _ -> + let mind = pb.proj_ind in + compile_mind_deps env prefix ~interactive init mind | _ -> init in let code, name = @@ -2054,7 +2062,7 @@ let mk_internal_let s code = (* ML Code for conversion function *) let mk_conv_code env sigma prefix t1 t2 = - clear_symb_tbl (); + clear_symbols (); clear_global_tbl (); let gl, (mind_updates, const_updates) = let init = ([], empty_updates) in @@ -2076,12 +2084,12 @@ let mk_conv_code env sigma prefix t1 t2 = let setref2 = Glet(Ginternal "_", MLsetref("rt2",g2)) in let gl = List.rev (setref2 :: setref1 :: t2 :: t1 :: gl) in let header = Glet(Ginternal "symbols_tbl", - MLapp (MLglobal (Ginternal "get_symbols_tbl"), + MLapp (MLglobal (Ginternal "get_symbols"), [|MLglobal (Ginternal "()")|])) in header::gl, (mind_updates, const_updates) let mk_norm_code env sigma prefix t = - clear_symb_tbl (); + clear_symbols (); clear_global_tbl (); let gl, (mind_updates, const_updates) = let init = ([], empty_updates) in @@ -2094,14 +2102,14 @@ let mk_norm_code env sigma prefix t = let setref = Glet(Ginternal "_", MLsetref("rt1",g1)) in let gl = List.rev (setref :: t1 :: gl) in let header = Glet(Ginternal "symbols_tbl", - MLapp (MLglobal (Ginternal "get_symbols_tbl"), + MLapp (MLglobal (Ginternal "get_symbols"), [|MLglobal (Ginternal "()")|])) in header::gl, (mind_updates, const_updates) let mk_library_header dir = let libname = Format.sprintf "(str_decode \"%s\")" (str_encode dir) in [Glet(Ginternal "symbols_tbl", - MLapp (MLglobal (Ginternal "get_library_symbols_tbl"), + MLapp (MLglobal (Ginternal "get_library_native_symbols"), [|MLglobal (Ginternal libname)|]))] let update_location (r,v) = r := v diff --git a/kernel/nativecode.mli b/kernel/nativecode.mli index 893db92d..5d4c9e1e 100644 --- a/kernel/nativecode.mli +++ b/kernel/nativecode.mli @@ -22,29 +22,33 @@ val pp_global : Format.formatter -> global -> unit val mk_open : string -> global +(* Precomputed values for a compilation unit *) type symbol +type symbols -val clear_symb_tbl : unit -> unit +val empty_symbols : symbols -val get_value : symbol array -> int -> Nativevalues.t +val clear_symbols : unit -> unit -val get_sort : symbol array -> int -> sorts +val get_value : symbols -> int -> Nativevalues.t -val get_name : symbol array -> int -> name +val get_sort : symbols -> int -> sorts -val get_const : symbol array -> int -> constant +val get_name : symbols -> int -> name -val get_match : symbol array -> int -> Nativevalues.annot_sw +val get_const : symbols -> int -> constant -val get_ind : symbol array -> int -> inductive +val get_match : symbols -> int -> Nativevalues.annot_sw -val get_meta : symbol array -> int -> metavariable +val get_ind : symbols -> int -> inductive -val get_evar : symbol array -> int -> existential +val get_meta : symbols -> int -> metavariable -val get_level : symbol array -> int -> Univ.Level.t +val get_evar : symbols -> int -> existential -val get_symbols_tbl : unit -> symbol array +val get_level : symbols -> int -> Univ.Level.t + +val get_symbols : unit -> symbols type code_location_update type code_location_updates diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index 75a3fc45..0242fd46 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -16,17 +16,21 @@ open Nativecode (** This module implements the conversion test by compiling to OCaml code *) -let rec conv_val env pb lvl cu v1 v2 = - if v1 == v2 then () +let rec conv_val env pb lvl v1 v2 cu = + if v1 == v2 then cu else match kind_of_value v1, kind_of_value v2 with - | Vaccu k1, Vaccu k2 -> - conv_accu env pb lvl cu k1 k2 | Vfun f1, Vfun f2 -> let v = mk_rel_accu lvl in - conv_val env CONV (lvl+1) cu (f1 v) (f2 v) + conv_val env CONV (lvl+1) (f1 v) (f2 v) cu + | Vfun f1, _ -> + conv_val env CONV lvl v1 (fun x -> v2 x) cu + | _, Vfun f2 -> + conv_val env CONV lvl (fun x -> v1 x) v2 cu + | Vaccu k1, Vaccu k2 -> + conv_accu env pb lvl k1 k2 cu | Vconst i1, Vconst i2 -> - if not (Int.equal i1 i2) then raise NotConvertible + if Int.equal i1 i2 then cu else raise NotConvertible | Vblock b1, Vblock b2 -> let n1 = block_size b1 in let n2 = block_size b2 in @@ -34,77 +38,81 @@ let rec conv_val env pb lvl cu v1 v2 = raise NotConvertible; let rec aux lvl max b1 b2 i cu = if Int.equal i max then - conv_val env CONV lvl cu (block_field b1 i) (block_field b2 i) + conv_val env CONV lvl (block_field b1 i) (block_field b2 i) cu else - (conv_val env CONV lvl cu (block_field b1 i) (block_field b2 i); - aux lvl max b1 b2 (i+1) cu) + let cu = conv_val env CONV lvl (block_field b1 i) (block_field b2 i) cu in + aux lvl max b1 b2 (i+1) cu in aux lvl (n1-1) b1 b2 0 cu - | Vfun f1, _ -> - conv_val env CONV lvl cu v1 (fun x -> v2 x) - | _, Vfun f2 -> - conv_val env CONV lvl cu (fun x -> v1 x) v2 - | _, _ -> raise NotConvertible + | Vaccu _, _ | Vconst _, _ | Vblock _, _ -> raise NotConvertible -and conv_accu env pb lvl cu k1 k2 = +and conv_accu env pb lvl k1 k2 cu = let n1 = accu_nargs k1 in let n2 = accu_nargs k2 in if not (Int.equal n1 n2) then raise NotConvertible; if Int.equal n1 0 then conv_atom env pb lvl (atom_of_accu k1) (atom_of_accu k2) cu else - (conv_atom env pb lvl (atom_of_accu k1) (atom_of_accu k2) cu; - List.iter2 (conv_val env CONV lvl cu) (args_of_accu k1) (args_of_accu k2)) + let cu = conv_atom env pb lvl (atom_of_accu k1) (atom_of_accu k2) cu in + List.fold_right2 (conv_val env CONV lvl) (args_of_accu k1) (args_of_accu k2) cu and conv_atom env pb lvl a1 a2 cu = - if a1 == a2 then () + if a1 == a2 then cu else match a1, a2 with + | Ameta _, _ | _, Ameta _ | Aevar _, _ | _, Aevar _ -> assert false | Arel i1, Arel i2 -> - if not (Int.equal i1 i2) then raise NotConvertible - | Aind ind1, Aind ind2 -> - if not (eq_puniverses eq_ind ind1 ind2) then raise NotConvertible - | Aconstant c1, Aconstant c2 -> - if not (eq_puniverses eq_constant c1 c2) then raise NotConvertible + if Int.equal i1 i2 then cu else raise NotConvertible + | Aind (ind1,u1), Aind (ind2,u2) -> + if eq_ind ind1 ind2 then convert_instances ~flex:false u1 u2 cu + else raise NotConvertible + | Aconstant (c1,u1), Aconstant (c2,u2) -> + if Constant.equal c1 c2 then convert_instances ~flex:true u1 u2 cu + else raise NotConvertible | Asort s1, Asort s2 -> - check_sort_cmp_universes env pb s1 s2 cu + sort_cmp_universes env pb s1 s2 cu | Avar id1, Avar id2 -> - if not (Id.equal id1 id2) then raise NotConvertible + if Id.equal id1 id2 then cu else raise NotConvertible | Acase(a1,ac1,p1,bs1), Acase(a2,ac2,p2,bs2) -> if not (eq_ind a1.asw_ind a2.asw_ind) then raise NotConvertible; - conv_accu env CONV lvl cu ac1 ac2; + let cu = conv_accu env CONV lvl ac1 ac2 cu in let tbl = a1.asw_reloc in let len = Array.length tbl in - if Int.equal len 0 then conv_val env CONV lvl cu p1 p2 + if Int.equal len 0 then conv_val env CONV lvl p1 p2 cu else begin - conv_val env CONV lvl cu p1 p2; - let max = len - 1 in - let rec aux i = - let tag,arity = tbl.(i) in - let ci = - if Int.equal arity 0 then mk_const tag - else mk_block tag (mk_rels_accu lvl arity) in - let bi1 = bs1 ci and bi2 = bs2 ci in - if Int.equal i max then conv_val env CONV (lvl + arity) cu bi1 bi2 - else (conv_val env CONV (lvl + arity) cu bi1 bi2; aux (i+1)) in - aux 0 + let cu = conv_val env CONV lvl p1 p2 cu in + let max = len - 1 in + let rec aux i cu = + let tag,arity = tbl.(i) in + let ci = + if Int.equal arity 0 then mk_const tag + else mk_block tag (mk_rels_accu lvl arity) in + let bi1 = bs1 ci and bi2 = bs2 ci in + if Int.equal i max then conv_val env CONV (lvl + arity) bi1 bi2 cu + else aux (i+1) (conv_val env CONV (lvl + arity) bi1 bi2 cu) in + aux 0 cu end | Afix(t1,f1,rp1,s1), Afix(t2,f2,rp2,s2) -> if not (Int.equal s1 s2) || not (Array.equal Int.equal rp1 rp2) then raise NotConvertible; - if f1 == f2 then () + if f1 == f2 then cu else conv_fix env lvl t1 f1 t2 f2 cu | (Acofix(t1,f1,s1,_) | Acofixe(t1,f1,s1,_)), (Acofix(t2,f2,s2,_) | Acofixe(t2,f2,s2,_)) -> if not (Int.equal s1 s2) then raise NotConvertible; - if f1 == f2 then () + if f1 == f2 then cu else if not (Int.equal (Array.length f1) (Array.length f2)) then raise NotConvertible else conv_fix env lvl t1 f1 t2 f2 cu | Aprod(_,d1,c1), Aprod(_,d2,c2) -> - conv_val env CONV lvl cu d1 d2; - let v = mk_rel_accu lvl in - conv_val env pb (lvl + 1) cu (d1 v) (d2 v) - | _, _ -> raise NotConvertible + let cu = conv_val env CONV lvl d1 d2 cu in + let v = mk_rel_accu lvl in + conv_val env pb (lvl + 1) (d1 v) (d2 v) cu + | Aproj(p1,ac1), Aproj(p2,ac2) -> + if not (Constant.equal p1 p2) then raise NotConvertible + else conv_accu env CONV lvl ac1 ac2 cu + | Arel _, _ | Aind _, _ | Aconstant _, _ | Asort _, _ | Avar _, _ + | Acase _, _ | Afix _, _ | Acofix _, _ | Acofixe _, _ | Aprod _, _ + | Aproj _, _ -> raise NotConvertible (* Precondition length t1 = length f1 = length f2 = length t2 *) and conv_fix env lvl t1 f1 t2 f2 cu = @@ -112,22 +120,15 @@ and conv_fix env lvl t1 f1 t2 f2 cu = let max = len - 1 in let fargs = mk_rels_accu lvl len in let flvl = lvl + len in - let rec aux i = - conv_val env CONV lvl cu t1.(i) t2.(i); + let rec aux i cu = + let cu = conv_val env CONV lvl t1.(i) t2.(i) cu in let fi1 = napply f1.(i) fargs in let fi2 = napply f2.(i) fargs in - if Int.equal i max then conv_val env CONV flvl cu fi1 fi2 - else (conv_val env CONV flvl cu fi1 fi2; aux (i+1)) in - aux 0 + if Int.equal i max then conv_val env CONV flvl fi1 fi2 cu + else aux (i+1) (conv_val env CONV flvl fi1 fi2 cu) in + aux 0 cu -let native_conv pb sigma env t1 t2 = - if !Flags.no_native_compiler then begin - let msg = "Native compiler is disabled, "^ - "falling back to VM conversion test." in - Pp.msg_warning (Pp.str msg); - vm_conv pb env t1 t2 - end - else +let native_conv_gen pb sigma env univs t1 t2 = let penv = Environ.pre_env env in let ml_filename, prefix = get_ml_filename () in let code, upds = mk_conv_code penv sigma prefix t1 t2 in @@ -141,8 +142,25 @@ let native_conv pb sigma env t1 t2 = let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in if !Flags.debug then Pp.msg_debug (Pp.str time_info); (* TODO change 0 when we can have deBruijn *) - conv_val env pb 0 (Environ.universes env) !rt1 !rt2 + fst (conv_val env pb 0 !rt1 !rt2 univs) end | _ -> anomaly (Pp.str "Compilation failure") -let _ = set_nat_conv native_conv +(* Wrapper for [native_conv] above *) +let native_conv cv_pb sigma env t1 t2 = + if Coq_config.no_native_compiler then begin + let msg = "Native compiler is disabled, falling back to VM conversion test." in + Pp.msg_warning (Pp.str msg); + vm_conv cv_pb env t1 t2 + end + else + let univs = Environ.universes env in + let b = + if cv_pb = CUMUL then Constr.leq_constr_univs univs t1 t2 + else Constr.eq_constr_univs univs t1 t2 + in + if not b then + let univs = (univs, checked_universes) in + let t1 = Term.it_mkLambda_or_LetIn t1 (Environ.rel_context env) in + let t2 = Term.it_mkLambda_or_LetIn t2 (Environ.rel_context env) in + let _ = native_conv_gen cv_pb sigma env univs t1 t2 in () diff --git a/kernel/nativeconv.mli b/kernel/nativeconv.mli index 318a7d83..4dddb9fd 100644 --- a/kernel/nativeconv.mli +++ b/kernel/nativeconv.mli @@ -12,3 +12,7 @@ open Nativelambda (** This module implements the conversion test by compiling to OCaml code *) val native_conv : conv_pb -> evars -> types conversion_function + +(** A conversion function parametrized by a universe comparator. Used outside of + the kernel. *) +val native_conv_gen : conv_pb -> evars -> (types, 'a) generic_conversion_function diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index 383f8102..4d033bc9 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -277,7 +277,7 @@ and reduce_lapp substf lids body substa largs = | [], _::_ -> simplify_app substf body substa (Array.of_list largs) -(* [occurence kind k lam]: +(* [occurrence kind k lam]: If [kind] is [true] return [true] if the variable [k] does not appear in [lam], return [false] if the variable appear one time and not under a lambda, a fixpoint, a cofixpoint; else raise Not_found. @@ -285,7 +285,7 @@ and reduce_lapp substf lids body substa largs = else raise [Not_found] *) -let rec occurence k kind lam = +let rec occurrence k kind lam = match lam with | Lrel (_,n) -> if Int.equal n k then @@ -294,35 +294,35 @@ let rec occurence k kind lam = | Lvar _ | Lconst _ | Lproj _ | Luint _ | Lval _ | Lsort _ | Lind _ | Lconstruct _ | Llazy | Lforce | Lmeta _ | Levar _ -> kind | Lprod(dom, codom) -> - occurence k (occurence k kind dom) codom + occurrence k (occurrence k kind dom) codom | Llam(ids,body) -> - let _ = occurence (k+Array.length ids) false body in kind + let _ = occurrence (k+Array.length ids) false body in kind | Llet(_,def,body) -> - occurence (k+1) (occurence k kind def) body + occurrence (k+1) (occurrence k kind def) body | Lapp(f, args) -> - occurence_args k (occurence k kind f) args + occurrence_args k (occurrence k kind f) args | Lprim(_,_,_,args) | Lmakeblock(_,_,_,args) -> - occurence_args k kind args + occurrence_args k kind args | Lcase(_,t,a,br) -> - let kind = occurence k (occurence k kind t) a in + let kind = occurrence k (occurrence k kind t) a in let r = ref kind in Array.iter (fun (_,ids,c) -> - r := occurence (k+Array.length ids) kind c && !r) br; + r := occurrence (k+Array.length ids) kind c && !r) br; !r | Lif (t, bt, bf) -> - let kind = occurence k kind t in - kind && occurence k kind bt && occurence k kind bf + let kind = occurrence k kind t in + kind && occurrence k kind bt && occurrence k kind bf | Lfix(_,(ids,ltypes,lbodies)) | Lcofix(_,(ids,ltypes,lbodies)) -> - let kind = occurence_args k kind ltypes in - let _ = occurence_args (k+Array.length ids) false lbodies in + let kind = occurrence_args k kind ltypes in + let _ = occurrence_args (k+Array.length ids) false lbodies in kind -and occurence_args k kind args = - Array.fold_left (occurence k) kind args +and occurrence_args k kind args = + Array.fold_left (occurrence k) kind args let occur_once lam = - try let _ = occurence 1 true lam in true + try let _ = occurrence 1 true lam in true with Not_found -> false (* [remove_let lam] remove let expression in [lam] if the variable is *) @@ -373,13 +373,13 @@ let makeblock env cn u tag args = (* Translation of constants *) -let rec get_allias env (kn, u as p) = +let rec get_alias env (kn, u as p) = let tps = (lookup_constant kn env).const_body_code in match tps with | None -> p | Some tps -> match Cemitcodes.force tps with - | Cemitcodes.BCallias kn' -> get_allias env kn' + | Cemitcodes.BCalias kn' -> get_alias env (kn', u) | _ -> p (*i Global environment *) @@ -651,7 +651,7 @@ let rec lambda_of_constr env sigma c = and lambda_of_app env sigma f args = match kind_of_term f with | Const (kn,u as c) -> - let kn,u = get_allias !global_env c in + let kn,u = get_alias !global_env c in let cb = lookup_constant kn !global_env in (try let prefix = get_const_prefix !global_env kn in diff --git a/kernel/nativelambda.mli b/kernel/nativelambda.mli index ccf2888b..3b6fafbb 100644 --- a/kernel/nativelambda.mli +++ b/kernel/nativelambda.mli @@ -26,7 +26,7 @@ val mk_lazy : lambda -> lambda val get_mind_prefix : env -> mutual_inductive -> string -val get_allias : env -> pconstant -> pconstant +val get_alias : env -> pconstant -> pconstant val lambda_of_constr : env -> evars -> Constr.constr -> lambda diff --git a/kernel/nativelib.ml b/kernel/nativelib.ml index 605c1225..b2142b43 100644 --- a/kernel/nativelib.ml +++ b/kernel/nativelib.ml @@ -94,7 +94,10 @@ let compile_library dir code fn = let basename = Filename.basename fn in let dirname = Filename.dirname fn in let dirname = dirname / output_dir in - if not (Sys.file_exists dirname) then Unix.mkdir dirname 0o755; + let () = + try Unix.mkdir dirname 0o755 + with Unix.Unix_error (Unix.EEXIST, _, _) -> () + in let fn = dirname / basename in write_ml_code fn ~header code; let r = fst (call_compiler fn) in @@ -102,22 +105,25 @@ let compile_library dir code fn = r (* call_linker links dynamically the code for constants in environment or a *) -(* conversion test. Silently fails if the file does not exist in bytecode *) -(* mode, since the standard library is not compiled to bytecode with default *) -(* settings. *) +(* conversion test. *) let call_linker ?(fatal=true) prefix f upds = rt1 := dummy_value (); rt2 := dummy_value (); - if Dynlink.is_native || Sys.file_exists f then + if not (Sys.file_exists f) then + begin + let msg = "Cannot find native compiler file " ^ f in + if fatal then Errors.error msg + else if !Flags.debug then Pp.msg_debug (Pp.str msg) + end + else (try if Dynlink.is_native then Dynlink.loadfile f else !load_obj f; register_native_file prefix - with | Dynlink.Error e -> - let msg = "Dynlink error, " ^ Dynlink.error_message e in - if fatal then anomaly (Pp.str msg) else Pp.msg_warning (Pp.str msg) - | e when Errors.noncritical e -> - if fatal then anomaly (Errors.print e) - else Pp.msg_warning (Errors.print_no_report e)); + with Dynlink.Error e as exn -> + let exn = Errors.push exn in + let msg = "Dynlink error, " ^ Dynlink.error_message e in + if fatal then (Pp.msg_error (Pp.str msg); iraise exn) + else if !Flags.debug then Pp.msg_debug (Pp.str msg)); match upds with Some upds -> update_locations upds | _ -> () let link_library ~prefix ~dirname ~basename = diff --git a/kernel/nativelibrary.ml b/kernel/nativelibrary.ml index 0b8662ff..443cd8c2 100644 --- a/kernel/nativelibrary.ml +++ b/kernel/nativelibrary.ml @@ -62,12 +62,12 @@ let dump_library mp dp env mod_expr = let prefix = mod_uid_of_dirpath dp ^ "." in let t0 = Sys.time () in clear_global_tbl (); - clear_symb_tbl (); + clear_symbols (); let mlcode = List.fold_left (translate_field prefix mp env) [] struc in let t1 = Sys.time () in let time_info = Format.sprintf "Time spent generating this code: %.5fs" (t1-.t0) in let mlcode = add_header_comment (List.rev mlcode) time_info in - mlcode, get_symbols_tbl () + mlcode, get_symbols () | _ -> assert false diff --git a/kernel/nativelibrary.mli b/kernel/nativelibrary.mli index a66fb715..29368d14 100644 --- a/kernel/nativelibrary.mli +++ b/kernel/nativelibrary.mli @@ -14,4 +14,4 @@ open Nativecode compiler *) val dump_library : module_path -> dir_path -> env -> module_signature -> - global list * symbol array + global list * symbols diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index e4a77999..40bef4bc 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -10,7 +10,7 @@ open Names open Errors open Util -(** This modules defines the representation of values internally used by +(** This module defines the representation of values internally used by the native compiler *) type t = t -> t diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml index 9f4361f4..badb15b5 100644 --- a/kernel/opaqueproof.ml +++ b/kernel/opaqueproof.ml @@ -43,7 +43,10 @@ let set_indirect_univ_accessor f = (get_univ := f) let create cu = Direct ([],cu) let turn_indirect dp o (prfs,odp) = match o with - | Indirect _ -> Errors.anomaly (Pp.str "Already an indirect opaque") + | Indirect (_,_,i) -> + if not (Int.Map.mem i prfs) + then Errors.anomaly (Pp.str "Indirect in a different table") + else Errors.anomaly (Pp.str "Already an indirect opaque") | Direct (d,cu) -> let cu = Future.chain ~pure:true cu (fun (c, u) -> hcons_constr c, u) in let id = Int.Map.cardinal prfs in diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml index 557ed3d7..5f3f559a 100644 --- a/kernel/pre_env.ml +++ b/kernel/pre_env.ml @@ -46,8 +46,7 @@ type globals = { type stratification = { env_universes : universes; - env_engagement : engagement option; - env_type_in_type : bool + env_engagement : engagement } type val_kind = @@ -95,8 +94,7 @@ let empty_env = { env_nb_rel = 0; env_stratification = { env_universes = initial_universes; - env_engagement = None; - env_type_in_type = false}; + env_engagement = (PredicativeSet,StratifiedType) }; env_conv_oracle = Conv_oracle.empty; retroknowledge = Retroknowledge.initial_retroknowledge; indirect_pterms = Opaqueproof.empty_opaquetab } diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli index 03ac41b4..0ce0bed2 100644 --- a/kernel/pre_env.mli +++ b/kernel/pre_env.mli @@ -33,8 +33,7 @@ type globals = { type stratification = { env_universes : universes; - env_engagement : engagement option; - env_type_in_type : bool + env_engagement : engagement } type lazy_val diff --git a/kernel/reduction.ml b/kernel/reduction.ml index b09367dd..892557ac 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -26,8 +26,6 @@ open Environ open Closure open Esubst -let left2right = ref false - let rec is_empty_stack = function [] -> true | Zupdate _::s -> is_empty_stack s @@ -175,7 +173,7 @@ let is_cumul = function CUMUL -> true | CONV -> false type 'a universe_compare = { (* Might raise NotConvertible *) compare : env -> conv_pb -> sorts -> sorts -> 'a -> 'a; - compare_instances: bool -> Univ.Instance.t -> Univ.Instance.t -> 'a -> 'a; + compare_instances: flex:bool -> Univ.Instance.t -> Univ.Instance.t -> 'a -> 'a; } type 'a universe_state = 'a * 'a universe_compare @@ -187,8 +185,10 @@ type 'a infer_conversion_function = env -> Univ.universes -> 'a -> 'a -> Univ.co let sort_cmp_universes env pb s0 s1 (u, check) = (check.compare env pb s0 s1 u, check) -let convert_instances flex u u' (s, check) = - (check.compare_instances flex u u' s, check) +(* [flex] should be true for constants, false for inductive types and + constructors. *) +let convert_instances ~flex u u' (s, check) = + (check.compare_instances ~flex u u' s, check) let conv_table_key infos k1 k2 cuniv = if k1 == k2 then cuniv else @@ -198,7 +198,7 @@ let conv_table_key infos k1 k2 cuniv = else let flex = evaluable_constant cst (info_env infos) && RedFlags.red_set (info_flags infos) (RedFlags.fCONST cst) - in convert_instances flex u u' cuniv + in convert_instances ~flex u u' cuniv | VarKey id, VarKey id' when Id.equal id id' -> cuniv | RelKey n, RelKey n' when Int.equal n n' -> cuniv | _ -> raise NotConvertible @@ -210,9 +210,7 @@ let compare_stacks f fmind lft1 stk1 lft2 stk2 cuniv = let cu1 = cmp_rec s1 s2 cuniv in (match (z1,z2) with | (Zlapp a1,Zlapp a2) -> - if !left2right then - Array.fold_left2 (fun cu x y -> f x y cu) cu1 a1 a2 - else Array.fold_right2 f a1 a2 cu1 + Array.fold_right2 f a1 a2 cu1 | (Zlproj (c1,l1),Zlproj (c2,l2)) -> if not (eq_constant c1 c2) then raise NotConvertible @@ -594,7 +592,7 @@ let check_sort_cmp_universes env pb s0 s1 univs = let checked_sort_cmp_universes env pb s0 s1 univs = check_sort_cmp_universes env pb s0 s1 univs; univs -let check_convert_instances _flex u u' univs = +let check_convert_instances ~flex u u' univs = if Univ.Instance.check_eq univs u u' then univs else raise NotConvertible @@ -634,10 +632,10 @@ let infer_cmp_universes env pb s0 s1 univs = | CONV -> infer_eq univs u1 u2) else univs -let infer_convert_instances flex u u' (univs,cstrs) = +let infer_convert_instances ~flex u u' (univs,cstrs) = (univs, Univ.enforce_eq_instances u u' cstrs) -let infered_universes : (Univ.universes * Univ.Constraint.t) universe_compare = +let inferred_universes : (Univ.universes * Univ.Constraint.t) universe_compare = { compare = infer_cmp_universes; compare_instances = infer_convert_instances } @@ -670,7 +668,7 @@ let trans_conv_universes ?(l2r=false) ?(evars=fun _->None) reds = let trans_conv_leq_universes ?(l2r=false) ?(evars=fun _->None) reds = trans_fconv_universes reds CUMUL l2r evars -let fconv = trans_fconv (Id.Pred.full, Cpred.full) +let fconv = trans_fconv full_transparent_state let conv_cmp ?(l2r=false) cv_pb = fconv cv_pb l2r (fun _->None) let conv ?(l2r=false) ?(evars=fun _->None) = fconv CONV l2r evars @@ -685,7 +683,7 @@ let conv_leq_vecti ?(l2r=false) ?(evars=fun _->None) env v1 v2 = v1 v2 -let generic_conv cv_pb l2r evars reds env univs t1 t2 = +let generic_conv cv_pb ~l2r evars reds env univs t1 t2 = let (s, _) = clos_fconv reds cv_pb l2r evars env univs t1 t2 in s @@ -697,7 +695,7 @@ let infer_conv_universes cv_pb l2r evars reds env univs t1 t2 = in if b then cstrs else - let univs = ((univs, Univ.Constraint.empty), infered_universes) in + let univs = ((univs, Univ.Constraint.empty), inferred_universes) in let ((_,cstrs), _) = clos_fconv reds cv_pb l2r evars env univs t1 t2 in cstrs @@ -716,39 +714,19 @@ let infer_conv_leq ?(l2r=false) ?(evars=fun _ -> None) ?(ts=full_transparent_sta env univs t1 t2 = infer_conv_universes CUMUL l2r evars ts env univs t1 t2 -(* option for conversion *) -let nat_conv = ref (fun cv_pb sigma -> - fconv cv_pb false (sigma.Nativelambda.evars_val)) -let set_nat_conv f = nat_conv := f - -let native_conv cv_pb sigma env t1 t2 = - if eq_constr t1 t2 then () - else begin - let t1 = (it_mkLambda_or_LetIn t1 (rel_context env)) in - let t2 = (it_mkLambda_or_LetIn t2 (rel_context env)) in - !nat_conv cv_pb sigma env t1 t2 - end - +(* This reference avoids always having to link C code with the kernel *) let vm_conv = ref (fun cv_pb -> fconv cv_pb false (fun _->None)) let set_vm_conv f = vm_conv := f let vm_conv cv_pb env t1 t2 = try !vm_conv cv_pb env t1 t2 with Not_found | Invalid_argument _ -> - (* If compilation fails, fall-back to closure conversion *) - fconv cv_pb false (fun _->None) env t1 t2 - - -let default_conv = ref (fun cv_pb ?(l2r=false) -> fconv cv_pb l2r (fun _->None)) - -let set_default_conv f = default_conv := f + (Pp.msg_warning + (Pp.str "Bytecode compilation failed, falling back to default conversion"); + fconv cv_pb false (fun _->None) env t1 t2) let default_conv cv_pb ?(l2r=false) env t1 t2 = - try - !default_conv ~l2r cv_pb env t1 t2 - with Not_found | Invalid_argument _ -> - (* If compilation fails, fall-back to closure conversion *) - fconv cv_pb false (fun _->None) env t1 t2 + fconv cv_pb false (fun _ -> None) env t1 t2 let default_conv_leq = default_conv CUMUL (* diff --git a/kernel/reduction.mli b/kernel/reduction.mli index 6ced5c49..0df26d62 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -10,8 +10,6 @@ open Term open Context open Environ -val left2right : bool ref - (*********************************************************************** s Reduction functions *) @@ -39,7 +37,7 @@ type conv_pb = CONV | CUMUL type 'a universe_compare = { (* Might raise NotConvertible *) compare : env -> conv_pb -> sorts -> sorts -> 'a -> 'a; - compare_instances: bool (* Instance of a flexible constant? *) -> + compare_instances: flex:bool -> Univ.Instance.t -> Univ.Instance.t -> 'a -> 'a; } @@ -49,14 +47,16 @@ type ('a,'b) generic_conversion_function = env -> 'b universe_state -> 'a -> 'a type 'a infer_conversion_function = env -> Univ.universes -> 'a -> 'a -> Univ.constraints -val check_sort_cmp_universes : - env -> conv_pb -> sorts -> sorts -> Univ.universes -> unit +val sort_cmp_universes : env -> conv_pb -> sorts -> sorts -> + 'a * 'a universe_compare -> 'a * 'a universe_compare -(* val sort_cmp : *) -(* conv_pb -> sorts -> sorts -> Univ.constraints -> Univ.constraints *) +(* [flex] should be true for constants, false for inductive types and +constructors. *) +val convert_instances : flex:bool -> Univ.Instance.t -> Univ.Instance.t -> + 'a * 'a universe_compare -> 'a * 'a universe_compare -(* val conv_sort : sorts conversion_function *) -(* val conv_sort_leq : sorts conversion_function *) +val checked_universes : Univ.universes universe_compare +val inferred_universes : (Univ.universes * Univ.Constraint.t) universe_compare val trans_conv_cmp : ?l2r:bool -> conv_pb -> constr trans_conversion_function val trans_conv : @@ -77,23 +77,20 @@ val conv_leq : val conv_leq_vecti : ?l2r:bool -> ?evars:(existential->constr option) -> types array conversion_function +(** These conversion functions are used by module subtyping, which needs to infer + universe constraints inside the kernel *) val infer_conv : ?l2r:bool -> ?evars:(existential->constr option) -> ?ts:Names.transparent_state -> constr infer_conversion_function val infer_conv_leq : ?l2r:bool -> ?evars:(existential->constr option) -> ?ts:Names.transparent_state -> types infer_conversion_function -val generic_conv : conv_pb -> bool -> (existential->constr option) -> +val generic_conv : conv_pb -> l2r:bool -> (existential->constr option) -> Names.transparent_state -> (constr,'a) generic_conversion_function (** option for conversion *) val set_vm_conv : (conv_pb -> types conversion_function) -> unit val vm_conv : conv_pb -> types conversion_function -val set_nat_conv : - (conv_pb -> Nativelambda.evars -> types conversion_function) -> unit -val native_conv : conv_pb -> Nativelambda.evars -> types conversion_function - -val set_default_conv : (conv_pb -> ?l2r:bool -> types conversion_function) -> unit val default_conv : conv_pb -> ?l2r:bool -> types conversion_function val default_conv_leq : ?l2r:bool -> types conversion_function diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index d762a246..e0a07dcc 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -81,8 +81,7 @@ open Declarations These fields could be deduced from [revstruct], but they allow faster name freshness checks. - [univ] and [future_cst] : current and future universe constraints - - [engagement] : are we Set-impredicative? - - [type_in_type] : does the universe hierarchy collapse? + - [engagement] : are we Set-impredicative? does the universe hierarchy collapse? - [required] : names and digests of Require'd libraries since big-bang. This field will only grow - [loads] : list of libraries Require'd inside the current module. @@ -119,13 +118,13 @@ type safe_environment = revstruct : structure_body; modlabels : Label.Set.t; objlabels : Label.Set.t; - univ : Univ.constraints; - future_cst : Univ.constraints Future.computation list; + univ : Univ.ContextSet.t; + future_cst : Univ.ContextSet.t Future.computation list; engagement : engagement option; - type_in_type : bool; required : vodigest DPMap.t; loads : (module_path * module_body) list; - local_retroknowledge : Retroknowledge.action list } + local_retroknowledge : Retroknowledge.action list; + native_symbols : Nativecode.symbols DPMap.t } and modvariant = | NONE @@ -149,12 +148,12 @@ let empty_environment = modlabels = Label.Set.empty; objlabels = Label.Set.empty; future_cst = []; - univ = Univ.Constraint.empty; + univ = Univ.ContextSet.empty; engagement = None; - type_in_type = false; required = DPMap.empty; loads = []; - local_retroknowledge = [] } + local_retroknowledge = []; + native_symbols = DPMap.empty } let is_initial senv = match senv.revstruct, senv.modvariant with @@ -182,16 +181,20 @@ let set_engagement c senv = (** Check that the engagement [c] expected by a library matches the current (initial) one *) -let check_engagement env c = - match Environ.engagement env, c with - | None, Some ImpredicativeSet -> - Errors.error "Needs option -impredicative-set." - | _ -> () - -let set_type_in_type senv = - { senv with - env = Environ.set_type_in_type senv.env; - type_in_type = true } +let check_engagement env (expected_impredicative_set,expected_type_in_type) = + let impredicative_set,type_in_type = Environ.engagement env in + begin + match impredicative_set, expected_impredicative_set with + | PredicativeSet, ImpredicativeSet -> + Errors.error "Needs option -impredicative-set." + | _ -> () + end; + begin + match type_in_type, expected_type_in_type with + | StratifiedType, TypeInType -> + Errors.error "Needs option -type-in-type." + | _ -> () + end (** {6 Stm machinery } *) @@ -204,36 +207,79 @@ let get_opaque_body env cbo = (Opaqueproof.force_proof (Environ.opaque_tables env) opaque, Opaqueproof.force_constraints (Environ.opaque_tables env) opaque) -let sideff_of_con env c = +type private_constant = Entries.side_effect +type private_constants = private_constant list + +type private_constant_role = Term_typing.side_effect_role = + | Subproof + | Schema of inductive * string + +let empty_private_constants = [] +let add_private x xs = x :: xs +let concat_private xs ys = xs @ ys +let mk_pure_proof = Term_typing.mk_pure_proof +let inline_private_constants_in_constr = Term_typing.inline_side_effects +let inline_private_constants_in_definition_entry = Term_typing.inline_entry_side_effects +let side_effects_of_private_constants x = Term_typing.uniq_seff (List.rev x) + +let constant_entry_of_private_constant = function + | { Entries.eff = Entries.SEsubproof (kn, cb, eff_env) } -> + [ kn, Term_typing.constant_entry_of_side_effect cb eff_env ] + | { Entries.eff = Entries.SEscheme (l,_) } -> + List.map (fun (_,kn,cb,eff_env) -> + kn, Term_typing.constant_entry_of_side_effect cb eff_env) l + +let private_con_of_con env c = let cbo = Environ.lookup_constant c env.env in - SEsubproof (c, cbo, get_opaque_body env.env cbo) -let sideff_of_scheme kind env cl = - SEscheme( - List.map (fun (i,c) -> - let cbo = Environ.lookup_constant c env.env in - i, c, cbo, get_opaque_body env.env cbo) cl, - kind) + { Entries.from_env = Ephemeron.create env.revstruct; + Entries.eff = Entries.SEsubproof (c,cbo,get_opaque_body env.env cbo) } + +let private_con_of_scheme ~kind env cl = + { Entries.from_env = Ephemeron.create env.revstruct; + Entries.eff = Entries.SEscheme( + List.map (fun (i,c) -> + let cbo = Environ.lookup_constant c env.env in + i, c, cbo, get_opaque_body env.env cbo) cl, + kind) } + +let universes_of_private eff = + let open Declarations in + List.fold_left (fun acc { Entries.eff } -> + match eff with + | Entries.SEscheme (l,s) -> + List.fold_left (fun acc (_,_,cb,c) -> + let acc = match c with + | `Nothing -> acc + | `Opaque (_, ctx) -> ctx :: acc in + if cb.const_polymorphic then acc + else (Univ.ContextSet.of_context cb.const_universes) :: acc) + acc l + | Entries.SEsubproof (c, cb, e) -> + if cb.const_polymorphic then acc + else Univ.ContextSet.of_context cb.const_universes :: acc) + [] eff let env_of_safe_env senv = senv.env let env_of_senv = env_of_safe_env type constraints_addition = - Now of Univ.constraints | Later of Univ.constraints Future.computation + | Now of bool * Univ.ContextSet.t + | Later of Univ.ContextSet.t Future.computation let add_constraints cst senv = match cst with | Later fc -> {senv with future_cst = fc :: senv.future_cst} - | Now cst -> + | Now (poly,cst) -> { senv with - env = Environ.add_constraints cst senv.env; - univ = Univ.Constraint.union cst senv.univ } + env = Environ.push_context_set ~strict:(not poly) cst senv.env; + univ = Univ.ContextSet.union cst senv.univ } let add_constraints_list cst senv = - List.fold_right add_constraints cst senv + List.fold_left (fun acc c -> add_constraints c acc) senv cst -let push_context_set ctx = add_constraints (Now (Univ.ContextSet.constraints ctx)) -let push_context ctx = add_constraints (Now (Univ.UContext.constraints ctx)) +let push_context_set poly ctx = add_constraints (Now (poly,ctx)) +let push_context poly ctx = add_constraints (Now (poly,Univ.ContextSet.of_context ctx)) let is_curmod_library senv = match senv.modvariant with LIBRARY -> true | _ -> false @@ -243,9 +289,11 @@ let join_safe_environment ?(except=Future.UUIDSet.empty) e = List.fold_left (fun e fc -> if Future.UUIDSet.mem (Future.uuid fc) except then e - else add_constraints (Now (Future.join fc)) e) + else add_constraints (Now (false, Future.join fc)) e) {e with future_cst = []} e.future_cst +let is_joined_environment e = List.is_empty e.future_cst + (** {6 Various checks } *) let exists_modlabel l senv = Label.Set.mem l senv.modlabels @@ -331,21 +379,22 @@ let safe_push_named (id,_,_ as d) env = let push_named_def (id,de) senv = - let c,typ,univs = Term_typing.translate_local_def senv.env id de in - let senv' = push_context univs senv in - let c, senv' = match c with - | Def c -> Mod_subst.force_constr c, senv' + let c,typ,univs = Term_typing.translate_local_def senv.revstruct senv.env id de in + let poly = de.Entries.const_entry_polymorphic in + let univs = Univ.ContextSet.of_context univs in + let c, univs = match c with + | Def c -> Mod_subst.force_constr c, univs | OpaqueDef o -> - Opaqueproof.force_proof (Environ.opaque_tables senv'.env) o, - push_context_set - (Opaqueproof.force_constraints (Environ.opaque_tables senv'.env) o) - senv' + Opaqueproof.force_proof (Environ.opaque_tables senv.env) o, + Univ.ContextSet.union univs + (Opaqueproof.force_constraints (Environ.opaque_tables senv.env) o) | _ -> assert false in + let senv' = push_context_set poly univs senv in let env'' = safe_push_named (id,Some c,typ) senv'.env in - {senv' with env=env''} + univs, {senv' with env=env''} -let push_named_assum ((id,t),ctx) senv = - let senv' = push_context_set ctx senv in +let push_named_assum ((id,t,poly),ctx) senv = + let senv' = push_context_set poly ctx senv in let t = Term_typing.translate_local_assum senv'.env t in let env'' = safe_push_named (id,None,t) senv'.env in {senv' with env=env''} @@ -368,10 +417,10 @@ let labels_of_mib mib = let globalize_constant_universes env cb = if cb.const_polymorphic then - [Now Univ.Constraint.empty] + [Now (true, Univ.ContextSet.empty)] else - let cstrs = Univ.UContext.constraints cb.const_universes in - Now cstrs :: + let cstrs = Univ.ContextSet.of_context cb.const_universes in + Now (false, cstrs) :: (match cb.const_body with | (Undef _ | Def _) -> [] | OpaqueDef lc -> @@ -379,23 +428,21 @@ let globalize_constant_universes env cb = | None -> [] | Some fc -> match Future.peek_val fc with - | None -> [Later (Future.chain - ~greedy:(not (Future.is_exn fc)) - ~pure:true fc Univ.ContextSet.constraints)] - | Some c -> [Now (Univ.ContextSet.constraints c)]) + | None -> [Later fc] + | Some c -> [Now (false, c)]) let globalize_mind_universes mb = if mb.mind_polymorphic then - [Now Univ.Constraint.empty] + [Now (true, Univ.ContextSet.empty)] else - [Now (Univ.UContext.constraints mb.mind_universes)] + [Now (false, Univ.ContextSet.of_context mb.mind_universes)] let constraints_of_sfb env sfb = match sfb with | SFBconst cb -> globalize_constant_universes env cb | SFBmind mib -> globalize_mind_universes mib - | SFBmodtype mtb -> [Now mtb.mod_constraints] - | SFBmodule mb -> [Now mb.mod_constraints] + | SFBmodtype mtb -> [Now (false, mtb.mod_constraints)] + | SFBmodule mb -> [Now (false, mb.mod_constraints)] (** A generic function for adding a new field in a same environment. It also performs the corresponding [add_constraints]. *) @@ -437,19 +484,16 @@ let update_resolver f senv = { senv with modresolver = f senv.modresolver } (** Insertion of constants and parameters in environment *) type global_declaration = - | ConstantEntry of Entries.constant_entry + | ConstantEntry of bool * private_constants Entries.constant_entry | GlobalRecipe of Cooking.recipe -let add_constant dir l decl senv = - let kn = make_con senv.modpath dir l in - let cb = match decl with - | ConstantEntry ce -> Term_typing.translate_constant senv.env kn ce - | GlobalRecipe r -> - let cb = Term_typing.translate_recipe senv.env kn r in - if DirPath.is_empty dir then Declareops.hcons_const_body cb else cb - in +type exported_private_constant = + constant * private_constants Entries.constant_entry * private_constant_role + +let add_constant_aux no_section senv (kn, cb) = + let l = pi3 (Constant.repr3 kn) in let cb, otab = match cb.const_body with - | OpaqueDef lc when DirPath.is_empty dir -> + | OpaqueDef lc when no_section -> (* In coqc, opaque constants outside sections will be stored indirectly in a specific table *) let od, otab = @@ -466,7 +510,32 @@ let add_constant dir l decl senv = (Mod_subst.add_inline_delta_resolver (user_con kn) (lev,None)) senv' | _ -> senv' in - kn, senv'' + senv'' + +let add_constant dir l decl senv = + let kn = make_con senv.modpath dir l in + let no_section = DirPath.is_empty dir in + let seff_to_export, decl = + match decl with + | ConstantEntry (true, ce) -> + let exports, ce = + Term_typing.export_side_effects senv.revstruct senv.env ce in + exports, ConstantEntry (false, ce) + | _ -> [], decl + in + let senv = + List.fold_left (add_constant_aux no_section) senv + (List.map (fun (kn,cb,_,_) -> kn, cb) seff_to_export) in + let senv = + let cb = + match decl with + | ConstantEntry (export_seff,ce) -> + Term_typing.translate_constant senv.revstruct senv.env kn ce + | GlobalRecipe r -> + let cb = Term_typing.translate_recipe senv.env kn r in + if no_section then Declareops.hcons_const_body cb else cb in + add_constant_aux no_section senv (kn, cb) in + (kn, List.map (fun (kn,_,ce,r) -> kn, ce, r) seff_to_export), senv (** Insertion of inductive types *) @@ -498,13 +567,13 @@ let add_modtype l params_mte inl senv = (** full_add_module adds module with universes and constraints *) let full_add_module mb senv = - let senv = add_constraints (Now mb.mod_constraints) senv in + let senv = add_constraints (Now (false, mb.mod_constraints)) senv in let dp = ModPath.dp mb.mod_mp in let linkinfo = Nativecode.link_info_of_dirpath dp in { senv with env = Modops.add_linked_module mb linkinfo senv.env } let full_add_module_type mp mt senv = - let senv = add_constraints (Now mt.mod_constraints) senv in + let senv = add_constraints (Now (false, mt.mod_constraints)) senv in { senv with env = Modops.add_module_type mp mt senv.env } (** Insertion of modules *) @@ -612,8 +681,8 @@ let propagate_senv newdef newenv newresolver senv oldsenv = modlabels = Label.Set.add (fst newdef) oldsenv.modlabels; univ = List.fold_left (fun acc cst -> - Univ.Constraint.union acc (Future.force cst)) - (Univ.Constraint.union senv.univ oldsenv.univ) + Univ.ContextSet.union acc (Future.force cst)) + (Univ.ContextSet.union senv.univ oldsenv.univ) now_cst; future_cst = later_cst @ oldsenv.future_cst; (* engagement is propagated to the upper level *) @@ -621,7 +690,8 @@ let propagate_senv newdef newenv newresolver senv oldsenv = required = senv.required; loads = senv.loads@oldsenv.loads; local_retroknowledge = - senv.local_retroknowledge@oldsenv.local_retroknowledge } + senv.local_retroknowledge@oldsenv.local_retroknowledge; + native_symbols = senv.native_symbols} let end_module l restype senv = let mp = senv.modpath in @@ -635,8 +705,8 @@ let end_module l restype senv = let senv'= propagate_loads { senv with env = newenv; - univ = Univ.Constraint.union senv.univ mb.mod_constraints} in - let newenv = Environ.add_constraints mb.mod_constraints senv'.env in + univ = Univ.ContextSet.union senv.univ mb.mod_constraints} in + let newenv = Environ.push_context_set ~strict:true mb.mod_constraints senv'.env in let newenv = Modops.add_module mb newenv in let newresolver = if Modops.is_functor mb.mod_type then oldsenv.modresolver @@ -661,7 +731,7 @@ let end_modtype l senv = let () = check_empty_context senv in let mbids = List.rev_map fst params in let newenv = Environ.set_opaque_tables oldsenv.env (Environ.opaque_tables senv.env) in - let newenv = Environ.add_constraints senv.univ newenv in + let newenv = Environ.push_context_set ~strict:true senv.univ newenv in let newenv = set_engagement_opt newenv senv.engagement in let senv' = propagate_loads {senv with env=newenv} in let auto_tb = functorize params (NoFunctor (List.rev senv.revstruct)) in @@ -676,38 +746,32 @@ let end_modtype l senv = let add_include me is_module inl senv = let open Mod_typing in let mp_sup = senv.modpath in - let sign,cst,resolver = - if is_module then - let sign,_,reso,cst = translate_mse_incl senv.env mp_sup inl me in - sign,cst,reso - else - let mtb = translate_modtype senv.env mp_sup inl ([],me) in - mtb.mod_type,mtb.mod_constraints,mtb.mod_delta + let sign,_,resolver,cst = + translate_mse_incl is_module senv.env mp_sup inl me in - let senv = add_constraints (Now cst) senv in + let senv = add_constraints (Now (false, cst)) senv in (* Include Self support *) let rec compute_sign sign mb resolver senv = match sign with | MoreFunctor(mbid,mtb,str) -> let cst_sub = Subtyping.check_subtypes senv.env mb mtb in - let senv = add_constraints (Now cst_sub) senv in + let senv = + add_constraints + (Now (false, Univ.ContextSet.add_constraints cst_sub Univ.ContextSet.empty)) + senv in let mpsup_delta = Modops.inline_delta_resolver senv.env inl mp_sup mbid mtb mb.mod_delta in let subst = Mod_subst.map_mbid mbid mp_sup mpsup_delta in let resolver = Mod_subst.subst_codom_delta_resolver subst resolver in compute_sign (Modops.subst_signature subst str) mb resolver senv - | str -> resolver,str,senv + | NoFunctor str -> resolver,str,senv in - let resolver,sign,senv = + let resolver,str,senv = let struc = NoFunctor (List.rev senv.revstruct) in - let mtb = build_mtb mp_sup struc Univ.Constraint.empty senv.modresolver in + let mtb = build_mtb mp_sup struc Univ.ContextSet.empty senv.modresolver in compute_sign sign mtb resolver senv in - let str = match sign with - | NoFunctor struc -> struc - | MoreFunctor _ -> Modops.error_higher_order_include () - in let senv = update_resolver (Mod_subst.add_delta_resolver resolver) senv in let add senv ((l,elem) as field) = @@ -729,12 +793,15 @@ type compiled_library = { comp_name : DirPath.t; comp_mod : module_body; comp_deps : library_info array; - comp_enga : engagement option; - comp_natsymbs : Nativecode.symbol array + comp_enga : engagement; + comp_natsymbs : Nativecode.symbols } type native_library = Nativecode.global list +let get_library_native_symbols senv dir = + DPMap.find dir senv.native_symbols + (** FIXME: MS: remove?*) let current_modpath senv = senv.modpath let current_dirpath senv = Names.ModPath.dp (current_modpath senv) @@ -771,17 +838,17 @@ let export ?except senv dir = mod_retroknowledge = senv.local_retroknowledge } in - let ast, values = - if !Flags.no_native_compiler then [], [||] - else + let ast, symbols = + if !Flags.native_compiler then Nativelibrary.dump_library mp dir senv.env str + else [], Nativecode.empty_symbols in let lib = { comp_name = dir; comp_mod = mb; comp_deps = Array.of_list (DPMap.bindings senv.required); comp_enga = Environ.engagement senv.env; - comp_natsymbs = values } + comp_natsymbs = symbols } in mp, lib, ast @@ -792,9 +859,11 @@ let import lib cst vodigest senv = check_engagement senv.env lib.comp_enga; let mp = MPfile lib.comp_name in let mb = lib.comp_mod in - let env = Environ.add_constraints mb.mod_constraints senv.env in - let env = Environ.push_context_set cst env in - (mp, lib.comp_natsymbs), + let env = Environ.push_context_set ~strict:true + (Univ.ContextSet.union mb.mod_constraints cst) + senv.env + in + mp, { senv with env = (let linkinfo = @@ -803,7 +872,8 @@ let import lib cst vodigest senv = Modops.add_linked_module mb linkinfo env); modresolver = Mod_subst.add_delta_resolver mb.mod_delta senv.modresolver; required = DPMap.add lib.comp_name vodigest senv.required; - loads = (mp,mb)::senv.loads } + loads = (mp,mb)::senv.loads; + native_symbols = DPMap.add lib.comp_name lib.comp_natsymbs senv.native_symbols } (** {6 Safe typing } *) @@ -845,7 +915,9 @@ let register_inline kn senv = let env = { env with env_globals = new_globals } in { senv with env = env_of_pre_env env } -let add_constraints c = add_constraints (Now c) +let add_constraints c = + add_constraints + (Now (false, Univ.ContextSet.add_constraints c Univ.ContextSet.empty)) (* NB: The next old comment probably refers to [propagate_loads] above. diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index abd5cd7a..2214cf8b 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -39,10 +39,30 @@ type 'a safe_transformer = safe_environment -> 'a * safe_environment (** {6 Stm machinery } *) -val sideff_of_con : safe_environment -> constant -> Declarations.side_effect -val sideff_of_scheme : - string -> safe_environment -> (inductive * constant) list -> - Declarations.side_effect +type private_constant +type private_constants + +type private_constant_role = + | Subproof + | Schema of inductive * string + +val side_effects_of_private_constants : + private_constants -> Entries.side_effects + +val empty_private_constants : private_constants +val add_private : private_constant -> private_constants -> private_constants +val concat_private : private_constants -> private_constants -> private_constants + +val private_con_of_con : safe_environment -> constant -> private_constant +val private_con_of_scheme : kind:string -> safe_environment -> (inductive * constant) list -> private_constant + +val mk_pure_proof : Constr.constr -> private_constants Entries.proof_output +val inline_private_constants_in_constr : + Environ.env -> Constr.constr -> private_constants -> Constr.constr +val inline_private_constants_in_definition_entry : + Environ.env -> private_constants Entries.definition_entry -> private_constants Entries.definition_entry + +val universes_of_private : private_constants -> Univ.universe_context_set list val is_curmod_library : safe_environment -> bool @@ -51,23 +71,35 @@ val is_curmod_library : safe_environment -> bool val join_safe_environment : ?except:Future.UUIDSet.t -> safe_environment -> safe_environment +val is_joined_environment : safe_environment -> bool (** {6 Enriching a safe environment } *) (** Insertion of local declarations (Local or Variables) *) val push_named_assum : - (Id.t * Term.types) Univ.in_universe_context_set -> safe_transformer0 + (Id.t * Term.types * bool (* polymorphic *)) + Univ.in_universe_context_set -> safe_transformer0 + +(** Returns the full universe context necessary to typecheck the definition + (futures are forced) *) val push_named_def : - Id.t * Entries.definition_entry -> safe_transformer0 + Id.t * private_constants Entries.definition_entry -> Univ.universe_context_set safe_transformer (** Insertion of global axioms or definitions *) type global_declaration = - | ConstantEntry of Entries.constant_entry + (* bool: export private constants *) + | ConstantEntry of bool * private_constants Entries.constant_entry | GlobalRecipe of Cooking.recipe +type exported_private_constant = + constant * private_constants Entries.constant_entry * private_constant_role + +(** returns the main constant plus a list of auxiliary constants (empty + unless one requires the side effects to be exported) *) val add_constant : - DirPath.t -> Label.t -> global_declaration -> constant safe_transformer + DirPath.t -> Label.t -> global_declaration -> + (constant * exported_private_constant list) safe_transformer (** Adding an inductive type *) @@ -87,10 +119,10 @@ val add_modtype : (** Adding universe constraints *) val push_context_set : - Univ.universe_context_set -> safe_transformer0 + bool -> Univ.universe_context_set -> safe_transformer0 val push_context : - Univ.universe_context -> safe_transformer0 + bool -> Univ.universe_context -> safe_transformer0 val add_constraints : Univ.constraints -> safe_transformer0 @@ -98,12 +130,9 @@ val add_constraints : (* (\** Generator of universes *\) *) (* val next_universe : int safe_transformer *) -(** Setting the strongly constructive or classical logical engagement *) +(** Setting the type theory flavor *) val set_engagement : Declarations.engagement -> safe_transformer0 -(** Collapsing the type hierarchy *) -val set_type_in_type : safe_transformer0 - (** {6 Interactive module functions } *) val start_module : Label.t -> module_path safe_transformer @@ -136,6 +165,8 @@ type compiled_library type native_library = Nativecode.global list +val get_library_native_symbols : safe_environment -> DirPath.t -> Nativecode.symbols + val start_library : DirPath.t -> module_path safe_transformer val export : @@ -145,7 +176,7 @@ val export : (* Constraints are non empty iff the file is a vi2vo *) val import : compiled_library -> Univ.universe_context_set -> vodigest -> - (module_path * Nativecode.symbol array) safe_transformer + module_path safe_transformer (** {6 Safe typing judgments } *) diff --git a/kernel/sorts.ml b/kernel/sorts.ml index ae86d686..e2854abf 100644 --- a/kernel/sorts.ml +++ b/kernel/sorts.ml @@ -26,8 +26,8 @@ let univ_of_sort = function | Prop Null -> Universe.type0m let sort_of_univ u = - if is_type0m_univ u then Prop Null - else if is_type0_univ u then Prop Pos + if is_type0m_univ u then prop + else if is_type0_univ u then set else Type u let compare s1 s2 = @@ -62,6 +62,8 @@ let is_small = function let family = function | Prop Null -> InProp | Prop Pos -> InSet + | Type u when is_type0m_univ u -> InProp + | Type u when is_type0_univ u -> InSet | Type _ -> InType let family_equal = (==) @@ -76,7 +78,7 @@ let hash = function in combinesmall 1 h | Type u -> - let h = Hashtbl.hash u in (** FIXME *) + let h = Univ.Universe.hash u in combinesmall 2 h module List = struct @@ -101,7 +103,7 @@ module Hsorts = | (Type u1, Type u2) -> u1 == u2 |_ -> false - let hash = Hashtbl.hash (** FIXME *) + let hash = hash end) let hcons = Hashcons.simple_hcons Hsorts.generate Hsorts.hcons hcons_univ diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index db155e6c..58f3bcdf 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -311,15 +311,19 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = try (* The environment with the expected universes plus equality of the body instances with the expected instance *) - let env = Environ.add_constraints cstrs env in - (* Check that the given definition does not add any constraint over - the expected ones, so that it can be used in place of the original. *) + let ctxi = Univ.Instance.append inst1 inst2 in + let ctx = Univ.UContext.make (ctxi, cstrs) in + let env = Environ.push_context ctx env in + (* Check that the given definition does not add any constraint over + the expected ones, so that it can be used in place of + the original. *) if Univ.check_constraints ctx1 (Environ.universes env) then cstrs, env, inst2 else error (IncompatibleConstraints ctx1) with Univ.UniverseInconsistency incon -> error (IncompatibleUniverses incon) - else cst, env, Univ.Instance.empty + else + cst, env, Univ.Instance.empty in (* Now check types *) let typ1 = Typeops.type_of_constant_type env' cb1.const_type in @@ -456,6 +460,7 @@ and check_modtypes cst env mtb1 mtb2 subst1 subst2 equiv = let check_subtypes env sup super = let env = add_module_type sup.mod_mp sup env in + let env = Environ.push_context_set ~strict:true super.mod_constraints env in check_modtypes Univ.Constraint.empty env (strengthen sup sup.mod_mp) super empty_subst (map_mp super.mod_mp sup.mod_mp sup.mod_delta) false diff --git a/kernel/term.ml b/kernel/term.ml index 7bf4c818..33ed25fe 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -566,8 +566,10 @@ let decompose_lam_assum = in lamdec_rec empty_rel_context -(* Given a positive integer n, transforms a product term (x1:T1)..(xn:Tn)T - into the pair ([(xn,Tn);...;(x1,T1)],T) *) +(* Given a positive integer n, decompose a product or let-in term + of the form [forall (x1:T1)..(xi:=ci:Ti)..(xn:Tn), T] into the pair + of the quantifying context [(xn,None,Tn);..;(xi,Some + ci,Ti);..;(x1,None,T1)] and of the inner type [T]) *) let decompose_prod_n_assum n = if n < 0 then error "decompose_prod_n_assum: integer parameter must be positive"; @@ -581,10 +583,12 @@ let decompose_prod_n_assum n = in prodec_rec empty_rel_context n -(* Given a positive integer n, transforms a lambda term [x1:T1]..[xn:Tn]T - into the pair ([(xn,Tn);...;(x1,T1)],T) +(* Given a positive integer n, decompose a lambda or let-in term [fun + (x1:T1)..(xi:=ci:Ti)..(xn:Tn) => T] into the pair of the abstracted + context [(xn,None,Tn);...;(xi,Some ci,Ti);...;(x1,None,T1)] and of + the inner body [T]. Lets in between are not expanded but turn into local definitions, - but n is the actual number of destructurated lambdas. *) + but n is the actual number of destructurated lambdas. *) let decompose_lam_n_assum n = if n < 0 then error "decompose_lam_n_assum: integer parameter must be positive"; @@ -598,6 +602,20 @@ let decompose_lam_n_assum n = in lamdec_rec empty_rel_context n +(* Same, counting let-in *) +let decompose_lam_n_decls n = + if n < 0 then + error "decompose_lam_n_decls: integer parameter must be positive"; + let rec lamdec_rec l n c = + if Int.equal n 0 then l,c + else match kind_of_term c with + | Lambda (x,t,c) -> lamdec_rec (add_rel_decl (x,None,t) l) (n-1) c + | LetIn (x,b,t,c) -> lamdec_rec (add_rel_decl (x,Some b,t) l) (n-1) c + | Cast (c,_,_) -> lamdec_rec l n c + | c -> error "decompose_lam_n_decls: not enough abstractions" + in + lamdec_rec empty_rel_context n + (* (nb_lam [na1:T1]...[nan:Tan]c) where c is not an abstraction * gives n (casts are ignored) *) let nb_lam = diff --git a/kernel/term.mli b/kernel/term.mli index 501aaf74..d6071641 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -281,13 +281,15 @@ val decompose_prod : constr -> (Name.t*constr) list * constr {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %}, where {% $ %}T{% $ %} is not a lambda. *) val decompose_lam : constr -> (Name.t*constr) list * constr -(** Given a positive integer n, transforms a product term +(** Given a positive integer n, decompose a product term {% $ %}(x_1:T_1)..(x_n:T_n)T{% $ %} - into the pair {% $ %}([(xn,Tn);...;(x1,T1)],T){% $ %}. *) + into the pair {% $ %}([(xn,Tn);...;(x1,T1)],T){% $ %}. + Raise a user error if not enough products. *) val decompose_prod_n : int -> constr -> (Name.t * constr) list * constr -(** Given a positive integer {% $ %}n{% $ %}, transforms a lambda term - {% $ %}[x_1:T_1]..[x_n:T_n]T{% $ %} into the pair {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %} *) +(** Given a positive integer {% $ %}n{% $ %}, decompose a lambda term + {% $ %}[x_1:T_1]..[x_n:T_n]T{% $ %} into the pair {% $ %}([(x_n,T_n);...;(x_1,T_1)],T){% $ %}. + Raise a user error if not enough lambdas. *) val decompose_lam_n : int -> constr -> (Name.t * constr) list * constr (** Extract the premisses and the conclusion of a term of the form @@ -297,10 +299,15 @@ val decompose_prod_assum : types -> rel_context * types (** Idem with lambda's *) val decompose_lam_assum : constr -> rel_context * constr -(** Idem but extract the first [n] premisses *) +(** Idem but extract the first [n] premisses, counting let-ins. *) val decompose_prod_n_assum : int -> types -> rel_context * types + +(** Idem for lambdas, _not_ counting let-ins *) val decompose_lam_n_assum : int -> constr -> rel_context * constr +(** Idem, counting let-ins *) +val decompose_lam_n_decls : int -> constr -> rel_context * constr + (** [nb_lam] {% $ %}[x_1:T_1]...[x_n:T_n]c{% $ %} where {% $ %}c{% $ %} is not an abstraction gives {% $ %}n{% $ %} (casts are ignored) *) val nb_lam : constr -> int @@ -308,12 +315,14 @@ val nb_lam : constr -> int (** Similar to [nb_lam], but gives the number of products instead *) val nb_prod : constr -> int -(** Returns the premisses/parameters of a type/term (let-in included) *) +(** Return the premisses/parameters of a type/term (let-in included) *) val prod_assum : types -> rel_context val lam_assum : constr -> rel_context -(** Returns the first n-th premisses/parameters of a type/term (let included)*) +(** Return the first n-th premisses/parameters of a type (let included and counted) *) val prod_n_assum : int -> types -> rel_context + +(** Return the first n-th premisses/parameters of a term (let included but not counted) *) val lam_n_assum : int -> constr -> rel_context (** Remove the premisses/parameters of a type/term *) @@ -328,11 +337,11 @@ val strip_lam_n : int -> constr -> constr val strip_prod_assum : types -> types val strip_lam_assum : constr -> constr -(** flattens application lists *) +(** Flattens application lists *) val collapse_appl : constr -> constr -(** Removes recursively the casts around a term i.e. +(** Remove recursively the casts around a term i.e. [strip_outer_cast (Cast (Cast ... (Cast c, t) ... ))] is [c]. *) val strip_outer_cast : constr -> constr @@ -352,10 +361,10 @@ type arity = rel_context * sorts (** Build an "arity" from its canonical form *) val mkArity : arity -> types -(** Destructs an "arity" into its canonical form *) +(** Destruct an "arity" into its canonical form *) val destArity : types -> arity -(** Tells if a term has the form of an arity *) +(** Tell if a term has the form of an arity *) val isArity : types -> bool (** {5 Kind of type} *) diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index a316b449..a566028d 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -43,10 +43,29 @@ let map_option_typ = function None -> `None | Some x -> `Some x (* Insertion of constants and parameters in environment. *) -let mk_pure_proof c = (c, Univ.ContextSet.empty), Declareops.no_seff +let mk_pure_proof c = (c, Univ.ContextSet.empty), [] -let handle_side_effects env body side_eff = - let handle_sideff t se = +let equal_eff e1 e2 = + let open Entries in + match e1, e2 with + | { eff = SEsubproof (c1,_,_) }, { eff = SEsubproof (c2,_,_) } -> + Names.Constant.equal c1 c2 + | { eff = SEscheme (cl1,_) }, { eff = SEscheme (cl2,_) } -> + CList.for_all2eq + (fun (_,c1,_,_) (_,c2,_,_) -> Names.Constant.equal c1 c2) + cl1 cl2 + | _ -> false + +let rec uniq_seff = function + | [] -> [] + | x :: xs -> x :: uniq_seff (List.filter (fun y -> not (equal_eff x y)) xs) +(* The list of side effects is in reverse order (most recent first). + * To keep the "topological" order between effects we have to uniq-ize from + * the tail *) +let uniq_seff l = List.rev (uniq_seff (List.rev l)) + +let inline_side_effects env body ctx side_eff = + let handle_sideff (t,ctx,sl) { eff = se; from_env = mb } = let cbl = match se with | SEsubproof (c,cb,b) -> [c,cb,b] | SEscheme (cl,_) -> List.map (fun (_,c,cb,b) -> c,cb,b) cl in @@ -65,8 +84,8 @@ let handle_side_effects env body side_eff = let rec sub_body c u b i x = match kind_of_term x with | Const (c',u') when eq_constant c c' -> Vars.subst_instance_constr u' b - | _ -> map_constr_with_binders ((+) 1) (fun i x -> sub_body c u b i x) i x in - let fix_body (c,cb,b) t = + | _ -> map_constr_with_binders ((+) 1) (sub_body c u b) i x in + let fix_body (c,cb,b) (t,ctx) = match cb.const_body, b with | Def b, _ -> let b = Mod_subst.force_constr b in @@ -74,37 +93,86 @@ let handle_side_effects env body side_eff = if not poly then let b_ty = Typeops.type_of_constant_type env cb.const_type in let t = sub c 1 (Vars.lift 1 t) in - mkLetIn (cname c, b, b_ty, t) + mkLetIn (cname c, b, b_ty, t), + Univ.ContextSet.union ctx + (Univ.ContextSet.of_context cb.const_universes) else let univs = cb.const_universes in - sub_body c (Univ.UContext.instance univs) b 1 (Vars.lift 1 t) + sub_body c (Univ.UContext.instance univs) b 1 (Vars.lift 1 t), ctx | OpaqueDef _, `Opaque (b,_) -> let poly = cb.const_polymorphic in if not poly then let b_ty = Typeops.type_of_constant_type env cb.const_type in let t = sub c 1 (Vars.lift 1 t) in - mkApp (mkLambda (cname c, b_ty, t), [|b|]) + mkApp (mkLambda (cname c, b_ty, t), [|b|]), + Univ.ContextSet.union ctx + (Univ.ContextSet.of_context cb.const_universes) else let univs = cb.const_universes in - sub_body c (Univ.UContext.instance univs) b 1 (Vars.lift 1 t) + sub_body c (Univ.UContext.instance univs) b 1 (Vars.lift 1 t), ctx | _ -> assert false in - List.fold_right fix_body cbl t + let t, ctx = List.fold_right fix_body cbl (t,ctx) in + t, ctx, (mb,List.length cbl) :: sl in (* CAVEAT: we assure a proper order *) - Declareops.fold_side_effects handle_sideff body - (Declareops.uniquize_side_effects side_eff) + List.fold_left handle_sideff (body,ctx,[]) (uniq_seff side_eff) + +(* Given the list of signatures of side effects, checks if they match. + * I.e. if they are ordered descendants of the current revstruct *) +let check_signatures curmb sl = + let is_direct_ancestor (sl, curmb) (mb, how_many) = + match curmb with + | None -> None, None + | Some curmb -> + try + let mb = Ephemeron.get mb in + match sl with + | None -> sl, None + | Some n -> + if List.length mb >= how_many && CList.skipn how_many mb == curmb + then Some (n + how_many), Some mb + else None, None + with Ephemeron.InvalidKey -> None, None in + let sl, _ = List.fold_left is_direct_ancestor (Some 0,Some curmb) sl in + sl + +let skip_trusted_seff sl b e = + let rec aux sl b e acc = + match sl, kind_of_term b with + | (None|Some 0), _ -> b, e, acc + | Some sl, LetIn (n,c,ty,bo) -> + aux (Some (sl-1)) bo + (Environ.push_rel (n,Some c,ty) e) (`Let(n,c,ty)::acc) + | Some sl, App(hd,arg) -> + begin match kind_of_term hd with + | Lambda (n,ty,bo) -> + aux (Some (sl-1)) bo + (Environ.push_rel (n,None,ty) e) (`Cut(n,ty,arg)::acc) + | _ -> assert false + end + | _ -> assert false + in + aux sl b e [] + +let rec unzip ctx j = + match ctx with + | [] -> j + | `Let (n,c,ty) :: ctx -> + unzip ctx { j with uj_val = mkLetIn (n,c,ty,j.uj_val) } + | `Cut (n,ty,arg) :: ctx -> + unzip ctx { j with uj_val = mkApp (mkLambda (n,ty,j.uj_val),arg) } let hcons_j j = { uj_val = hcons_constr j.uj_val; uj_type = hcons_constr j.uj_type} let feedback_completion_typecheck = Option.iter (fun state_id -> Pp.feedback ~state_id Feedback.Complete) - -let infer_declaration env kn dcl = + +let infer_declaration ~trust env kn dcl = match dcl with | ParameterEntry (ctx,poly,(t,uctx),nl) -> - let env = push_context uctx env in + let env = push_context ~strict:(not poly) uctx env in let j = infer env t in let abstract = poly && not (Option.is_empty kn) in let usubst, univs = Univ.abstract_universes abstract uctx in @@ -115,34 +183,41 @@ let infer_declaration env kn dcl = | DefinitionEntry ({ const_entry_type = Some typ; const_entry_opaque = true; const_entry_polymorphic = false} as c) -> - let env = push_context c.const_entry_universes env in + let env = push_context ~strict:true c.const_entry_universes env in let { const_entry_body = body; const_entry_feedback = feedback_id } = c in let tyj = infer_type env typ in let proofterm = - Future.chain ~greedy:true ~pure:true body (fun ((body, ctx),side_eff) -> - let body = handle_side_effects env body side_eff in - let env' = push_context_set ctx env in - let j = infer env' body in + Future.chain ~greedy:true ~pure:true body (fun ((body,uctx),side_eff) -> + let body, uctx, signatures = + inline_side_effects env body uctx side_eff in + let valid_signatures = check_signatures trust signatures in + let env' = push_context_set uctx env in + let j = + let body,env',ectx = skip_trusted_seff valid_signatures body env' in + let j = infer env' body in + unzip ectx j in let j = hcons_j j in let subst = Univ.LMap.empty in let _typ = constrain_type env' j c.const_entry_polymorphic subst (`SomeWJ (typ,tyj)) in feedback_completion_typecheck feedback_id; - j.uj_val, ctx) in + j.uj_val, uctx) in let def = OpaqueDef (Opaqueproof.create proofterm) in def, RegularArity typ, None, c.const_entry_polymorphic, c.const_entry_universes, c.const_entry_inline_code, c.const_entry_secctx | DefinitionEntry c -> - let env = push_context c.const_entry_universes env in let { const_entry_type = typ; const_entry_opaque = opaque } = c in let { const_entry_body = body; const_entry_feedback = feedback_id } = c in let (body, ctx), side_eff = Future.join body in - assert(Univ.ContextSet.is_empty ctx); - let body = handle_side_effects env body side_eff in + let univsctx = Univ.ContextSet.of_context c.const_entry_universes in + let body, ctx, _ = inline_side_effects env body + (Univ.ContextSet.union univsctx ctx) side_eff in + let env = push_context_set ~strict:(not c.const_entry_polymorphic) ctx env in let abstract = c.const_entry_polymorphic && not (Option.is_empty kn) in - let usubst, univs = Univ.abstract_universes abstract c.const_entry_universes in + let usubst, univs = + Univ.abstract_universes abstract (Univ.ContextSet.to_context ctx) in let j = infer env body in let typ = constrain_type env j c.const_entry_polymorphic usubst (map_option_typ typ) in let def = hcons_constr (Vars.subst_univs_level_constr usubst j.uj_val) in @@ -176,14 +251,17 @@ let global_vars_set_constant_type env = function (fun t c -> Id.Set.union (global_vars_set env t) c)) ctx ~init:Id.Set.empty -let record_aux env s1 s2 = +let record_aux env s_ty s_bo suggested_expr = + let in_ty = keep_hyps env s_ty in let v = String.concat " " - (List.map (fun (id, _,_) -> Id.to_string id) - (keep_hyps env (Id.Set.union s1 s2))) in - Aux_file.record_in_aux "context_used" v + (CList.map_filter (fun (id, _,_) -> + if List.exists (fun (id',_,_) -> Id.equal id id') in_ty then None + else Some (Id.to_string id)) + (keep_hyps env s_bo)) in + Aux_file.record_in_aux "context_used" (v ^ ";" ^ suggested_expr) -let suggest_proof_using = ref (fun _ _ _ _ _ -> ()) +let suggest_proof_using = ref (fun _ _ _ _ _ -> "") let set_suggest_proof_using f = suggest_proof_using := f let build_constant_declaration kn env (def,typ,proj,poly,univs,inline_code,ctx) = @@ -198,6 +276,10 @@ let build_constant_declaration kn env (def,typ,proj,poly,univs,inline_code,ctx) str " " ++ str (String.conjugate_verb_to_be n) ++ str " used but not declared:" ++ fnl () ++ pr_sequence Id.print (List.rev l) ++ str ".")) in + let sort evn l = + List.filter (fun (id,_,_) -> + List.exists (fun (id',_,_) -> Names.Id.equal id id') l) + (named_context env) in (* We try to postpone the computation of used section variables *) let hyps, def = let context_ids = List.map pi1 (named_context env) in @@ -215,19 +297,21 @@ let build_constant_declaration kn env (def,typ,proj,poly,univs,inline_code,ctx) (Opaqueproof.force_proof (opaque_tables env) lc) in (* we force so that cst are added to the env immediately after *) ignore(Opaqueproof.force_constraints (opaque_tables env) lc); - !suggest_proof_using kn env vars ids_typ context_ids; + let expr = + !suggest_proof_using (Constant.to_string kn) + env vars ids_typ context_ids in if !Flags.compilation_mode = Flags.BuildVo then - record_aux env ids_typ vars; + record_aux env ids_typ vars expr; vars in keep_hyps env (Idset.union ids_typ ids_def), def | None -> if !Flags.compilation_mode = Flags.BuildVo then - record_aux env Id.Set.empty Id.Set.empty; + record_aux env Id.Set.empty Id.Set.empty ""; [], def (* Empty section context: no need to check *) | Some declared -> (* We use the declared set and chain a check of correctness *) - declared, + sort env declared, match def with | Undef _ as x -> x (* nothing to check *) | Def cs as x -> @@ -243,16 +327,30 @@ let build_constant_declaration kn env (def,typ,proj,poly,univs,inline_code,ctx) let inferred = keep_hyps env (Idset.union ids_typ ids_def) in check declared inferred) lc) in let tps = - (* FIXME: incompleteness of the bytecode vm: we compile polymorphic - constants like opaque definitions. *) - if poly then Some (Cemitcodes.from_val Cemitcodes.BCconstant) - else - let res = - match proj with - | None -> compile_constant_body env def - | Some pb -> - compile_constant_body env (Def (Mod_subst.from_val pb.proj_body)) - in Option.map Cemitcodes.from_val res + let res = + let comp_univs = if poly then Some univs else None in + match proj with + | None -> compile_constant_body env comp_univs def + | Some pb -> + (* The compilation of primitive projections is a bit tricky, because + they refer to themselves (the body of p looks like fun c => + Proj(p,c)). We break the cycle by building an ad-hoc compilation + environment. A cleaner solution would be that kernel projections are + simply Proj(i,c) with i an int and c a constr, but we would have to + get rid of the compatibility layer. *) + let cb = + { const_hyps = hyps; + const_body = def; + const_type = typ; + const_proj = proj; + const_body_code = None; + const_polymorphic = poly; + const_universes = univs; + const_inline_code = inline_code } + in + let env = add_constant kn cb env in + compile_constant_body env comp_univs def + in Option.map Cemitcodes.from_val res in { const_hyps = hyps; const_body = def; @@ -263,11 +361,95 @@ let build_constant_declaration kn env (def,typ,proj,poly,univs,inline_code,ctx) const_universes = univs; const_inline_code = inline_code } - (*s Global and local constant declaration. *) -let translate_constant env kn ce = - build_constant_declaration kn env (infer_declaration env (Some kn) ce) +let translate_constant mb env kn ce = + build_constant_declaration kn env + (infer_declaration ~trust:mb env (Some kn) ce) + +let constant_entry_of_side_effect cb u = + let pt = + match cb.const_body, u with + | OpaqueDef _, `Opaque (b, c) -> b, c + | Def b, `Nothing -> Mod_subst.force_constr b, Univ.ContextSet.empty + | _ -> assert false in + DefinitionEntry { + const_entry_body = Future.from_val (pt, []); + const_entry_secctx = None; + const_entry_feedback = None; + const_entry_type = + (match cb.const_type with RegularArity t -> Some t | _ -> None); + const_entry_polymorphic = cb.const_polymorphic; + const_entry_universes = cb.const_universes; + const_entry_opaque = Declareops.is_opaque cb; + const_entry_inline_code = cb.const_inline_code } +;; + +let turn_direct (kn,cb,u,r as orig) = + match cb.const_body, u with + | OpaqueDef _, `Opaque (b,c) -> + let pt = Future.from_val (b,c) in + kn, { cb with const_body = OpaqueDef (Opaqueproof.create pt) }, u, r + | _ -> orig +;; + +type side_effect_role = + | Subproof + | Schema of inductive * string + +type exported_side_effect = + constant * constant_body * side_effects constant_entry * side_effect_role + +let export_side_effects mb env ce = + match ce with + | ParameterEntry _ | ProjectionEntry _ -> [], ce + | DefinitionEntry c -> + let { const_entry_body = body } = c in + let _, eff = Future.force body in + let ce = DefinitionEntry { c with + const_entry_body = Future.chain ~greedy:true ~pure:true body + (fun (b_ctx, _) -> b_ctx, []) } in + let not_exists (c,_,_,_) = + try ignore(Environ.lookup_constant c env); false + with Not_found -> true in + let aux (acc,sl) { eff = se; from_env = mb } = + let cbl = match se with + | SEsubproof (c,cb,b) -> [c,cb,b,Subproof] + | SEscheme (cl,k) -> + List.map (fun (i,c,cb,b) -> c,cb,b,Schema(i,k)) cl in + let cbl = List.filter not_exists cbl in + if cbl = [] then acc, sl + else cbl :: acc, (mb,List.length cbl) :: sl in + let seff, signatures = List.fold_left aux ([],[]) (uniq_seff eff) in + let trusted = check_signatures mb signatures in + let push_seff env = function + | kn, cb, `Nothing, _ -> + Environ.add_constant kn cb env + | kn, cb, `Opaque(_, ctx), _ -> + let env = Environ.add_constant kn cb env in + Environ.push_context_set + ~strict:(not cb.const_polymorphic) ctx env in + let rec translate_seff sl seff acc env = + match sl, seff with + | _, [] -> List.rev acc, ce + | (None | Some 0), cbs :: rest -> + let env, cbs = + List.fold_left (fun (env,cbs) (kn, ocb, u, r) -> + let ce = constant_entry_of_side_effect ocb u in + let cb = translate_constant mb env kn ce in + (push_seff env (kn, cb,`Nothing, Subproof),(kn,cb,ce,r) :: cbs)) + (env,[]) cbs in + translate_seff sl rest (cbs @ acc) env + | Some sl, cbs :: rest -> + let cbs_len = List.length cbs in + let cbs = List.map turn_direct cbs in + let env = List.fold_left push_seff env cbs in + let ecbs = List.map (fun (kn,cb,u,r) -> + kn, cb, constant_entry_of_side_effect cb u, r) cbs in + translate_seff (Some (sl-cbs_len)) rest (ecbs @ acc) env + in + translate_seff trusted seff [] env +;; let translate_local_assum env t = let j = infer env t in @@ -277,18 +459,36 @@ let translate_local_assum env t = let translate_recipe env kn r = build_constant_declaration kn env (Cooking.cook_constant env r) -let translate_local_def env id centry = +let translate_local_def mb env id centry = let def,typ,proj,poly,univs,inline_code,ctx = - infer_declaration env None (DefinitionEntry centry) in + infer_declaration ~trust:mb env None (DefinitionEntry centry) in let typ = type_of_constant_type env typ in + if ctx = None && !Flags.compilation_mode = Flags.BuildVo then begin + match def with + | Undef _ -> () + | Def _ -> () + | OpaqueDef lc -> + let context_ids = List.map pi1 (named_context env) in + let ids_typ = global_vars_set env typ in + let ids_def = global_vars_set env + (Opaqueproof.force_proof (opaque_tables env) lc) in + let expr = + !suggest_proof_using (Id.to_string id) + env ids_def ids_typ context_ids in + record_aux env ids_typ ids_def expr + end; def, typ, univs (* Insertion of inductive types. *) let translate_mind env kn mie = Indtypes.check_inductive env kn mie -let handle_entry_side_effects env ce = { ce with +let inline_entry_side_effects env ce = { ce with const_entry_body = Future.chain ~greedy:true ~pure:true ce.const_entry_body (fun ((body, ctx), side_eff) -> - (handle_side_effects env body side_eff, ctx), Declareops.no_seff); + let body, ctx',_ = inline_side_effects env body ctx side_eff in + (body, ctx'), []); } + +let inline_side_effects env body side_eff = + pi1 (inline_side_effects env body Univ.ContextSet.empty side_eff) diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index 1b54b1ea..2e6aa161 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -12,23 +12,46 @@ open Environ open Declarations open Entries -val translate_local_def : env -> Id.t -> definition_entry -> +val translate_local_def : structure_body -> env -> Id.t -> side_effects definition_entry -> constant_def * types * constant_universes val translate_local_assum : env -> types -> types -val mk_pure_proof : constr -> proof_output +val mk_pure_proof : constr -> side_effects proof_output -val handle_side_effects : env -> constr -> Declareops.side_effects -> constr +val inline_side_effects : env -> constr -> side_effects -> constr (** Returns the term where side effects have been turned into let-ins or beta redexes. *) -val handle_entry_side_effects : env -> definition_entry -> definition_entry -(** Same as {!handle_side_effects} but applied to entries. Only modifies the +val inline_entry_side_effects : + env -> side_effects definition_entry -> side_effects definition_entry +(** Same as {!inline_side_effects} but applied to entries. Only modifies the {!Entries.const_entry_body} field. It is meant to get a term out of a not yet type checked proof. *) -val translate_constant : env -> constant -> constant_entry -> constant_body +val uniq_seff : side_effects -> side_effects + +val translate_constant : + structure_body -> env -> constant -> side_effects constant_entry -> + constant_body + +type side_effect_role = + | Subproof + | Schema of inductive * string + +type exported_side_effect = + constant * constant_body * side_effects constant_entry * side_effect_role + +(* Given a constant entry containing side effects it exports them (either + * by re-checking them or trusting them). Returns the constant bodies to + * be pushed in the safe_env by safe typing. The main constant entry + * needs to be translated as usual after this step. *) +val export_side_effects : + structure_body -> env -> side_effects constant_entry -> + exported_side_effect list * side_effects constant_entry + +val constant_entry_of_side_effect : + constant_body -> seff_env -> side_effects constant_entry val translate_mind : env -> mutual_inductive -> mutual_inductive_entry -> mutual_inductive_body @@ -37,11 +60,11 @@ val translate_recipe : env -> constant -> Cooking.recipe -> constant_body (** Internal functions, mentioned here for debug purpose only *) -val infer_declaration : env -> constant option -> - constant_entry -> Cooking.result +val infer_declaration : trust:structure_body -> env -> constant option -> + side_effects constant_entry -> Cooking.result val build_constant_declaration : constant -> env -> Cooking.result -> constant_body val set_suggest_proof_using : - (constant -> env -> Id.Set.t -> Id.Set.t -> Id.t list -> unit) -> unit + (string -> env -> Id.Set.t -> Id.Set.t -> Id.t list -> string) -> unit diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 48dbacf1..4f32fdce 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -134,10 +134,16 @@ let extract_context_levels env l = let make_polymorphic_if_constant_for_ind env {uj_val = c; uj_type = t} = let params, ccl = dest_prod_assum env t in match kind_of_term ccl with - | Sort (Type u) when isInd (fst (decompose_app (whd_betadeltaiota env c))) -> - let param_ccls = extract_context_levels env params in - let s = { template_param_levels = param_ccls; template_level = u} in - TemplateArity (params,s) + | Sort (Type u) -> + let ind, l = decompose_app (whd_betadeltaiota env c) in + if isInd ind && List.is_empty l then + let mis = lookup_mind_specif env (fst (destInd ind)) in + let nparams = Inductive.inductive_params mis in + let paramsl = CList.lastn nparams params in + let param_ccls = extract_context_levels env paramsl in + let s = { template_param_levels = param_ccls; template_level = u} in + TemplateArity (params,s) + else RegularArity t | _ -> RegularArity t @@ -252,14 +258,12 @@ let sort_of_product env domsort rangsort = | (Prop _, Prop Pos) -> rangsort (* Product rule (Type,Set,?) *) | (Type u1, Prop Pos) -> - begin match engagement env with - | Some ImpredicativeSet -> + if is_impredicative_set env then (* Rule is (Type,Set,Set) in the Set-impredicative calculus *) rangsort - | _ -> + else (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *) Type (Universe.sup Universe.type0 u1) - end (* Product rule (Prop,Type_i,Type_i) *) | (Prop Pos, Type u2) -> Type (Universe.sup Universe.type0 u2) (* Product rule (Prop,Type_i,Type_i) *) @@ -296,7 +300,7 @@ let judge_of_cast env cj k tj = match k with | VMcast -> mkCast (cj.uj_val, k, expected_type), - vm_conv CUMUL env cj.uj_type expected_type + Reduction.vm_conv CUMUL env cj.uj_type expected_type | DEFAULTcast -> mkCast (cj.uj_val, k, expected_type), default_conv ~l2r:false CUMUL env cj.uj_type expected_type @@ -306,7 +310,7 @@ let judge_of_cast env cj k tj = | NATIVEcast -> let sigma = Nativelambda.empty_evars in mkCast (cj.uj_val, k, expected_type), - native_conv CUMUL sigma env cj.uj_type expected_type + Nativeconv.native_conv CUMUL sigma env cj.uj_type expected_type in { uj_val = c; uj_type = expected_type } @@ -473,7 +477,7 @@ let rec execute env cstr = let j' = execute env1 c3 in judge_of_letin env name j1 j2 j' - | Cast (c,k, t) -> + | Cast (c,k,t) -> let cj = execute env c in let tj = execute_type env t in judge_of_cast env cj k tj diff --git a/kernel/univ.ml b/kernel/univ.ml index 763c0822..6c231698 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -270,8 +270,10 @@ module Level = struct let is_small x = match data x with | Level _ -> false - | _ -> true - + | Var _ -> false + | Prop -> true + | Set -> true + let is_prop x = match data x with | Prop -> true @@ -551,6 +553,10 @@ struct | Cons (l, _, Nil) -> Expr.is_level l | _ -> false + let rec is_levels l = match l with + | Cons (l, _, r) -> Expr.is_level l && is_levels r + | Nil -> true + let level l = match l with | Cons (l, _, Nil) -> Expr.level l | _ -> None @@ -577,7 +583,7 @@ struct let is_type0m x = equal type0m x let is_type0 x = equal type0 x - (* Returns the formal universe that lies juste above the universe variable u. + (* Returns the formal universe that lies just above the universe variable u. Used to type the sort u. *) let super l = if is_small l then type1 @@ -655,7 +661,6 @@ type canonical_arc = lt: Level.t list; le: Level.t list; rank : int; - predicative : bool; mutable status : status; (** Guaranteed to be unset out of the [compare_neq] functions. It is used to do an imperative traversal of the graph, ensuring a O(1) check that @@ -670,7 +675,7 @@ let arc_is_lt arc = match arc.status with | Unset | SetLe -> false | SetLt -> true -let terminal u = {univ=u; lt=[]; le=[]; rank=0; predicative=false; status = Unset} +let terminal u = {univ=u; lt=[]; le=[]; rank=0; status = Unset} module UMap : sig @@ -720,35 +725,51 @@ let enter_arc ca g = (* Every Level.t has a unique canonical arc representative *) +(** The graph always contains nodes for Prop and Set. *) + +let terminal_lt u v = + {(terminal u) with lt=[v]} + +let empty_universes = + let g = enter_arc (terminal Level.set) UMap.empty in + let g = enter_arc (terminal_lt Level.prop Level.set) g in + g + (* repr : universes -> Level.t -> canonical_arc *) (* canonical representative : we follow the Equiv links *) -let repr g u = - let rec repr_rec u = - let a = - try UMap.find u g - with Not_found -> anomaly ~label:"Univ.repr" - (str"Universe " ++ Level.pr u ++ str" undefined") - in - match a with - | Equiv v -> repr_rec v - | Canonical arc -> arc +let rec repr g u = + let a = + try UMap.find u g + with Not_found -> anomaly ~label:"Univ.repr" + (str"Universe " ++ Level.pr u ++ str" undefined") in - repr_rec u + match a with + | Equiv v -> repr g v + | Canonical arc -> arc -(* [safe_repr] also search for the canonical representative, but - if the graph doesn't contain the searched universe, we add it. *) +let get_prop_arc g = repr g Level.prop +let get_set_arc g = repr g Level.set +let is_set_arc u = Level.is_set u.univ +let is_prop_arc u = Level.is_prop u.univ -let safe_repr g u = - let rec safe_repr_rec u = - match UMap.find u g with - | Equiv v -> safe_repr_rec v - | Canonical arc -> arc - in - try g, safe_repr_rec u - with Not_found -> - let can = terminal u in - enter_arc can g, can +exception AlreadyDeclared + +let add_universe vlev strict g = + try + let _arcv = UMap.find vlev g in + raise AlreadyDeclared + with Not_found -> + let v = terminal vlev in + let arc = + let arc = get_set_arc g in + if strict then + { arc with lt=vlev::arc.lt} + else + { arc with le=vlev::arc.le} + in + let g = enter_arc arc g in + enter_arc v g (* reprleq : canonical_arc -> canonical_arc list *) (* All canonical arcv such that arcu<=arcv with arcv#arcu *) @@ -792,7 +813,6 @@ let between g arcu arcv = in let good,_,_ = explore ([arcv],[],false) arcu in good - (* We assume compare(u,v) = LE with v canonical (see compare below). In this case List.hd(between g u v) = repr u Otherwise, between g u v = [] @@ -903,8 +923,9 @@ let get_explanation strict g arcu arcv = in find [] arc.lt in + let start = (* if is_prop_arc arcu then [Le, make arcv.univ] else *) [] in try - let (to_revert, c) = cmp [] [] [] [(arcu, [])] in + let (to_revert, c) = cmp start [] [] [(arcu, [])] in (** Reset all the touched arcs. *) let () = List.iter (fun arc -> arc.status <- Unset) to_revert in List.rev c @@ -928,25 +949,8 @@ let fast_compare_neq strict g arcu arcv = if arc_is_lt arc then cmp c to_revert lt_todo le_todo else - let rec find lt_todo lt le = match le with - | [] -> - begin match lt with - | [] -> - let () = arc.status <- SetLt in - cmp c (arc :: to_revert) lt_todo le_todo - | u :: lt -> - let arc = repr g u in - if arc == arcv then - if strict then (to_revert, FastLT) else (to_revert, FastLE) - else find (arc :: lt_todo) lt le - end - | u :: le -> - let arc = repr g u in - if arc == arcv then - if strict then (to_revert, FastLT) else (to_revert, FastLE) - else find (arc :: lt_todo) lt le - in - find lt_todo arc.lt arc.le + let () = arc.status <- SetLt in + process_lt c (arc :: to_revert) lt_todo le_todo arc.lt arc.le | [], arc::le_todo -> if arc == arcv then (* No need to continue inspecting universes above arc: @@ -958,22 +962,39 @@ let fast_compare_neq strict g arcu arcv = if arc_is_le arc then cmp c to_revert [] le_todo else - let rec find lt_todo lt = match lt with - | [] -> - let fold accu u = - let node = repr g u in - node :: accu - in - let le_new = List.fold_left fold le_todo arc.le in - let () = arc.status <- SetLe in - cmp c (arc :: to_revert) lt_todo le_new - | u :: lt -> - let arc = repr g u in - if arc == arcv then - if strict then (to_revert, FastLT) else (to_revert, FastLE) - else find (arc :: lt_todo) lt - in - find [] arc.lt + let () = arc.status <- SetLe in + process_le c (arc :: to_revert) [] le_todo arc.lt arc.le + + and process_lt c to_revert lt_todo le_todo lt le = match le with + | [] -> + begin match lt with + | [] -> cmp c to_revert lt_todo le_todo + | u :: lt -> + let arc = repr g u in + if arc == arcv then + if strict then (to_revert, FastLT) else (to_revert, FastLE) + else process_lt c to_revert (arc :: lt_todo) le_todo lt le + end + | u :: le -> + let arc = repr g u in + if arc == arcv then + if strict then (to_revert, FastLT) else (to_revert, FastLE) + else process_lt c to_revert (arc :: lt_todo) le_todo lt le + + and process_le c to_revert lt_todo le_todo lt le = match lt with + | [] -> + let fold accu u = + let node = repr g u in + node :: accu + in + let le_new = List.fold_left fold le_todo le in + cmp c to_revert lt_todo le_new + | u :: lt -> + let arc = repr g u in + if arc == arcv then + if strict then (to_revert, FastLT) else (to_revert, FastLE) + else process_le c to_revert (arc :: lt_todo) le_todo lt le + in try let (to_revert, c) = cmp FastNLE [] [] [arcu] in @@ -1017,24 +1038,18 @@ let is_lt g arcu arcv = (** First, checks on universe levels *) let check_equal g u v = - let g, arcu = safe_repr g u in - let _, arcv = safe_repr g v in - arcu == arcv + let arcu = repr g u and arcv = repr g v in + arcu == arcv let check_eq_level g u v = u == v || check_equal g u v -let is_set_arc u = Level.is_set u.univ -let is_prop_arc u = Level.is_prop u.univ -let get_prop_arc g = snd (safe_repr g Level.prop) - let check_smaller g strict u v = - let g, arcu = safe_repr g u in - let g, arcv = safe_repr g v in + let arcu = repr g u and arcv = repr g v in if strict then is_lt g arcu arcv else is_prop_arc arcu - || (is_set_arc arcu && arcv.predicative) + || (is_set_arc arcu && not (is_prop_arc arcv)) || is_leq g arcu arcv (** Then, checks on universes *) @@ -1076,19 +1091,11 @@ let check_leq g u v = (** Enforcing new constraints : [setlt], [setleq], [merge], [merge_disc] *) -(** To speed up tests of Set </<= i *) -let set_predicative g arcv = - enter_arc {arcv with predicative = true} g - (* setlt : Level.t -> Level.t -> reason -> unit *) (* forces u > v *) (* this is normally an update of u in g rather than a creation. *) let setlt g arcu arcv = let arcu' = {arcu with lt=arcv.univ::arcu.lt} in - let g = - if is_set_arc arcu then set_predicative g arcv - else g - in enter_arc arcu' g, arcu' (* checks that non-redundant *) @@ -1102,11 +1109,6 @@ let setlt_if (g,arcu) v = (* this is normally an update of u in g rather than a creation. *) let setleq g arcu arcv = let arcu' = {arcu with le=arcv.univ::arcu.le} in - let g = - if is_set_arc arcu' then - set_predicative g arcv - else g - in enter_arc arcu' g, arcu' (* checks that non-redundant *) @@ -1122,7 +1124,8 @@ let merge g arcu arcv = (* we find the arc with the biggest rank, and we redirect all others to it *) let arcu, g, v = let best_ranked (max_rank, old_max_rank, best_arc, rest) arc = - if Level.is_small arc.univ || arc.rank >= max_rank + if Level.is_small arc.univ || + (arc.rank >= max_rank && not (Level.is_small best_arc.univ)) then (arc.rank, max_rank, arc, best_arc::rest) else (max_rank, old_max_rank, best_arc, arc::rest) in @@ -1152,7 +1155,7 @@ let merge g arcu arcv = (* we assume compare(u,v) = compare(v,u) = NLE *) (* merge_disc u v forces u ~ v with repr u as canonical repr *) let merge_disc g arc1 arc2 = - let arcu, arcv = if arc1.rank < arc2.rank then arc2, arc1 else arc1, arc2 in + let arcu, arcv = if Level.is_small arc2.univ || arc1.rank < arc2.rank then arc2, arc1 else arc1, arc2 in let arcu, g = if not (Int.equal arc1.rank arc2.rank) then arcu, g else @@ -1175,12 +1178,11 @@ exception UniverseInconsistency of univ_inconsistency let error_inconsistency o u v (p:explanation option) = raise (UniverseInconsistency (o,make u,make v,p)) -(* enforc_univ_eq : Level.t -> Level.t -> unit *) -(* enforc_univ_eq u v will force u=v if possible, will fail otherwise *) +(* enforce_univ_eq : Level.t -> Level.t -> unit *) +(* enforce_univ_eq u v will force u=v if possible, will fail otherwise *) let enforce_univ_eq u v g = - let g,arcu = safe_repr g u in - let g,arcv = safe_repr g v in + let arcu = repr g u and arcv = repr g v in match fast_compare g arcu arcv with | FastEQ -> g | FastLT -> @@ -1199,8 +1201,7 @@ let enforce_univ_eq u v g = (* enforce_univ_leq : Level.t -> Level.t -> unit *) (* enforce_univ_leq u v will force u<=v if possible, will fail otherwise *) let enforce_univ_leq u v g = - let g,arcu = safe_repr g u in - let g,arcv = safe_repr g v in + let arcu = repr g u and arcv = repr g v in if is_leq g arcu arcv then g else match fast_compare g arcv arcu with @@ -1213,8 +1214,7 @@ let enforce_univ_leq u v g = (* enforce_univ_lt u v will force u<v if possible, will fail otherwise *) let enforce_univ_lt u v g = - let g,arcu = safe_repr g u in - let g,arcv = safe_repr g v in + let arcu = repr g u and arcv = repr g v in match fast_compare g arcu arcv with | FastLT -> g | FastLE -> fst (setlt g arcu arcv) @@ -1227,18 +1227,10 @@ let enforce_univ_lt u v g = let p = get_explanation false g arcv arcu in error_inconsistency Lt u v p -let empty_universes = UMap.empty - (* Prop = Set is forbidden here. *) -let initial_universes = enforce_univ_lt Level.prop Level.set UMap.empty +let initial_universes = empty_universes let is_initial_universes g = UMap.equal (==) g initial_universes - -let add_universe vlev g = - let v = terminal vlev in - let proparc = get_prop_arc g in - enter_arc {proparc with le=vlev::proparc.le} - (enter_arc v g) (* Constraints and sets of constraints. *) @@ -1372,10 +1364,12 @@ let check_univ_leq u v = let enforce_leq u v c = let open Universe.Huniv in + let rec aux acc v = match v with - | Cons (v, _, Nil) -> - fold (fun u -> constraint_add_leq u v) u c - | _ -> anomaly (Pp.str"A universe bound can only be a variable") + | Cons (v, _, l) -> + aux (fold (fun u -> constraint_add_leq u v) u c) l + | Nil -> acc + in aux c v let enforce_leq u v c = if check_univ_leq u v then c @@ -1446,7 +1440,6 @@ let normalize_universes g = lt = LSet.elements lt; le = LSet.elements le; rank = rank; - predicative = false; status = Unset; } in @@ -1589,9 +1582,9 @@ let sort_universes orig = let sorted = LMap.fold fold compact UMap.empty in (** Add all [Type.n] nodes *) let fold i accu u = - if 0 < i then - let pred = types.(i - 1) in - let arc = {univ = u; lt = [pred]; le = []; rank = 0; predicative = false; status = Unset; } in + if i < max then + let pred = types.(i + 1) in + let arc = {univ = u; lt = [pred]; le = []; rank = 0; status = Unset; } in UMap.add u (Canonical arc) accu else accu in @@ -1761,7 +1754,7 @@ let eq_puniverses f (x, u) (y, u') = f x y && Instance.equal u u' (** A context of universe levels with universe constraints, - representiong local universe variables and constraints *) + representing local universe variables and constraints *) module UContext = struct @@ -1775,7 +1768,7 @@ struct let pr prl (univs, cst as ctx) = if is_empty ctx then mt() else - Instance.pr prl univs ++ str " |= " ++ v 0 (Constraint.pr prl cst) + h 0 (Instance.pr prl univs ++ str " |= ") ++ h 0 (v 0 (Constraint.pr prl cst)) let hcons (univs, cst) = (Instance.hcons univs, hcons_constraints cst) @@ -1785,8 +1778,11 @@ struct let union (univs, cst) (univs', cst') = Instance.append univs univs', Constraint.union cst cst' - + let dest x = x + + let size (x,_) = Instance.length x + end type universe_context = UContext.t @@ -1804,6 +1800,9 @@ struct let empty = (LSet.empty, Constraint.empty) let is_empty (univs, cst) = LSet.is_empty univs && Constraint.is_empty cst + let equal (univs, cst as x) (univs', cst' as y) = + x == y || (LSet.equal univs univs' && Constraint.equal cst cst') + let of_set s = (s, Constraint.empty) let singleton l = of_set (LSet.singleton l) let of_instance i = of_set (Instance.levels i) @@ -1843,7 +1842,7 @@ struct let pr prl (univs, cst as ctx) = if is_empty ctx then mt() else - LSet.pr prl univs ++ str " |= " ++ v 0 (Constraint.pr prl cst) + h 0 (LSet.pr prl univs ++ str " |= ") ++ h 0 (v 0 (Constraint.pr prl cst)) let constraints (univs, cst) = cst let levels (univs, cst) = univs diff --git a/kernel/univ.mli b/kernel/univ.mli index 7aaf2ffe..c926c57b 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -20,7 +20,11 @@ sig val is_small : t -> bool (** Is the universe set or prop? *) - + + val is_prop : t -> bool + val is_set : t -> bool + (** Is it specifically Prop or Set *) + val compare : t -> t -> int (** Comparison function *) @@ -87,6 +91,9 @@ sig val is_level : t -> bool (** Test if the universe is a level or an algebraic universe. *) + val is_levels : t -> bool + (** Test if the universe is a lub of levels or contains +n's. *) + val level : t -> Level.t option (** Try to get a level out of a universe, returns [None] if it is an algebraic universe. *) @@ -159,8 +166,12 @@ val is_initial_universes : universes -> bool val sort_universes : universes -> universes -(** Adds a universe to the graph, ensuring it is >= Prop. *) -val add_universe : universe_level -> universes -> universes +(** Adds a universe to the graph, ensuring it is >= or > Set. + @raises AlreadyDeclared if the level is already declared in the graph. *) + +exception AlreadyDeclared + +val add_universe : universe_level -> bool -> universes -> universes (** {6 Constraints. } *) @@ -332,6 +343,9 @@ sig (** Keeps the order of the instances *) val union : t -> t -> t + (* the number of universes in the context *) + val size : t -> int + end type universe_context = UContext.t @@ -349,6 +363,7 @@ sig val of_instance : Instance.t -> t val of_set : universe_set -> t + val equal : t -> t -> bool val union : t -> t -> t val append : t -> t -> t diff --git a/kernel/vars.ml b/kernel/vars.ml index 88c1e103..a800e253 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -337,5 +337,5 @@ let subst_instance_context s ctx = if Univ.Instance.is_empty s then ctx else map_rel_context (fun x -> subst_instance_constr s x) ctx -type id_key = pconstant tableKey -let eq_id_key x y = Names.eq_table_key (Univ.eq_puniverses Constant.equal) x y +type id_key = constant tableKey +let eq_id_key x y = Names.eq_table_key Constant.equal x y diff --git a/kernel/vars.mli b/kernel/vars.mli index fdd4603b..c0fbeeb6 100644 --- a/kernel/vars.mli +++ b/kernel/vars.mli @@ -88,5 +88,5 @@ val subst_univs_level_context : Univ.universe_level_subst -> rel_context -> rel_ val subst_instance_constr : universe_instance -> constr -> constr val subst_instance_context : universe_instance -> rel_context -> rel_context -type id_key = pconstant tableKey +type id_key = constant tableKey val eq_id_key : id_key -> id_key -> bool diff --git a/kernel/vconv.ml b/kernel/vconv.ml index 1c31cc04..4610dbcb 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -18,8 +18,8 @@ let compare_zipper z1 z2 = match z1, z2 with | Zapp args1, Zapp args2 -> Int.equal (nargs args1) (nargs args2) | Zfix(f1,args1), Zfix(f2,args2) -> Int.equal (nargs args1) (nargs args2) - | Zswitch _, Zswitch _ -> true - | _ , _ -> false + | Zswitch _, Zswitch _ | Zproj _, Zproj _ -> true + | Zapp _ , _ | Zfix _, _ | Zswitch _, _ | Zproj _, _ -> false let rec compare_stack stk1 stk2 = match stk1, stk2 with @@ -40,15 +40,20 @@ let conv_vect fconv vect1 vect2 cu = !rcu else raise NotConvertible -let infos = ref (create_clos_infos betaiotazeta Environ.empty_env) - let rec conv_val env pb k v1 v2 cu = if v1 == v2 then cu else conv_whd env pb k (whd_val v1) (whd_val v2) cu and conv_whd env pb k whd1 whd2 cu = +(* Pp.(msg_debug (str "conv_whd(" ++ pr_whd whd1 ++ str ", " ++ pr_whd whd2 ++ str ")")) ; *) match whd1, whd2 with - | Vsort s1, Vsort s2 -> check_sort_cmp_universes env pb s1 s2 cu; cu + | Vsort s1, Vsort s2 -> sort_cmp_universes env pb s1 s2 cu + | Vuniv_level _ , _ + | _ , Vuniv_level _ -> + (** Both of these are invalid since universes are handled via + ** special cases in the code. + **) + assert false | Vprod p1, Vprod p2 -> let cu = conv_val env CONV k (dom p1) (dom p2) cu in conv_fun env pb k (codom p1) (codom p2) cu @@ -76,50 +81,53 @@ and conv_whd env pb k whd1 whd2 cu = | Vatom_stk(a1,stk1), Vatom_stk(a2,stk2) -> conv_atom env pb k a1 stk1 a2 stk2 cu | Vfun _, _ | _, Vfun _ -> - conv_val env CONV (k+1) (eta_whd k whd1) (eta_whd k whd2) cu - | _, Vatom_stk(Aiddef(_,v),stk) -> - conv_whd env pb k whd1 (force_whd v stk) cu - | Vatom_stk(Aiddef(_,v),stk), _ -> - conv_whd env pb k (force_whd v stk) whd2 cu - | _, _ -> raise NotConvertible + conv_val env CONV (k+1) (apply_whd k whd1) (apply_whd k whd2) cu + + | Vsort _, _ | Vprod _, _ | Vfix _, _ | Vcofix _, _ | Vconstr_const _, _ + | Vconstr_block _, _ | Vatom_stk _, _ -> raise NotConvertible + and conv_atom env pb k a1 stk1 a2 stk2 cu = +(* Pp.(msg_debug (str "conv_atom(" ++ pr_atom a1 ++ str ", " ++ pr_atom a2 ++ str ")")) ; *) match a1, a2 with - | Aind ind1, Aind ind2 -> - if eq_puniverses eq_ind ind1 ind2 && compare_stack stk1 stk2 + | Aind ((mi,i) as ind1) , Aind ind2 -> + if eq_ind ind1 ind2 && compare_stack stk1 stk2 then - conv_stack env k stk1 stk2 cu + if Environ.polymorphic_ind ind1 env + then + let mib = Environ.lookup_mind mi env in + let ulen = Univ.UContext.size mib.Declarations.mind_universes in + match stk1 , stk2 with + | [], [] -> assert (Int.equal ulen 0); cu + | Zapp args1 :: stk1' , Zapp args2 :: stk2' -> + assert (ulen <= nargs args1); + assert (ulen <= nargs args2); + let u1 = Array.init ulen (fun i -> uni_lvl_val (arg args1 i)) in + let u2 = Array.init ulen (fun i -> uni_lvl_val (arg args2 i)) in + let u1 = Univ.Instance.of_array u1 in + let u2 = Univ.Instance.of_array u2 in + let cu = convert_instances ~flex:false u1 u2 cu in + conv_arguments env ~from:ulen k args1 args2 + (conv_stack env k stk1' stk2' cu) + | _, _ -> assert false (* Should not happen if problem is well typed *) + else + conv_stack env k stk1 stk2 cu else raise NotConvertible | Aid ik1, Aid ik2 -> if Vars.eq_id_key ik1 ik2 && compare_stack stk1 stk2 then conv_stack env k stk1 stk2 cu else raise NotConvertible - | Aiddef(ik1,v1), Aiddef(ik2,v2) -> - begin - try - if Vars.eq_id_key ik1 ik2 && compare_stack stk1 stk2 then - conv_stack env k stk1 stk2 cu - else raise NotConvertible - with NotConvertible -> - if oracle_order Univ.out_punivs (oracle_of_infos !infos) - false ik1 ik2 then - conv_whd env pb k (whd_stack v1 stk1) (Vatom_stk(a2,stk2)) cu - else conv_whd env pb k (Vatom_stk(a1,stk1)) (whd_stack v2 stk2) cu - end - | Aiddef(ik1,v1), _ -> - conv_whd env pb k (force_whd v1 stk1) (Vatom_stk(a2,stk2)) cu - | _, Aiddef(ik2,v2) -> - conv_whd env pb k (Vatom_stk(a1,stk1)) (force_whd v2 stk2) cu - | _, _ -> raise NotConvertible + | Atype _ , _ | _, Atype _ -> assert false + | Aind _, _ | Aid _, _ -> raise NotConvertible -and conv_stack env k stk1 stk2 cu = +and conv_stack env ?from:(from=0) k stk1 stk2 cu = match stk1, stk2 with | [], [] -> cu | Zapp args1 :: stk1, Zapp args2 :: stk2 -> - conv_stack env k stk1 stk2 (conv_arguments env k args1 args2 cu) + conv_stack env k stk1 stk2 (conv_arguments env ~from:from k args1 args2 cu) | Zfix(f1,args1) :: stk1, Zfix(f2,args2) :: stk2 -> conv_stack env k stk1 stk2 - (conv_arguments env k args1 args2 (conv_fix env k f1 f2 cu)) + (conv_arguments env ~from:from k args1 args2 (conv_fix env k f1 f2 cu)) | Zswitch sw1 :: stk1, Zswitch sw2 :: stk2 -> if check_switch sw1 sw2 then let vt1,vt2 = type_of_switch sw1, type_of_switch sw2 in @@ -131,7 +139,11 @@ and conv_stack env k stk1 stk2 cu = done; conv_stack env k stk1 stk2 !rcu else raise NotConvertible - | _, _ -> raise NotConvertible + | Zproj p1 :: stk1, Zproj p2 :: stk2 -> + if Constant.equal p1 p2 then conv_stack env k stk1 stk2 cu + else raise NotConvertible + | [], _ | Zapp _ :: _, _ | Zfix _ :: _, _ | Zswitch _ :: _, _ + | Zproj _ :: _, _ -> raise NotConvertible and conv_fun env pb k f1 f2 cu = if f1 == f2 then cu @@ -159,98 +171,37 @@ and conv_cofix env k cf1 cf2 cu = conv_vect (conv_val env CONV (k + Array.length tcf1)) bcf1 bcf2 cu else raise NotConvertible -and conv_arguments env k args1 args2 cu = +and conv_arguments env ?from:(from=0) k args1 args2 cu = if args1 == args2 then cu else let n = nargs args1 in if Int.equal n (nargs args2) then let rcu = ref cu in - for i = 0 to n - 1 do + for i = from to n - 1 do rcu := conv_val env CONV k (arg args1 i) (arg args2 i) !rcu done; !rcu else raise NotConvertible -let rec eq_puniverses f (x,l1) (y,l2) cu = - if f x y then conv_universes l1 l2 cu - else raise NotConvertible - -and conv_universes l1 l2 cu = - if Univ.Instance.equal l1 l2 then cu else raise NotConvertible - -let rec conv_eq env pb t1 t2 cu = - if t1 == t2 then cu - else - match kind_of_term t1, kind_of_term t2 with - | Rel n1, Rel n2 -> - if Int.equal n1 n2 then cu else raise NotConvertible - | Meta m1, Meta m2 -> - if Int.equal m1 m2 then cu else raise NotConvertible - | Var id1, Var id2 -> - if Id.equal id1 id2 then cu else raise NotConvertible - | Sort s1, Sort s2 -> check_sort_cmp_universes env pb s1 s2 cu; cu - | Cast (c1,_,_), _ -> conv_eq env pb c1 t2 cu - | _, Cast (c2,_,_) -> conv_eq env pb t1 c2 cu - | Prod (_,t1,c1), Prod (_,t2,c2) -> - conv_eq env pb c1 c2 (conv_eq env CONV t1 t2 cu) - | Lambda (_,t1,c1), Lambda (_,t2,c2) -> conv_eq env CONV c1 c2 cu - | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> - conv_eq env pb c1 c2 (conv_eq env CONV b1 b2 cu) - | App (c1,l1), App (c2,l2) -> - conv_eq_vect env l1 l2 (conv_eq env CONV c1 c2 cu) - | Evar (e1,l1), Evar (e2,l2) -> - if Evar.equal e1 e2 then conv_eq_vect env l1 l2 cu - else raise NotConvertible - | Const c1, Const c2 -> eq_puniverses eq_constant c1 c2 cu - | Proj (p1,c1), Proj (p2,c2) -> - if eq_constant (Projection.constant p1) (Projection.constant p2) then - conv_eq env pb c1 c2 cu - else raise NotConvertible - | Ind c1, Ind c2 -> - eq_puniverses eq_ind c1 c2 cu - | Construct c1, Construct c2 -> - eq_puniverses eq_constructor c1 c2 cu - | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> - let pcu = conv_eq env CONV p1 p2 cu in - let ccu = conv_eq env CONV c1 c2 pcu in - conv_eq_vect env bl1 bl2 ccu - | Fix ((ln1, i1),(_,tl1,bl1)), Fix ((ln2, i2),(_,tl2,bl2)) -> - if Int.equal i1 i2 && Array.equal Int.equal ln1 ln2 then conv_eq_vect env tl1 tl2 (conv_eq_vect env bl1 bl2 cu) - else raise NotConvertible - | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> - if Int.equal ln1 ln2 then conv_eq_vect env tl1 tl2 (conv_eq_vect env bl1 bl2 cu) - else raise NotConvertible - | _ -> raise NotConvertible - -and conv_eq_vect env vt1 vt2 cu = - let len = Array.length vt1 in - if Int.equal len (Array.length vt2) then - let rcu = ref cu in - for i = 0 to len-1 do - rcu := conv_eq env CONV vt1.(i) vt2.(i) !rcu - done; !rcu - else raise NotConvertible - -let vconv pb env t1 t2 = - infos := create_clos_infos betaiotazeta env; - let _cu = - try conv_eq env pb t1 t2 (universes env) - with NotConvertible -> - let v1 = val_of_constr env t1 in - let v2 = val_of_constr env t2 in - let cu = conv_val env pb (nb_rel env) v1 v2 (universes env) in - cu - in () - -let _ = Reduction.set_vm_conv vconv - -let use_vm = ref false - -let set_use_vm b = - use_vm := b; - if b then Reduction.set_default_conv (fun cv_pb ?(l2r=false) -> vconv cv_pb) - else Reduction.set_default_conv (fun cv_pb ?(l2r=false) -> Reduction.conv_cmp cv_pb) - -let use_vm _ = !use_vm - - +let vm_conv_gen cv_pb env univs t1 t2 = + try + let v1 = val_of_constr env t1 in + let v2 = val_of_constr env t2 in + fst (conv_val env cv_pb (nb_rel env) v1 v2 univs) + with Not_found | Invalid_argument _ -> + (Pp.msg_warning + (Pp.str "Bytecode compilation failed, falling back to default conversion"); + Reduction.generic_conv cv_pb ~l2r:false (fun _ -> None) + full_transparent_state env univs t1 t2) + +let vm_conv cv_pb env t1 t2 = + let univs = Environ.universes env in + let b = + if cv_pb = CUMUL then Constr.leq_constr_univs univs t1 t2 + else Constr.eq_constr_univs univs t1 t2 + in + if not b then + let univs = (univs, checked_universes) in + let _ = vm_conv_gen cv_pb env univs t1 t2 in () + +let _ = Reduction.set_vm_conv vm_conv diff --git a/kernel/vconv.mli b/kernel/vconv.mli index 096d31ac..49e5d23e 100644 --- a/kernel/vconv.mli +++ b/kernel/vconv.mli @@ -12,9 +12,11 @@ open Reduction (********************************************************************** s conversion functions *) -val use_vm : unit -> bool -val set_use_vm : bool -> unit -val vconv : conv_pb -> types conversion_function +val vm_conv : conv_pb -> types conversion_function -val val_of_constr : env -> constr -> values +(** A conversion function parametrized by a universe comparator. Used outside of + the kernel. *) +val vm_conv_gen : conv_pb -> (types, 'a) generic_conversion_function +(** Precompute a VM value from a constr *) +val val_of_constr : env -> constr -> values diff --git a/kernel/vm.ml b/kernel/vm.ml index d4bf461b..64ddc437 100644 --- a/kernel/vm.ml +++ b/kernel/vm.ml @@ -19,8 +19,6 @@ external set_drawinstr : unit -> unit = "coq_set_drawinstr" external offset_closure : Obj.t -> int -> Obj.t = "coq_offset_closure" external offset : Obj.t -> int = "coq_offset" -let accu_tag = 0 - (*******************************************) (* Initalization of the abstract machine ***) (*******************************************) @@ -29,9 +27,6 @@ external init_vm : unit -> unit = "init_coq_vm" let _ = init_vm () -external transp_values : unit -> bool = "get_coq_transp_value" -external set_transp_values : bool -> unit = "coq_set_transp_value" - (*******************************************) (* Machine code *** ************************) (*******************************************) @@ -126,11 +121,12 @@ type vswitch = { (* *) (* + Accumulators : At_[accumulate| accu | arg1 | ... | argn ] *) (* - representation of [accu] : tag_[....] *) -(* -- tag <= 2 : encoding atom type (sorts, free vars, etc.) *) -(* -- 3_[accu|fix_app] : a fixpoint blocked by an accu *) -(* -- 4_[accu|vswitch] : a match blocked by an accu *) -(* -- 5_[fcofix] : a cofix function *) -(* -- 6_[fcofix|val] : a cofix function, val represent the value *) +(* -- tag <= 3 : encoding atom type (sorts, free vars, etc.) *) +(* -- 10_[accu|proj name] : a projection blocked by an accu *) +(* -- 11_[accu|fix_app] : a fixpoint blocked by an accu *) +(* -- 12_[accu|vswitch] : a match blocked by an accu *) +(* -- 13_[fcofix] : a cofix function *) +(* -- 14_[fcofix|val] : a cofix function, val represent the value *) (* of the function applied to arg1 ... argn *) (* The [arguments] type, which is abstracted as an array, represents : *) (* tag[ _ | _ |v1|... | vn] *) @@ -140,8 +136,8 @@ type vswitch = { type atom = | Aid of Vars.id_key - | Aiddef of Vars.id_key * values - | Aind of pinductive + | Aind of inductive + | Atype of Univ.universe (* Zippers *) @@ -149,6 +145,7 @@ type zipper = | Zapp of arguments | Zfix of vfix*arguments (* Possibly empty *) | Zswitch of vswitch + | Zproj of Constant.t (* name of the projection *) type stack = zipper list @@ -163,28 +160,112 @@ type whd = | Vconstr_const of int | Vconstr_block of vblock | Vatom_stk of atom * stack + | Vuniv_level of Univ.universe_level + +(************************************************) +(* Abstract machine *****************************) +(************************************************) + +(* gestion de la pile *) +external push_ra : tcode -> unit = "coq_push_ra" +external push_val : values -> unit = "coq_push_val" +external push_arguments : arguments -> unit = "coq_push_arguments" +external push_vstack : vstack -> unit = "coq_push_vstack" + + +(* interpreteur *) +external interprete : tcode -> values -> vm_env -> int -> values = + "coq_interprete_ml" + + + +(* Functions over arguments *) +let nargs : arguments -> int = fun args -> (Obj.size (Obj.repr args)) - 2 +let arg args i = + if 0 <= i && i < (nargs args) then + val_of_obj (Obj.field (Obj.repr args) (i+2)) + else invalid_arg + ("Vm.arg size = "^(string_of_int (nargs args))^ + " acces "^(string_of_int i)) + +(* Apply a value to arguments contained in [vargs] *) +let apply_arguments vf vargs = + let n = nargs vargs in + if Int.equal n 0 then vf + else + begin + push_ra stop; + push_arguments vargs; + interprete (fun_code vf) vf (Obj.magic vf) (n - 1) + end + +(* Apply value [vf] to an array of argument values [varray] *) +let apply_varray vf varray = + let n = Array.length varray in + if Int.equal n 0 then vf + else + begin + push_ra stop; + push_vstack varray; + interprete (fun_code vf) vf (Obj.magic vf) (n - 1) + end (*************************************************) (* Destructors ***********************************) (*************************************************) +let uni_lvl_val (v : values) : Univ.universe_level = + let whd = Obj.magic v in + match whd with + | Vuniv_level lvl -> lvl + | _ -> + let pr = + let open Pp in + match whd with + | Vsort _ -> str "Vsort" + | Vprod _ -> str "Vprod" + | Vfun _ -> str "Vfun" + | Vfix _ -> str "Vfix" + | Vcofix _ -> str "Vcofix" + | Vconstr_const i -> str "Vconstr_const" + | Vconstr_block b -> str "Vconstr_block" + | Vatom_stk (a,stk) -> str "Vatom_stk" + | _ -> assert false + in + Errors.anomaly + Pp.( strbrk "Parsing virtual machine value expected universe level, got " + ++ pr) + let rec whd_accu a stk = let stk = if Int.equal (Obj.size a) 2 then stk else Zapp (Obj.obj a) :: stk in let at = Obj.field a 1 in match Obj.tag at with - | i when i <= 2 -> + | i when Int.equal i type_atom_tag -> + begin match stk with + | [Zapp args] -> + let u = ref (Obj.obj (Obj.field at 0)) in + for i = 0 to nargs args - 1 do + u := Univ.Universe.sup !u (Univ.Universe.make (uni_lvl_val (arg args i))) + done; + Vsort (Type !u) + | _ -> assert false + end + | i when i <= max_atom_tag -> Vatom_stk(Obj.magic at, stk) - | 3 (* fix_app tag *) -> + | i when Int.equal i proj_tag -> + let zproj = Zproj (Obj.obj (Obj.field at 0)) in + whd_accu (Obj.field at 1) (zproj :: stk) + | i when Int.equal i fix_app_tag -> let fa = Obj.field at 1 in let zfix = Zfix (Obj.obj (Obj.field fa 1), Obj.obj fa) in whd_accu (Obj.field at 0) (zfix :: stk) - | 4 (* switch tag *) -> + | i when Int.equal i switch_tag -> let zswitch = Zswitch (Obj.obj (Obj.field at 1)) in whd_accu (Obj.field at 0) (zswitch :: stk) - | 5 (* cofix_tag *) -> + | i when Int.equal i cofix_tag -> let vcfx = Obj.obj (Obj.field at 0) in let to_up = Obj.obj a in begin match stk with @@ -192,7 +273,7 @@ let rec whd_accu a stk = | [Zapp args] -> Vcofix(vcfx, to_up, Some args) | _ -> assert false end - | 6 (* cofix_evaluated_tag *) -> + | i when Int.equal i cofix_evaluated_tag -> let vcofix = Obj.obj (Obj.field at 0) in let res = Obj.obj a in begin match stk with @@ -200,7 +281,9 @@ let rec whd_accu a stk = | [Zapp args] -> Vcofix(vcofix, res, Some args) | _ -> assert false end - | _ -> assert false + | tg -> + Errors.anomaly + Pp.(strbrk "Failed to parse VM value. Tag = " ++ int tg) external kind_of_closure : Obj.t -> int = "coq_kind_of_closure" @@ -213,65 +296,19 @@ let whd_val : values -> whd = if tag = accu_tag then ( if Int.equal (Obj.size o) 1 then Obj.obj o (* sort *) - else + else if is_accumulate (fun_code o) then whd_accu o [] - else (Vprod(Obj.obj o))) + else Vprod(Obj.obj o)) else if tag = Obj.closure_tag || tag = Obj.infix_tag then - ( match kind_of_closure o with + (match kind_of_closure o with | 0 -> Vfun(Obj.obj o) | 1 -> Vfix(Obj.obj o, None) | 2 -> Vfix(Obj.obj (Obj.field o 1), Some (Obj.obj o)) | 3 -> Vatom_stk(Aid(RelKey(int_tcode (fun_code o) 1)), []) | _ -> Errors.anomaly ~label:"Vm.whd " (Pp.str "kind_of_closure does not work")) - else - Vconstr_block(Obj.obj o) - -(************************************************) -(* Abstrct machine ******************************) -(************************************************) - -(* gestion de la pile *) -external push_ra : tcode -> unit = "coq_push_ra" -external push_val : values -> unit = "coq_push_val" -external push_arguments : arguments -> unit = "coq_push_arguments" -external push_vstack : vstack -> unit = "coq_push_vstack" - - -(* interpreteur *) -external interprete : tcode -> values -> vm_env -> int -> values = - "coq_interprete_ml" - - - -(* Functions over arguments *) -let nargs : arguments -> int = fun args -> (Obj.size (Obj.repr args)) - 2 -let arg args i = - if 0 <= i && i < (nargs args) then - val_of_obj (Obj.field (Obj.repr args) (i+2)) - else invalid_arg - ("Vm.arg size = "^(string_of_int (nargs args))^ - " acces "^(string_of_int i)) - -let apply_arguments vf vargs = - let n = nargs vargs in - if Int.equal n 0 then vf - else - begin - push_ra stop; - push_arguments vargs; - interprete (fun_code vf) vf (Obj.magic vf) (n - 1) - end - -let apply_vstack vf vstk = - let n = Array.length vstk in - if Int.equal n 0 then vf - else - begin - push_ra stop; - push_vstack vstk; - interprete (fun_code vf) vf (Obj.magic vf) (n - 1) - end + else + Vconstr_block(Obj.obj o) (**********************************************) (* Constructors *******************************) @@ -289,6 +326,7 @@ let rec obj_of_str_const str = match str with | Const_sorts s -> Obj.repr (Vsort s) | Const_ind ind -> obj_of_atom (Aind ind) + | Const_proj p -> Obj.repr p | Const_b0 tag -> Obj.repr tag | Const_bn(tag, args) -> let len = Array.length args in @@ -297,6 +335,8 @@ let rec obj_of_str_const str = Obj.set_field res i (obj_of_str_const args.(i)) done; res + | Const_univ_level l -> Obj.repr (Vuniv_level l) + | Const_type u -> obj_of_atom (Atype u) let val_of_obj o = ((Obj.obj o) : values) @@ -304,13 +344,22 @@ let val_of_str_const str = val_of_obj (obj_of_str_const str) let val_of_atom a = val_of_obj (obj_of_atom a) +let atom_of_proj kn v = + let r = Obj.new_block proj_tag 2 in + Obj.set_field r 0 (Obj.repr kn); + Obj.set_field r 1 (Obj.repr v); + ((Obj.obj r) : atom) + +let val_of_proj kn v = + val_of_atom (atom_of_proj kn v) + module IdKeyHash = struct - type t = pconstant tableKey - let equal = Names.eq_table_key (Univ.eq_puniverses Constant.equal) + type t = constant tableKey + let equal = Names.eq_table_key Constant.equal open Hashset.Combine let hash = function - | ConstKey (c,u) -> combinesmall 1 (Constant.hash c) + | ConstKey c -> combinesmall 1 (Constant.hash c) | VarKey id -> combinesmall 2 (Id.hash id) | RelKey i -> combinesmall 3 (Int.hash i) end @@ -354,14 +403,14 @@ external closure_arity : vfun -> int = "coq_closure_arity" let body_of_vfun k vf = let vargs = mkrel_vstack k 1 in - apply_vstack (Obj.magic vf) vargs + apply_varray (Obj.magic vf) vargs let decompose_vfun2 k vf1 vf2 = let arity = min (closure_arity vf1) (closure_arity vf2) in assert (0 < arity && arity < Sys.max_array_length); let vargs = mkrel_vstack k arity in - let v1 = apply_vstack (Obj.magic vf1) vargs in - let v2 = apply_vstack (Obj.magic vf2) vargs in + let v1 = apply_varray (Obj.magic vf1) vargs in + let v2 = apply_varray (Obj.magic vf2) vargs in arity, v1, v2 (* Functions over fixpoint *) @@ -491,7 +540,7 @@ let reduce_cofix k vcf = let self = Obj.new_block accu_tag 2 in Obj.set_field self 0 (Obj.repr accumulate); Obj.set_field self 1 (Obj.repr atom); - apply_vstack (Obj.obj e) [|Obj.obj self|] in + apply_varray (Obj.obj e) [|Obj.obj self|] in (Array.init ndef cofix_body, ftyp) @@ -544,62 +593,13 @@ let branch_of_switch k sw = in Array.map eval_branch sw.sw_annot.rtbl - - -(* Evaluation *) - -let rec whd_stack v stk = - match stk with - | [] -> whd_val v - | Zapp args :: stkt -> whd_stack (apply_arguments v args) stkt - | Zfix (f,args) :: stkt -> - let o = Obj.repr v in - if Obj.is_block o && Obj.tag o = accu_tag then - whd_accu (Obj.repr v) stk - else - let v', stkt = - match stkt with - | Zapp args' :: stkt -> - push_ra stop; - push_arguments args'; - push_val v; - push_arguments args; - let v' = - interprete (fun_code f) (Obj.magic f) (Obj.magic f) - (nargs args+ nargs args') in - v', stkt - | _ -> - push_ra stop; - push_val v; - push_arguments args; - let v' = - interprete (fun_code f) (Obj.magic f) (Obj.magic f) - (nargs args) in - v', stkt - in - whd_stack v' stkt - | Zswitch sw :: stkt -> - let o = Obj.repr v in - if Obj.is_block o && Obj.tag o = accu_tag then - if Obj.tag (Obj.field o 1) < cofix_tag then whd_accu (Obj.repr v) stk - else - let to_up = - match whd_accu (Obj.repr v) [] with - | Vcofix (_, to_up, _) -> to_up - | _ -> assert false in - whd_stack (apply_switch sw to_up) stkt - else whd_stack (apply_switch sw v) stkt - -let rec force_whd v stk = - match whd_stack v stk with - | Vatom_stk(Aiddef(_,v),stk) -> force_whd v stk - | res -> res - - -let rec eta_stack a stk v = +(* Apply the term represented by a under stack stk to argument v *) +(* t = a stk --> t v *) +let rec apply_stack a stk v = match stk with - | [] -> apply_vstack a [|v|] - | Zapp args :: stk -> eta_stack (apply_arguments a args) stk v + | [] -> apply_varray a [|v|] + | Zapp args :: stk -> apply_stack (apply_arguments a args) stk v + | Zproj kn :: stk -> apply_stack (val_of_proj kn a) stk v | Zfix(f,args) :: stk -> let a,stk = match stk with @@ -620,11 +620,11 @@ let rec eta_stack a stk v = interprete (fun_code f) (Obj.magic f) (Obj.magic f) (nargs args) in a, stk in - eta_stack a stk v + apply_stack a stk v | Zswitch sw :: stk -> - eta_stack (apply_switch sw a) stk v + apply_stack (apply_switch sw a) stk v -let eta_whd k whd = +let apply_whd k whd = let v = val_of_rel k in match whd with | Vsort _ | Vprod _ | Vconstr_const _ | Vconstr_block _ -> assert false @@ -643,8 +643,35 @@ let eta_whd k whd = push_val v; interprete (fun_code to_up) (Obj.magic to_up) (Obj.magic to_up) 0 | Vatom_stk(a,stk) -> - eta_stack (val_of_atom a) stk v - - - - + apply_stack (val_of_atom a) stk v + | Vuniv_level lvl -> assert false + +let rec pr_atom a = + Pp.(match a with + | Aid c -> str "Aid(" ++ (match c with + | ConstKey c -> Names.pr_con c + | RelKey i -> str "#" ++ int i + | _ -> str "...") ++ str ")" + | Aind (mi,i) -> str "Aind(" ++ Names.pr_mind mi ++ str "#" ++ int i ++ str ")" + | Atype _ -> str "Atype(") +and pr_whd w = + Pp.(match w with + | Vsort _ -> str "Vsort" + | Vprod _ -> str "Vprod" + | Vfun _ -> str "Vfun" + | Vfix _ -> str "Vfix" + | Vcofix _ -> str "Vcofix" + | Vconstr_const i -> str "Vconstr_const(" ++ int i ++ str ")" + | Vconstr_block b -> str "Vconstr_block" + | Vatom_stk (a,stk) -> str "Vatom_stk(" ++ pr_atom a ++ str ", " ++ pr_stack stk ++ str ")" + | Vuniv_level _ -> assert false) +and pr_stack stk = + Pp.(match stk with + | [] -> str "[]" + | s :: stk -> pr_zipper s ++ str " :: " ++ pr_stack stk) +and pr_zipper z = + Pp.(match z with + | Zapp args -> str "Zapp(len = " ++ int (nargs args) ++ str ")" + | Zfix (f,args) -> str "Zfix(..., len=" ++ int (nargs args) ++ str ")" + | Zswitch s -> str "Zswitch(...)" + | Zproj c -> str "Zproj(" ++ Names.pr_con c ++ str ")") diff --git a/kernel/vm.mli b/kernel/vm.mli index 51903568..43a42eb9 100644 --- a/kernel/vm.mli +++ b/kernel/vm.mli @@ -2,13 +2,10 @@ open Names open Term open Cbytecodes -(** Efficient Virtual Machine *) +(** Debug printing *) val set_drawinstr : unit -> unit -val transp_values : unit -> bool -val set_transp_values : bool -> unit - (** Machine code *) type tcode @@ -25,8 +22,8 @@ type arguments type atom = | Aid of Vars.id_key - | Aiddef of Vars.id_key * values - | Aind of pinductive + | Aind of inductive + | Atype of Univ.universe (** Zippers *) @@ -34,6 +31,7 @@ type zipper = | Zapp of arguments | Zfix of vfix * arguments (** might be empty *) | Zswitch of vswitch + | Zproj of Constant.t (* name of the projection *) type stack = zipper list @@ -48,19 +46,24 @@ type whd = | Vconstr_const of int | Vconstr_block of vblock | Vatom_stk of atom * stack + | Vuniv_level of Univ.universe_level + +val pr_atom : atom -> Pp.std_ppcmds +val pr_whd : whd -> Pp.std_ppcmds (** Constructors *) val val_of_str_const : structured_constant -> values val val_of_rel : int -> values val val_of_named : Id.t -> values -val val_of_constant : pconstant -> values +val val_of_constant : constant -> values external val_of_annot_switch : annot_switch -> values = "%identity" (** Destructors *) val whd_val : values -> whd +val uni_lvl_val : values -> Univ.universe_level (** Arguments *) @@ -105,10 +108,6 @@ val case_info : vswitch -> case_info val type_of_switch : vswitch -> values val branch_of_switch : int -> vswitch -> (int * values) array -(** Evaluation *) - -val whd_stack : values -> stack -> whd -val force_whd : values -> stack -> whd - -val eta_whd : int -> whd -> values +(** Apply a value *) +val apply_whd : int -> whd -> values diff --git a/lib/aux_file.ml b/lib/aux_file.ml index c9018c9e..5dedb0d0 100644 --- a/lib/aux_file.ml +++ b/lib/aux_file.ml @@ -42,6 +42,8 @@ module M = Map.Make(String) type data = string M.t type aux_file = data H.t +let contents x = x + let empty_aux_file = H.empty let get aux loc key = M.find key (H.find (Loc.unloc loc) aux) diff --git a/lib/aux_file.mli b/lib/aux_file.mli index e340fc65..b672d3db 100644 --- a/lib/aux_file.mli +++ b/lib/aux_file.mli @@ -13,6 +13,10 @@ val get : aux_file -> Loc.t -> string -> string val empty_aux_file : aux_file val set : aux_file -> Loc.t -> string -> string -> aux_file +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 stop_aux_file : unit -> unit val recording : unit -> bool diff --git a/lib/cThread.ml b/lib/cThread.ml index 2d1f10bf..9cbdf5a9 100644 --- a/lib/cThread.ml +++ b/lib/cThread.ml @@ -8,22 +8,12 @@ type thread_ic = in_channel -let prepare_in_channel_for_thread_friendly_io ic = - Unix.set_nonblock (Unix.descr_of_in_channel ic); ic - -let safe_wait_timed_read fd time = - try Thread.wait_timed_read fd time - with Unix.Unix_error (Unix.EINTR, _, _) -> - (** On Unix, the above function may raise this exception when it is - interrupted by a signal. (It uses Unix.select internally.) *) - false +let prepare_in_channel_for_thread_friendly_io ic = ic let thread_friendly_read_fd fd s ~off ~len = let rec loop () = try Unix.read fd s off len - with Unix.Unix_error((Unix.EWOULDBLOCK|Unix.EAGAIN|Unix.EINTR),_,_) -> - while not (safe_wait_timed_read fd 0.05) do Thread.yield () done; - loop () + with Unix.Unix_error(Unix.EINTR,_,_) -> loop () in loop () diff --git a/lib/clib.mllib b/lib/clib.mllib index 2da81c95..7ff1d293 100644 --- a/lib/clib.mllib +++ b/lib/clib.mllib @@ -29,6 +29,7 @@ Util Stateid Feedback Pp +Ppstyle Xml_lexer Xml_parser Xml_printer @@ -7,6 +7,7 @@ (************************************************************************) open Errors +open Pp (* Dynamics, programmed with DANGER !!! *) @@ -23,7 +24,7 @@ let create (s : string) = let () = if Int.Map.mem hash !dyntab then let old = Int.Map.find hash !dyntab in - let msg = Pp.str ("Dynamic tag collision: " ^ s ^ " vs. " ^ old) in + let msg = str "Dynamic tag collision: " ++ str s ++ str " vs. " ++ str old in anomaly ~label:"Dyn.create" msg in let () = dyntab := Int.Map.add hash s !dyntab in @@ -31,8 +32,7 @@ let create (s : string) = let outfun (nh, rv) = if Int.equal hash nh then Obj.magic rv else - let msg = (Pp.str ("dyn_out: expected " ^ s)) in - anomaly msg + anomaly (str "dyn_out: expected " ++ str s) in (infun, outfun) @@ -43,8 +43,7 @@ let has_tag (s, _) tag = let tag (s,_) = try Int.Map.find s !dyntab with Not_found -> - let msg = Pp.str ("Unknown dynamic tag " ^ (string_of_int s)) in - anomaly msg + anomaly (str "Unknown dynamic tag " ++ int s) let pointer_equal (t1,o1) (t2,o2) = t1 = t2 && o1 == o2 diff --git a/lib/errors.ml b/lib/errors.ml index a4ec357e..c1d224df 100644 --- a/lib/errors.ml +++ b/lib/errors.ml @@ -69,12 +69,12 @@ let rec print_gen bottom stk e = let where = function | None -> mt () | Some s -> - if !Flags.debug then str ("in "^s^":") ++ spc () else mt () + if !Flags.debug then str "in " ++ str s ++ str ":" ++ spc () else mt () let raw_anomaly e = match e with | Anomaly (s, pps) -> where s ++ pps ++ str "." - | Assert_failure _ | Match_failure _ -> str (Printexc.to_string e ^ ".") - | _ -> str ("Uncaught exception " ^ Printexc.to_string e ^ ".") + | Assert_failure _ | Match_failure _ -> str (Printexc.to_string e) ++ str "." + | _ -> str "Uncaught exception " ++ str (Printexc.to_string e) ++ str "." let print_backtrace e = match Backtrace.get_backtrace e with | None -> mt () @@ -99,6 +99,8 @@ let iprint (e, info) = print ~info e (** Same as [print], except that the "Please report" part of an anomaly isn't printed (used in Ltac debugging). *) let print_no_report e = print_gen (print_anomaly false) !handle_stack e +let iprint_no_report (e, info) = + print_gen (print_anomaly false) !handle_stack e ++ print_backtrace info (** Predefined handlers **) @@ -118,3 +120,22 @@ let noncritical = function | Timeout | Drop | Quit -> false | Invalid_argument "equal: functional value" -> false | _ -> true + +(** Check whether an exception is handled *) + +exception Bottom + +let handled e = + let bottom _ = raise Bottom in + try let _ = print_gen bottom !handle_stack e in true + with Bottom -> false + +(** Prints info which is either an error or + an anomaly and then exits with the appropriate + error code *) + +let fatal_error info anomaly = + let msg = info ++ fnl () in + pp_with ~pp_tag:Ppstyle.pp_tag !Pp_control.err_ft msg; + flush_all (); + exit (if anomaly then 129 else 1) diff --git a/lib/errors.mli b/lib/errors.mli index 03caa6a9..e5dad93f 100644 --- a/lib/errors.mli +++ b/lib/errors.mli @@ -80,6 +80,7 @@ val iprint : Exninfo.iexn -> Pp.std_ppcmds (** Same as [print], except that the "Please report" part of an anomaly isn't printed (used in Ltac debugging). *) val print_no_report : exn -> Pp.std_ppcmds +val iprint_no_report : Exninfo.iexn -> Pp.std_ppcmds (** Critical exceptions should not be caught and ignored by mistake by inner functions during a [vernacinterp]. They should be handled @@ -87,3 +88,12 @@ val print_no_report : exn -> Pp.std_ppcmds Typical example: [Sys.Break], [Assert_failure], [Anomaly] ... *) val noncritical : exn -> bool + +(** Check whether an exception is handled by some toplevel printer. The + [Anomaly] exception is never handled. *) +val handled : exn -> bool + +(** Prints info which is either an error or + an anomaly and then exits with the appropriate + error code *) +val fatal_error : Pp.std_ppcmds -> bool -> 'a diff --git a/lib/flags.ml b/lib/flags.ml index c8e7f7af..ab4ac03f 100644 --- a/lib/flags.ml +++ b/lib/flags.ml @@ -48,6 +48,8 @@ let batch_mode = ref false type compilation_mode = BuildVo | BuildVio | Vio2Vo let compilation_mode = ref BuildVo +let test_mode = ref false + type async_proofs = APoff | APonLazy | APon let async_proofs_mode = ref APoff type cache = Force @@ -160,7 +162,7 @@ let make_polymorphic_flag b = let program_mode = ref false let is_program_mode () = !program_mode -let warn = ref true +let warn = ref false let make_warn flag = warn := flag; () let if_warn f x = if !warn then f x @@ -206,10 +208,14 @@ let inline_level = ref default_inline_level let set_inline_level = (:=) inline_level let get_inline_level () = !inline_level -(* Disabling native code compilation for conversion and normalization *) -let no_native_compiler = ref Coq_config.no_native_compiler +(* Native code compilation for conversion and normalization *) +let native_compiler = ref false (* Print the mod uid associated to a vo file by the native compiler *) let print_mod_uid = ref false let tactic_context_compat = ref false + +let dump_bytecode = ref false +let set_dump_bytecode = (:=) dump_bytecode +let get_dump_bytecode () = !dump_bytecode diff --git a/lib/flags.mli b/lib/flags.mli index 756d3b85..8e371365 100644 --- a/lib/flags.mli +++ b/lib/flags.mli @@ -15,6 +15,8 @@ val batch_mode : bool ref type compilation_mode = BuildVo | BuildVio | Vio2Vo val compilation_mode : compilation_mode ref +val test_mode : bool ref + type async_proofs = APoff | APonLazy | APon val async_proofs_mode : async_proofs ref type cache = Force @@ -128,12 +130,17 @@ val set_inline_level : int -> unit val get_inline_level : unit -> int val default_inline_level : int -(* Disabling native code compilation for conversion and normalization *) -val no_native_compiler : bool ref +(** Native code compilation for conversion and normalization *) +val native_compiler : bool ref -(* Print the mod uid associated to a vo file by the native compiler *) +(** Print the mod uid associated to a vo file by the native compiler *) val print_mod_uid : bool ref val tactic_context_compat : bool ref (** Set to [true] to trigger the compatibility bugged context matching (old context vs. appcontext) is set. *) + +(** Dump the bytecode after compilation (for debugging purposes) *) +val dump_bytecode : bool ref +val set_dump_bytecode : bool -> unit +val get_dump_bytecode : unit -> bool diff --git a/lib/future.ml b/lib/future.ml index 02d3702d..78a15826 100644 --- a/lib/future.ml +++ b/lib/future.ml @@ -11,21 +11,27 @@ let freeze = ref (fun () -> assert false : unit -> Dyn.t) let unfreeze = ref (fun _ -> () : Dyn.t -> unit) let set_freeze f g = freeze := f; unfreeze := g -exception NotReady of string -exception NotHere of string -let _ = Errors.register_handler (function - | NotReady name -> +let not_ready_msg = ref (fun name -> Pp.strbrk("The value you are asking for ("^name^") is not ready yet. "^ "Please wait or pass "^ "the \"-async-proofs off\" option to CoqIDE to disable "^ "asynchronous script processing and don't pass \"-quick\" to "^ - "coqc.") - | NotHere name -> + "coqc.")) +let not_here_msg = ref (fun name -> Pp.strbrk("The value you are asking for ("^name^") is not available "^ "in this process. If you really need this, pass "^ "the \"-async-proofs off\" option to CoqIDE to disable "^ "asynchronous script processing and don't pass \"-quick\" to "^ - "coqc.") + "coqc.")) + +let customize_not_ready_msg f = not_ready_msg := f +let customize_not_here_msg f = not_here_msg := f + +exception NotReady of string +exception NotHere of string +let _ = Errors.register_handler (function + | NotReady name -> !not_ready_msg name + | NotHere name -> !not_here_msg name | _ -> raise Errors.Unhandled) type fix_exn = Exninfo.iexn -> Exninfo.iexn diff --git a/lib/future.mli b/lib/future.mli index 324d5f7d..adc15e49 100644 --- a/lib/future.mli +++ b/lib/future.mli @@ -91,13 +91,13 @@ val from_here : ?fix_exn:fix_exn -> 'a -> 'a computation * When a future enters the environment a corresponding hook is run to perform * some work. If this fails, then its failure has to be annotated with the * same state id that corresponds to the future computation end. I.e. Qed - * is split into two parts, the lazy one (the future) and the eagher one + * is split into two parts, the lazy one (the future) and the eager one * (the hook), both performing some computations for the same state id. *) val fix_exn_of : 'a computation -> fix_exn (* Run remotely, returns the function to assign. If not blocking (the default) it raises NotReady if forced before the - delage assigns it. *) + delegate assigns it. *) type 'a assignement = [ `Val of 'a | `Exn of Exninfo.iexn | `Comp of 'a computation] val create_delegate : ?blocking:bool -> name:string -> @@ -161,3 +161,6 @@ val print : ('a -> Pp.std_ppcmds) -> 'a computation -> Pp.std_ppcmds Thy are set for the outermos layer of the system, since they have to deal with the whole system state. *) val set_freeze : (unit -> Dyn.t) -> (Dyn.t -> unit) -> unit + +val customize_not_ready_msg : (string -> Pp.std_ppcmds) -> unit +val customize_not_here_msg : (string -> Pp.std_ppcmds) -> unit @@ -8,13 +8,9 @@ module Glue : sig - (* A left associative glue implements efficient glue operator - when used as left associative. If glue is denoted ++ then + (** The [Glue] module implements a container data structure with + efficient concatenation. *) - a ++ b ++ c ++ d = ((a ++ b) ++ c) ++ d = [d] @ ([c] @ ([b] @ [a])) - - I.e. if the short list is the second argument - *) type 'a t val atom : 'a -> 'a t @@ -22,19 +18,28 @@ module Glue : sig val empty : 'a t val is_empty : 'a t -> bool val iter : ('a -> unit) -> 'a t -> unit - val map : ('a -> 'b) -> 'a t -> 'b t end = struct - type 'a t = 'a list + type 'a t = GEmpty | GLeaf of 'a | GNode of 'a t * 'a t + + let atom x = GLeaf x + + let glue x y = + match x, y with + | GEmpty, _ -> y + | _, GEmpty -> x + | _, _ -> GNode (x,y) + + let empty = GEmpty - let atom x = [x] - let glue x y = y @ x - let empty = [] - let is_empty x = x = [] + let is_empty x = x = GEmpty + + let rec iter f = function + | GEmpty -> () + | GLeaf x -> f x + | GNode (x,y) -> iter f x; iter f y - let iter f g = List.iter f (List.rev g) - let map = List.map end module Tag : @@ -145,21 +150,6 @@ let app = Glue.glue let is_empty g = Glue.is_empty g -let rewrite f p = - let strtoken = function - | Str_len (s, n) -> - let s' = f s in - Str_len (s', String.length s') - | Str_def s -> - Str_def (f s) - in - let rec ppcmd_token = function - | Ppcmd_print x -> Ppcmd_print (strtoken x) - | Ppcmd_box (bt, g) -> Ppcmd_box (bt, Glue.map ppcmd_token g) - | p -> p - in - Glue.map ppcmd_token p - (* 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 @@ -259,7 +249,7 @@ let escape_string s = else escape_at s (i-1) in escape_at s (String.length s - 1) -let qstring s = str ("\""^escape_string s^"\"") +let qstring s = str "\"" ++ str (escape_string s) ++ str "\"" let qs = qstring let quote s = h 0 (str "\"" ++ s ++ str "\"") @@ -372,11 +362,11 @@ let emacs_quote_info_start = "<infomsg>" let emacs_quote_info_end = "</infomsg>" let emacs_quote g = - if !print_emacs then str emacs_quote_start ++ hov 0 g ++ str emacs_quote_end + if !print_emacs then hov 0 (str emacs_quote_start ++ g ++ str emacs_quote_end) else hov 0 g let emacs_quote_info g = - if !print_emacs then str emacs_quote_info_start++fnl() ++ hov 0 g ++ str emacs_quote_info_end + if !print_emacs then hov 0 (str emacs_quote_info_start++ brk(0,0) ++ g ++ brk(0,0) ++ str emacs_quote_info_end) else hov 0 g @@ -434,7 +424,7 @@ type logger = message_level -> std_ppcmds -> unit let make_body info s = emacs_quote (hov 0 (info ++ spc () ++ s)) -let debugbody strm = hov 0 (str "Debug:" ++ spc () ++ strm) +let debugbody strm = emacs_quote_info (hov 0 (str "Debug:" ++ spc () ++ strm)) let warnbody strm = make_body (str "Warning:") strm let errorbody strm = make_body (str "Error:") strm let infobody strm = emacs_quote_info strm @@ -458,6 +448,27 @@ let logger = ref std_logger let make_pp_emacs() = print_emacs:=true; logger:=emacs_logger let make_pp_nonemacs() = print_emacs:=false; logger := std_logger +let ft_logger old_logger ft ~id level mesg = match level with + | Debug _ -> msgnl_with ft (debugbody mesg) + | Info -> msgnl_with ft (infobody mesg) + | Notice -> msgnl_with ft mesg + | Warning -> old_logger ~id:id level mesg + | Error -> old_logger ~id:id level mesg + +let with_output_to_file fname func input = + let old_logger = !logger in + let channel = open_out (String.concat "." [fname; "out"]) in + logger := ft_logger old_logger (Format.formatter_of_out_channel channel); + try + let output = func input in + logger := old_logger; + close_out channel; + output + with reraise -> + let reraise = Backtrace.add_backtrace reraise in + logger := old_logger; + close_out channel; + Exninfo.iraise reraise let feedback_id = ref (Feedback.Edit 0) let feedback_route = ref Feedback.default_route @@ -12,6 +12,8 @@ val make_pp_emacs:unit -> unit val make_pp_nonemacs:unit -> unit +val with_output_to_file : string -> ('a -> 'b) -> 'a -> 'b + (** Pretty-printers. *) type std_ppcmds @@ -46,9 +48,6 @@ val eval_ppcmds : std_ppcmds -> std_ppcmds val is_empty : std_ppcmds -> bool (** Test emptyness. *) -val rewrite : (string -> string) -> std_ppcmds -> std_ppcmds -(** [rewrite f pps] applies [f] to all strings that appear in [pps]. *) - (** {6 Derived commands} *) val spc : unit -> std_ppcmds diff --git a/lib/pp_control.ml b/lib/pp_control.ml index 0d224c03..969c1550 100644 --- a/lib/pp_control.ml +++ b/lib/pp_control.ml @@ -20,7 +20,7 @@ let dflt_gp = { margin = 78; max_indent = 50; max_depth = 50; - ellipsis = ".." } + ellipsis = "..." } (* A deeper pretty-printer to print proof scripts *) @@ -84,5 +84,10 @@ let set_margin v = let v = match v with None -> default_margin | Some v -> v in Format.pp_set_margin Format.str_formatter v; Format.pp_set_margin !std_ft v; - Format.pp_set_margin !deep_ft v - + Format.pp_set_margin !deep_ft v; + (* Heuristic, based on usage: the column on the right of max_indent + column is 20% of width, capped to 30 characters *) + let m = max (64 * v / 100) (v-30) in + Format.pp_set_max_indent Format.str_formatter m; + Format.pp_set_max_indent !std_ft m; + Format.pp_set_max_indent !deep_ft m diff --git a/printing/ppstyle.ml b/lib/ppstyle.ml index fb334c70..fb334c70 100644 --- a/printing/ppstyle.ml +++ b/lib/ppstyle.ml diff --git a/printing/ppstyle.mli b/lib/ppstyle.mli index f5d6184c..f5d6184c 100644 --- a/printing/ppstyle.mli +++ b/lib/ppstyle.mli diff --git a/lib/richpp.mli b/lib/richpp.mli index bf80c8dc..a0d3c374 100644 --- a/lib/richpp.mli +++ b/lib/richpp.mli @@ -20,7 +20,7 @@ type 'annotation located = { of [ppcmds] as a semi-structured document that represents (located) annotations of this string. The [get_annotations] function is used to convert tags into the desired - annotation. If this function returns [None], then no annotation is put. *) + annotation. *) val rich_pp : (Pp.Tag.t -> 'annotation option) -> Pp.std_ppcmds -> 'annotation located Xml_datatype.gxml diff --git a/lib/spawn.ml b/lib/spawn.ml index 9b63be70..851c6a22 100644 --- a/lib/spawn.ml +++ b/lib/spawn.ml @@ -45,26 +45,38 @@ end (* Common code *) let assert_ b s = if not b then Errors.anomaly (Pp.str s) +(* According to http://caml.inria.fr/mantis/view.php?id=5325 + * you can't use the same socket for both writing and reading (may change + * in 4.03 *) let mk_socket_channel () = let open Unix in - let s = socket PF_INET SOCK_STREAM 0 in - bind s (ADDR_INET (inet_addr_loopback,0)); - listen s 1; - match getsockname s with - | ADDR_INET(host, port) -> - s, string_of_inet_addr host ^":"^ string_of_int port + let sr = socket PF_INET SOCK_STREAM 0 in + bind sr (ADDR_INET (inet_addr_loopback,0)); listen sr 1; + let sw = socket PF_INET SOCK_STREAM 0 in + bind sw (ADDR_INET (inet_addr_loopback,0)); listen sw 1; + match getsockname sr, getsockname sw with + | ADDR_INET(host, portr), ADDR_INET(_, portw) -> + (sr, sw), + string_of_inet_addr host + ^":"^ string_of_int portr ^":"^ string_of_int portw | _ -> assert false -let accept s = - let r, _, _ = Unix.select [s] [] [] accept_timeout in +let accept (sr,sw) = + let r, _, _ = Unix.select [sr] [] [] accept_timeout in if r = [] then raise (Failure (Printf.sprintf "The spawned process did not connect back in %2.1fs" accept_timeout)); - let cs, _ = Unix.accept s in - Unix.close s; - let cin, cout = Unix.in_channel_of_descr cs, Unix.out_channel_of_descr cs in + let csr, _ = Unix.accept sr in + Unix.close sr; + let cin = Unix.in_channel_of_descr csr in set_binary_mode_in cin true; + let w, _, _ = Unix.select [sw] [] [] accept_timeout in + if w = [] then raise (Failure (Printf.sprintf + "The spawned process did not connect back in %2.1fs" accept_timeout)); + let csw, _ = Unix.accept sw in + Unix.close sw; + let cout = Unix.out_channel_of_descr csw in set_binary_mode_out cout true; - cs, cin, cout + (csr, csw), cin, cout let handshake cin cout = try @@ -116,7 +128,7 @@ let spawn_pipe env prog args = let cout = Unix.out_channel_of_descr master2worker_w in set_binary_mode_in cin true; set_binary_mode_out cout true; - pid, cin, cout, worker2master_r + pid, cin, cout, (worker2master_r, master2worker_w) let filter_args args = let rec aux = function @@ -180,10 +192,10 @@ let spawn ?(prefer_sock=prefer_sock) ?(env=Unix.environment ()) = let pid, oob_resp, oob_req, cin, cout, main, is_sock = spawn_with_control prefer_sock env prog args in - Unix.set_nonblock main; + Unix.set_nonblock (fst main); let gchan = - if is_sock then ML.async_chan_of_socket main - else ML.async_chan_of_file main in + if is_sock then ML.async_chan_of_socket (fst main) + else ML.async_chan_of_file (fst main) in let alive, watch = true, None in let p = { cin; cout; gchan; pid; oob_resp; oob_req; alive; watch } in p.watch <- Some ( diff --git a/lib/system.ml b/lib/system.ml index 73095f9c..ddc56956 100644 --- a/lib/system.ml +++ b/lib/system.ml @@ -118,7 +118,8 @@ let is_in_system_path filename = let open_trapping_failure name = try open_out_bin name - with e when Errors.noncritical e -> error ("Can't open " ^ name) + with e when Errors.noncritical e -> + errorlabstrm "System.open" (str "Can't open " ++ str name) let try_remove filename = try Sys.remove filename @@ -126,7 +127,8 @@ let try_remove filename = msg_warning (str"Could not remove file " ++ str filename ++ str" which is corrupted!") -let error_corrupted file s = error (file ^": " ^ s ^ ". Try to rebuild it.") +let error_corrupted file s = + errorlabstrm "System" (str file ++ str ": " ++ str s ++ str ". Try to rebuild it.") let input_binary_int f ch = try input_binary_int ch @@ -172,47 +174,42 @@ let skip_in_segment f ch = exception Bad_magic_number of string -let raw_extern_intern magic = - let extern_state filename = - let channel = open_trapping_failure filename in - output_binary_int channel magic; - filename, channel - and intern_state filename = - try - let channel = open_in_bin filename in - if not (Int.equal (input_binary_int filename channel) magic) then - raise (Bad_magic_number filename); - channel - with - | End_of_file -> error_corrupted filename "premature end of file" - | Failure s | Sys_error s -> error_corrupted filename s - in - (extern_state,intern_state) +let raw_extern_state magic filename = + let channel = open_trapping_failure filename in + output_binary_int channel magic; + channel -let extern_intern ?(warn=true) magic = - let (raw_extern,raw_intern) = raw_extern_intern magic in - let extern_state name val_0 = - try - let (filename,channel) = raw_extern name in - try - marshal_out channel val_0; - close_out channel - with reraise -> - let reraise = Errors.push reraise in - let () = try_remove filename in - iraise reraise - with Sys_error s -> error ("System error: " ^ s) - and intern_state paths name = +let raw_intern_state magic filename = + try + let channel = open_in_bin filename in + if not (Int.equal (input_binary_int filename channel) magic) then + raise (Bad_magic_number filename); + channel + with + | End_of_file -> error_corrupted filename "premature end of file" + | Failure s | Sys_error s -> error_corrupted filename s + +let extern_state magic filename val_0 = + try + let channel = raw_extern_state magic filename in try - let _,filename = find_file_in_path ~warn paths name in - let channel = raw_intern filename in - let v = marshal_in filename channel in - close_in channel; - v - with Sys_error s -> - error("System error: " ^ s) - in - (extern_state,intern_state) + marshal_out channel val_0; + close_out channel + with reraise -> + let reraise = Errors.push reraise in + let () = try_remove filename in + iraise reraise + with Sys_error s -> + errorlabstrm "System.extern_state" (str "System error: " ++ str s) + +let intern_state magic filename = + try + let channel = raw_intern_state magic filename in + let v = marshal_in filename channel in + close_in channel; + v + with Sys_error s -> + errorlabstrm "System.intern_state" (str "System error: " ++ str s) let with_magic_number_check f a = try f a diff --git a/lib/system.mli b/lib/system.mli index a3d66d57..247d528b 100644 --- a/lib/system.mli +++ b/lib/system.mli @@ -36,11 +36,13 @@ val find_file_in_path : exception Bad_magic_number of string -val raw_extern_intern : int -> - (string -> string * out_channel) * (string -> in_channel) +val raw_extern_state : int -> string -> out_channel -val extern_intern : ?warn:bool -> int -> - (string -> 'a -> unit) * (CUnix.load_path -> string -> 'a) +val raw_intern_state : int -> string -> in_channel + +val extern_state : int -> string -> 'a -> unit + +val intern_state : int -> string -> 'a val with_magic_number_check : ('a -> 'b) -> 'a -> 'b diff --git a/lib/terminal.ml b/lib/terminal.ml index 0f6b23af..58851ed2 100644 --- a/lib/terminal.ml +++ b/lib/terminal.ml @@ -117,7 +117,7 @@ let is_extended = function | `INDEX _ | `RGB _ -> true | _ -> false -let eval st = +let repr st = let fg = match st.fg_color with | None -> [] | Some c -> @@ -152,7 +152,10 @@ let eval st = | Some true -> [7] | Some false -> [27] in - let tags = fg @ bg @ bold @ italic @ underline @ negative in + fg @ bg @ bold @ italic @ underline @ negative + +let eval st = + let tags = repr st in let tags = List.map string_of_int tags in Printf.sprintf "\027[%sm" (String.concat ";" tags) diff --git a/lib/terminal.mli b/lib/terminal.mli index f308ede3..49172e3c 100644 --- a/lib/terminal.mli +++ b/lib/terminal.mli @@ -46,6 +46,9 @@ val make : ?fg_color:color -> ?bg_color:color -> val merge : style -> style -> style (** [merge s1 s2] returns [s1] with all defined values of [s2] overwritten. *) +val repr : style -> int list +(** Generate the ANSI code representing the given style. *) + val eval : style -> string (** Generate an escape sequence from a style. *) diff --git a/lib/util.ml b/lib/util.ml index a8c25f74..a20dba0f 100644 --- a/lib/util.ml +++ b/lib/util.ml @@ -132,3 +132,14 @@ let map_union f g = function type iexn = Exninfo.iexn let iraise = Exninfo.iraise + +let open_utf8_file_in fname = + let is_bom s = + Int.equal (Char.code s.[0]) 0xEF && + Int.equal (Char.code s.[1]) 0xBB && + Int.equal (Char.code s.[2]) 0xBF + in + let in_chan = open_in fname in + let s = " " in + if input in_chan s 0 3 < 3 || not (is_bom s) then seek_in in_chan 0; + in_chan diff --git a/lib/util.mli b/lib/util.mli index 4fce809c..1dc405fc 100644 --- a/lib/util.mli +++ b/lib/util.mli @@ -110,3 +110,6 @@ val map_union : ('a -> 'c) -> ('b -> 'd) -> ('a, 'b) union -> ('c, 'd) union type 'a until = 'a CSig.until = Stop of 'a | Cont of 'a (** Used for browsable-until structures. *) + +val open_utf8_file_in : string -> in_channel +(** Open an utf-8 encoded file and skip the byte-order mark if any. *) diff --git a/lib/xml_lexer.mll b/lib/xml_lexer.mll index a33be9da..290f2c89 100644 --- a/lib/xml_lexer.mll +++ b/lib/xml_lexer.mll @@ -88,7 +88,8 @@ let error lexbuf e = let newline = ['\n'] let break = ['\r'] let space = [' ' '\t'] -let identchar = ['A'-'Z' 'a'-'z' '_' '0'-'9' ':' '-'] +let identchar = ['A'-'Z' 'a'-'z' '_' '0'-'9' ':' '-' '.'] +let ident = ['A'-'Z' 'a'-'z' '_' ':'] identchar* let entitychar = ['A'-'Z' 'a'-'z'] let pcchar = [^ '\r' '\n' '<' '>' '&'] @@ -226,7 +227,7 @@ and entity = parse { raise (Error EUnterminatedEntity) } and ident_name = parse - | identchar+ + | ident { lexeme lexbuf } | _ | eof { error lexbuf EIdentExpected } @@ -252,7 +253,7 @@ and attributes = parse } and attribute = parse - | identchar+ + | ident { lexeme lexbuf } | _ | eof { error lexbuf EAttributeNameExpected } @@ -281,6 +282,11 @@ and dq_string = parse Buffer.add_char tmp (lexeme_char lexbuf 1); dq_string lexbuf } + | '&' + { + Buffer.add_string tmp (entity lexbuf); + dq_string lexbuf + } | eof { raise (Error EUnterminatedString) } | _ @@ -297,6 +303,11 @@ and q_string = parse Buffer.add_char tmp (lexeme_char lexbuf 1); q_string lexbuf } + | '&' + { + Buffer.add_string tmp (entity lexbuf); + q_string lexbuf + } | eof { raise (Error EUnterminatedString) } | _ diff --git a/lib/xml_parser.mli b/lib/xml_parser.mli index cefb4af8..ac2eab35 100644 --- a/lib/xml_parser.mli +++ b/lib/xml_parser.mli @@ -36,10 +36,10 @@ type t (** Several exceptions can be raised when parsing an Xml document : {ul {li {!Xml.Error} is raised when an xml parsing error occurs. the - {!Xml.error_msg} tells you which error occured during parsing - and the {!Xml.error_pos} can be used to retreive the document - location where the error occured at.} - {li {!Xml.File_not_found} is raised when and error occured while + {!Xml.error_msg} tells you which error occurred during parsing + and the {!Xml.error_pos} can be used to retrieve the document + location where the error occurred at.} + {li {!Xml.File_not_found} is raised when an error occurred while opening a file with the {!Xml.parse_file} function.} } *) @@ -71,13 +71,13 @@ val error : error -> string (** Get the Xml error message as a string. *) val error_msg : error_msg -> string -(** Get the line the error occured at. *) +(** Get the line the error occurred at. *) val line : error_pos -> int -(** Get the relative character range (in current line) the error occured at.*) +(** Get the relative character range (in current line) the error occurred at.*) val range : error_pos -> int * int -(** Get the absolute character range the error occured at. *) +(** Get the absolute character range the error occurred at. *) val abs_range : error_pos -> int * int val pos : Lexing.lexbuf -> error_pos @@ -98,7 +98,7 @@ val make : source -> t in the original Xmllight)}. *) val check_eof : t -> bool -> unit -(** Once the parser is configurated, you can run the parser on a any kind +(** Once the parser is configured, you can run the parser on a any kind of xml document source to parse its contents into an Xml data structure. When [do_not_canonicalize] is set, the XML document is given as diff --git a/lib/xml_printer.ml b/lib/xml_printer.ml index eeddd53c..bbb7b51b 100644 --- a/lib/xml_printer.ml +++ b/lib/xml_printer.ml @@ -46,6 +46,8 @@ let buffer_attr tmp (n,v) = match v.[p] with | '\\' -> output "\\\\" | '"' -> output "\\\"" + | '<' -> output "<" + | '&' -> output "&" | c -> output' c done; output' '"' diff --git a/library/declare.ml b/library/declare.ml index c3181e4c..5968fbf3 100644 --- a/library/declare.ml +++ b/library/declare.ml @@ -27,22 +27,22 @@ open Decls open Decl_kinds (** flag for internal message display *) -type internal_flag = - | KernelVerbose (* kernel action, a message is displayed *) - | KernelSilent (* kernel action, no message is displayed *) - | UserVerbose (* user action, a message is displayed *) +type internal_flag = + | UserAutomaticRequest (* kernel action, a message is displayed *) + | InternalTacticRequest (* kernel action, no message is displayed *) + | UserIndividualRequest (* user action, a message is displayed *) (** Declaration of section variables and local definitions *) type section_variable_entry = - | SectionLocalDef of definition_entry + | SectionLocalDef of Safe_typing.private_constants definition_entry | SectionLocalAssum of types Univ.in_universe_context_set * polymorphic * bool (** Implicit status *) type variable_declaration = DirPath.t * section_variable_entry * logical_kind let cache_variable ((sp,_),o) = match o with - | Inl ctx -> Global.push_context_set ctx + | Inl ctx -> Global.push_context_set false ctx | Inr (id,(p,d,mk)) -> (* Constr raisonne sur les noms courts *) if variable_exists id then @@ -50,20 +50,20 @@ let cache_variable ((sp,_),o) = let impl,opaq,poly,ctx = match d with (* Fails if not well-typed *) | SectionLocalAssum ((ty,ctx),poly,impl) -> - let () = Global.push_named_assum ((id,ty),ctx) in + let () = Global.push_named_assum ((id,ty,poly),ctx) in let impl = if impl then Implicit else Explicit in impl, true, poly, ctx | SectionLocalDef (de) -> - let () = Global.push_named_def (id,de) in - Explicit, de.const_entry_opaque, de.const_entry_polymorphic, - (Univ.ContextSet.of_context de.const_entry_universes) in + let univs = Global.push_named_def (id,de) in + Explicit, de.const_entry_opaque, + de.const_entry_polymorphic, univs in Nametab.push (Nametab.Until 1) (restrict_path 0 sp) (VarRef id); add_section_variable id impl poly ctx; Dischargedhypsmap.set_discharged_hyps sp []; add_variable_data id (p,opaq,ctx,poly,mk) let discharge_variable (_,o) = match o with - | Inr (id,_) -> + | Inr (id,_) -> if variable_polymorphic id then None else Some (Inl (variable_context id)) | Inl _ -> Some o @@ -93,9 +93,13 @@ type constant_obj = { cst_hyps : Dischargedhypsmap.discharged_hyps; cst_kind : logical_kind; cst_locl : bool; + mutable cst_exported : Safe_typing.exported_private_constant list; + (* mutable: to avoid change the libobject API, since cache_function + * does not return an updated object *) + mutable cst_was_seff : bool } -type constant_declaration = constant_entry * logical_kind +type constant_declaration = Safe_typing.private_constants constant_entry * logical_kind (* At load-time, the segment starting from the module name to the discharge *) (* section (if Remark or Fact) is needed to access a construction *) @@ -116,8 +120,9 @@ let open_constant i ((sp,kn), obj) = match (Global.lookup_constant con).const_body with | (Def _ | Undef _) -> () | OpaqueDef lc -> - match Opaqueproof.get_constraints (Global.opaque_tables ())lc with - | Some f when Future.is_val f -> Global.push_context_set (Future.force f) + match Opaqueproof.get_constraints (Global.opaque_tables ()) lc with + | Some f when Future.is_val f -> + Global.push_context_set false (Future.force f) | _ -> () let exists_name id = @@ -130,8 +135,17 @@ let check_exists sp = let cache_constant ((sp,kn), obj) = let id = basename sp in let _,dir,_ = repr_kn kn in - let () = check_exists sp in - let kn' = Global.add_constant dir id obj.cst_decl in + let kn' = + if obj.cst_was_seff then begin + obj.cst_was_seff <- false; + if Global.exists_objlabel (Label.of_id (basename sp)) + then constant_of_kn kn + else Errors.anomaly Pp.(str"Ex seff not found: " ++ Id.print(basename sp)) + end else + let () = check_exists sp in + let kn', exported = Global.add_constant dir id obj.cst_decl in + obj.cst_exported <- exported; + kn' in assert (eq_constant kn' (constant_of_kn kn)); Nametab.push (Nametab.Until 1) sp (ConstRef (constant_of_kn kn)); let cst = Global.lookup_constant kn' in @@ -156,19 +170,22 @@ let discharge_constant ((sp, kn), obj) = (* Hack to reduce the size of .vo: we keep only what load/open needs *) let dummy_constant_entry = - ConstantEntry (ParameterEntry (None,false,(mkProp,Univ.UContext.empty),None)) + ConstantEntry + (false, ParameterEntry (None,false,(mkProp,Univ.UContext.empty),None)) let dummy_constant cst = { cst_decl = dummy_constant_entry; cst_hyps = []; cst_kind = cst.cst_kind; cst_locl = cst.cst_locl; + cst_exported = []; + cst_was_seff = cst.cst_was_seff; } let classify_constant cst = Substitute (dummy_constant cst) -let inConstant : constant_obj -> obj = - declare_object { (default_object "CONSTANT") with +let (inConstant, outConstant : (constant_obj -> obj) * (obj -> constant_obj)) = + declare_object_full { (default_object "CONSTANT") with cache_function = cache_constant; load_function = load_constant; open_function = open_constant; @@ -176,17 +193,41 @@ let inConstant : constant_obj -> obj = subst_function = ident_subst_function; discharge_function = discharge_constant } +let declare_scheme = ref (fun _ _ -> assert false) +let set_declare_scheme f = declare_scheme := f + let declare_constant_common id cst = - let (sp,kn) = add_leaf id (inConstant cst) in + let update_tables c = +(* Printf.eprintf "tables: %s\n%!" (Names.Constant.to_string c); *) + declare_constant_implicits c; + Heads.declare_head (EvalConstRef c); + Notation.declare_ref_arguments_scope (ConstRef c) in + let o = inConstant cst in + let _, kn as oname = add_leaf id o in + List.iter (fun (c,ce,role) -> + (* handling of private_constants just exported *) + let o = inConstant { + cst_decl = ConstantEntry (false, ce); + cst_hyps = [] ; + cst_kind = IsProof Theorem; + cst_locl = false; + cst_exported = []; + cst_was_seff = true; } in + let id = Label.to_id (pi3 (Constant.repr3 c)) in + ignore(add_leaf id o); + update_tables c; + match role with + | Safe_typing.Subproof -> () + | Safe_typing.Schema (ind, kind) -> !declare_scheme kind [|ind,c|]) + (outConstant o).cst_exported; + pull_to_head oname; let c = Global.constant_of_delta_kn kn in - declare_constant_implicits c; - Heads.declare_head (EvalConstRef c); - Notation.declare_ref_arguments_scope (ConstRef c); + update_tables c; c -let definition_entry ?(opaque=false) ?(inline=false) ?types - ?(poly=false) ?(univs=Univ.UContext.empty) ?(eff=Declareops.no_seff) body = - { const_entry_body = Future.from_val ((body,Univ.ContextSet.empty), eff); +let definition_entry ?fix_exn ?(opaque=false) ?(inline=false) ?types + ?(poly=false) ?(univs=Univ.UContext.empty) ?(eff=Safe_typing.empty_private_constants) body = + { const_entry_body = Future.from_val ?fix_exn ((body,Univ.ContextSet.empty), eff); const_entry_secctx = None; const_entry_type = types; const_entry_polymorphic = poly; @@ -195,98 +236,33 @@ let definition_entry ?(opaque=false) ?(inline=false) ?types const_entry_feedback = None; const_entry_inline_code = inline} -let declare_scheme = ref (fun _ _ -> assert false) -let set_declare_scheme f = declare_scheme := f -let declare_sideff env fix_exn se = - let cbl, scheme = match se with - | SEsubproof (c, cb, pt) -> [c, cb, pt], None - | SEscheme (cbl, k) -> - List.map (fun (_,c,cb,pt) -> c,cb,pt) cbl, Some (cbl,k) in - let id_of c = Names.Label.to_id (Names.Constant.label c) in - let pt_opaque_of cb pt = - match cb, pt with - | { const_body = Def sc }, _ -> (Mod_subst.force_constr sc, Univ.ContextSet.empty), false - | { const_body = OpaqueDef _ }, `Opaque(pt,univ) -> (pt, univ), true - | _ -> assert false - in - let ty_of cb = - match cb.Declarations.const_type with - | Declarations.RegularArity t -> Some t - | Declarations.TemplateArity _ -> None in - let cst_of cb pt = - let pt, opaque = pt_opaque_of cb pt in - let univs, subst = - if cb.const_polymorphic then - let univs = Univ.instantiate_univ_context cb.const_universes in - univs, Vars.subst_instance_constr (Univ.UContext.instance univs) - else cb.const_universes, fun x -> x - in - let pt = (subst (fst pt), snd pt) in - let ty = Option.map subst (ty_of cb) in - { cst_decl = ConstantEntry (DefinitionEntry { - const_entry_body = Future.from_here ~fix_exn (pt, Declareops.no_seff); - const_entry_secctx = Some cb.Declarations.const_hyps; - const_entry_type = ty; - const_entry_opaque = opaque; - const_entry_inline_code = false; - const_entry_feedback = None; - const_entry_polymorphic = cb.const_polymorphic; - const_entry_universes = univs; - }); - cst_hyps = [] ; - cst_kind = Decl_kinds.IsDefinition Decl_kinds.Definition; - cst_locl = true; - } in - let exists c = - try ignore(Environ.lookup_constant c env); true - with Not_found -> false in - let knl = - CList.map_filter (fun (c,cb,pt) -> - if exists c then None - else Some (c,declare_constant_common (id_of c) (cst_of cb pt))) cbl in - match scheme with - | None -> () - | Some (inds_consts,kind) -> - !declare_scheme kind (Array.of_list - (List.map (fun (c,kn) -> - CList.find_map (fun (x,c',_,_) -> - if Constant.equal c c' then Some (x,kn) else None) inds_consts) - knl)) - -let declare_constant ?(internal = UserVerbose) ?(local = false) id ?(export_seff=false) (cd, kind) = - let cd = (* We deal with side effects *) +let declare_constant ?(internal = UserIndividualRequest) ?(local = false) id ?(export_seff=false) (cd, kind) = + let export = (* We deal with side effects *) match cd with - | Entries.DefinitionEntry de -> - if export_seff || - not de.const_entry_opaque || - de.const_entry_polymorphic then + | DefinitionEntry de when + export_seff || + not de.const_entry_opaque || + de.const_entry_polymorphic -> let bo = de.const_entry_body in let _, seff = Future.force bo in - if Declareops.side_effects_is_empty seff then cd - else begin - let seff = Declareops.uniquize_side_effects seff in - Declareops.iter_side_effects - (declare_sideff (Global.env ()) (Future.fix_exn_of bo)) seff; - Entries.DefinitionEntry { de with - const_entry_body = Future.chain ~pure:true bo (fun (pt, _) -> - pt, Declareops.no_seff) } - end - else cd - | _ -> cd + Safe_typing.empty_private_constants <> seff + | _ -> false in let cst = { - cst_decl = ConstantEntry cd; + cst_decl = ConstantEntry (export,cd); cst_hyps = [] ; cst_kind = kind; cst_locl = local; + cst_exported = []; + cst_was_seff = false; } in let kn = declare_constant_common id cst in kn -let declare_definition ?(internal=UserVerbose) +let declare_definition ?(internal=UserIndividualRequest) ?(opaque=false) ?(kind=Decl_kinds.Definition) ?(local = false) ?(poly=false) id ?types (body,ctx) = - let cb = + let cb = definition_entry ?types ~poly ~univs:(Univ.ContextSet.to_context ctx) ~opaque body in declare_constant ~internal ~local id @@ -382,12 +358,12 @@ let inInductive : inductive_obj -> obj = let declare_projections mind = let spec,_ = Inductive.lookup_mind_specif (Global.env ()) (mind,0) in match spec.mind_record with - | Some (Some (_, kns, pjs)) -> - Array.iteri (fun i kn -> + | Some (Some (_, kns, pjs)) -> + Array.iteri (fun i kn -> let id = Label.to_id (Constant.label kn) in let entry = {proj_entry_ind = mind; proj_entry_arg = i} in let kn' = declare_constant id (ProjectionEntry entry, - IsDefinition StructureComponent) + IsDefinition StructureComponent) in assert(eq_constant kn kn')) kns; true | Some None | None -> false @@ -441,50 +417,69 @@ let assumption_message id = (** Global universe names, in a different summary *) -type universe_names = +type universe_names = (Univ.universe_level Idmap.t * Id.t Univ.LMap.t) -let input_universes : universe_names -> Libobject.obj = - let open Libobject in - declare_object +(* Discharged or not *) +type universe_decl = polymorphic * (Id.t * Univ.universe_level) list + +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)) + (glob, Univ.ContextSet.empty) l + in + Global.push_context_set false ctx; + if p then Lib.add_section_context ctx; + Universes.set_global_universe_names glob' + +let input_universes : universe_decl -> Libobject.obj = + declare_object { (default_object "Global universe name state") with - cache_function = (fun (na, pi) -> Universes.set_global_universe_names pi); - load_function = (fun _ (_, pi) -> Universes.set_global_universe_names pi); - discharge_function = (fun (_, a) -> Some a); + cache_function = (fun (na, pi) -> cache_universes pi); + load_function = (fun _ (_, pi) -> cache_universes pi); + discharge_function = (fun (_, (p, _ as x)) -> if p then None else Some x); classify_function = (fun a -> Keep a) } -let do_universe l = - let glob = Universes.global_universe_names () in - let glob' = - List.fold_left (fun (idl,lid) (l, id) -> - let lev = Universes.new_univ_level (Global.current_dirpath ()) in - (Idmap.add id lev idl, Univ.LMap.add lev id lid)) - glob l +let do_universe poly l = + let l = + List.map (fun (l, id) -> + let lev = Universes.new_univ_level (Global.current_dirpath ()) in + (id, lev)) l in - Lib.add_anonymous_leaf (input_universes glob') + Lib.add_anonymous_leaf (input_universes (poly, l)) + +type constraint_decl = polymorphic * Univ.constraints + +let cache_constraints (na, (p, c)) = + Global.add_constraints c; + if p then Lib.add_section_context (Univ.ContextSet.add_constraints c Univ.ContextSet.empty) +let discharge_constraints (_, (p, c as a)) = + if p then None else Some a -let input_constraints : Univ.constraints -> Libobject.obj = - let open Libobject in +let input_constraints : constraint_decl -> Libobject.obj = + let open Libobject in declare_object { (default_object "Global universe constraints") with - cache_function = (fun (na, c) -> Global.add_constraints c); - load_function = (fun _ (_, c) -> Global.add_constraints c); - discharge_function = (fun (_, a) -> Some a); + cache_function = cache_constraints; + load_function = (fun _ -> cache_constraints); + discharge_function = discharge_constraints; classify_function = (fun a -> Keep a) } -let do_constraint l = - let u_of_id = +let do_constraint poly l = + let u_of_id = let names, _ = Universes.global_universe_names () in - fun (loc, id) -> + fun (loc, id) -> try Idmap.find id names with Not_found -> - user_err_loc (loc, "Constraint", str "Undeclared universe " ++ pr_id id) + user_err_loc (loc, "Constraint", str "Undeclared universe " ++ pr_id id) 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) Univ.Constraint.empty l in - Lib.add_anonymous_leaf (input_constraints constraints) - + Lib.add_anonymous_leaf (input_constraints (poly, constraints)) diff --git a/library/declare.mli b/library/declare.mli index d8a00db0..c6119a58 100644 --- a/library/declare.mli +++ b/library/declare.mli @@ -22,7 +22,7 @@ open Decl_kinds (** Declaration of local constructions (Variable/Hypothesis/Local) *) type section_variable_entry = - | SectionLocalDef of definition_entry + | SectionLocalDef of Safe_typing.private_constants definition_entry | SectionLocalAssum of types Univ.in_universe_context_set * polymorphic * bool (** Implicit status *) type variable_declaration = DirPath.t * section_variable_entry * logical_kind @@ -32,7 +32,7 @@ val declare_variable : variable -> variable_declaration -> object_name (** Declaration of global constructions i.e. Definition/Theorem/Axiom/Parameter/... *) -type constant_declaration = constant_entry * logical_kind +type constant_declaration = Safe_typing.private_constants constant_entry * logical_kind (** [declare_constant id cd] declares a global declaration (constant/parameter) with name [id] in the current section; it returns @@ -43,14 +43,15 @@ type constant_declaration = constant_entry * logical_kind *) type internal_flag = - | KernelVerbose - | KernelSilent - | UserVerbose + | UserAutomaticRequest + | InternalTacticRequest + | UserIndividualRequest (* Defaut definition entries, transparent with no secctx or proj information *) -val definition_entry : ?opaque:bool -> ?inline:bool -> ?types:types -> - ?poly:polymorphic -> ?univs:Univ.universe_context -> ?eff:Declareops.side_effects -> - constr -> definition_entry +val definition_entry : ?fix_exn:Future.fix_exn -> + ?opaque:bool -> ?inline:bool -> ?types:types -> + ?poly:polymorphic -> ?univs:Univ.universe_context -> + ?eff:Safe_typing.private_constants -> constr -> Safe_typing.private_constants definition_entry val declare_constant : ?internal:internal_flag -> ?local:bool -> Id.t -> ?export_seff:bool -> constant_declaration -> constant @@ -60,7 +61,7 @@ val declare_definition : ?local:bool -> ?poly:polymorphic -> Id.t -> ?types:constr -> constr Univ.in_universe_context_set -> constant -(** Since transparent constant's side effects are globally declared, we +(** Since transparent constants' side effects are globally declared, we * need that *) val set_declare_scheme : (string -> (inductive * constant) array -> unit) -> unit @@ -85,5 +86,5 @@ val exists_name : Id.t -> bool (** Global universe names and constraints *) -val do_universe : Id.t Loc.located list -> unit -val do_constraint : (Id.t Loc.located * Univ.constraint_type * Id.t Loc.located) list -> unit +val do_universe : polymorphic -> Id.t Loc.located list -> unit +val do_constraint : polymorphic -> (Id.t Loc.located * Univ.constraint_type * Id.t Loc.located) list -> unit diff --git a/library/declaremods.ml b/library/declaremods.ml index cc7c4d7f..7f607a51 100644 --- a/library/declaremods.ml +++ b/library/declaremods.ml @@ -166,12 +166,14 @@ let consistency_checks exists dir dirinfo = let globref = try Nametab.locate_dir (qualid_of_dirpath dir) with Not_found -> - anomaly (pr_dirpath dir ++ str " should already exist!") + errorlabstrm "consistency_checks" + (pr_dirpath dir ++ str " should already exist!") in assert (eq_global_dir_reference globref dirinfo) else if Nametab.exists_dir dir then - anomaly (pr_dirpath dir ++ str " already exists") + errorlabstrm "consistency_checks" + (pr_dirpath dir ++ str " already exists") let compute_visibility exists i = if exists then Nametab.Exactly i else Nametab.Until i @@ -845,10 +847,6 @@ type library_objects = Lib.lib_objects * Lib.lib_objects (** For the native compiler, we cache the library values *) -type library_values = Nativecode.symbol array -let library_values = - Summary.ref (Dirmap.empty : library_values Dirmap.t) ~name:"LIBVALUES" - let register_library dir cenv (objs:library_objects) digest univ = let mp = MPfile dir in let () = @@ -857,15 +855,15 @@ let register_library dir cenv (objs:library_objects) digest univ = ignore(Global.lookup_module mp); with Not_found -> (* If not, let's do it now ... *) - let mp', values = Global.import cenv univ digest in + let mp' = Global.import cenv univ digest in if not (ModPath.equal mp mp') then anomaly (Pp.str "Unexpected disk module name"); - library_values := Dirmap.add dir values !library_values in let sobjs,keepobjs = objs in do_module false Lib.load_objects 1 dir mp ([],Objs sobjs) keepobjs -let get_library_symbols_tbl dir = Dirmap.find dir !library_values +let get_library_native_symbols dir = + Safe_typing.get_library_native_symbols (Global.safe_env ()) dir let start_library dir = let mp = Global.start_library dir in @@ -950,7 +948,7 @@ type 'modast module_params = let debug_print_modtab _ = let pr_seg = function | [] -> str "[]" - | l -> str ("[." ^ string_of_int (List.length l) ^ ".]") + | l -> str "[." ++ int (List.length l) ++ str ".]" in let pr_modinfo mp (prefix,substobjs,keepobjs) s = s ++ str (string_of_mp mp) ++ (spc ()) diff --git a/library/declaremods.mli b/library/declaremods.mli index c3578ec4..319d168d 100644 --- a/library/declaremods.mli +++ b/library/declaremods.mli @@ -75,7 +75,7 @@ val register_library : Safe_typing.compiled_library -> library_objects -> Safe_typing.vodigest -> Univ.universe_context_set -> unit -val get_library_symbols_tbl : library_name -> Nativecode.symbol array +val get_library_native_symbols : library_name -> Nativecode.symbols val start_library : library_name -> unit diff --git a/library/global.ml b/library/global.ml index 875097e4..6002382c 100644 --- a/library/global.ml +++ b/library/global.ml @@ -19,6 +19,7 @@ module GlobalSafeEnv : sig val safe_env : unit -> Safe_typing.safe_environment val set_safe_env : Safe_typing.safe_environment -> unit val join_safe_environment : ?except:Future.UUIDSet.t -> unit -> unit + val is_joined_environment : unit -> bool end = struct @@ -27,6 +28,9 @@ let global_env = ref Safe_typing.empty_environment let join_safe_environment ?except () = global_env := Safe_typing.join_safe_environment ?except !global_env +let is_joined_environment () = + Safe_typing.is_joined_environment !global_env + let () = Summary.declare_summary global_env_summary_name { Summary.freeze_function = (function @@ -50,6 +54,7 @@ end let safe_env = GlobalSafeEnv.safe_env let join_safe_environment ?except () = GlobalSafeEnv.join_safe_environment ?except () +let is_joined_environment = GlobalSafeEnv.is_joined_environment let env () = Safe_typing.env_of_safe_env (safe_env ()) @@ -73,13 +78,12 @@ let globalize_with_summary fs f = let i2l = Label.of_id let push_named_assum a = globalize0 (Safe_typing.push_named_assum a) -let push_named_def d = globalize0 (Safe_typing.push_named_def d) +let push_named_def d = globalize (Safe_typing.push_named_def d) let add_constraints c = globalize0 (Safe_typing.add_constraints c) -let push_context_set c = globalize0 (Safe_typing.push_context_set c) -let push_context c = globalize0 (Safe_typing.push_context c) +let push_context_set b c = globalize0 (Safe_typing.push_context_set b c) +let push_context b c = globalize0 (Safe_typing.push_context b c) let set_engagement c = globalize0 (Safe_typing.set_engagement c) -let set_type_in_type () = globalize0 (Safe_typing.set_type_in_type) let add_constant dir id d = globalize (Safe_typing.add_constant dir (i2l id) d) let add_mind dir id mie = globalize (Safe_typing.add_mind dir (i2l id) mie) let add_modtype id me inl = globalize (Safe_typing.add_modtype (i2l id) me inl) @@ -245,7 +249,7 @@ let current_dirpath () = let with_global f = let (a, ctx) = f (env ()) (current_dirpath ()) in - push_context_set ctx; a + push_context_set false ctx; a (* spiwack: register/unregister functions for retroknowledge *) let register field value by_clause = diff --git a/library/global.mli b/library/global.mli index 62d7ea32..03469bea 100644 --- a/library/global.mli +++ b/library/global.mli @@ -27,23 +27,23 @@ val named_context : unit -> Context.named_context (** Changing the (im)predicativity of the system *) val set_engagement : Declarations.engagement -> unit -val set_type_in_type : unit -> unit (** Variables, Local definitions, constants, inductive types *) -val push_named_assum : (Id.t * Constr.types) Univ.in_universe_context_set -> unit -val push_named_def : (Id.t * Entries.definition_entry) -> unit +val push_named_assum : (Id.t * Constr.types * bool) Univ.in_universe_context_set -> unit +val push_named_def : (Id.t * Safe_typing.private_constants Entries.definition_entry) -> Univ.universe_context_set val add_constant : - DirPath.t -> Id.t -> Safe_typing.global_declaration -> constant + DirPath.t -> Id.t -> Safe_typing.global_declaration -> + constant * Safe_typing.exported_private_constant list val add_mind : DirPath.t -> Id.t -> Entries.mutual_inductive_entry -> mutual_inductive (** Extra universe constraints *) val add_constraints : Univ.constraints -> unit -val push_context : Univ.universe_context -> unit -val push_context_set : Univ.universe_context_set -> unit +val push_context : bool -> Univ.universe_context -> unit +val push_context_set : bool -> Univ.universe_context_set -> unit (** Non-interactive modules and module types *) @@ -102,7 +102,7 @@ val export : ?except:Future.UUIDSet.t -> DirPath.t -> module_path * Safe_typing.compiled_library * Safe_typing.native_library val import : Safe_typing.compiled_library -> Univ.universe_context_set -> Safe_typing.vodigest -> - module_path * Nativecode.symbol array + module_path (** {6 Misc } *) @@ -112,6 +112,7 @@ val import : val env_of_context : Environ.named_context_val -> Environ.env val join_safe_environment : ?except:Future.UUIDSet.t -> unit -> unit +val is_joined_environment : unit -> bool val is_polymorphic : Globnames.global_reference -> bool val is_template_polymorphic : Globnames.global_reference -> bool diff --git a/library/goptions.ml b/library/goptions.ml index ef25fa59..30d195f8 100644 --- a/library/goptions.ml +++ b/library/goptions.ml @@ -20,6 +20,7 @@ type option_value = | BoolValue of bool | IntValue of int option | StringValue of string + | StringOptValue of string option (** Summary of an option status *) type option_state = { @@ -35,7 +36,7 @@ type option_state = { let nickname table = String.concat " " table let error_undeclared_key key = - error ((nickname key)^": no table or option of this type") + errorlabstrm "Goptions" (str (nickname key) ++ str ": no table or option of this type") (****************************************************************************) (* 1- Tables *) @@ -293,6 +294,10 @@ let declare_string_option = declare_option (fun v -> StringValue v) (function StringValue v -> v | _ -> anomaly (Pp.str "async_option")) +let declare_stringopt_option = + declare_option + (fun v -> StringOptValue v) + (function StringOptValue v -> v | _ -> anomaly (Pp.str "async_option")) (* 3- User accessible commands *) @@ -301,7 +306,9 @@ let declare_string_option = let set_option_value locality check_and_cast key v = let (name, depr, (_,read,write,lwrite,gwrite)) = try get_option key - with Not_found -> error ("There is no option "^(nickname key)^".") + with Not_found -> + errorlabstrm "Goptions.set_option_value" + (str "There is no option " ++ str (nickname key) ++ str ".") in let write = match locality with | None -> write @@ -322,11 +329,13 @@ let check_bool_value v = function let check_string_value v = function | StringValue _ -> StringValue v + | StringOptValue _ -> StringOptValue (Some v) | _ -> bad_type_error () let check_unset_value v = function | BoolValue _ -> BoolValue false | IntValue _ -> IntValue None + | StringOptValue _ -> StringOptValue None | _ -> bad_type_error () (* Nota: For compatibility reasons, some errors are treated as @@ -357,6 +366,8 @@ let msg_option_value (name,v) = | IntValue (Some n) -> int n | IntValue None -> str "undefined" | StringValue s -> str s + | StringOptValue None -> str"undefined" + | StringOptValue (Some s) -> str s (* | IdentValue r -> pr_global_env Id.Set.empty r *) let print_option_value key = @@ -364,9 +375,9 @@ let print_option_value key = let s = read () in match s with | BoolValue b -> - msg_info (str ("The "^name^" mode is "^(if b then "on" else "off"))) + msg_info (str "The " ++ str name ++ str " mode is " ++ str (if b then "on" else "off")) | _ -> - msg_info (str ("Current value of "^name^" is ") ++ msg_option_value (name, s)) + msg_info (str "Current value of " ++ str name ++ str " is " ++ msg_option_value (name, s)) let get_tables () = let tables = !value_tab in @@ -383,7 +394,7 @@ let get_tables () = let print_tables () = let print_option key name value depr = - let msg = str (" "^(nickname key)^": ") ++ msg_option_value (name, value) in + let msg = str " " ++ str (nickname key) ++ str ": " ++ msg_option_value (name, value) in if depr then msg ++ str " [DEPRECATED]" ++ fnl () else msg ++ fnl () in @@ -401,10 +412,10 @@ let print_tables () = !value_tab (mt ()) ++ str "Tables:" ++ fnl () ++ List.fold_right - (fun (nickkey,_) p -> p ++ str (" "^nickkey) ++ fnl ()) + (fun (nickkey,_) p -> p ++ str " " ++ str nickkey ++ fnl ()) !string_table (mt ()) ++ List.fold_right - (fun (nickkey,_) p -> p ++ str (" "^nickkey) ++ fnl ()) + (fun (nickkey,_) p -> p ++ str " " ++ str nickkey ++ fnl ()) !ref_table (mt ()) ++ fnl () diff --git a/library/goptions.mli b/library/goptions.mli index 1c44f890..9d87c14c 100644 --- a/library/goptions.mli +++ b/library/goptions.mli @@ -128,6 +128,7 @@ type 'a write_function = 'a -> unit val declare_int_option : int option option_sig -> int option write_function val declare_bool_option : bool option_sig -> bool write_function val declare_string_option: string option_sig -> string write_function +val declare_stringopt_option: string option option_sig -> string option write_function (** {6 Special functions supposed to be used only in vernacentries.ml } *) @@ -165,6 +166,7 @@ type option_value = | BoolValue of bool | IntValue of int option | StringValue of string + | StringOptValue of string option (** Summary of an option status *) type option_state = { diff --git a/library/heads.ml b/library/heads.ml index 5c153b06..73d2aa05 100644 --- a/library/heads.ml +++ b/library/heads.ml @@ -68,7 +68,10 @@ let kind_of_head env t = | None -> NotImmediatelyComputableHead) | Const (cst,_) -> (try on_subterm k l b (constant_head cst) - with Not_found -> assert false) + with Not_found -> + Errors.anomaly + Pp.(str "constant not found in kind_of_head: " ++ + str (Names.Constant.to_string cst))) | Construct _ | CoFix _ -> if b then NotImmediatelyComputableHead else ConstructorHead | Sort _ | Ind _ | Prod _ -> RigidHead RigidType diff --git a/library/impargs.ml b/library/impargs.ml index 4b0e2e3d..d15a02fe 100644 --- a/library/impargs.ml +++ b/library/impargs.ml @@ -10,6 +10,7 @@ open Errors open Util open Names open Globnames +open Nameops open Term open Reduction open Declarations @@ -103,7 +104,7 @@ let set_maximality imps b = inferable following a rigid path (useful to know how to print a partial application) -- [Manual] means the argument has been explicitely set as implicit. +- [Manual] means the argument has been explicitly set as implicit. We also consider arguments inferable from the conclusion but it is operational only if [conclusion_matters] is true. @@ -337,10 +338,12 @@ let check_correct_manual_implicits autoimps l = List.iter (function | ExplByName id,(b,fi,forced) -> if not forced then - error ("Wrong or non-dependent implicit argument name: "^(Id.to_string id)^".") + errorlabstrm "" + (str "Wrong or non-dependent implicit argument name: " ++ pr_id id ++ str ".") | ExplByPos (i,_id),_t -> if i<1 || i>List.length autoimps then - error ("Bad implicit argument number: "^(string_of_int i)^".") + errorlabstrm "" + (str "Bad implicit argument number: " ++ int i ++ str ".") else errorlabstrm "" (str "Cannot set implicit argument number " ++ int i ++ diff --git a/library/impargs.mli b/library/impargs.mli index 1d3a73e9..30f2e30f 100644 --- a/library/impargs.mli +++ b/library/impargs.mli @@ -59,8 +59,8 @@ type implicit_explanation = inferable following a rigid path (useful to know how to print a partial application) *) | Manual - (** means the argument has been explicitely set as implicit. *) - + (** means the argument has been explicitly set as implicit. *) + (** We also consider arguments inferable from the conclusion but it is operational only if [conclusion_matters] is true. *) diff --git a/library/lib.ml b/library/lib.ml index 9977b666..297441e6 100644 --- a/library/lib.ml +++ b/library/lib.ml @@ -75,7 +75,8 @@ let classify_segment seg = | (_,ClosedModule _) :: stk -> clean acc stk | (_,OpenedSection _) :: _ -> error "there are still opened sections" | (_,OpenedModule (ty,_,_,_)) :: _ -> - error ("there are still opened " ^ module_kind ty ^"s") + errorlabstrm "Lib.classify_segment" + (str "there are still opened " ++ str (module_kind ty) ++ str "s") | (_,FrozenState _) :: stk -> clean acc stk in clean ([],[],[]) (List.rev seg) @@ -197,6 +198,9 @@ let split_lib_at_opening sp = let add_entry sp node = lib_stk := (sp,node) :: !lib_stk +let pull_to_head oname = + lib_stk := (oname,List.assoc oname !lib_stk) :: List.remove_assoc oname !lib_stk + let anonymous_id = let n = ref 0 in fun () -> incr n; Names.Id.of_string ("_" ^ (string_of_int !n)) @@ -274,7 +278,7 @@ let start_modtype = start_mod true None let error_still_opened string oname = let id = basename (fst oname) in errorlabstrm "" - (str ("The "^string^" ") ++ pr_id id ++ str " is still opened.") + (str "The " ++ str string ++ str " " ++ pr_id id ++ str " is still opened.") let end_mod is_type = let oname,fs = @@ -318,7 +322,8 @@ let end_compilation_checks dir = try match snd (find_entry_p is_opening_node) with | OpenedSection _ -> error "There are some open sections." | OpenedModule (ty,_,_,_) -> - error ("There are some open "^module_kind ty^"s.") + errorlabstrm "Lib.end_compilation_checks" + (str "There are some open " ++ str (module_kind ty) ++ str "s.") | _ -> assert false with Not_found -> () in @@ -369,7 +374,8 @@ let find_opening_node id = let oname,entry = find_entry_p is_opening_node in let id' = basename (fst oname) in if not (Names.Id.equal id id') then - error ("Last block to end has name "^(Names.Id.to_string id')^"."); + errorlabstrm "Lib.find_opening_node" + (str "Last block to end has name " ++ pr_id id' ++ str "."); entry with Not_found -> error "There is nothing to end." @@ -389,10 +395,13 @@ type abstr_info = variable_context * Univ.universe_level_subst * Univ.UContext.t type abstr_list = abstr_info Names.Cmap.t * abstr_info Names.Mindmap.t +type secentry = + | Variable of (Names.Id.t * Decl_kinds.binding_kind * + Decl_kinds.polymorphic * Univ.universe_context_set) + | Context of Univ.universe_context_set + let sectab = - Summary.ref ([] : ((Names.Id.t * Decl_kinds.binding_kind * - Decl_kinds.polymorphic * Univ.universe_context_set) list * - Opaqueproof.work_list * abstr_list) list) + Summary.ref ([] : (secentry list * Opaqueproof.work_list * abstr_list) list) ~name:"section-context" let add_section () = @@ -403,16 +412,25 @@ let add_section_variable id impl poly ctx = match !sectab with | [] -> () (* because (Co-)Fixpoint temporarily uses local vars *) | (vars,repl,abs)::sl -> - sectab := ((id,impl,poly,ctx)::vars,repl,abs)::sl + sectab := (Variable (id,impl,poly,ctx)::vars,repl,abs)::sl + +let add_section_context ctx = + match !sectab with + | [] -> () (* because (Co-)Fixpoint temporarily uses local vars *) + | (vars,repl,abs)::sl -> + sectab := (Context ctx :: vars,repl,abs)::sl let extract_hyps (secs,ohyps) = let rec aux = function - | ((id,impl,poly,ctx)::idl,(id',b,t)::hyps) when Names.Id.equal id id' -> + | (Variable (id,impl,poly,ctx)::idl,(id',b,t)::hyps) when Names.Id.equal id id' -> let l, r = aux (idl,hyps) in (id',impl,b,t) :: l, if poly then Univ.ContextSet.union r ctx else r - | ((_,_,poly,ctx)::idl,hyps) -> + | (Variable (_,_,poly,ctx)::idl,hyps) -> let l, r = aux (idl,hyps) in l, if poly then Univ.ContextSet.union r ctx else r + | (Context ctx :: idl, hyps) -> + let l, r = aux (idl, hyps) in + l, Univ.ContextSet.union r ctx | [], _ -> [],Univ.ContextSet.empty in aux (secs,ohyps) @@ -433,7 +451,8 @@ let add_section_replacement f g hyps = let ctx = Univ.ContextSet.to_context ctx in let subst, ctx = Univ.abstract_universes true ctx in let args = instance_from_variable_context (List.rev sechyps) in - sectab := (vars,f (Univ.UContext.instance ctx,args) exps,g (sechyps,subst,ctx) abs)::sl + sectab := (vars,f (Univ.UContext.instance ctx,args) exps, + g (sechyps,subst,ctx) abs)::sl let add_section_kn kn = let f x (l1,l2) = (l1,Names.Mindmap.add kn x l2) in @@ -453,10 +472,13 @@ let section_segment_of_mutual_inductive kn = let section_instance = function | VarRef id -> - if List.exists (fun (id',_,_,_) -> Names.id_eq id id') - (pi1 (List.hd !sectab)) - then Univ.Instance.empty, [||] - else raise Not_found + let eq = function + | Variable (id',_,_,_) -> Names.id_eq id id' + | Context _ -> false + in + if List.exists eq (pi1 (List.hd !sectab)) + then Univ.Instance.empty, [||] + else raise Not_found | ConstRef con -> Names.Cmap.find con (fst (pi2 (List.hd !sectab))) | IndRef (kn,_) | ConstructRef ((kn,_),_) -> diff --git a/library/lib.mli b/library/lib.mli index 9c4d26c5..bb883175 100644 --- a/library/lib.mli +++ b/library/lib.mli @@ -55,6 +55,7 @@ val segment_of_objects : val add_leaf : Names.Id.t -> Libobject.obj -> Libnames.object_name val add_anonymous_leaf : Libobject.obj -> unit +val pull_to_head : Libnames.object_name -> unit (** this operation adds all objects with the same name and calls [load_object] for each of them *) @@ -172,7 +173,7 @@ val section_instance : Globnames.global_reference -> Univ.universe_instance * Na val is_in_section : Globnames.global_reference -> bool val add_section_variable : Names.Id.t -> Decl_kinds.binding_kind -> Decl_kinds.polymorphic -> Univ.universe_context_set -> unit - +val add_section_context : Univ.universe_context_set -> unit val add_section_constant : bool (* is_projection *) -> Names.constant -> Context.named_context -> unit val add_section_kn : Names.mutual_inductive -> Context.named_context -> unit diff --git a/library/libobject.ml b/library/libobject.ml index 5f2a2127..85c830ea 100644 --- a/library/libobject.ml +++ b/library/libobject.ml @@ -7,6 +7,7 @@ (************************************************************************) open Libnames +open Pp (* The relax flag is used to make it possible to load files while ignoring failures to incorporate some objects. This can be useful when one @@ -33,15 +34,13 @@ type 'a object_declaration = { discharge_function : object_name * 'a -> 'a option; rebuild_function : 'a -> 'a } -let yell s = Errors.anomaly (Pp.str s) - let default_object s = { object_name = s; cache_function = (fun _ -> ()); load_function = (fun _ _ -> ()); open_function = (fun _ _ -> ()); subst_function = (fun _ -> - yell ("The object "^s^" does not know how to substitute!")); + Errors.anomaly (str "The object " ++ str s ++ str " does not know how to substitute!")); classify_function = (fun obj -> Keep obj); discharge_function = (fun _ -> None); rebuild_function = (fun x -> x)} @@ -102,7 +101,16 @@ let declare_object_full odecl = dyn_rebuild_function = rebuild }; (infun,outfun) -let declare_object odecl = fst (declare_object_full odecl) +(* The "try .. with .. " allows for correct printing when calling + declare_object a loading time. +*) + +let declare_object odecl = + try fst (declare_object_full odecl) + with e -> Errors.fatal_error (Errors.print e) (Errors.is_anomaly e) +let declare_object_full odecl = + try declare_object_full odecl + with e -> Errors.fatal_error (Errors.print e) (Errors.is_anomaly e) let missing_tab = (Hashtbl.create 17 : (string, unit) Hashtbl.t) diff --git a/library/library.ml b/library/library.ml index b4261309..024ac9e6 100644 --- a/library/library.ml +++ b/library/library.ml @@ -19,10 +19,12 @@ open Lib (************************************************************************) (*s Low-level interning/externing of libraries to files *) -(*s Loading from disk to cache (preparation phase) *) +let raw_extern_library f = + System.raw_extern_state Coq_config.vo_magic_number f -let (raw_extern_library, raw_intern_library) = - System.raw_extern_intern Coq_config.vo_magic_number +let raw_intern_library f = + System.with_magic_number_check + (System.raw_intern_state Coq_config.vo_magic_number) f (************************************************************************) (** Serialized objects loaded on-the-fly *) @@ -56,7 +58,7 @@ let in_delayed f ch = let fetch_delayed del = let { del_digest = digest; del_file = f; del_off = pos; } = del in try - let ch = System.with_magic_number_check raw_intern_library f in + let ch = raw_intern_library f in let () = seek_in ch pos in let obj, _, digest' = System.marshal_in_segment f ch in let () = close_in ch in @@ -76,19 +78,22 @@ open Delayed type compilation_unit_name = DirPath.t type library_disk = { - md_name : compilation_unit_name; md_compiled : Safe_typing.compiled_library; md_objects : Declaremods.library_objects; +} + +type summary_disk = { + md_name : compilation_unit_name; + md_imports : compilation_unit_name array; md_deps : (compilation_unit_name * Safe_typing.vodigest) array; - md_imports : compilation_unit_name array } +} (*s Modules loaded in memory contain the following informations. They are kept in the global table [libraries_table]. *) type library_t = { library_name : compilation_unit_name; - library_compiled : Safe_typing.compiled_library; - library_objects : Declaremods.library_objects; + library_data : library_disk delayed; library_deps : (compilation_unit_name * Safe_typing.vodigest) array; library_imports : compilation_unit_name array; library_digests : Safe_typing.vodigest; @@ -126,7 +131,8 @@ let find_library dir = let try_find_library dir = try find_library dir with Not_found -> - error ("Unknown library " ^ (DirPath.to_string dir)) + errorlabstrm "Library.find_library" + (str "Unknown library " ++ str (DirPath.to_string dir)) let register_library_filename dir f = (* Not synchronized: overwrite the previous binding if one existed *) @@ -165,8 +171,9 @@ let register_loaded_library m = let prefix = Nativecode.mod_uid_of_dirpath libname ^ "." in let f = prefix ^ "cmo" in let f = Dynlink.adapt_filename f in - if not !Flags.no_native_compiler then - Nativelib.link_library ~prefix ~dirname ~basename:f + (* This will not produce errors or warnings if the native compiler was + not enabled *) + Nativelib.link_library ~prefix ~dirname ~basename:f in let rec aux = function | [] -> link m; [libname] @@ -374,14 +381,14 @@ let access_table what tables dp i = | Fetched t -> t | ToFetch f -> let dir_path = Names.DirPath.to_string dp in - msg_info (str"Fetching " ++ str what++str" from disk for " ++ str dir_path); + Flags.if_verbose msg_info (str"Fetching " ++ str what++str" from disk for " ++ str dir_path); let t = try fetch_delayed f with Faulty f -> - error - ("The file "^f^" (bound to " ^ dir_path ^ - ") is inaccessible or corrupted,\n" ^ - "cannot load some "^what^" in it.\n") + errorlabstrm "Library.access_table" + (str "The file " ++ str f ++ str " (bound to " ++ str dir_path ++ + str ") is inaccessible or corrupted,\ncannot load some " ++ + str what ++ str " in it.\n") in tables := LibraryMap.add dp (Fetched t) !tables; t @@ -405,19 +412,19 @@ let () = (************************************************************************) (* Internalise libraries *) +type seg_sum = summary_disk type seg_lib = library_disk type seg_univ = (* true = vivo, false = vi *) Univ.universe_context_set Future.computation array * Univ.universe_context_set * bool type seg_discharge = Opaqueproof.cooking_info list array type seg_proofs = Term.constr Future.computation array -let mk_library md digests univs = +let mk_library sd md digests univs = { - library_name = md.md_name; - library_compiled = md.md_compiled; - library_objects = md.md_objects; - library_deps = md.md_deps; - library_imports = md.md_imports; + library_name = sd.md_name; + library_data = md; + library_deps = sd.md_deps; + library_imports = sd.md_imports; library_digests = digests; library_extra_univs = univs; } @@ -429,24 +436,25 @@ let mk_summary m = { } let intern_from_file f = - let ch = System.with_magic_number_check raw_intern_library f in - let (lmd : seg_lib), pos, digest_lmd = System.marshal_in_segment f ch in + 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 (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 close_in ch; - register_library_filename lmd.md_name f; - add_opaque_table lmd.md_name (ToFetch del_opaque); + 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 lmd (Dvo_or_vi digest_lmd) Univ.ContextSet.empty + | None -> mk_library lsd lmd (Dvo_or_vi digest_lsd) Univ.ContextSet.empty | Some (utab,uall,true) -> - add_univ_table lmd.md_name (Fetched utab); - mk_library lmd (Dvivo (digest_lmd,digest_u)) uall + add_univ_table lsd.md_name (Fetched utab); + mk_library lsd lmd (Dvivo (digest_lsd,digest_u)) uall | Some (utab,_,false) -> - add_univ_table lmd.md_name (Fetched utab); - mk_library lmd (Dvo_or_vi digest_lmd) Univ.ContextSet.empty + add_univ_table lsd.md_name (Fetched utab); + mk_library lsd lmd (Dvo_or_vi digest_lsd) Univ.ContextSet.empty module DPMap = Map.Make(DirPath) @@ -462,7 +470,7 @@ let rec intern_library (needed, contents) (dir, f) from = let m = intern_from_file f in if not (DirPath.equal dir m.library_name) then errorlabstrm "load_physical_library" - (str ("The file " ^ f ^ " contains library") ++ spc () ++ + (str "The file " ++ str f ++ str " contains library" ++ spc () ++ pr_dirpath m.library_name ++ spc () ++ str "and not library" ++ spc() ++ pr_dirpath dir); Pp.feedback(Feedback.FileLoaded(DirPath.to_string dir, f)); @@ -475,52 +483,18 @@ and intern_library_deps libs dir m from = and intern_mandatory_library caller from libs (dir,d) = let digest, libs = intern_library libs (try_locate_absolute_library dir) from in if not (Safe_typing.digest_match ~actual:digest ~required:d) then - errorlabstrm "" (strbrk ("Compiled library "^ DirPath.to_string caller ^ - ".vo makes inconsistent assumptions over library " ^ - DirPath.to_string dir)); + errorlabstrm "" (str "Compiled library " ++ str (DirPath.to_string caller) ++ str ".vo makes inconsistent assumptions over library " ++ str (DirPath.to_string dir)); libs let rec_intern_library libs mref = let _, libs = intern_library libs mref None in libs -let check_library_short_name f dir = function - | Some id when not (Id.equal id (snd (split_dirpath dir))) -> - errorlabstrm "check_library_short_name" - (str ("The file " ^ f ^ " contains library") ++ spc () ++ - pr_dirpath dir ++ spc () ++ str "and not library" ++ spc () ++ - pr_id id) - | _ -> () - -let rec_intern_by_filename_only id f = - let m = try intern_from_file f with Sys_error s -> error s in - (* Only the base name is expected to match *) - check_library_short_name f m.library_name id; - (* We check no other file containing same library is loaded *) - if library_is_loaded m.library_name then - begin - msg_warning - (pr_dirpath m.library_name ++ str " is already loaded from file " ++ - str (library_full_filename m.library_name)); - m.library_name, [] - end - else - let needed, contents = intern_library_deps ([], DPMap.empty) m.library_name m (Some f) in - let needed = List.map (fun dir -> dir, DPMap.find dir contents) needed in - m.library_name, needed - let native_name_from_filename f = - let ch = System.with_magic_number_check raw_intern_library f in - let (lmd : seg_lib), pos, digest_lmd = System.marshal_in_segment f ch in + let ch = raw_intern_library f in + let (lmd : seg_sum), pos, digest_lmd = System.marshal_in_segment f ch in Nativecode.mod_uid_of_dirpath lmd.md_name -let rec_intern_library_from_file idopt f = - (* A name is specified, we have to check it contains library id *) - let paths = Loadpath.get_paths () in - let _, f = - System.find_file_in_path ~warn:(Flags.is_verbose()) paths (f^".vo") in - rec_intern_by_filename_only idopt f - (**********************************************************************) (*s [require_library] loads and possibly opens a library. This is a synchronized operation. It is performed as follows: @@ -539,10 +513,11 @@ let rec_intern_library_from_file idopt f = *) let register_library m = + let l = fetch_delayed m.library_data in Declaremods.register_library m.library_name - m.library_compiled - m.library_objects + l.md_compiled + l.md_objects m.library_digests m.library_extra_univs; register_loaded_library (mk_summary m) @@ -595,25 +570,13 @@ let require_library_from_dirpath modrefl export = add_anonymous_leaf (in_require (needed,modrefl,export)); add_frozen_state () -let require_library_from_file idopt file export = - let modref,needed = rec_intern_library_from_file idopt file in - let needed = List.rev_map snd needed in - if Lib.is_module_or_modtype () then begin - add_anonymous_leaf (in_require (needed,[modref],None)); - Option.iter (fun exp -> add_anonymous_leaf (in_import_library ([modref],exp))) - export - end - else - add_anonymous_leaf (in_require (needed,[modref],export)); - add_frozen_state () - (* the function called by Vernacentries.vernac_import *) let safe_locate_module (loc,qid) = try Nametab.locate_module qid with Not_found -> user_err_loc - (loc,"import_library", str (string_of_qualid qid ^ " is not a module")) + (loc,"import_library", str (string_of_qualid qid) ++ str " is not a module") let import_module export modl = (* Optimization: libraries in a raw in the list are imported @@ -638,7 +601,7 @@ let import_module export modl = try Declaremods.import_module export mp; aux [] l with Not_found -> user_err_loc (loc,"import_library", - str ((string_of_qualid dir)^" is not a module"))) + str (string_of_qualid dir) ++ str " is not a module")) | [] -> flush acc in aux [] modl @@ -650,8 +613,8 @@ let check_coq_overwriting p id = let is_empty = match l with [] -> true | _ -> false in if not !Flags.boot && not is_empty && String.equal (Id.to_string (List.last l)) "Coq" then errorlabstrm "" - (strbrk ("Cannot build module "^DirPath.to_string p^"."^Id.to_string id^ - ": it starts with prefix \"Coq\" which is reserved for the Coq library.")) + (str "Cannot build module " ++ str (DirPath.to_string p) ++ str "." ++ pr_id id ++ str "." ++ spc () ++ + str "it starts with prefix \"Coq\" which is reserved for the Coq library.") (* Verifies that a string starts by a letter and do not contain others caracters than letters, digits, or `_` *) @@ -673,29 +636,28 @@ let check_module_name s = | c -> err c let start_library f = - let paths = Loadpath.get_paths () in - let _, longf = - System.find_file_in_path ~warn:(Flags.is_verbose()) paths (f^".v") in + let () = if not (Sys.file_exists f) then + errorlabstrm "" (hov 0 (str "Can't find file" ++ spc () ++ str f)) + in let ldir0 = try - let lp = Loadpath.find_load_path (Filename.dirname longf) in + let lp = Loadpath.find_load_path (Filename.dirname f) in Loadpath.logical lp with Not_found -> Nameops.default_root_prefix in - let file = Filename.basename f in + let file = Filename.chop_extension (Filename.basename f) in let id = Id.of_string file in check_module_name file; check_coq_overwriting ldir0 id; let ldir = add_dirpath_suffix ldir0 id in Declaremods.start_library ldir; - ldir,longf + ldir let load_library_todo f = - let paths = Loadpath.get_paths () in - let _, longf = - System.find_file_in_path ~warn:(Flags.is_verbose()) paths (f^".v") in + let longf = Loadpath.locate_file (f^".v") in let f = longf^"io" in - let ch = System.with_magic_number_check raw_intern_library f in + let ch = raw_intern_library f in + let (s0 : seg_sum), _, _ = System.marshal_in_segment f ch in let (s1 : seg_lib), _, _ = System.marshal_in_segment f ch in let (s2 : seg_univ option), _, _ = System.marshal_in_segment f ch in let (s3 : seg_discharge option), _, _ = System.marshal_in_segment f ch in @@ -706,7 +668,7 @@ let load_library_todo f = if s2 = None then errorlabstrm "restart" (str"not a .vio file"); if s3 = None then errorlabstrm "restart" (str"not a .vio file"); if pi3 (Option.get s2) then errorlabstrm "restart" (str"not a .vio file"); - longf, s1, Option.get s2, Option.get s3, Option.get tasks, s5 + longf, s0, s1, Option.get s2, Option.get s3, Option.get tasks, s5 (************************************************************************) (*s [save_library dir] ends library [dir] and save it to the disk. *) @@ -770,18 +732,23 @@ let save_library_to ?todo dir f otab = if not(is_done_or_todo i x) then Errors.errorlabstrm "library" Pp.(str"Proof object "++int i++str" is not checked nor to be checked")) opaque_table; - let md = { + let sd = { md_name = dir; + md_deps = Array.of_list (current_deps ()); + md_imports = Array.of_list (current_reexports ()); + } in + let md = { md_compiled = cenv; md_objects = seg; - md_deps = Array.of_list (current_deps ()); - md_imports = Array.of_list (current_reexports ()) } in - if Array.exists (fun (d,_) -> DirPath.equal d dir) md.md_deps then + } in + if Array.exists (fun (d,_) -> DirPath.equal d dir) sd.md_deps then error_recursively_dependent_library dir; (* Open the vo file and write the magic number *) - let (f',ch) = raw_extern_library f in + let f' = f in + let ch = raw_extern_library f' in try (* Writing vo payload *) + System.marshal_out_segment f' ch (sd : seg_sum); System.marshal_out_segment f' ch (md : seg_lib); System.marshal_out_segment f' ch (utab : seg_univ option); System.marshal_out_segment f' ch (dtab : seg_discharge option); @@ -789,19 +756,21 @@ let save_library_to ?todo dir f otab = System.marshal_out_segment f' ch (opaque_table : seg_proofs); close_out ch; (* Writing native code files *) - if not !Flags.no_native_compiler then + if !Flags.native_compiler then let fn = Filename.dirname f'^"/"^Nativecode.mod_uid_of_dirpath dir in if not (Nativelib.compile_library dir ast fn) then - msg_error (str"Could not compile the library to native code. Skipping.") + error "Could not compile the library to native code." with reraise -> let reraise = Errors.push reraise in - let () = msg_warning (str ("Removed file "^f')) in + let () = msg_warning (str "Removed file " ++ str f') in let () = close_out ch in let () = Sys.remove f' in iraise reraise -let save_library_raw f lib univs proofs = - let (f',ch) = raw_extern_library (f^"o") in +let save_library_raw f sum lib univs proofs = + let f' = f^"o" in + let ch = raw_extern_library f' in + System.marshal_out_segment f' ch (sum : seg_sum); System.marshal_out_segment f' ch (lib : seg_lib); System.marshal_out_segment f' ch (Some univs : seg_univ option); System.marshal_out_segment f' ch (None : seg_discharge option); diff --git a/library/library.mli b/library/library.mli index 35067068..d5e610dd 100644 --- a/library/library.mli +++ b/library/library.mli @@ -22,12 +22,11 @@ open Libnames (** Require = load in the environment + open (if the optional boolean is not [None]); mark also for export if the boolean is [Some true] *) val require_library_from_dirpath : (DirPath.t * string) list -> bool option -> unit -val require_library_from_file : - Id.t option -> CUnix.physical_path -> bool option -> unit -(** {6 ... } *) +(** {6 Start the compilation of a library } *) (** Segments of a library *) +type seg_sum type seg_lib type seg_univ = (* cst, all_cst, finished? *) Univ.universe_context_set Future.computation array * Univ.universe_context_set * bool @@ -38,17 +37,19 @@ type seg_proofs = Term.constr Future.computation array an export otherwise just a simple import *) val import_module : bool -> qualid located list -> unit -(** {6 Start the compilation of a library } *) -val start_library : string -> DirPath.t * string +(** 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. *) +val start_library : CUnix.physical_path -> DirPath.t -(** {6 End the compilation of a library and save it to a ".vo" file } *) +(** End the compilation of a library and save it to a ".vo" file *) val save_library_to : ?todo:(((Future.UUID.t,'document) Stateid.request * bool) list * 'counters) -> DirPath.t -> string -> Opaqueproof.opaquetab -> unit val load_library_todo : - string -> string * seg_lib * seg_univ * seg_discharge * 'tasks * seg_proofs -val save_library_raw : string -> seg_lib -> seg_univ -> seg_proofs -> unit + string -> string * seg_sum * seg_lib * seg_univ * seg_discharge * 'tasks * seg_proofs +val save_library_raw : string -> seg_sum -> seg_lib -> seg_univ -> seg_proofs -> unit (** {6 Interrogate the status of libraries } *) diff --git a/library/library.mllib b/library/library.mllib index eca28c82..92065736 100644 --- a/library/library.mllib +++ b/library/library.mllib @@ -16,5 +16,4 @@ Dischargedhypsmap Goptions Decls Heads -Assumptions Keys diff --git a/library/loadpath.ml b/library/loadpath.ml index 26af809e..622d390a 100644 --- a/library/loadpath.ml +++ b/library/loadpath.ml @@ -28,8 +28,6 @@ let physical p = p.path_physical let get_load_paths () = !load_paths -let get_paths () = List.map physical !load_paths - let anomaly_too_many_paths path = anomaly (str "Several logical paths are associated to" ++ spc () ++ str path) @@ -112,3 +110,9 @@ let expand_path dir = if DirPath.equal dir lg then (ph, lg) :: aux l else aux l in aux !load_paths + +let locate_file fname = + let paths = List.map physical !load_paths in + let _,longfname = + System.find_file_in_path ~warn:(Flags.is_verbose()) paths fname in + longfname diff --git a/library/loadpath.mli b/library/loadpath.mli index 3251b8c6..269e28e0 100644 --- a/library/loadpath.mli +++ b/library/loadpath.mli @@ -27,9 +27,6 @@ val logical : t -> DirPath.t val get_load_paths : unit -> t list (** Get the current loadpath association. *) -val get_paths : unit -> CUnix.physical_path list -(** Same as [get_load_paths] but only get the physical part. *) - val add_load_path : CUnix.physical_path -> DirPath.t -> implicit:bool -> unit (** [add_load_path phys log type] adds the binding [phys := log] to the current loadpaths. *) @@ -52,3 +49,7 @@ val expand_path : DirPath.t -> (CUnix.physical_path * DirPath.t) list val filter_path : (DirPath.t -> bool) -> (CUnix.physical_path * DirPath.t) list (** As {!expand_path} but uses a filter function instead, and ignores the implicit status of loadpaths. *) + +val locate_file : string -> string +(** Locate a file among the registered paths. Do not use this function, as + it does not respect the visibility of paths. *) diff --git a/library/nameops.ml b/library/nameops.ml index 02b085a7..3a23ab97 100644 --- a/library/nameops.ml +++ b/library/nameops.ml @@ -136,6 +136,11 @@ let name_fold_map f e = function | Name id -> let (e,id) = f e id in (e,Name id) | Anonymous -> e,Anonymous +let name_max na1 na2 = + match na1 with + | Name _ -> na1 + | Anonymous -> na2 + let pr_lab l = str (Label.to_string l) let default_library = Names.DirPath.initial (* = ["Top"] *) diff --git a/library/nameops.mli b/library/nameops.mli index 23432ae2..de1f99fe 100644 --- a/library/nameops.mli +++ b/library/nameops.mli @@ -34,7 +34,7 @@ val name_iter : (Id.t -> unit) -> Name.t -> unit val name_cons : Name.t -> Id.t list -> Id.t list val name_app : (Id.t -> Id.t) -> Name.t -> Name.t val name_fold_map : ('a -> Id.t -> 'a * Id.t) -> 'a -> Name.t -> 'a * Name.t - +val name_max : Name.t -> Name.t -> Name.t val pr_lab : Label.t -> Pp.std_ppcmds diff --git a/library/nametab.ml b/library/nametab.ml index 6af1e686..5b6d7cd9 100644 --- a/library/nametab.ml +++ b/library/nametab.ml @@ -524,7 +524,8 @@ let shortest_qualid_of_tactic kn = let pr_global_env env ref = try str (string_of_qualid (shortest_qualid_of_global env ref)) - with Not_found as e -> prerr_endline "pr_global_env not found"; raise e + with Not_found as e -> + if !Flags.debug then Pp.msg_debug (Pp.str "pr_global_env not found"); raise e let global_inductive r = match global r with diff --git a/library/states.ml b/library/states.ml index 96a487b1..3cb6da12 100644 --- a/library/states.ml +++ b/library/states.ml @@ -21,18 +21,12 @@ let unfreeze (fl,fs) = Lib.unfreeze fl; Summary.unfreeze_summaries fs -let (extern_state,intern_state) = - let ensure_suffix f = CUnix.make_suffix f ".coq" in - let (raw_extern, raw_intern) = - extern_intern Coq_config.state_magic_number in - (fun s -> - let s = ensure_suffix s in - raw_extern s (freeze ~marshallable:`Yes)), - (fun s -> - let s = ensure_suffix s in - let paths = Loadpath.get_paths () in - unfreeze (with_magic_number_check (raw_intern paths) s); - Library.overwrite_library_filenames s) +let extern_state s = + System.extern_state Coq_config.state_magic_number s (freeze ~marshallable:`Yes) + +let intern_state s = + unfreeze (with_magic_number_check (System.intern_state Coq_config.state_magic_number) s); + Library.overwrite_library_filenames s (* Rollback. *) diff --git a/library/universes.ml b/library/universes.ml index 9fddc706..6cccb10e 100644 --- a/library/universes.ml +++ b/library/universes.ml @@ -12,11 +12,14 @@ open Names open Term open Environ open Univ +open Globnames +(** Global universe names *) type universe_names = Univ.universe_level Idmap.t * Id.t Univ.LMap.t -let global_universes = Summary.ref ~name:"Global universe names" +let global_universes = + Summary.ref ~name:"Global universe names" ((Idmap.empty, Univ.LMap.empty) : universe_names) let global_universe_names () = !global_universes @@ -26,6 +29,25 @@ let pr_with_global_universes l = try Nameops.pr_id (LMap.find l (snd !global_universes)) with Not_found -> Level.pr l +(** Local universe names of polymorphic references *) + +type universe_binders = (Id.t * Univ.universe_level) list + +let universe_binders_table = Summary.ref Refmap.empty ~name:"universe binders" + +let universe_binders_of_global ref = + try + let l = Refmap.find ref !universe_binders_table in l + with Not_found -> [] + +let register_universe_binders ref l = + universe_binders_table := Refmap.add ref l !universe_binders_table + +(* To disallow minimization to Set *) + +let set_minimization = ref true +let is_set_minimization () = !set_minimization + type universe_constraint_type = ULe | UEq | ULub type universe_constraint = universe * universe_constraint_type * universe @@ -139,6 +161,32 @@ let eq_constr_univs_infer univs m n = let res = Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n in res, !cstrs +(** Variant of [eq_constr_univs_infer] taking kind-of-term functions, + to expose subterms of [m] and [n], arguments. *) +let eq_constr_univs_infer_with kind1 kind2 univs m n = + (* spiwack: duplicates the code of [eq_constr_univs_infer] because I + haven't find a way to factor the code without destroying + pointer-equality optimisations in [eq_constr_univs_infer]. + Pointer equality is not sufficient to ensure equality up to + [kind1,kind2], because [kind1] and [kind2] may be different, + typically evaluating [m] and [n] in different evar maps. *) + let cstrs = ref Constraints.empty in + let eq_universes strict = Univ.Instance.check_eq univs in + let eq_sorts s1 s2 = + if Sorts.equal s1 s2 then true + else + let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in + if Univ.check_eq univs u1 u2 then true + else + (cstrs := Constraints.add (u1, UEq, u2) !cstrs; + true) + in + let rec eq_constr' m n = + Constr.compare_head_gen_with kind1 kind2 eq_universes eq_sorts eq_constr' m n + in + let res = Constr.compare_head_gen_with kind1 kind2 eq_universes eq_sorts eq_constr' m n in + res, !cstrs + let leq_constr_univs_infer univs m n = if m == n then true, Constraints.empty else @@ -148,15 +196,18 @@ let leq_constr_univs_infer univs m n = if Sorts.equal s1 s2 then true else let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in - if Univ.check_eq univs u1 u2 then true - else (cstrs := Constraints.add (u1, UEq, u2) !cstrs; - true) + if Univ.check_eq univs u1 u2 then true + else (cstrs := Constraints.add (u1, UEq, u2) !cstrs; + true) in let leq_sorts s1 s2 = if Sorts.equal s1 s2 then true else let u1 = Sorts.univ_of_sort s1 and u2 = Sorts.univ_of_sort s2 in - if Univ.check_leq univs u1 u2 then true + if Univ.check_leq univs u1 u2 then + ((if Univ.is_small_univ u1 then + cstrs := Constraints.add (u1, ULe, u2) !cstrs); + true) else (cstrs := Constraints.add (u1, ULe, u2) !cstrs; true) @@ -169,7 +220,7 @@ let leq_constr_univs_infer univs m n = eq_constr' leq_constr' m n and leq_constr' m n = m == n || compare_leq m n in let res = compare_leq m n in - res, !cstrs + res, !cstrs let eq_constr_universes m n = if m == n then true, Constraints.empty @@ -188,7 +239,7 @@ let eq_constr_universes m n = m == n || Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n in let res = Constr.compare_head_gen eq_universes eq_sorts eq_constr' m n in - res, !cstrs + res, !cstrs let leq_constr_universes m n = if m == n then true, Constraints.empty @@ -216,22 +267,22 @@ let leq_constr_universes m n = Constr.compare_head_gen_leq eq_universes leq_sorts eq_constr' leq_constr' m n and leq_constr' m n = m == n || compare_leq m n in let res = compare_leq m n in - res, !cstrs + res, !cstrs let compare_head_gen_proj env equ eqs eqc' m n = match kind_of_term m, kind_of_term n with | Proj (p, c), App (f, args) | App (f, args), Proj (p, c) -> - (match kind_of_term f with - | Const (p', u) when eq_constant (Projection.constant p) p' -> - let pb = Environ.lookup_projection p env in - let npars = pb.Declarations.proj_npars in - if Array.length args == npars + 1 then - eqc' c args.(npars) - else false - | _ -> false) + (match kind_of_term f with + | Const (p', u) when eq_constant (Projection.constant p) p' -> + let pb = Environ.lookup_projection p env in + let npars = pb.Declarations.proj_npars in + if Array.length args == npars + 1 then + eqc' c args.(npars) + else false + | _ -> false) | _ -> Constr.compare_head_gen equ eqs eqc' m n - + let eq_constr_universes_proj env m n = if m == n then true, Constraints.empty else @@ -249,7 +300,7 @@ let eq_constr_universes_proj env m n = m == n || compare_head_gen_proj env eq_universes eq_sorts eq_constr' m n in let res = eq_constr' m n in - res, !cstrs + res, !cstrs (* Generator of levels *) let new_univ_level, set_remote_new_univ_level = @@ -697,7 +748,10 @@ let pr_constraints_map cmap = prlist_with_sep spc (fun (d,r) -> pr_constraint_type d ++ Level.pr r) cstrs ++ fnl () ++ acc) cmap (mt ()) - + +let remove_alg l (ctx, us, algs, insts, cstrs) = + (ctx, us, LSet.remove l algs, insts, cstrs) + let minimize_univ_variables ctx us algs left right cstrs = let left, lbounds = Univ.LMap.fold (fun r lower (left, lbounds as acc) -> @@ -713,15 +767,14 @@ let minimize_univ_variables ctx us algs left right cstrs = let rec instance (ctx', us, algs, insts, cstrs as acc) u = let acc, left = try let l = LMap.find u left in - List.fold_left (fun (acc, left') (d, l) -> - let acc', (enf,alg,l') = aux acc l in - (* if alg then assert(not alg); *) - let l' = - if enf then Universe.make l - else l' - (* match Universe.level l' with Some _ -> l' | None -> Universe.make l *) - in - acc', (d, l') :: left') (acc, []) l + List.fold_left + (fun (acc, left') (d, l) -> + let acc', (enf,alg,l') = aux acc l in + let l' = + if enf then Universe.make l + else l' + in acc', (d, l') :: left') + (acc, []) l with Not_found -> acc, [] and right = try Some (LMap.find u right) @@ -729,24 +782,22 @@ let minimize_univ_variables ctx us algs left right cstrs = in let instantiate_lbound lbound = let alg = LSet.mem u algs in - if alg then - (* u is algebraic and has no upper bound constraints: we - instantiate it with it's lower bound, if any *) - instantiate_with_lbound u lbound true false acc - else (* u is non algebraic *) - match Universe.level lbound with - | Some l -> (* The lowerbound is directly a level *) - (* u is not algebraic but has no upper bounds, - we instantiate it with its lower bound if it is a - different level, otherwise we keep it. *) - if not (Level.equal l u) && not (LSet.mem l algs) then - (* if right = None then. Should check that u does not - have upper constraints that are not already in right *) - instantiate_with_lbound u lbound false false acc - (* else instantiate_with_lbound u lbound false true acc *) - else - (* assert false: l can't be alg *) - acc, (true, false, lbound) + if alg then + (* u is algebraic: we instantiate it with it's lower bound, if any, + or enforce the constraints if it is bounded from the top. *) + instantiate_with_lbound u lbound true false acc + else (* u is non algebraic *) + match Universe.level lbound with + | Some l -> (* The lowerbound is directly a level *) + (* u is not algebraic but has no upper bounds, + we instantiate it with its lower bound if it is a + different level, otherwise we keep it. *) + if not (Level.equal l u) then + (* Should check that u does not + have upper constraints that are not already in right *) + let acc' = remove_alg l acc in + instantiate_with_lbound u lbound false false acc' + else acc, (true, false, lbound) | None -> try (* if right <> None then raise Not_found; *) @@ -794,22 +845,63 @@ let minimize_univ_variables ctx us algs left right cstrs = if v == None then fst (aux acc u) else LSet.remove u ctx', us, LSet.remove u algs, seen, cstrs) us (ctx, us, algs, lbounds, cstrs) - + let normalize_context_set ctx us algs = let (ctx, csts) = ContextSet.levels ctx, ContextSet.constraints ctx in let uf = UF.create () in + (** Keep the Prop/Set <= i constraints separate for minimization *) + let smallles, csts = + Constraint.fold (fun (l,d,r as cstr) (smallles, noneqs) -> + if d == Le then + if Univ.Level.is_small l then + if is_set_minimization () then + (Constraint.add cstr smallles, noneqs) + else (smallles, noneqs) + else if Level.is_small r then + if Level.is_prop r then + raise (Univ.UniverseInconsistency + (Le,Universe.make l,Universe.make r,None)) + else (smallles, Constraint.add (l,Eq,r) noneqs) + else (smallles, Constraint.add cstr noneqs) + else (smallles, Constraint.add cstr noneqs)) + csts (Constraint.empty, Constraint.empty) + in let csts = (* We first put constraints in a normal-form: all self-loops are collapsed to equalities. *) - let g = Univ.merge_constraints csts Univ.empty_universes in + let g = Univ.LSet.fold (fun v g -> Univ.add_universe v false g) + ctx Univ.empty_universes + in + let g = + Univ.Constraint.fold + (fun (l, d, r) g -> + let g = + if not (Level.is_small l || LSet.mem l ctx) then + try Univ.add_universe l false g + with Univ.AlreadyDeclared -> g + else g + in + let g = + if not (Level.is_small r || LSet.mem r ctx) then + try Univ.add_universe r false g + with Univ.AlreadyDeclared -> g + else g + in g) csts g + in + let g = Univ.Constraint.fold Univ.enforce_constraint csts g in Univ.constraints_of_universes g in let noneqs = - Constraint.fold (fun (l,d,r) noneqs -> - if d == Eq then (UF.union l r uf; noneqs) - else Constraint.add (l,d,r) noneqs) - csts Constraint.empty + Constraint.fold (fun (l,d,r as cstr) noneqs -> + if d == Eq then (UF.union l r uf; noneqs) + else (* We ignore the trivial Prop/Set <= i constraints. *) + if d == Le && Univ.Level.is_small l then noneqs + else if Univ.Level.is_prop l && d == Lt && Univ.Level.is_set r + then noneqs + else Constraint.add cstr noneqs) + csts Constraint.empty in + let noneqs = Constraint.union noneqs smallles in let partition = UF.partition uf in let flex x = LMap.mem x us in let ctx, subst, eqs = List.fold_left (fun (ctx, subst, cstrs) s -> @@ -819,7 +911,7 @@ let normalize_context_set ctx us algs = Constraint.add (canon, Univ.Eq, g) cst) global cstrs in - let subst = LSet.fold (fun f -> LMap.add f canon) rigid subst in + let subst = LSet.fold (fun f -> LMap.add f canon) rigid subst in let subst = LSet.fold (fun f -> LMap.add f canon) flexible subst in (LSet.diff (LSet.diff ctx rigid) flexible, subst, cstrs)) (ctx, LMap.empty, Constraint.empty) partition @@ -915,12 +1007,12 @@ let simplify_universe_context (univs,csts) = let csts' = subst_univs_level_constraints subst csts' in (univs', csts'), subst -let is_small_leq (l,d,r) = - Level.is_small l && d == Univ.Le +let is_trivial_leq (l,d,r) = + Univ.Level.is_prop l && (d == Univ.Le || (d == Univ.Lt && Univ.Level.is_set r)) (* Prop < i <-> Set+1 <= i <-> Set < i *) let translate_cstr (l,d,r as cstr) = - if Level.equal Level.prop l && d == Univ.Lt then + if Level.equal Level.prop l && d == Univ.Lt && not (Level.equal Level.set r) then (Level.set, d, r) else cstr @@ -928,7 +1020,7 @@ let refresh_constraints univs (ctx, cstrs) = let cstrs', univs' = Univ.Constraint.fold (fun c (cstrs', univs as acc) -> let c = translate_cstr c in - if Univ.check_constraint univs c && not (is_small_leq c) then acc + if is_trivial_leq c then acc else (Univ.Constraint.add c cstrs', Univ.enforce_constraint c univs)) cstrs (Univ.Constraint.empty, univs) in ((ctx, cstrs'), univs') @@ -995,13 +1087,14 @@ let solve_constraints_system levels level_bounds level_min = for i=0 to nind-1 do for j=0 to nind-1 do if not (Int.equal i j) && Int.Set.mem j clos.(i) then - (v.(i) <- Universe.sup v.(i) level_bounds.(j); - level_min.(i) <- Universe.sup level_min.(i) level_min.(j)) + (v.(i) <- Universe.sup v.(i) level_bounds.(j)); + (* level_min.(i) <- Universe.sup level_min.(i) level_min.(j)) *) done; - for j=0 to nind-1 do - match levels.(j) with - | Some u -> v.(i) <- univ_level_rem u v.(i) level_min.(i) - | None -> () - done + (* for j=0 to nind-1 do *) + (* match levels.(j) with *) + (* | Some u when not (Univ.Level.is_small u) -> *) + (* v.(i) <- univ_level_rem u v.(i) level_min.(i) *) + (* | _ -> () *) + (* done *) done; v diff --git a/library/universes.mli b/library/universes.mli index 252648d7..45672ef4 100644 --- a/library/universes.mli +++ b/library/universes.mli @@ -12,8 +12,12 @@ open Term open Environ open Univ +val set_minimization : bool ref +val is_set_minimization : unit -> bool + (** Universes *) +(** Global universe name <-> level mapping *) type universe_names = Univ.universe_level Idmap.t * Id.t Univ.LMap.t @@ -22,6 +26,13 @@ val set_global_universe_names : universe_names -> unit val pr_with_global_universes : Level.t -> Pp.std_ppcmds +(** Local universe name <-> level mapping *) + +type universe_binders = (Id.t * Univ.universe_level) list + +val register_universe_binders : Globnames.global_reference -> universe_binders -> unit +val universe_binders_of_global : Globnames.global_reference -> universe_binders + (** The global universe counter *) val set_remote_new_univ_level : universe_level RemoteCounter.installer @@ -66,6 +77,14 @@ val to_constraints : universes -> universe_constraints -> constraints application grouping, the universe constraints in [u] and additional constraints [c]. *) val eq_constr_univs_infer : Univ.universes -> constr -> constr -> bool universe_constrained +(** [eq_constr_univs_infer_With kind1 kind2 univs m n] is a variant of + {!eq_constr_univs_infer} taking kind-of-term functions, to expose + subterms of [m] and [n], arguments. *) +val eq_constr_univs_infer_with : + (constr -> (constr,types) kind_of_term) -> + (constr -> (constr,types) kind_of_term) -> + Univ.universes -> constr -> constr -> bool universe_constrained + (** [leq_constr_univs u a b] is [true, c] if [a] is convertible to [b] modulo alpha, casts, application grouping, the universe constraints in [u] and additional constraints [c]. *) diff --git a/man/coqide.1 b/man/coqide.1 index 3fa7f0e4..6a3e67ad 100644 --- a/man/coqide.1 +++ b/man/coqide.1 @@ -63,15 +63,17 @@ Load Coq file (Load Verbose .IR f .). .TP -.BI \-load\-vernac\-object\ f -Load Coq object file -.IR f .vo. -.TP -.BI \-require\ f -Load Coq object file -.IR f .vo -and import it (Require -.IR f .). +.BI \-load\-vernac\-object\ path +Load Coq library +.IR path +(Require +.IR path .). +.TP +.BI \-require\ path +Load Coq library +.IR path +and import it (Require Import +.IR path .). .TP .BI \-compile\ f Compile Coq file diff --git a/man/coqtop.1 b/man/coqtop.1 index 1bc4629d..62d17aa6 100644 --- a/man/coqtop.1 +++ b/man/coqtop.1 @@ -73,18 +73,19 @@ load verbosely Coq file (Load Verbose filename.) .TP -.BI \-load\-vernac\-object \ filename -load Coq object file -.I filename.vo +.BI \-load\-vernac\-object \ path +load Coq library +.I path +(Require path.) .TP -.BI \-require \ filename -load Coq object file -.I filename.vo -and import it (Require Import filename.) +.BI \-require \ path +load Coq library +.I path +and import it (Require Import path.) .TP -.BI \-compile \ filename +.BI \-compile \ filename.v compile Coq file .I filename.v (implies @@ -92,7 +93,7 @@ compile Coq file ) .TP -.BI \-compile\-verbose \ filename +.BI \-compile\-verbose \ filename.v verbosely compile Coq file .I filename.v (implies diff --git a/parsing/g_constr.ml4 b/parsing/g_constr.ml4 index 3bb029a8..e2e6795f 100644 --- a/parsing/g_constr.ml4 +++ b/parsing/g_constr.ml4 @@ -153,12 +153,12 @@ GEXTEND Gram [ [ "Set" -> GSet | "Prop" -> GProp | "Type" -> GType [] - | "Type"; "@{"; u = universe; "}" -> GType (List.map Id.to_string u) + | "Type"; "@{"; u = universe; "}" -> GType (List.map (fun (loc,x) -> (loc, Id.to_string x)) u) ] ] ; universe: - [ [ IDENT "max"; "("; ids = LIST1 ident SEP ","; ")" -> ids - | id = ident -> [id] + [ [ IDENT "max"; "("; ids = LIST1 identref SEP ","; ")" -> ids + | id = identref -> [id] ] ] ; lconstr: @@ -223,26 +223,29 @@ GEXTEND Gram CHole (!@loc, None, IntroAnonymous, Some arg) ] ] ; - forall: - [ [ "forall" -> () ] ] - ; - lambda: - [ [ "fun" -> () ] ] - ; record_declaration: - [ [ fs = LIST0 record_field_declaration SEP ";" -> CRecord (!@loc, None, fs) + [ [ fs = record_fields -> CRecord (!@loc, None, fs) (* | c = lconstr; "with"; fs = LIST1 record_field_declaration SEP ";" -> *) (* CRecord (!@loc, Some c, fs) *) ] ] ; + + record_fields: + [ [ f = record_field_declaration; ";"; fs = record_fields -> f :: fs + | f = record_field_declaration; ";" -> [f] + | f = record_field_declaration -> [f] + | -> [] + ] ] + ; + record_field_declaration: [ [ id = global; params = LIST0 identref; ":="; c = lconstr -> (id, abstract_constr_expr c (binders_of_lidents params)) ] ] ; binder_constr: - [ [ forall; bl = open_binders; ","; c = operconstr LEVEL "200" -> + [ [ "forall"; bl = open_binders; ","; c = operconstr LEVEL "200" -> mkCProdN (!@loc) bl c - | lambda; bl = open_binders; "=>"; c = operconstr LEVEL "200" -> + | "fun"; bl = open_binders; "=>"; c = operconstr LEVEL "200" -> mkCLambdaN (!@loc) bl c | "let"; id=name; bl = binders; ty = type_cstr; ":="; c1 = operconstr LEVEL "200"; "in"; c2 = operconstr LEVEL "200" -> @@ -308,7 +311,7 @@ GEXTEND Gram [ [ "Set" -> GSet | "Prop" -> GProp | "Type" -> GType None - | id = ident -> GType (Some (Id.to_string id)) + | id = identref -> GType (Some (fst id, Id.to_string (snd id))) ] ] ; fix_constr: @@ -362,18 +365,25 @@ GEXTEND Gram [ [ pll = LIST1 mult_pattern SEP "|"; "=>"; rhs = lconstr -> (!@loc,pll,rhs) ] ] ; - recordpattern: + record_pattern: [ [ id = global; ":="; pat = pattern -> (id, pat) ] ] ; + record_patterns: + [ [ p = record_pattern; ";"; ps = record_patterns -> p :: ps + | p = record_pattern; ";" -> [p] + | p = record_pattern-> [p] + | -> [] + ] ] + ; pattern: [ "200" RIGHTA [ ] | "100" RIGHTA [ p = pattern; "|"; pl = LIST1 pattern SEP "|" -> CPatOr (!@loc,p::pl) ] | "99" RIGHTA [ ] - | "10" LEFTA + | "11" LEFTA [ p = pattern; "as"; id = ident -> CPatAlias (!@loc, p, id) ] - | "9" RIGHTA + | "10" RIGHTA [ p = pattern; lp = LIST1 NEXT -> (match p with | CPatAtom (_, Some r) -> CPatCstr (!@loc, r, [], lp) @@ -388,7 +398,7 @@ GEXTEND Gram [ c = pattern; "%"; key=IDENT -> CPatDelimiters (!@loc,key,c) ] | "0" [ r = Prim.reference -> CPatAtom (!@loc,Some r) - | "{|"; pat = LIST0 recordpattern SEP ";" ; "|}" -> CPatRecord (!@loc, pat) + | "{|"; pat = record_patterns; "|}" -> CPatRecord (!@loc, pat) | "_" -> CPatAtom (!@loc,None) | "("; p = pattern LEVEL "200"; ")" -> (match p with diff --git a/parsing/g_proofs.ml4 b/parsing/g_proofs.ml4 index 1e254c16..017f0ea5 100644 --- a/parsing/g_proofs.ml4 +++ b/parsing/g_proofs.ml4 @@ -37,12 +37,12 @@ GEXTEND Gram command: [ [ IDENT "Goal"; c = lconstr -> VernacGoal c | IDENT "Proof" -> - VernacProof (None,hint_proof_using G_vernac.section_subset_descr None) + VernacProof (None,hint_proof_using G_vernac.section_subset_expr None) | IDENT "Proof" ; IDENT "Mode" ; mn = string -> VernacProofMode mn | IDENT "Proof"; "with"; ta = tactic; - l = OPT [ "using"; l = G_vernac.section_subset_descr -> l ] -> - VernacProof (Some ta,hint_proof_using G_vernac.section_subset_descr l) - | IDENT "Proof"; "using"; l = G_vernac.section_subset_descr; + l = OPT [ "using"; l = G_vernac.section_subset_expr -> l ] -> + VernacProof (Some ta,hint_proof_using G_vernac.section_subset_expr l) + | IDENT "Proof"; "using"; l = G_vernac.section_subset_expr; ta = OPT [ "with"; ta = tactic -> ta ] -> VernacProof (ta,Some l) | IDENT "Proof"; c = lconstr -> VernacExactProof c @@ -73,8 +73,10 @@ GEXTEND Gram | IDENT "Unfocused" -> VernacUnfocused | IDENT "Show" -> VernacShow (ShowGoal OpenSubgoals) | IDENT "Show"; n = natural -> VernacShow (ShowGoal (NthGoal n)) + | IDENT "Show"; id = ident -> VernacShow (ShowGoal (GoalId id)) + | IDENT "Show"; IDENT "Goal" -> VernacShow (ShowGoal (GoalId (Names.Id.of_string "Goal"))) | IDENT "Show"; IDENT "Goal"; n = string -> - VernacShow (ShowGoal (GoalId n)) + VernacShow (ShowGoal (GoalUid n)) | IDENT "Show"; IDENT "Implicit"; IDENT "Arguments"; n = OPT natural -> VernacShow (ShowGoalImplicitly n) | IDENT "Show"; IDENT "Node" -> VernacShow ShowNode diff --git a/parsing/g_tactic.ml4 b/parsing/g_tactic.ml4 index 69593f99..c94ac846 100644 --- a/parsing/g_tactic.ml4 +++ b/parsing/g_tactic.ml4 @@ -339,21 +339,6 @@ GEXTEND Gram | d = delta_flag -> all_with d ] ] ; - red_tactic: - [ [ IDENT "red" -> Red false - | IDENT "hnf" -> Hnf - | IDENT "simpl"; d = delta_flag; po = OPT ref_or_pattern_occ -> Simpl (all_with d,po) - | IDENT "cbv"; s = strategy_flag -> Cbv s - | IDENT "cbn"; s = strategy_flag -> Cbn s - | IDENT "lazy"; s = strategy_flag -> Lazy s - | IDENT "compute"; delta = delta_flag -> Cbv (all_with delta) - | IDENT "vm_compute"; po = OPT ref_or_pattern_occ -> CbvVm po - | IDENT "native_compute"; po = OPT ref_or_pattern_occ -> CbvNative po - | IDENT "unfold"; ul = LIST1 unfold_occ SEP "," -> Unfold ul - | IDENT "fold"; cl = LIST1 constr -> Fold cl - | IDENT "pattern"; pl = LIST1 pattern_occ SEP"," -> Pattern pl ] ] - ; - (* This is [red_tactic] including possible extensions *) red_expr: [ [ IDENT "red" -> Red false | IDENT "hnf" -> Hnf @@ -452,16 +437,6 @@ GEXTEND Gram [ [ "using"; l = LIST1 constr SEP "," -> l | -> [] ] ] ; - trivial: - [ [ IDENT "trivial" -> Off - | IDENT "info_trivial" -> Info - | IDENT "debug"; IDENT "trivial" -> Debug ] ] - ; - auto: - [ [ IDENT "auto" -> Off - | IDENT "info_auto" -> Info - | IDENT "debug"; IDENT "auto" -> Debug ] ] - ; eliminator: [ [ "using"; el = constr_with_bindings -> el ] ] ; @@ -627,9 +602,18 @@ GEXTEND Gram TacAtom (!@loc, TacInductionDestruct(false,true,icl)) (* Automation tactic *) - | d = trivial; lems = auto_using; db = hintbases -> TacAtom (!@loc, TacTrivial (d,lems,db)) - | d = auto; n = OPT int_or_var; lems = auto_using; db = hintbases -> - TacAtom (!@loc, TacAuto (d,n,lems,db)) + | IDENT "trivial"; lems = auto_using; db = hintbases -> + TacAtom (!@loc, TacTrivial (Off, lems, db)) + | IDENT "info_trivial"; lems = auto_using; db = hintbases -> + TacAtom (!@loc, TacTrivial (Info, lems, db)) + | IDENT "debug"; IDENT "trivial"; lems = auto_using; db = hintbases -> + TacAtom (!@loc, TacTrivial (Debug, lems, db)) + | IDENT "auto"; n = OPT int_or_var; lems = auto_using; db = hintbases -> + TacAtom (!@loc, TacAuto (Off, n, lems, db)) + | IDENT "info_auto"; n = OPT int_or_var; lems = auto_using; db = hintbases -> + TacAtom (!@loc, TacAuto (Info, n, lems, db)) + | IDENT "debug"; IDENT "auto"; n = OPT int_or_var; lems = auto_using; db = hintbases -> + TacAtom (!@loc, TacAuto (Debug, n, lems, db)) (* Context management *) | IDENT "clear"; "-"; l = LIST1 id_or_meta -> TacAtom (!@loc, TacClear (true, l)) @@ -677,7 +661,31 @@ GEXTEND Gram TacAtom (!@loc, TacInversion (InversionUsing (c,cl), hyp)) (* Conversion *) - | r = red_tactic; cl = clause_dft_concl -> TacAtom (!@loc, TacReduce (r, cl)) + | IDENT "red"; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Red false, cl)) + | IDENT "hnf"; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Hnf, cl)) + | IDENT "simpl"; d = delta_flag; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Simpl (all_with d, po), cl)) + | IDENT "cbv"; s = strategy_flag; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Cbv s, cl)) + | IDENT "cbn"; s = strategy_flag; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Cbn s, cl)) + | IDENT "lazy"; s = strategy_flag; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Lazy s, cl)) + | IDENT "compute"; delta = delta_flag; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Cbv (all_with delta), cl)) + | IDENT "vm_compute"; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (CbvVm po, cl)) + | IDENT "native_compute"; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (CbvNative po, cl)) + | IDENT "unfold"; ul = LIST1 unfold_occ SEP ","; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Unfold ul, cl)) + | IDENT "fold"; l = LIST1 constr; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Fold l, cl)) + | IDENT "pattern"; pl = LIST1 pattern_occ SEP","; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Pattern pl, cl)) + (* Change ne doit pas s'appliquer dans un Definition t := Eval ... *) | IDENT "change"; (oc,c) = conversion; cl = clause_dft_concl -> let p,cl = merge_occurrences (!@loc) cl oc in diff --git a/parsing/g_vernac.ml4 b/parsing/g_vernac.ml4 index cf7f6af2..1f9f57f6 100644 --- a/parsing/g_vernac.ml4 +++ b/parsing/g_vernac.ml4 @@ -46,7 +46,7 @@ let record_field = Gram.entry_create "vernac:record_field" let of_type_with_opt_coercion = Gram.entry_create "vernac:of_type_with_opt_coercion" let subgoal_command = Gram.entry_create "proof_mode:subgoal_command" let instance_name = Gram.entry_create "vernac:instance_name" -let section_subset_descr = Gram.entry_create "vernac:section_subset_descr" +let section_subset_expr = Gram.entry_create "vernac:section_subset_expr" let command_entry = ref noedit_mode let set_command_entry e = command_entry := e @@ -71,6 +71,17 @@ let make_bullet s = | '*' -> Star n | _ -> assert false +(* Hack to parse "[ id" without dropping [ *) +let test_bracket_ident = + Gram.Entry.of_parser "test_bracket_ident" + (fun strm -> + match get_tok (stream_nth 0 strm) with + | KEYWORD "[" -> + (match get_tok (stream_nth 1 strm) with + | IDENT _ -> () + | _ -> raise Stream.Failure) + | _ -> raise Stream.Failure) + let default_command_entry = Gram.Entry.of_parser "command_entry" (fun strm -> Gram.parse_tokens_after_filter (get_command_entry ()) strm) @@ -79,6 +90,7 @@ GEXTEND Gram GLOBAL: vernac gallina_ext tactic_mode noedit_mode subprf subgoal_command; vernac: FIRST [ [ IDENT "Time"; l = vernac_list -> VernacTime l + | IDENT "Redirect"; s = ne_string; l = vernac_list -> VernacRedirect (s, l) | IDENT "Timeout"; n = natural; v = vernac -> VernacTimeout(n,v) | IDENT "Fail"; v = vernac -> VernacFail v @@ -95,12 +107,12 @@ GEXTEND Gram | IDENT "Stm"; IDENT "Command"; v = vernac_aux -> VernacStm (Command v) | IDENT "Stm"; IDENT "PGLast"; v = vernac_aux -> VernacStm (PGLast v) - | v = vernac_poly -> v ] + | v = vernac_poly -> v ] ] ; - vernac_poly: + vernac_poly: [ [ IDENT "Polymorphic"; v = vernac_aux -> VernacPolymorphic (true, v) - | IDENT "Monomorphic"; v = vernac_aux -> VernacPolymorphic (false, v) + | IDENT "Monomorphic"; v = vernac_aux -> VernacPolymorphic (false, v) | v = vernac_aux -> v ] ] ; @@ -128,7 +140,7 @@ GEXTEND Gram selector: [ [ n=natural; ":" -> SelectNth n - | "["; id = ident; "]"; ":" -> SelectId id + | test_bracket_ident; "["; id = ident; "]"; ":" -> SelectId id | IDENT "all" ; ":" -> SelectAll | IDENT "par" ; ":" -> SelectAllParallel ] ] ; @@ -145,7 +157,7 @@ GEXTEND Gram ] ] ; - subgoal_command: + subgoal_command: [ [ c = query_command; "." -> begin function | Some (SelectNth g) -> c (Some g) @@ -184,9 +196,9 @@ GEXTEND Gram gallina: (* Definition, Theorem, Variable, Axiom, ... *) - [ [ thm = thm_token; id = identref; bl = binders; ":"; c = lconstr; + [ [ thm = thm_token; id = pidentref; bl = binders; ":"; c = lconstr; l = LIST0 - [ "with"; id = identref; bl = binders; ":"; c = lconstr -> + [ "with"; id = pidentref; bl = binders; ":"; c = lconstr -> (Some id,(bl,c,None)) ] -> VernacStartTheoremProof (thm, (Some id,(bl,c,None))::l, false) | stre = assumption_token; nl = inline; bl = assum_list -> @@ -194,10 +206,10 @@ GEXTEND Gram | stre = assumptions_token; nl = inline; bl = assum_list -> test_plurial_form bl; VernacAssumption (stre, nl, bl) - | d = def_token; id = identref; b = def_body -> + | d = def_token; id = pidentref; b = def_body -> VernacDefinition (d, id, b) | IDENT "Let"; id = identref; b = def_body -> - VernacDefinition ((Some Discharge, Definition), id, b) + VernacDefinition ((Some Discharge, Definition), (id, None), b) (* Gallina inductive declarations *) | priv = private_token; f = finite_token; indl = LIST1 inductive_definition SEP "with" -> @@ -248,13 +260,17 @@ GEXTEND Gram [ [ IDENT "Hypotheses" -> (Some Discharge, Logical) | IDENT "Variables" -> (Some Discharge, Definitional) | IDENT "Axioms" -> (None, Logical) - | IDENT "Parameters" -> (None, Definitional) ] ] + | IDENT "Parameters" -> (None, Definitional) + | IDENT "Conjectures" -> (None, Conjectural) ] ] ; inline: [ [ IDENT "Inline"; "("; i = INT; ")" -> InlineAt (int_of_string i) | IDENT "Inline" -> DefaultInline | -> NoInline] ] ; + pidentref: + [ [ i = identref; l = OPT [ "@{" ; l = LIST0 identref; "}" -> l ] -> (i,l) ] ] + ; univ_constraint: [ [ l = identref; ord = [ "<" -> Univ.Lt | "=" -> Univ.Eq | "<=" -> Univ.Le ]; r = identref -> (l, ord, r) ] ] @@ -299,7 +315,7 @@ GEXTEND Gram | -> RecordDecl (None, []) ] ] ; inductive_definition: - [ [ oc = opt_coercion; id = identref; indpar = binders; + [ [ oc = opt_coercion; id = pidentref; indpar = binders; c = OPT [ ":"; c = lconstr -> c ]; lc=opt_constructors_or_fields; ntn = decl_notation -> (((oc,id),indpar,c,lc),ntn) ] ] @@ -309,9 +325,9 @@ GEXTEND Gram | id = identref ; c = constructor_type; "|"; l = LIST0 constructor SEP "|" -> Constructors ((c id)::l) | id = identref ; c = constructor_type -> Constructors [ c id ] - | cstr = identref; "{"; fs = LIST0 record_field SEP ";"; "}" -> + | cstr = identref; "{"; fs = record_fields; "}" -> RecordDecl (Some cstr,fs) - | "{";fs = LIST0 record_field SEP ";"; "}" -> RecordDecl (None,fs) + | "{";fs = record_fields; "}" -> RecordDecl (None,fs) | -> Constructors [] ] ] ; (* @@ -325,14 +341,14 @@ GEXTEND Gram ; (* (co)-fixpoints *) rec_definition: - [ [ id = identref; + [ [ id = pidentref; bl = binders_fixannot; ty = type_cstr; def = OPT [":="; def = lconstr -> def]; ntn = decl_notation -> let bl, annot = bl in ((id,annot,bl,ty,def),ntn) ] ] ; corec_definition: - [ [ id = identref; bl = binders; ty = type_cstr; + [ [ id = pidentref; bl = binders; ty = type_cstr; def = OPT [":="; def = lconstr -> def]; ntn = decl_notation -> ((id,bl,ty,def),ntn) ] ] ; @@ -373,6 +389,13 @@ GEXTEND Gram [ [ bd = record_binder; pri = OPT [ "|"; n = natural -> n ]; ntn = decl_notation -> (bd,pri),ntn ] ] ; + record_fields: + [ [ f = record_field; ";"; fs = record_fields -> f :: fs + | f = record_field; ";" -> [f] + | f = record_field -> [f] + | -> [] + ] ] + ; record_binder_body: [ [ l = binders; oc = of_type_with_opt_coercion; t = lconstr -> fun id -> (oc,AssumExpr (id,mkCProdN (!@loc) l t)) @@ -397,7 +420,7 @@ GEXTEND Gram [ [ "("; a = simple_assum_coe; ")" -> a ] ] ; simple_assum_coe: - [ [ idl = LIST1 identref; oc = of_type_with_opt_coercion; c = lconstr -> + [ [ idl = LIST1 pidentref; oc = of_type_with_opt_coercion; c = lconstr -> (not (Option.is_empty oc),(idl,c)) ] ] ; @@ -424,20 +447,24 @@ GEXTEND Gram ; END -let only_identrefs = - Gram.Entry.of_parser "test_only_identrefs" +let only_starredidentrefs = + Gram.Entry.of_parser "test_only_starredidentrefs" (fun strm -> let rec aux n = match get_tok (Util.stream_nth n strm) with | KEYWORD "." -> () | KEYWORD ")" -> () - | IDENT _ -> aux (n+1) + | (IDENT _ | KEYWORD "Type" | KEYWORD "*") -> aux (n+1) | _ -> raise Stream.Failure in aux 0) +let starredidentreflist_to_expr l = + match l with + | [] -> SsEmpty + | x :: xs -> List.fold_right (fun i acc -> SsUnion(i,acc)) xs x (* Modules and Sections *) GEXTEND Gram - GLOBAL: gallina_ext module_expr module_type section_subset_descr; + GLOBAL: gallina_ext module_expr module_type section_subset_expr; gallina_ext: [ [ (* Interactive module declaration *) @@ -460,7 +487,7 @@ GEXTEND Gram | IDENT "End"; id = identref -> VernacEndSegment id (* Naming a set of section hyps *) - | IDENT "Collection"; id = identref; ":="; expr = section_subset_descr -> + | IDENT "Collection"; id = identref; ":="; expr = section_subset_expr -> VernacNameSectionHypSet (id, expr) (* Requiring an already compiled module *) @@ -551,22 +578,32 @@ GEXTEND Gram CMwith (!@loc,mty,decl) ] ] ; - section_subset_descr: - [ [ IDENT "All" -> SsAll - | "Type" -> SsType - | only_identrefs; l = LIST0 identref -> SsExpr (SsSet l) - | e = section_subset_expr -> SsExpr e ] ] - ; + (* Proof using *) section_subset_expr: + [ [ only_starredidentrefs; l = LIST0 starredidentref -> + starredidentreflist_to_expr l + | e = ssexpr -> e ]] + ; + starredidentref: + [ [ i = identref -> SsSingl i + | i = identref; "*" -> SsFwdClose(SsSingl i) + | "Type" -> SsSingl (!@loc, Id.of_string "Type") + | "Type"; "*" -> SsFwdClose (SsSingl (!@loc, Id.of_string "Type")) ]] + ; + ssexpr: [ "35" - [ "-"; e = section_subset_expr -> SsCompl e ] + [ "-"; e = ssexpr -> SsCompl e ] | "50" - [ e1 = section_subset_expr; "-"; e2 = section_subset_expr->SsSubstr(e1,e2) - | e1 = section_subset_expr; "+"; e2 = section_subset_expr->SsUnion(e1,e2)] + [ e1 = ssexpr; "-"; e2 = ssexpr->SsSubstr(e1,e2) + | e1 = ssexpr; "+"; e2 = ssexpr->SsUnion(e1,e2)] | "0" - [ i = identref -> SsSet [i] - | "("; only_identrefs; l = LIST0 identref; ")"-> SsSet l - | "("; e = section_subset_expr; ")"-> e ] ] + [ i = starredidentref -> i + | "("; only_starredidentrefs; l = LIST0 starredidentref; ")"-> + starredidentreflist_to_expr l + | "("; only_starredidentrefs; l = LIST0 starredidentref; ")"; "*" -> + SsFwdClose(starredidentreflist_to_expr l) + | "("; e = ssexpr; ")"-> e + | "("; e = ssexpr; ")"; "*" -> SsFwdClose e ] ] ; END @@ -592,15 +629,15 @@ GEXTEND Gram d = def_body -> let s = coerce_reference_to_id qid in VernacDefinition - ((Some Global,CanonicalStructure),(Loc.ghost,s),d) + ((Some Global,CanonicalStructure),((Loc.ghost,s),None),d) (* Coercions *) | IDENT "Coercion"; qid = global; d = def_body -> let s = coerce_reference_to_id qid in - VernacDefinition ((None,Coercion),(Loc.ghost,s),d) + VernacDefinition ((None,Coercion),((Loc.ghost,s),None),d) | IDENT "Coercion"; IDENT "Local"; qid = global; d = def_body -> let s = coerce_reference_to_id qid in - VernacDefinition ((Some Decl_kinds.Local,Coercion),(Loc.ghost,s),d) + VernacDefinition ((Some Decl_kinds.Local,Coercion),((Loc.ghost,s),None),d) | IDENT "Identity"; IDENT "Coercion"; IDENT "Local"; f = identref; ":"; s = class_rawexpr; ">->"; t = class_rawexpr -> VernacIdentityCoercion (true, f, s, t) @@ -1041,7 +1078,9 @@ GEXTEND Gram VernacOpenCloseScope (local,(false,sc)) | IDENT "Delimit"; IDENT "Scope"; sc = IDENT; "with"; key = IDENT -> - VernacDelimiters (sc,key) + VernacDelimiters (sc, Some key) + | IDENT "Undelimit"; IDENT "Scope"; sc = IDENT -> + VernacDelimiters (sc, None) | IDENT "Bind"; IDENT "Scope"; sc = IDENT; "with"; refl = LIST1 smart_global -> VernacBindScope (sc,refl) diff --git a/parsing/g_xml.ml4 b/parsing/g_xml.ml4 deleted file mode 100644 index 84e4a573..00000000 --- a/parsing/g_xml.ml4 +++ /dev/null @@ -1,290 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open Compat -open Pp -open Errors -open Util -open Names -open Pcoq -open Glob_term -open Tacexpr -open Libnames -open Globnames -open Detyping -open Misctypes -open Decl_kinds -open Genredexpr -open Tok (* necessary for camlp4 *) - -(* Generic xml parser without raw data *) - -type attribute = string * (Loc.t * string) -type xml = XmlTag of Loc.t * string * attribute list * xml list - -let check_tags loc otag ctag = - if not (String.equal otag ctag) then - user_err_loc (loc,"",str "closing xml tag " ++ str ctag ++ - str "does not match open xml tag " ++ str otag ++ str ".") - -let xml_eoi = (Gram.entry_create "xml_eoi" : xml Gram.entry) - -GEXTEND Gram - GLOBAL: xml_eoi; - - xml_eoi: - [ [ x = xml; EOI -> x ] ] - ; - xml: - [ [ "<"; otag = IDENT; attrs = LIST0 attr; ">"; l = LIST1 xml; - "<"; "/"; ctag = IDENT; ">" -> - check_tags (!@loc) otag ctag; - XmlTag (!@loc,ctag,attrs,l) - | "<"; tag = IDENT; attrs = LIST0 attr; "/"; ">" -> - XmlTag (!@loc,tag,attrs,[]) - ] ] - ; - attr: - [ [ name = IDENT; "="; data = STRING -> (name, (!@loc, data)) ] ] - ; -END - -(* Errors *) - -let error_bad_arity loc n = - let s = match n with 0 -> "none" | 1 -> "one" | 2 -> "two" | _ -> "many" in - user_err_loc (loc,"",str ("wrong number of arguments (expect "^s^").")) - -(* Interpreting attributes *) - -let nmtoken (loc,a) = - try int_of_string a - with Failure _ -> user_err_loc (loc,"",str "nmtoken expected.") - -let get_xml_attr s al = - try String.List.assoc s al - with Not_found -> error ("No attribute "^s) - -(* Interpreting specific attributes *) - -let ident_of_cdata (loc,a) = Id.of_string a - -let uri_of_data s = - try - let n = String.index s ':' in - let p = String.index s '.' in - let s = String.sub s (n+2) (p-n-2) in - for i = 0 to String.length s - 1 do - match s.[i] with - | '/' -> s.[i] <- '.' - | _ -> () - done; - qualid_of_string s - with Not_found | Invalid_argument _ -> - error ("Malformed URI \""^s^"\"") - -let constant_of_cdata (loc,a) = - let q = uri_of_data a in - try Nametab.locate_constant q - with Not_found -> error ("No such constant "^string_of_qualid q) - -let global_of_cdata (loc,a) = - let q = uri_of_data a in - try Nametab.locate q - with Not_found -> error ("No such global "^string_of_qualid q) - -let inductive_of_cdata a = match global_of_cdata a with - | IndRef (kn,_) -> kn - | _ -> error (string_of_qualid (uri_of_data (snd a)) ^" is not an inductive") - -let ltacref_of_cdata (loc,a) = - let q = uri_of_data a in - try (loc,Nametab.locate_tactic q) - with Not_found -> error ("No such ltac "^string_of_qualid q) - -let sort_of_cdata (loc,a) = match a with - | "Prop" -> GProp - | "Set" -> GSet - | "Type" -> GType None - | _ -> user_err_loc (loc,"",str "sort expected.") - -let get_xml_sort al = sort_of_cdata (get_xml_attr "value" al) - -let get_xml_inductive_kn al = - inductive_of_cdata (* uriType apparent synonym of uri *) - (try get_xml_attr "uri" al - with UserError _ -> get_xml_attr "uriType" al) - -let get_xml_constant al = constant_of_cdata (get_xml_attr "uri" al) - -let get_xml_inductive al = - (get_xml_inductive_kn al, nmtoken (get_xml_attr "noType" al)) - -let get_xml_constructor al = - (get_xml_inductive al, nmtoken (get_xml_attr "noConstr" al)) - -let get_xml_binder al = - try Name (ident_of_cdata (String.List.assoc "binder" al)) - with Not_found -> Anonymous - -let get_xml_ident al = ident_of_cdata (get_xml_attr "binder" al) - -let get_xml_name al = ident_of_cdata (get_xml_attr "name" al) - -let get_xml_noFun al = nmtoken (get_xml_attr "noFun" al) - -let get_xml_no al = Evar.unsafe_of_int (nmtoken (get_xml_attr "no" al)) - -(* A leak in the xml dtd: arities of constructor need to know global env *) - -let compute_branches_lengths ind = - let (_,mip) = Inductive.lookup_mind_specif (Global.env()) ind in - mip.Declarations.mind_consnrealdecls - -let compute_inductive_ndecls ind = - Inductiveops.inductive_nrealdecls ind - -(* Interpreting constr as a glob_constr *) - -let rec interp_xml_constr = function - | XmlTag (loc,"REL",al,[]) -> - GVar (loc, get_xml_ident al) - | XmlTag (loc,"VAR",al,[]) -> - error "XML parser: unable to interp free variables" - | XmlTag (loc,"LAMBDA",al,(_::_ as xl)) -> - let body,decls = List.sep_last xl in - let ctx = List.map interp_xml_decl decls in - List.fold_right (fun (na,t) b -> GLambda (loc, na, Explicit, t, b)) - ctx (interp_xml_target body) - | XmlTag (loc,"PROD",al,(_::_ as xl)) -> - let body,decls = List.sep_last xl in - let ctx = List.map interp_xml_decl decls in - List.fold_right (fun (na,t) b -> GProd (loc, na, Explicit, t, b)) - ctx (interp_xml_target body) - | XmlTag (loc,"LETIN",al,(_::_ as xl)) -> - let body,defs = List.sep_last xl in - let ctx = List.map interp_xml_def defs in - List.fold_right (fun (na,t) b -> GLetIn (loc, na, t, b)) - ctx (interp_xml_target body) - | XmlTag (loc,"APPLY",_,x::xl) -> - GApp (loc, interp_xml_constr x, List.map interp_xml_constr xl) - | XmlTag (loc,"instantiate",_, - (XmlTag (_,("CONST"|"MUTIND"|"MUTCONSTRUCT"),_,_) as x)::xl) -> - GApp (loc, interp_xml_constr x, List.map interp_xml_arg xl) - | XmlTag (loc,"META",al,xl) -> - GEvar (loc, get_xml_name al, Some (List.map interp_xml_substitution xl)) - | XmlTag (loc,"CONST",al,[]) -> - GRef (loc, ConstRef (get_xml_constant al), None) - | XmlTag (loc,"MUTCASE",al,x::y::yl) -> - let ind = get_xml_inductive al in - let p = interp_xml_patternsType x in - let tm = interp_xml_inductiveTerm y in - let vars = compute_branches_lengths ind in - let brs = List.map_i (fun i c -> (i,vars.(i),interp_xml_pattern c)) 0 yl - in - let mat = simple_cases_matrix_of_branches ind brs in - let n = compute_inductive_ndecls ind in - let nal,rtn = return_type_of_predicate ind n p in - GCases (loc,RegularStyle,rtn,[tm,nal],mat) - | XmlTag (loc,"MUTIND",al,[]) -> - GRef (loc, IndRef (get_xml_inductive al), None) - | XmlTag (loc,"MUTCONSTRUCT",al,[]) -> - GRef (loc, ConstructRef (get_xml_constructor al), None) - | XmlTag (loc,"FIX",al,xl) -> - let li,lnct = List.split (List.map interp_xml_FixFunction xl) in - let ln,lc,lt = List.split3 lnct in - let lctx = List.map (fun _ -> []) ln in - GRec (loc, GFix (Array.of_list li, get_xml_noFun al), Array.of_list ln, Array.of_list lctx, Array.of_list lc, Array.of_list lt) - | XmlTag (loc,"COFIX",al,xl) -> - let ln,lc,lt = List.split3 (List.map interp_xml_CoFixFunction xl) in - GRec (loc, GCoFix (get_xml_noFun al), Array.of_list ln, [||], Array.of_list lc, Array.of_list lt) - | XmlTag (loc,"CAST",al,[x1;x2]) -> - GCast (loc, interp_xml_term x1, CastConv (interp_xml_type x2)) - | XmlTag (loc,"SORT",al,[]) -> - GSort (loc, get_xml_sort al) - | XmlTag (loc,s,_,_) -> - user_err_loc (loc,"", str "Unexpected tag " ++ str s ++ str ".") - -and interp_xml_tag s = function - | XmlTag (loc,tag,al,xl) when String.equal tag s -> (loc,al,xl) - | XmlTag (loc,tag,_,_) -> user_err_loc (loc, "", - str "Expect tag " ++ str s ++ str " but find " ++ str s ++ str ".") - -and interp_xml_constr_alias s x = - match interp_xml_tag s x with - | (_,_,[x]) -> interp_xml_constr x - | (loc,_,_) -> error_bad_arity loc 1 - -and interp_xml_term x = interp_xml_constr_alias "term" x -and interp_xml_type x = interp_xml_constr_alias "type" x -and interp_xml_target x = interp_xml_constr_alias "target" x -and interp_xml_body x = interp_xml_constr_alias "body" x -and interp_xml_pattern x = interp_xml_constr_alias "pattern" x -and interp_xml_patternsType x = interp_xml_constr_alias "patternsType" x -and interp_xml_inductiveTerm x = interp_xml_constr_alias "inductiveTerm" x -and interp_xml_arg x = interp_xml_constr_alias "arg" x -and interp_xml_substitution x = - match interp_xml_tag "substitution" x with - _, al, [x] -> get_xml_name al, interp_xml_constr x - | loc, _, _ -> error_bad_arity loc 1 - (* no support for empty substitution from official dtd *) - -and interp_xml_decl_alias s x = - match interp_xml_tag s x with - | (_,al,[x]) -> (get_xml_binder al, interp_xml_constr x) - | (loc,_,_) -> error_bad_arity loc 1 - -and interp_xml_def x = interp_xml_decl_alias "def" x -and interp_xml_decl x = interp_xml_decl_alias "decl" x - -and interp_xml_recursionOrder x = - let (loc, al, l) = interp_xml_tag "RecursionOrder" x in - let (locs, s) = get_xml_attr "type" al in - match s, l with - | "Structural", [] -> GStructRec - | "Structural", _ -> error_bad_arity loc 0 - | "WellFounded", [c] -> GWfRec (interp_xml_type c) - | "WellFounded", _ -> error_bad_arity loc 1 - | "Measure", [m;r] -> GMeasureRec (interp_xml_type m, Some (interp_xml_type r)) - | "Measure", _ -> error_bad_arity loc 2 - | _ -> user_err_loc (locs,"",str "Invalid recursion order.") - -and interp_xml_FixFunction x = - match interp_xml_tag "FixFunction" x with - | (loc,al,[x1;x2;x3]) -> (* Not in official cic.dtd, not in constr *) - ((Some (nmtoken (get_xml_attr "recIndex" al)), - interp_xml_recursionOrder x1), - (get_xml_name al, interp_xml_type x2, interp_xml_body x3)) - | (loc,al,[x1;x2]) -> - ((Some (nmtoken (get_xml_attr "recIndex" al)), GStructRec), - (get_xml_name al, interp_xml_type x1, interp_xml_body x2)) - | (loc,_,_) -> - error_bad_arity loc 1 - -and interp_xml_CoFixFunction x = - match interp_xml_tag "CoFixFunction" x with - | (loc,al,[x1;x2]) -> - (get_xml_name al, interp_xml_type x1, interp_xml_body x2) - | (loc,_,_) -> - error_bad_arity loc 1 - -(* Interpreting tactic argument *) - -let rec interp_xml_tactic_arg = function - | XmlTag (loc,"TERM",[],[x]) -> - ConstrMayEval (ConstrTerm (interp_xml_constr x,None)) - | XmlTag (loc,"CALL",al,xl) -> - let ltacref = ltacref_of_cdata (get_xml_attr "uri" al) in - TacCall(loc,ArgArg ltacref,List.map interp_xml_tactic_arg xl) - | XmlTag (loc,s,_,_) -> - user_err_loc (loc,"", str "Unexpected tag " ++ str s ++ str ".") - -let parse_tactic_arg ch = - interp_xml_tactic_arg - (Pcoq.Gram.entry_parse xml_eoi - (Pcoq.Gram.parsable (Stream.of_channel ch))) diff --git a/parsing/lexer.ml4 b/parsing/lexer.ml4 index 8e839296..c6d5f3b9 100644 --- a/parsing/lexer.ml4 +++ b/parsing/lexer.ml4 @@ -70,7 +70,7 @@ let ttree_remove ttree str = remove ttree 0 -(* Errors occuring while lexing (explained as "Lexer error: ...") *) +(* Errors occurring while lexing (explained as "Lexer error: ...") *) module Error = struct diff --git a/parsing/pcoq.ml4 b/parsing/pcoq.ml4 index 54edbb2c..2e47e07a 100644 --- a/parsing/pcoq.ml4 +++ b/parsing/pcoq.ml4 @@ -298,7 +298,7 @@ module Prim = struct let gec_gen x = make_gen_entry uprim x - (* Entries that can be refered via the string -> Gram.entry table *) + (* Entries that can be referred via the string -> Gram.entry table *) (* Typically for tactic or vernac extensions *) let preident = gec_gen (rawwit wit_pre_ident) "preident" let ident = gec_gen (rawwit wit_ident) "ident" @@ -334,7 +334,7 @@ module Constr = struct let gec_constr = make_gen_entry uconstr (rawwit wit_constr) - (* Entries that can be refered via the string -> Gram.entry table *) + (* Entries that can be referred via the string -> Gram.entry table *) let constr = gec_constr "constr" let operconstr = gec_constr "operconstr" let constr_eoi = eoi_entry constr @@ -367,7 +367,7 @@ module Tactic = (* Main entry for extensions *) let simple_tactic = Gram.entry_create "tactic:simple_tactic" - (* Entries that can be refered via the string -> Gram.entry table *) + (* Entries that can be referred via the string -> Gram.entry table *) (* Typically for tactic user extensions *) let open_constr = make_gen_entry utactic (rawwit wit_open_constr) "open_constr" @@ -459,8 +459,8 @@ let default_pattern_levels = [200,Extend.RightA,true; 100,Extend.RightA,false; 99,Extend.RightA,true; - 10,Extend.LeftA,false; - 9,Extend.RightA,false; + 11,Extend.LeftA,false; + 10,Extend.RightA,false; 1,Extend.LeftA,false; 0,Extend.RightA,false] diff --git a/plugins/btauto/Algebra.v b/plugins/btauto/Algebra.v index bc5a3900..ee7341a4 100644 --- a/plugins/btauto/Algebra.v +++ b/plugins/btauto/Algebra.v @@ -283,7 +283,7 @@ end. (** Quotienting a polynomial by the relation X_i^2 ~ X_i *) -(* Remove the multiple occurences of monomials x_k *) +(* Remove the multiple occurrences of monomials x_k *) Fixpoint reduce_aux k p := match p with diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 29bca862..97ea5fdc 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -129,14 +129,14 @@ type cinfo= ci_nhyps: int} (* # projectable args *) let family_eq f1 f2 = match f1, f2 with -| InProp, InProp -| InSet, InSet -| InType, InType -> true -| _ -> false + | Prop Pos, Prop Pos + | Prop Null, Prop Null + | Type _, Type _ -> true + | _ -> false type term= Symb of constr - | Product of sorts_family * sorts_family + | Product of sorts * sorts | Eps of Id.t | Appli of term*term | Constructor of cinfo (* constructor arity + nhyps *) @@ -161,7 +161,7 @@ let hash_sorts_family = function let rec hash_term = function | Symb c -> combine 1 (hash_constr c) - | Product (s1, s2) -> combine3 2 (hash_sorts_family s1) (hash_sorts_family s2) + | Product (s1, s2) -> combine3 2 (Sorts.hash s1) (Sorts.hash s2) | Eps i -> combine 3 (Id.hash i) | Appli (t1, t2) -> combine3 4 (hash_term t1) (hash_term t2) | Constructor {ci_constr=(c,u); ci_arity=i; ci_nhyps=j} -> combine4 5 (constructor_hash c) i j @@ -425,8 +425,8 @@ let _B_ = Name (Id.of_string "A") let _body_ = mkProd(Anonymous,mkRel 2,mkRel 2) let cc_product s1 s2 = - mkLambda(_A_,mkSort(Universes.new_sort_in_family s1), - mkLambda(_B_,mkSort(Universes.new_sort_in_family s2),_body_)) + mkLambda(_A_,mkSort(s1), + mkLambda(_B_,mkSort(s2),_body_)) let rec constr_of_term = function Symb s-> applist_projection s [] @@ -513,7 +513,7 @@ let rec add_term state t= Not_found -> let b=next uf in let trm = constr_of_term t in - let typ = pf_type_of state.gls trm in + let typ = pf_unsafe_type_of state.gls trm in let typ = canonize_name typ in let new_node= match t with @@ -836,7 +836,7 @@ let complete_one_class state i= let _,etyp,rest= destProd typ in let id = new_state_var etyp state in app (Appli(t,Eps id)) (substl [mkVar id] rest) (n-1) in - let _c = pf_type_of state.gls + let _c = pf_unsafe_type_of state.gls (constr_of_term (term state.uf pac.cnode)) in let _args = List.map (fun i -> constr_of_term (term state.uf i)) diff --git a/plugins/cc/ccalgo.mli b/plugins/cc/ccalgo.mli index c72843d5..0dcf3a87 100644 --- a/plugins/cc/ccalgo.mli +++ b/plugins/cc/ccalgo.mli @@ -30,7 +30,7 @@ type cinfo = type term = Symb of constr - | Product of sorts_family * sorts_family + | Product of sorts * sorts | Eps of Id.t | Appli of term*term | Constructor of cinfo (* constructor arity + nhyps *) diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 8884aef1..068cb25c 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -46,7 +46,7 @@ let whd_delta env= (* decompose member of equality in an applicative format *) (** FIXME: evar leak *) -let sf_of env sigma c = family_of_sort (sort_of env (ref sigma) c) +let sf_of env sigma c = sort_of env (ref sigma) c let rec decompose_term env sigma t= match kind_of_term (whd env t) with @@ -253,9 +253,15 @@ let new_app_global f args k = let new_refine c = Proofview.V82.tactic (refine c) +let assert_before n c = + Proofview.Goal.enter begin fun gl -> + let evm, _ = Tacmach.New.pf_apply type_of gl c in + Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm)) (assert_before n c) + end + let rec proof_tac p : unit Proofview.tactic = Proofview.Goal.nf_enter begin fun gl -> - let type_of t = Tacmach.New.pf_type_of gl t in + let type_of t = Tacmach.New.pf_unsafe_type_of gl t in try (* type_of can raise exceptions *) match p.p_rule with Ax c -> exact_check c @@ -302,9 +308,9 @@ let rec proof_tac p : unit Proofview.tactic = Tacticals.New.tclFIRST [Tacticals.New.tclTHEN (Proofview.V82.tactic (lemma2 refine)) (proof_tac p2); reflexivity; - Proofview.tclZERO (UserError ("Congruence" , + Tacticals.New.tclZEROMSG (Pp.str - "I don't know how to handle dependent equality")))]] + "I don't know how to handle dependent equality")]] | Inject (prf,cstr,nargs,argind) -> let ti=constr_of_term prf.p_lhs in let tj=constr_of_term prf.p_rhs in @@ -325,7 +331,7 @@ let refute_tac c t1 t2 p = Proofview.Goal.nf_enter begin fun gl -> let tt1=constr_of_term t1 and tt2=constr_of_term t2 in let intype = - Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_type_of gls tt1)) gl + Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_unsafe_type_of gls tt1)) gl in let neweq= new_app_global _eq [|intype;tt1;tt2|] in let hid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "Heq")) gl in @@ -335,14 +341,14 @@ let refute_tac c t1 t2 p = end let refine_exact_check c gl = - let evm, _ = pf_apply e_type_of gl c in + let evm, _ = pf_apply type_of gl c in Tacticals.tclTHEN (Refiner.tclEVARS evm) (Proofview.V82.of_tactic (exact_check c)) gl let convert_to_goal_tac c t1 t2 p = Proofview.Goal.nf_enter begin fun gl -> let tt1=constr_of_term t1 and tt2=constr_of_term t2 in let sort = - Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_type_of gls tt2)) gl + Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_unsafe_type_of gls tt2)) gl in let neweq= new_app_global _eq [|sort;tt1;tt2|] in let e = Tacmach.New.of_old (pf_get_new_id (Id.of_string "e")) gl in @@ -367,7 +373,7 @@ let discriminate_tac (cstr,u as cstru) p = Proofview.Goal.nf_enter begin fun gl -> let t1=constr_of_term p.p_lhs and t2=constr_of_term p.p_rhs in let intype = - Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_type_of gls t1)) gl + Tacmach.New.of_old (fun gls -> (* Termops.refresh_universes *) (pf_unsafe_type_of gls t1)) gl in let concl = Proofview.Goal.concl gl in (* let evm,outsort = Evd.new_sort_variable Evd.univ_rigid (project gls) in *) @@ -376,7 +382,7 @@ let discriminate_tac (cstr,u as cstru) p = (* let tid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "t")) gl in *) (* let identity=mkLambda(Name xid,outsort,mkLambda(Name tid,mkRel 1,mkRel 1)) in *) let identity = Universes.constr_of_global (Lazy.force _I) in - (* let trivial=pf_type_of gls identity in *) + (* let trivial=pf_unsafe_type_of gls identity in *) let trivial = Universes.constr_of_global (Lazy.force _True) in let evm, outtype = Evd.new_sort_variable Evd.univ_flexible (Proofview.Goal.sigma gl) in let outtype = mkSort outtype in @@ -476,19 +482,28 @@ let congruence_tac depth l = This isn't particularly related with congruence, apart from the fact that congruence is called internally. *) - + +let mk_eq f c1 c2 k = + Tacticals.New.pf_constr_of_global (Lazy.force f) (fun fc -> + Proofview.Goal.enter begin + fun gl -> + let open Tacmach.New in + let evm, ty = pf_apply type_of gl c1 in + let evm, ty = Evarsolve.refresh_universes (Some false) (pf_env gl) evm ty in + let term = mkApp (fc, [| ty; c1; c2 |]) in + let evm, _ = type_of (pf_env gl) evm term in + Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm)) + (k term) + end) + let f_equal = Proofview.Goal.nf_enter begin fun gl -> let concl = Proofview.Goal.concl gl in - let type_of = Tacmach.New.pf_type_of gl in let cut_eq c1 c2 = try (* type_of can raise an exception *) - let ty = (* Termops.refresh_universes *) (type_of c1) in - if eq_constr_nounivs c1 c2 then Proofview.tclUNIT () - else - Tacticals.New.tclTRY (Tacticals.New.tclTHEN - ((new_app_global _eq [|ty; c1; c2|]) Tactics.cut) - (Tacticals.New.tclTRY ((new_app_global _refl_equal [||]) apply))) + Tacticals.New.tclTHEN + (mk_eq _eq c1 c2 Tactics.cut) + (Tacticals.New.tclTRY ((new_app_global _refl_equal [||]) apply)) with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e in Proofview.tclORELSE diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index 9d0b7f34..1a908064 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -125,10 +125,34 @@ let go_to_proof_mode () = (* closing gaps *) +(* spiwack: should use [Proofview.give_up] but that would require + moving the whole declarative mode into the new proof engine. It + will eventually have to be done. + + As far as I can tell, [daimon_tac] is used after a [thus thesis], + it will leave uninstantiated variables instead of giving a relevant + message at [Qed]. *) let daimon_tac gls = set_daimon_flag (); {it=[];sigma=sig_sig gls;} +let daimon_instr env p = + let (p,(status,_)) = + Proof.run_tactic env begin + Proofview.tclINDEPENDENT Proofview.give_up + end p + in + p,status + +let do_daimon () = + let env = Global.env () in + let status = + Proof_global.with_current_proof begin fun _ p -> + daimon_instr env p + end + in + if not status then Pp.feedback Feedback.AddedAxiom else () + (* post-instruction focus management *) let goto_current_focus () = @@ -144,7 +168,7 @@ let goto_current_focus_or_top () = (* return *) let close_tactic_mode () = - try goto_current_focus () + try do_daimon ();goto_current_focus () with Not_found -> error "\"return\" cannot be used outside of Declarative Proof Mode." @@ -165,7 +189,7 @@ let close_block bt pts = in match bt,stack with B_claim, Claim::_ | B_focus, Focus_claim::_ | B_proof, [] -> - (goto_current_focus ()) + do_daimon ();goto_current_focus () | _, Claim::_ -> error "\"end claim\" expected." | _, Focus_claim::_ -> @@ -188,7 +212,7 @@ let close_previous_case pts = Proof.is_done pts then match get_top_stack pts with - Per (et,_,_,_) :: _ -> anomaly (Pp.str "Weird case occured ...") + Per (et,_,_,_) :: _ -> anomaly (Pp.str "Weird case occurred ...") | Suppose_case :: Per (et,_,_,_) :: _ -> goto_current_focus () | _ -> error "Not inside a proof per cases or induction." @@ -196,7 +220,7 @@ let close_previous_case pts = match get_stack pts with Per (et,_,_,_) :: _ -> () | Suppose_case :: Per (et,_,_,_) :: _ -> - goto_current_focus () + do_daimon ();goto_current_focus () | _ -> error "Not inside a proof per cases or induction." (* Proof instructions *) @@ -749,7 +773,7 @@ let rec take_tac wits gls = match wits with [] -> tclIDTAC gls | wit::rest -> - let typ = pf_type_of gls wit in + let typ = pf_unsafe_type_of gls wit in tclTHEN (thus_tac wit typ []) (take_tac rest) gls @@ -830,7 +854,7 @@ let start_tree env ind rp = let build_per_info etype casee gls = let concl=pf_concl gls in let env=pf_env gls in - let ctyp=pf_type_of gls casee in + let ctyp=pf_unsafe_type_of gls casee in let is_dep = dependent casee concl in let hd,args = decompose_app (special_whd gls ctyp) in let (ind,u) = @@ -845,7 +869,7 @@ let build_per_info etype casee gls = | _ -> mind.mind_nparams,None in let params,real_args = List.chop nparams args in let abstract_obj c body = - let typ=pf_type_of gls c in + let typ=pf_unsafe_type_of gls c in lambda_create env (typ,subst_term c body) in let pred= List.fold_right abstract_obj real_args (lambda_create env (ctyp,subst_term casee concl)) in @@ -1204,13 +1228,13 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls = let nparams = mind.mind_nparams in let concl=pf_concl gls in let env=pf_env gls in - let ctyp=pf_type_of gls casee in + let ctyp=pf_unsafe_type_of gls casee in let hd,all_args = decompose_app (special_whd gls ctyp) in let ind', u = destInd hd in let _ = assert (eq_ind ind' ind) in (* just in case *) let params,real_args = List.chop nparams all_args in let abstract_obj c body = - let typ=pf_type_of gls c in + let typ=pf_unsafe_type_of gls c in lambda_create env (typ,subst_term c body) in let elim_pred = List.fold_right abstract_obj real_args (lambda_create env (ctyp,subst_term casee concl)) in diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index c232ae31..d6c29283 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -6,8 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -let map_const_entry_body (f:Term.constr->Term.constr) (x:Entries.const_entry_body) - : Entries.const_entry_body = +let map_const_entry_body (f:Term.constr->Term.constr) (x:Safe_typing.private_constants Entries.const_entry_body) + : Safe_typing.private_constants Entries.const_entry_body = Future.chain ~pure:true x begin fun ((b,ctx),fx) -> (f b , ctx) , fx end diff --git a/plugins/extraction/CHANGES b/plugins/extraction/CHANGES index fbcd01a1..cf97ae3a 100644 --- a/plugins/extraction/CHANGES +++ b/plugins/extraction/CHANGES @@ -193,7 +193,7 @@ beginning of files. Possible clashes are dealt with. in extracted code. -* A few constants are explicitely declared to be inlined in extracted code. +* A few constants are explicitly declared to be inlined in extracted code. For the moment there are: Wf.Acc_rec Wf.Acc_rect @@ -234,12 +234,12 @@ Those two commands enable a precise control of what is inlined and what is not. Print Extraction Inline. -Sum up the current state of the table recording the custom inlings +Sum up the current state of the table recording the custom inlinings (Extraction (No)Inline). Reset Extraction Inline. -Put the table recording the custom inlings back to empty. +Put the table recording the custom inlinings back to empty. As a consequence, there is no more need for options inside the commands of extraction: diff --git a/plugins/extraction/ExtrHaskellNatInt.v b/plugins/extraction/ExtrHaskellNatInt.v new file mode 100644 index 00000000..e94e7d42 --- /dev/null +++ b/plugins/extraction/ExtrHaskellNatInt.v @@ -0,0 +1,13 @@ +(** Extraction of [nat] into Haskell's [Int] *) + +Require Import Arith. +Require Import ExtrHaskellNatNum. + +(** + * Disclaimer: trying to obtain efficient certified programs + * by extracting [nat] into [Int] is definitively *not* a good idea. + * See comments in [ExtrOcamlNatInt.v]. + *) + +Extract Inductive nat => "Prelude.Int" [ "0" "Prelude.succ" ] + "(\fO fS n -> if n Prelude.== 0 then fO () else fS (n Prelude.- 1))". diff --git a/plugins/extraction/ExtrHaskellNatInteger.v b/plugins/extraction/ExtrHaskellNatInteger.v new file mode 100644 index 00000000..038f0ed8 --- /dev/null +++ b/plugins/extraction/ExtrHaskellNatInteger.v @@ -0,0 +1,13 @@ +(** Extraction of [nat] into Haskell's [Integer] *) + +Require Import Arith. +Require Import ExtrHaskellNatNum. + +(** + * Disclaimer: trying to obtain efficient certified programs + * by extracting [nat] into [Integer] isn't necessarily a good idea. + * See comments in [ExtrOcamlNatInt.v]. +*) + +Extract Inductive nat => "Prelude.Integer" [ "0" "Prelude.succ" ] + "(\fO fS n -> if n Prelude.== 0 then fO () else fS (n Prelude.- 1))". diff --git a/plugins/extraction/ExtrHaskellNatNum.v b/plugins/extraction/ExtrHaskellNatNum.v new file mode 100644 index 00000000..244eb85f --- /dev/null +++ b/plugins/extraction/ExtrHaskellNatNum.v @@ -0,0 +1,35 @@ +(** + * Efficient (but uncertified) extraction of usual [nat] functions + * into equivalent versions in Haskell's Prelude that are defined + * for any [Num] typeclass instances. Useful in combination with + * [Extract Inductive nat] that maps [nat] onto a Haskell type that + * implements [Num]. + *) + +Require Import Arith. +Require Import EqNat. + +Extract Inlined Constant Nat.add => "(Prelude.+)". +Extract Inlined Constant Nat.mul => "(Prelude.*)". +Extract Inlined Constant Nat.max => "Prelude.max". +Extract Inlined Constant Nat.min => "Prelude.min". +Extract Inlined Constant Init.Nat.add => "(Prelude.+)". +Extract Inlined Constant Init.Nat.mul => "(Prelude.*)". +Extract Inlined Constant Init.Nat.max => "Prelude.max". +Extract Inlined Constant Init.Nat.min => "Prelude.min". +Extract Inlined Constant Compare_dec.lt_dec => "(Prelude.<)". +Extract Inlined Constant Compare_dec.leb => "(Prelude.<=)". +Extract Inlined Constant Compare_dec.le_lt_dec => "(Prelude.<=)". +Extract Inlined Constant EqNat.beq_nat => "(Prelude.==)". +Extract Inlined Constant EqNat.eq_nat_decide => "(Prelude.==)". +Extract Inlined Constant Peano_dec.eq_nat_dec => "(Prelude.==)". + +Extract Constant Nat.pred => "(\n -> Prelude.max 0 (Prelude.pred n))". +Extract Constant Nat.sub => "(\n m -> Prelude.max 0 (n Prelude.- m))". +Extract Constant Init.Nat.pred => "(\n -> Prelude.max 0 (Prelude.pred n))". +Extract Constant Init.Nat.sub => "(\n m -> Prelude.max 0 (n Prelude.- m))". + +Extract Constant Nat.div => "(\n m -> if m Prelude.== 0 then 0 else Prelude.div n m)". +Extract Constant Nat.modulo => "(\n m -> if m Prelude.== 0 then 0 else Prelude.mod n m)". +Extract Constant Init.Nat.div => "(\n m -> if m Prelude.== 0 then 0 else Prelude.div n m)". +Extract Constant Init.Nat.modulo => "(\n m -> if m Prelude.== 0 then 0 else Prelude.mod n m)".
\ No newline at end of file diff --git a/plugins/extraction/ExtrHaskellString.v b/plugins/extraction/ExtrHaskellString.v new file mode 100644 index 00000000..3558f4f2 --- /dev/null +++ b/plugins/extraction/ExtrHaskellString.v @@ -0,0 +1,38 @@ +(** + * Special handling of ascii and strings for extraction to Haskell. + *) + +Require Import Ascii. +Require Import String. + +(** + * At the moment, Coq's extraction has no way to add extra import + * statements to the extracted Haskell code. You will have to + * manually add: + * + * import qualified Data.Bits + * import qualified Data.Char + *) + +Extract Inductive ascii => "Prelude.Char" + [ "(\b0 b1 b2 b3 b4 b5 b6 b7 -> Data.Char.chr ( + (if b0 then Data.Bits.shiftL 1 0 else 0) Prelude.+ + (if b1 then Data.Bits.shiftL 1 1 else 0) Prelude.+ + (if b2 then Data.Bits.shiftL 1 2 else 0) Prelude.+ + (if b3 then Data.Bits.shiftL 1 3 else 0) Prelude.+ + (if b4 then Data.Bits.shiftL 1 4 else 0) Prelude.+ + (if b5 then Data.Bits.shiftL 1 5 else 0) Prelude.+ + (if b6 then Data.Bits.shiftL 1 6 else 0) Prelude.+ + (if b7 then Data.Bits.shiftL 1 7 else 0)))" ] + "(\f a -> f (Data.Bits.testBit (Data.Char.ord a) 0) + (Data.Bits.testBit (Data.Char.ord a) 1) + (Data.Bits.testBit (Data.Char.ord a) 2) + (Data.Bits.testBit (Data.Char.ord a) 3) + (Data.Bits.testBit (Data.Char.ord a) 4) + (Data.Bits.testBit (Data.Char.ord a) 5) + (Data.Bits.testBit (Data.Char.ord a) 6) + (Data.Bits.testBit (Data.Char.ord a) 7))". +Extract Inlined Constant Ascii.ascii_dec => "(Prelude.==)". + +Extract Inductive string => "Prelude.String" [ "([])" "(:)" ]. +Extract Inlined Constant String.string_dec => "(Prelude.==)". diff --git a/plugins/extraction/ExtrHaskellZInt.v b/plugins/extraction/ExtrHaskellZInt.v new file mode 100644 index 00000000..66690851 --- /dev/null +++ b/plugins/extraction/ExtrHaskellZInt.v @@ -0,0 +1,24 @@ +(** Extraction of [Z] into Haskell's [Int] *) + +Require Import ZArith. +Require Import ExtrHaskellZNum. + +(** + * Disclaimer: trying to obtain efficient certified programs + * by extracting [Z] into [Int] is definitively *not* a good idea. + * See comments in [ExtrOcamlNatInt.v]. + *) + +Extract Inductive positive => "Prelude.Int" [ + "(\x -> 2 Prelude.* x Prelude.+ 1)" + "(\x -> 2 Prelude.* x)" + "1" ] + "(\fI fO fH n -> if n Prelude.== 1 then fH () else + if Prelude.odd n + then fI (n `Prelude.div` 2) + else fO (n `Prelude.div` 2))". + +Extract Inductive Z => "Prelude.Int" [ "0" "(\x -> x)" "Prelude.negate" ] + "(\fO fP fN n -> if n Prelude.== 0 then fO () else + if n Prelude.> 0 then fP n else + fN (Prelude.negate n))". diff --git a/plugins/extraction/ExtrHaskellZInteger.v b/plugins/extraction/ExtrHaskellZInteger.v new file mode 100644 index 00000000..f192f16e --- /dev/null +++ b/plugins/extraction/ExtrHaskellZInteger.v @@ -0,0 +1,23 @@ +(** Extraction of [Z] into Haskell's [Integer] *) + +Require Import ZArith. +Require Import ExtrHaskellZNum. + +(** Disclaimer: trying to obtain efficient certified programs + by extracting [Z] into [Integer] isn't necessarily a good idea. + See comments in [ExtrOcamlNatInt.v]. +*) + +Extract Inductive positive => "Prelude.Integer" [ + "(\x -> 2 Prelude.* x Prelude.+ 1)" + "(\x -> 2 Prelude.* x)" + "1" ] + "(\fI fO fH n -> if n Prelude.== 1 then fH () else + if Prelude.odd n + then fI (n `Prelude.div` 2) + else fO (n `Prelude.div` 2))". + +Extract Inductive Z => "Prelude.Integer" [ "0" "(\x -> x)" "Prelude.negate" ] + "(\fO fP fN n -> if n Prelude.== 0 then fO () else + if n Prelude.> 0 then fP n else + fN (Prelude.negate n))". diff --git a/plugins/extraction/ExtrHaskellZNum.v b/plugins/extraction/ExtrHaskellZNum.v new file mode 100644 index 00000000..cbbfda75 --- /dev/null +++ b/plugins/extraction/ExtrHaskellZNum.v @@ -0,0 +1,21 @@ +(** + * Efficient (but uncertified) extraction of usual [Z] functions + * into equivalent versions in Haskell's Prelude that are defined + * for any [Num] typeclass instances. Useful in combination with + * [Extract Inductive Z] that maps [Z] onto a Haskell type that + * implements [Num]. + *) + +Require Import ZArith. +Require Import EqNat. + +Extract Inlined Constant Z.add => "(Prelude.+)". +Extract Inlined Constant Z.sub => "(Prelude.-)". +Extract Inlined Constant Z.mul => "(Prelude.*)". +Extract Inlined Constant Z.max => "Prelude.max". +Extract Inlined Constant Z.min => "Prelude.min". +Extract Inlined Constant Z_ge_lt_dec => "(Prelude.>=)". +Extract Inlined Constant Z_gt_le_dec => "(Prelude.>)". + +Extract Constant Z.div => "(\n m -> if m Prelude.== 0 then 0 else Prelude.div n m)". +Extract Constant Z.modulo => "(\n m -> if m Prelude.== 0 then 0 else Prelude.mod n m)". diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 080512b2..6ae519ef 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -633,7 +633,8 @@ let rec extract_term env mle mlt c args = | Construct (cp,u) -> extract_cons_app env mle mlt cp u args | Proj (p, c) -> - extract_cst_app env mle mlt (Projection.constant p) Univ.Instance.empty (c :: args) + let term = Retyping.expand_projection env (Evd.from_env env) p c [] in + extract_term env mle mlt term args | Rel n -> (* As soon as the expected [mlt] for the head is known, *) (* we unify it with an fresh copy of the stored type of [Rel n]. *) diff --git a/plugins/extraction/mlutil.ml b/plugins/extraction/mlutil.ml index 9fdb0205..6fc1195f 100644 --- a/plugins/extraction/mlutil.ml +++ b/plugins/extraction/mlutil.ml @@ -490,8 +490,8 @@ let ast_occurs_itvl k k' t = ast_iter_rel (fun i -> if (k <= i) && (i <= k') then raise Found) t; false with Found -> true -(* Number of occurences of [Rel 1] in [t], with special treatment of match: - occurences in different branches aren't added, but we rather use max. *) +(* Number of occurrences of [Rel 1] in [t], with special treatment of match: + occurrences in different branches aren't added, but we rather use max. *) let nb_occur_match = let rec nb k = function @@ -851,7 +851,7 @@ let factor_branches o typ br = else Some (br_factor, br_set) end -(*s If all branches are functions, try to permut the case and the functions. *) +(*s If all branches are functions, try to permute the case and the functions. *) let rec merge_ids ids ids' = match ids,ids' with | [],l -> l @@ -1127,7 +1127,7 @@ let term_expunge s (ids,c) = MLlam (Dummy, ast_lift 1 c) else named_lams ids c -(*s [kill_dummy_args ids r t] looks for occurences of [MLrel r] in [t] and +(*s [kill_dummy_args ids r t] looks for occurrences of [MLrel r] in [t] and purge the args of [MLrel r] corresponding to a [dummy_name]. It makes eta-expansion if needed. *) @@ -1351,10 +1351,10 @@ let is_not_strict t = We expand small terms with at least one non-strict variable (i.e. a variable that may not be evaluated). - Futhermore we don't expand fixpoints. + Furthermore we don't expand fixpoints. - Moreover, as mentionned by X. Leroy (bug #2241), - inling a constant from inside an opaque module might + Moreover, as mentioned by X. Leroy (bug #2241), + inlining a constant from inside an opaque module might break types. To avoid that, we require below that both [r] and its body are globally visible. This isn't fully satisfactory, since [r] might not be visible (functor), diff --git a/plugins/extraction/vo.itarget b/plugins/extraction/vo.itarget index f0489048..9c30c5eb 100644 --- a/plugins/extraction/vo.itarget +++ b/plugins/extraction/vo.itarget @@ -1,4 +1,11 @@ ExtrHaskellBasic.vo +ExtrHaskellNatNum.vo +ExtrHaskellNatInt.vo +ExtrHaskellNatInteger.vo +ExtrHaskellZNum.vo +ExtrHaskellZInt.vo +ExtrHaskellZInteger.vo +ExtrHaskellString.vo ExtrOcamlBasic.vo ExtrOcamlIntConv.vo ExtrOcamlBigIntConv.vo @@ -6,4 +13,4 @@ ExtrOcamlNatInt.vo ExtrOcamlNatBigInt.vo ExtrOcamlZInt.vo ExtrOcamlZBigInt.vo -ExtrOcamlString.vo
\ No newline at end of file +ExtrOcamlString.vo diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index 5912f0a0..c80a8081 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -105,7 +105,7 @@ let mk_open_instance id idc gl m t= let evmap=Refiner.project gl in let var_id= if id==dummy_id then dummy_bvid else - let typ=pf_type_of gl idc in + let typ=pf_unsafe_type_of gl idc in (* since we know we will get a product, reduction is not too expensive *) let (nam,_,_)=destProd (whd_betadeltaiota env evmap typ) in @@ -154,7 +154,7 @@ let left_instance_tac (inst,id) continue seq= it_mkLambda_or_LetIn (mkApp(idc,[|ot|])) rc in let evmap, _ = - try Typing.e_type_of (pf_env gl) evmap gt + try Typing.type_of (pf_env gl) evmap gt with e when Errors.noncritical e -> error "Untypable instance, maybe higher-order non-prenex quantification" in tclTHEN (Refiner.tclEVARS evmap) (generalize [gt]) gl) diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index 7d034db5..a77af03d 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -200,7 +200,7 @@ let extend_with_ref_list l seq gl = let l = expand_constructor_hints l in let f gr (seq,gl) = let gl, c = pf_eapply Evd.fresh_global gl gr in - let typ=(pf_type_of gl c) in + let typ=(pf_unsafe_type_of gl c) in (add_formula Hyp gr typ seq gl,gl) in List.fold_right f l (seq,gl) @@ -209,12 +209,13 @@ open Hints let extend_with_auto_hints l seq gl= let seqref=ref seq in let f p_a_t = - match repr_auto_tactic p_a_t.code with + match repr_hint p_a_t.code with Res_pf (c,_) | Give_exact (c,_) | Res_pf_THEN_trivial_fail (c,_) -> + let (c, _, _) = c in (try let gr = global_of_constr c in - let typ=(pf_type_of gl c) in + let typ=(pf_unsafe_type_of gl c) in seqref:=add_formula Hint gr typ !seqref gl with Not_found->()) | _-> () in diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 4a832435..169a7060 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -328,7 +328,7 @@ let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = let all_ids = pf_ids_of_hyps g in let new_ids,_ = list_chop ctxt_size all_ids in let to_refine = applist(witness_fun,List.rev_map mkVar new_ids) in - let evm, _ = pf_apply Typing.e_type_of g to_refine in + let evm, _ = pf_apply Typing.type_of g to_refine in tclTHEN (Refiner.tclEVARS evm) (refine to_refine) g ) in @@ -543,7 +543,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = tclIDTAC in try - scan_type [] (Typing.type_of env sigma (mkVar hyp_id)), [hyp_id] + scan_type [] (Typing.unsafe_type_of env sigma (mkVar hyp_id)), [hyp_id] with TOREMOVE -> thin [hyp_id],[] @@ -593,7 +593,7 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = tclMAP (fun id -> Proofview.V82.of_tactic (introduction ~check:false id)) dyn_infos.rec_hyps; observe_tac "after_introduction" (fun g' -> (* We get infos on the equations introduced*) - let new_term_value_eq = pf_type_of g' (mkVar heq_id) in + let new_term_value_eq = pf_unsafe_type_of g' (mkVar heq_id) in (* compute the new value of the body *) let new_term_value = match kind_of_term new_term_value_eq with @@ -606,7 +606,7 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = in let fun_body = mkLambda(Anonymous, - pf_type_of g' term, + pf_unsafe_type_of g' term, Termops.replace_term term (mkRel 1) dyn_infos.info ) in @@ -638,7 +638,7 @@ let instanciate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id = fun g -> let prov_hid = pf_get_new_id hid g in let c = mkApp(mkVar hid,args) in - let evm, _ = pf_apply Typing.e_type_of g c in + let evm, _ = pf_apply Typing.type_of g c in tclTHENLIST[ Refiner.tclEVARS evm; Proofview.V82.of_tactic (pose_proof (Name prov_hid) c); @@ -699,7 +699,7 @@ let build_proof let dyn_infos = {dyn_info' with info = mkCase(ci,ct,t,cb)} in let g_nb_prod = nb_prod (pf_concl g) in - let type_of_term = pf_type_of g t in + let type_of_term = pf_unsafe_type_of g t in let term_eq = make_refl_eq (Lazy.force refl_equal) type_of_term t in @@ -919,7 +919,7 @@ let generalize_non_dep hyp g = (* observe (str "rec id := " ++ Ppconstr.pr_id hyp); *) let hyps = [hyp] in let env = Global.env () in - let hyp_typ = pf_type_of g (mkVar hyp) in + let hyp_typ = pf_unsafe_type_of g (mkVar hyp) in let to_revert,_ = Environ.fold_named_context_reverse (fun (clear,keep) (hyp,_,_ as decl) -> if Id.List.mem hyp hyps @@ -964,7 +964,7 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num let eq_rhs = nf_betaiotazeta (mkApp(compose_lam params f_body_with_params_and_other_fun,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i)))) in (* observe (str "eq_rhs " ++ pr_lconstr eq_rhs); *) let (type_ctxt,type_of_f),evd = - let evd,t = Typing.e_type_of ~refresh:true (Global.env ()) evd f + let evd,t = Typing.type_of ~refresh:true (Global.env ()) evd f in decompose_prod_n_assum (nb_params + nb_args) t,evd @@ -1034,8 +1034,8 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a (Global.env ()) !evd (Constrintern.locate_reference (qualid_of_ident equation_lemma_id)) in - let evd',_ = Typing.e_type_of ~refresh:true (Global.env ()) evd' res in - evd:=evd'; + evd:=evd'; + let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd res in res in let nb_intro_to_do = nb_prod (pf_concl g) in @@ -1414,7 +1414,7 @@ let backtrack_eqs_until_hrec hrec eqs : tactic = let rewrite = tclFIRST (List.map (fun x -> Proofview.V82.of_tactic (Equality.rewriteRL x)) eqs ) in - let _,hrec_concl = decompose_prod (pf_type_of gls (mkVar hrec)) in + let _,hrec_concl = decompose_prod (pf_unsafe_type_of gls (mkVar hrec)) in let f_app = Array.last (snd (destApp hrec_concl)) in let f = (fst (destApp f_app)) in let rec backtrack : tactic = @@ -1641,7 +1641,7 @@ let prove_principle_for_gen (* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl () ++ *) (* str "fix arg num" ++ int (List.length args_ids + 1) ); tclIDTAC g); *) (* observe_tac "h_fix " *) (fix (Some fix_id) (List.length args_ids + 1)); -(* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl() ++ pr_lconstr_env (pf_env g ) (pf_type_of g (mkVar fix_id) )); tclIDTAC g); *) +(* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl() ++ pr_lconstr_env (pf_env g ) (pf_unsafe_type_of g (mkVar fix_id) )); tclIDTAC g); *) h_intros (List.rev (acc_rec_arg_id::args_ids)); Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_ref)); (* observe_tac "finish" *) (fun gl' -> diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 45e5aaf5..c47602bd 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -274,7 +274,7 @@ let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_prin let new_princ_name = next_ident_away_in_goal (Id.of_string "___________princ_________") [] in - let _ = evd := fst(Typing.e_type_of ~refresh:true (Global.env ()) !evd new_principle_type ) in + let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd new_principle_type in let hook = Lemmas.mk_hook (hook new_principle_type) in begin Lemmas.start_proof @@ -303,7 +303,8 @@ let generate_functional_principle (evd: Evd.evar_map ref) try let f = funs.(i) in - let type_sort = Universes.new_sort_in_family InType in + let env = Global.env () in + let type_sort = Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evd InType in let new_sorts = match sorts with | None -> Array.make (Array.length funs) (type_sort) @@ -317,23 +318,23 @@ let generate_functional_principle (evd: Evd.evar_map ref) id_of_f,Indrec.make_elimination_ident id_of_f (family_of_sort type_sort) in let names = ref [new_princ_name] in - let evd' = !evd in let hook = fun new_principle_type _ _ -> if Option.is_empty sorts then (* let id_of_f = Label.to_id (con_label f) in *) let register_with_sort fam_sort = - let s = Universes.new_sort_in_family fam_sort in + let evd' = Evd.from_env (Global.env ()) in + let evd',s = Evd.fresh_sort_in_family env evd' fam_sort in let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in let evd',value = change_property_sort evd' s new_principle_type new_princ_name in - let evd' = fst (Typing.e_type_of ~refresh:true (Global.env ()) evd' value) in + let evd' = fst (Typing.type_of ~refresh:true (Global.env ()) evd' value) in (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) - let ce = Declare.definition_entry ~poly:(Flags.is_universe_polymorphism ()) ~univs:(Evd.universe_context evd') value in + let ce = Declare.definition_entry ~poly:(Flags.is_universe_polymorphism ()) ~univs:(snd (Evd.universe_context evd')) value in ignore( Declare.declare_constant name - (Entries.DefinitionEntry ce, + (DefinitionEntry ce, Decl_kinds.IsDefinition (Decl_kinds.Scheme)) ); Declare.definition_message name; @@ -394,7 +395,7 @@ let get_funs_constant mp dp = let body = Tacred.cbv_norm_flags (Closure.RedFlags.mkflags [Closure.RedFlags.fZETA]) (Global.env ()) - (Evd.empty) + (Evd.from_env (Global.env ())) body in body @@ -446,7 +447,7 @@ let get_funs_constant mp dp = exception No_graph_found exception Found_type of int -let make_scheme evd (fas : (pconstant*glob_sort) list) : Entries.definition_entry list = +let make_scheme evd (fas : (pconstant*glob_sort) list) : Safe_typing.private_constants definition_entry list = let env = Global.env () in let funs = List.map fst fas in let first_fun = List.hd funs in @@ -478,16 +479,15 @@ let make_scheme evd (fas : (pconstant*glob_sort) list) : Entries.definition_entr in let _ = evd := sigma in let l_schemes = - List.map (Typing.type_of env sigma) schemes + List.map (Typing.unsafe_type_of env sigma) schemes in let i = ref (-1) in let sorts = List.rev_map (fun (_,x) -> - Universes.new_sort_in_family (Pretyping.interp_elimination_sort x) + Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evd (Pretyping.interp_elimination_sort x) ) fas in - evd:=sigma; (* We create the first priciple by tactic *) let first_type,other_princ_types = match l_schemes with @@ -541,7 +541,7 @@ let make_scheme evd (fas : (pconstant*glob_sort) list) : Entries.definition_entr let sorts = Array.of_list sorts in List.map (compute_new_princ_type_from_rel funs sorts) other_princ_types in - let first_princ_body,first_princ_type = const.Entries.const_entry_body, const.Entries.const_entry_type in + let first_princ_body,first_princ_type = const.const_entry_body, const.const_entry_type in let ctxt,fix = decompose_lam_assum (fst(fst(Future.force first_princ_body))) in (* the principle has for forall ...., fix .*) let (idxs,_),(_,ta,_ as decl) = destFix fix in let other_result = @@ -585,30 +585,29 @@ let make_scheme evd (fas : (pconstant*glob_sort) list) : Entries.definition_entr Termops.it_mkLambda_or_LetIn (mkFix((idxs,i),decl)) ctxt in {const with - Entries.const_entry_body = - (Future.from_val (Term_typing.mk_pure_proof princ_body)); - Entries.const_entry_type = Some scheme_type + const_entry_body = + (Future.from_val (Safe_typing.mk_pure_proof princ_body)); + const_entry_type = Some scheme_type } ) other_fun_princ_types in const::other_result - let build_scheme fas = - Dumpglob.pause (); - let evd = (ref Evd.empty) in + let evd = (ref (Evd.from_env (Global.env ()))) in let pconstants = (List.map (fun (_,f,sort) -> let f_as_constant = try Smartlocate.global_with_alias f with Not_found -> - Errors.error ("Cannot find "^ Libnames.string_of_reference f) + errorlabstrm "FunInd.build_scheme" + (str "Cannot find " ++ Libnames.pr_reference f) in let evd',f = Evd.fresh_global (Global.env ()) !evd f_as_constant in - let evd',_ = Typing.e_type_of ~refresh:true (Global.env ()) evd' f in - let _ = evd := evd' in + let _ = evd := evd' in + let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd f in (destConst f,sort) ) fas @@ -621,25 +620,24 @@ let build_scheme fas = ignore (Declare.declare_constant princ_id - (Entries.DefinitionEntry def_entry,Decl_kinds.IsProof Decl_kinds.Theorem)); + (DefinitionEntry def_entry,Decl_kinds.IsProof Decl_kinds.Theorem)); Declare.definition_message princ_id ) fas - bodies_types; - Dumpglob.continue () - - + bodies_types let build_case_scheme fa = let env = Global.env () - and sigma = Evd.empty in + and sigma = (Evd.from_env (Global.env ())) in (* let id_to_constr id = *) (* Constrintern.global_reference id *) (* in *) - let funs = (fun (_,f,_) -> - try fst (Universes.unsafe_constr_of_global (Smartlocate.global_with_alias f)) - with Not_found -> - Errors.error ("Cannot find "^ Libnames.string_of_reference f)) fa in + let funs = + let (_,f,_) = fa in + try fst (Universes.unsafe_constr_of_global (Smartlocate.global_with_alias f)) + with Not_found -> + errorlabstrm "FunInd.build_case_scheme" + (str "Cannot find " ++ Libnames.pr_reference f) in let first_fun,u = destConst funs in let funs_mp,funs_dp,_ = Names.repr_con first_fun in let first_fun_kn = try fst (find_Function_infos first_fun).graph_ind with Not_found -> raise No_graph_found in @@ -656,7 +654,7 @@ let build_case_scheme fa = in let sigma, scheme = (fun (ind,sf) -> Indrec.build_case_analysis_scheme_default env sigma ind sf) ind_fun in - let scheme_type = (Typing.type_of env sigma ) scheme in + let scheme_type = (Typing.unsafe_type_of env sigma ) scheme in let sorts = (fun (_,_,x) -> Universes.new_sort_in_family (Pretyping.interp_elimination_sort x) @@ -670,14 +668,14 @@ let build_case_scheme fa = ); *) generate_functional_principle - (ref Evd.empty) + (ref (Evd.from_env (Global.env ()))) false scheme_type (Some ([|sorts|])) (Some princ_name) this_block_funs 0 - (prove_princ_for_struct (ref Evd.empty) false 0 [|fst (destConst funs)|]) + (prove_princ_for_struct (ref (Evd.from_env (Global.env ()))) false 0 [|fst (destConst funs)|]) in () diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli index f6e5578d..bc082f07 100644 --- a/plugins/funind/functional_principles_types.mli +++ b/plugins/funind/functional_principles_types.mli @@ -1,3 +1,11 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + open Names open Term open Misctypes @@ -29,7 +37,7 @@ val compute_new_princ_type_from_rel : constr array -> sorts array -> exception No_graph_found val make_scheme : Evd.evar_map ref -> - (pconstant*glob_sort) list -> Entries.definition_entry list + (pconstant*glob_sort) list -> Safe_typing.private_constants Entries.definition_entry list val build_scheme : (Id.t*Libnames.reference*glob_sort) list -> unit val build_case_scheme : (Id.t*Libnames.reference*glob_sort) -> unit diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 043d4328..045beb37 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -247,247 +247,3 @@ END VERNAC COMMAND EXTEND GenerateGraph CLASSIFIED AS QUERY ["Generate" "graph" "for" reference(c)] -> [ make_graph (Smartlocate.global_with_alias c) ] END - - - - - -(* FINDUCTION *) - -(* comment this line to see debug msgs *) -let msg x = () ;; let pr_lconstr c = str "" - (* uncomment this to see debugging *) -let prconstr c = msg (str" " ++ Printer.pr_lconstr c ++ str"\n") -let prlistconstr lc = List.iter prconstr lc -let prstr s = msg(str s) -let prNamedConstr s c = - begin - msg(str ""); - msg(str(s^"==>\n ") ++ Printer.pr_lconstr c ++ str "\n<==\n"); - msg(str ""); - end - - - -(** Information about an occurrence of a function call (application) - inside a term. *) -type fapp_info = { - fname: constr; (** The function applied *) - largs: constr list; (** List of arguments *) - free: bool; (** [true] if all arguments are debruijn free *) - max_rel: int; (** max debruijn index in the funcall *) - onlyvars: bool (** [true] if all arguments are variables (and not debruijn) *) -} - - -(** [constr_head_match(a b c) a] returns true, false otherwise. *) -let constr_head_match u t= - if isApp u - then - let uhd,args= destApp u in - Constr.equal uhd t - else false - -(** [hdMatchSub inu t] returns the list of occurrences of [t] in - [inu]. DeBruijn are not pushed, so some of them may be unbound in - the result. *) -let rec hdMatchSub inu (test: constr -> bool) : fapp_info list = - let subres = - match kind_of_term inu with - | Lambda (nm,tp,cstr) | Prod (nm,tp,cstr) -> - hdMatchSub tp test @ hdMatchSub (lift 1 cstr) test - | Fix (_,(lna,tl,bl)) -> (* not sure Fix is correct *) - Array.fold_left - (fun acc cstr -> acc @ hdMatchSub (lift (Array.length tl) cstr) test) - [] bl - | _ -> (* Cofix will be wrong *) - fold_constr - (fun l cstr -> - l @ hdMatchSub cstr test) [] inu in - if not (test inu) then subres - else - let f,args = decompose_app inu in - let freeset = Termops.free_rels inu in - let max_rel = try Int.Set.max_elt freeset with Not_found -> -1 in - {fname = f; largs = args; free = Int.Set.is_empty freeset; - max_rel = max_rel; onlyvars = List.for_all isVar args } - ::subres - -let make_eq () = -(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ()) - -let mkEq typ c1 c2 = - mkApp (make_eq(),[| typ; c1; c2|]) - - -let poseq_unsafe idunsafe cstr gl = - let typ = Tacmach.pf_type_of gl cstr in - tclTHEN - (Proofview.V82.of_tactic (Tactics.letin_tac None (Name idunsafe) cstr None Locusops.allHypsAndConcl)) - (tclTHENFIRST - (Proofview.V82.of_tactic (Tactics.assert_before Anonymous (mkEq typ (mkVar idunsafe) cstr))) - (Proofview.V82.of_tactic Tactics.reflexivity)) - gl - - -let poseq id cstr gl = - let x = Tactics.fresh_id [] id gl in - poseq_unsafe x cstr gl - -(* dirty? *) - -let list_constr_largs = ref [] - -let rec poseq_list_ids_rec lcstr gl = - match lcstr with - | [] -> tclIDTAC gl - | c::lcstr' -> - match kind_of_term c with - | Var _ -> - (list_constr_largs:=c::!list_constr_largs ; poseq_list_ids_rec lcstr' gl) - | _ -> - let _ = prstr "c = " in - let _ = prconstr c in - let _ = prstr "\n" in - let typ = Tacmach.pf_type_of gl c in - let cname = Namegen.id_of_name_using_hdchar (Global.env()) typ Anonymous in - let x = Tactics.fresh_id [] cname gl in - let _ = list_constr_largs:=mkVar x :: !list_constr_largs in - let _ = prstr " list_constr_largs = " in - let _ = prlistconstr !list_constr_largs in - let _ = prstr "\n" in - - tclTHEN - (poseq_unsafe x c) - (poseq_list_ids_rec lcstr') - gl - -let poseq_list_ids lcstr gl = - let _ = list_constr_largs := [] in - poseq_list_ids_rec lcstr gl - -(** [find_fapp test g] returns the list of [app_info] of all calls to - functions that satisfy [test] in the conclusion of goal g. Trivial - repetition (not modulo conversion) are deleted. *) -let find_fapp (test:constr -> bool) g : fapp_info list = - let pre_res = hdMatchSub (Tacmach.pf_concl g) test in - let res = - List.fold_right (List.add_set Pervasives.(=)) pre_res [] in - (prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) res); - res) - - - -(** [finduction id filter g] tries to apply functional induction on - an occurence of function [id] in the conclusion of goal [g]. If - [id]=[None] then calls to any function are selected. In any case - [heuristic] is used to select the most pertinent occurrence. *) -let finduction (oid:Id.t option) (heuristic: fapp_info list -> fapp_info list) - (nexttac:Proof_type.tactic) g = - let test = match oid with - | Some id -> - let idref = const_of_id id in - (* JF : FIXME : we probably need to keep trace of evd in presence of universe polymorphism *) - let idconstr = snd (Evd.fresh_global (Global.env ()) Evd.empty idref) in - (fun u -> constr_head_match u idconstr) (* select only id *) - | None -> (fun u -> isApp u) in (* select calls to any function *) - let info_list = find_fapp test g in - let ordered_info_list = heuristic info_list in - prlistconstr (List.map (fun x -> applist (x.fname,x.largs)) ordered_info_list); - if List.is_empty ordered_info_list then Errors.error "function not found in goal\n"; - let taclist: Proof_type.tactic list = - List.map - (fun info -> - (tclTHEN - (tclTHEN (poseq_list_ids info.largs) - ( - fun gl -> - (functional_induction - true (applist (info.fname, List.rev !list_constr_largs)) - None None) gl)) - nexttac)) ordered_info_list in - (* we try each (f t u v) until one does not fail *) - (* TODO: try also to mix functional schemes *) - tclFIRST taclist g - - - - -(** [chose_heuristic oi x] returns the heuristic for reordering - (and/or forgetting some elts of) a list of occurrences of - function calls infos to chose first with functional induction. *) -let chose_heuristic (oi:int option) : fapp_info list -> fapp_info list = - match oi with - | Some i -> (fun l -> [ List.nth l (i-1) ]) (* occurrence was given by the user *) - | None -> - (* Default heuristic: put first occurrences where all arguments - are *bound* (meaning already introduced) variables *) - let ordering x y = - if x.free && x.onlyvars && y.free && y.onlyvars then 0 (* both pertinent *) - else if x.free && x.onlyvars then -1 - else if y.free && y.onlyvars then 1 - else 0 (* both not pertinent *) - in - List.sort ordering - - - -TACTIC EXTEND finduction - ["finduction" ident(id) natural_opt(oi)] -> - [ - match oi with - | Some(n) when n<=0 -> Errors.error "numerical argument must be > 0" - | _ -> - let heuristic = chose_heuristic oi in - Proofview.V82.tactic (finduction (Some id) heuristic tclIDTAC) - ] -END - - - -TACTIC EXTEND fauto - [ "fauto" tactic(tac)] -> - [ - let heuristic = chose_heuristic None in - Proofview.V82.tactic (finduction None heuristic (Proofview.V82.of_tactic (Tacinterp.eval_tactic tac))) - ] - | - [ "fauto" ] -> - [ - let heuristic = chose_heuristic None in - Proofview.V82.tactic (finduction None heuristic tclIDTAC) - ] - -END - - -TACTIC EXTEND poseq - [ "poseq" ident(x) constr(c) ] -> - [ Proofview.V82.tactic (poseq x c) ] -END - -VERNAC COMMAND EXTEND Showindinfo CLASSIFIED AS QUERY - [ "showindinfo" ident(x) ] -> [ Merge.showind x ] -END - -VERNAC COMMAND EXTEND MergeFunind CLASSIFIED AS SIDEFF - [ "Mergeschemes" "(" ident(id1) ne_ident_list(cl1) ")" - "with" "(" ident(id2) ne_ident_list(cl2) ")" "using" ident(id) ] -> - [ - let f1,ctx = Constrintern.interp_constr (Global.env()) Evd.empty - (CRef (Libnames.Ident (Loc.ghost,id1),None)) in - let f2,ctx' = Constrintern.interp_constr (Global.env()) Evd.empty - (CRef (Libnames.Ident (Loc.ghost,id2),None)) in - let f1type = Typing.type_of (Global.env()) Evd.empty f1 in - let f2type = Typing.type_of (Global.env()) Evd.empty f2 in - let ar1 = List.length (fst (decompose_prod f1type)) in - let ar2 = List.length (fst (decompose_prod f2type)) in - let _ = - if not (Int.equal ar1 (List.length cl1)) then - Errors.error ("not the right number of arguments for " ^ Id.to_string id1) in - let _ = - if not (Int.equal ar2 (List.length cl2)) then - Errors.error ("not the right number of arguments for " ^ Id.to_string id2) in - Merge.merge id1 id2 (Array.of_list cl1) (Array.of_list cl2) id - ] -END diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 9e3f3986..1b12cd42 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -333,20 +333,20 @@ let raw_push_named (na,raw_value,raw_typ) env = match na with | Anonymous -> env | Name id -> - let value = Option.map (fun x-> fst (Pretyping.understand env Evd.empty x)) raw_value in - let typ,ctx = Pretyping.understand env Evd.empty ~expected_type:Pretyping.IsType raw_typ in + let value = Option.map (fun x-> fst (Pretyping.understand env (Evd.from_env env) x)) raw_value in + let typ,ctx = Pretyping.understand env (Evd.from_env env) ~expected_type:Pretyping.IsType raw_typ in Environ.push_named (id,value,typ) env let add_pat_variables pat typ env : Environ.env = let rec add_pat_variables env pat typ : Environ.env = - observe (str "new rel env := " ++ Printer.pr_rel_context_of env Evd.empty); + observe (str "new rel env := " ++ Printer.pr_rel_context_of env (Evd.from_env env)); match pat with | PatVar(_,na) -> Environ.push_rel (na,None,typ) env | PatCstr(_,c,patl,na) -> let Inductiveops.IndType(indf,indargs) = - try Inductiveops.find_rectype env Evd.empty typ + try Inductiveops.find_rectype env (Evd.from_env env) typ with Not_found -> assert false in let constructors = Inductiveops.get_constructors env indf in @@ -376,7 +376,7 @@ let add_pat_variables pat typ env : Environ.env = ~init:(env,[]) ) in - observe (str "new var env := " ++ Printer.pr_named_context_of res Evd.empty); + observe (str "new var env := " ++ Printer.pr_named_context_of res (Evd.from_env env)); res @@ -393,7 +393,7 @@ let rec pattern_to_term_and_type env typ = function constr in let Inductiveops.IndType(indf,indargs) = - try Inductiveops.find_rectype env Evd.empty typ + try Inductiveops.find_rectype env (Evd.from_env env) typ with Not_found -> assert false in let constructors = Inductiveops.get_constructors env indf in @@ -405,7 +405,7 @@ let rec pattern_to_term_and_type env typ = function Array.to_list (Array.init (cst_narg - List.length patternl) - (fun i -> Detyping.detype false [] env Evd.empty csta.(i)) + (fun i -> Detyping.detype false [] env (Evd.from_env env) csta.(i)) ) in let patl_as_term = @@ -486,9 +486,9 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = a pseudo value "v1 ... vn". The "value" of this branch is then simply [res] *) - let rt_as_constr,ctx = Pretyping.understand env Evd.empty rt in - let rt_typ = Typing.type_of env Evd.empty rt_as_constr in - let res_raw_type = Detyping.detype false [] env Evd.empty rt_typ in + let rt_as_constr,ctx = Pretyping.understand env (Evd.from_env env) rt in + let rt_typ = Typing.unsafe_type_of env (Evd.from_env env) rt_as_constr in + let res_raw_type = Detyping.detype false [] env (Evd.from_env env) rt_typ in let res = fresh_id args_res.to_avoid "_res" in let new_avoid = res::args_res.to_avoid in let res_rt = mkGVar res in @@ -594,8 +594,8 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = and combine the two result *) let v_res = build_entry_lc env funnames avoid v in - let v_as_constr,ctx = Pretyping.understand env Evd.empty v in - let v_type = Typing.type_of env Evd.empty v_as_constr in + let v_as_constr,ctx = Pretyping.understand env (Evd.from_env env) v in + let v_type = Typing.unsafe_type_of env (Evd.from_env env) v_as_constr in let new_env = match n with Anonymous -> env @@ -610,10 +610,10 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let make_discr = make_discr_match brl in build_entry_lc_from_case env funnames make_discr el brl avoid | GIf(_,b,(na,e_option),lhs,rhs) -> - let b_as_constr,ctx = Pretyping.understand env Evd.empty b in - let b_typ = Typing.type_of env Evd.empty b_as_constr in + let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in + let b_typ = Typing.unsafe_type_of env (Evd.from_env env) b_as_constr in let (ind,_) = - try Inductiveops.find_inductive env Evd.empty b_typ + try Inductiveops.find_inductive env (Evd.from_env env) b_typ with Not_found -> errorlabstrm "" (str "Cannot find the inductive associated to " ++ Printer.pr_glob_constr b ++ str " in " ++ @@ -642,10 +642,10 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = ) nal in - let b_as_constr,ctx = Pretyping.understand env Evd.empty b in - let b_typ = Typing.type_of env Evd.empty b_as_constr in + let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in + let b_typ = Typing.unsafe_type_of env (Evd.from_env env) b_as_constr in let (ind,_) = - try Inductiveops.find_inductive env Evd.empty b_typ + try Inductiveops.find_inductive env (Evd.from_env env) b_typ with Not_found -> errorlabstrm "" (str "Cannot find the inductive associated to " ++ Printer.pr_glob_constr b ++ str " in " ++ @@ -689,8 +689,8 @@ and build_entry_lc_from_case env funname make_discr in let types = List.map (fun (case_arg,_) -> - let case_arg_as_constr,ctx = Pretyping.understand env Evd.empty case_arg in - Typing.type_of env Evd.empty case_arg_as_constr + let case_arg_as_constr,ctx = Pretyping.understand env (Evd.from_env env) case_arg in + Typing.unsafe_type_of env (Evd.from_env env) case_arg_as_constr ) el in (****** The next works only if the match is not dependent ****) @@ -737,11 +737,11 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve List.fold_right (fun id acc -> let typ_of_id = - Typing.type_of env_with_pat_ids Evd.empty (mkVar id) + Typing.unsafe_type_of env_with_pat_ids (Evd.from_env env) (mkVar id) in let raw_typ_of_id = Detyping.detype false [] - env_with_pat_ids Evd.empty typ_of_id + env_with_pat_ids (Evd.from_env env) typ_of_id in mkGProd (Name id,raw_typ_of_id,acc)) pat_ids @@ -785,15 +785,15 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve List.map3 (fun pat e typ_as_constr -> let this_pat_ids = ids_of_pat pat in - let typ = Detyping.detype false [] new_env Evd.empty typ_as_constr in + let typ = Detyping.detype false [] new_env (Evd.from_env env) typ_as_constr in let pat_as_term = pattern_to_term pat in List.fold_right (fun id acc -> if Id.Set.mem id this_pat_ids then (Prod (Name id), - let typ_of_id = Typing.type_of new_env Evd.empty (mkVar id) in + let typ_of_id = Typing.unsafe_type_of new_env (Evd.from_env env) (mkVar id) in let raw_typ_of_id = - Detyping.detype false [] new_env Evd.empty typ_of_id + Detyping.detype false [] new_env (Evd.from_env env) typ_of_id in raw_typ_of_id )::acc @@ -894,7 +894,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let new_t = mkGApp(mkGVar(mk_rel_id this_relname),args'@[res_rt]) in - let t',ctx = Pretyping.understand env Evd.empty new_t in + let t',ctx = Pretyping.understand env (Evd.from_env env) new_t in let new_env = Environ.push_rel (n,None,t') env in let new_b,id_to_exclude = rebuild_cons new_env @@ -914,7 +914,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = try observe (str "computing new type for eq : " ++ pr_glob_constr rt); let t' = - try fst (Pretyping.understand env Evd.empty t)(*FIXME*) + try fst (Pretyping.understand env (Evd.from_env env) t)(*FIXME*) with e when Errors.noncritical e -> raise Continue in let is_in_b = is_free_in id b in @@ -937,7 +937,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = mkGProd(n,t,new_b),id_to_exclude with Continue -> let jmeq = Globnames.IndRef (fst (destInd (jmeq ()))) in - let ty',ctx = Pretyping.understand env Evd.empty ty in + let ty',ctx = Pretyping.understand env (Evd.from_env env) ty in let ind,args' = Inductive.find_inductive env ty' in let mib,_ = Global.lookup_inductive (fst ind) in let nparam = mib.Declarations.mind_nparams in @@ -949,7 +949,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = GRef (Loc.ghost,Globnames.IndRef (fst ind),None), (List.map (fun p -> Detyping.detype false [] - env Evd.empty + env (Evd.from_env env) p) params)@(Array.to_list (Array.make (List.length args' - nparam) @@ -959,7 +959,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = GApp(loc1,GRef(loc2,jmeq,None),[ty;GVar(loc3,id);rt_typ;rt]) in observe (str "computing new type for jmeq : " ++ pr_glob_constr eq'); - let eq'_as_constr,ctx = Pretyping.understand env Evd.empty eq' in + let eq'_as_constr,ctx = Pretyping.understand env (Evd.from_env env) eq' in observe (str " computing new type for jmeq : done") ; let new_args = match kind_of_term eq'_as_constr with @@ -978,12 +978,12 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = | Name id' -> (id',Detyping.detype false [] env - Evd.empty + (Evd.from_env env) arg)::acc else if isVar var_as_constr then (destVar var_as_constr,Detyping.detype false [] env - Evd.empty + (Evd.from_env env) arg)::acc else acc ) @@ -1009,7 +1009,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = if is_in_b then b else replace_var_by_term id rt b in let new_env = - let t',ctx = Pretyping.understand env Evd.empty eq' in + let t',ctx = Pretyping.understand env (Evd.from_env env) eq' in Environ.push_rel (n,None,t') env in let new_b,id_to_exclude = @@ -1047,7 +1047,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = else raise Continue with Continue -> observe (str "computing new type for prod : " ++ pr_glob_constr rt); - let t',ctx = Pretyping.understand env Evd.empty t in + let t',ctx = Pretyping.understand env (Evd.from_env env) t in let new_env = Environ.push_rel (n,None,t') env in let new_b,id_to_exclude = rebuild_cons new_env @@ -1063,7 +1063,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = end | _ -> observe (str "computing new type for prod : " ++ pr_glob_constr rt); - let t',ctx = Pretyping.understand env Evd.empty t in + let t',ctx = Pretyping.understand env (Evd.from_env env) t in let new_env = Environ.push_rel (n,None,t') env in let new_b,id_to_exclude = rebuild_cons new_env @@ -1082,7 +1082,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let not_free_in_t id = not (is_free_in id t) in let new_crossed_types = t :: crossed_types in observe (str "computing new type for lambda : " ++ pr_glob_constr rt); - let t',ctx = Pretyping.understand env Evd.empty t in + let t',ctx = Pretyping.understand env (Evd.from_env env) t in match n with | Name id -> let new_env = Environ.push_rel (n,None,t') env in @@ -1104,8 +1104,10 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = | GLetIn(_,n,t,b) -> begin let not_free_in_t id = not (is_free_in id t) in - let t',ctx = Pretyping.understand env Evd.empty t in - let type_t' = Typing.type_of env Evd.empty t' in + let evd = (Evd.from_env env) in + let t',ctx = Pretyping.understand env evd t in + let evd = Evd.from_ctx ctx in + let type_t' = Typing.unsafe_type_of env evd t' in let new_env = Environ.push_rel (n,Some t',type_t') env in let new_b,id_to_exclude = rebuild_cons new_env @@ -1129,7 +1131,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = args (crossed_types) depth t in - let t',ctx = Pretyping.understand env Evd.empty new_t in + let t',ctx = Pretyping.understand env (Evd.from_env env) new_t in let new_env = Environ.push_rel (na,None,t') env in let new_b,id_to_exclude = rebuild_cons new_env @@ -1255,7 +1257,7 @@ let do_build_inductive let evd,env = Array.fold_right2 (fun id c (evd,env) -> - let evd,t = Typing.e_type_of env evd (mkConstU c) in + let evd,t = Typing.type_of env evd (mkConstU c) in evd, Environ.push_named (id,None,t) (* try *) @@ -1297,7 +1299,7 @@ let do_build_inductive let rel_arities = Array.mapi rel_arity funsargs in Util.Array.fold_left2 (fun env rel_name rel_ar -> Environ.push_named (rel_name,None, - fst (with_full_print (Constrintern.interp_constr env Evd.empty) rel_ar)) env) env relnames rel_arities + fst (with_full_print (Constrintern.interp_constr env evd) rel_ar)) env) env relnames rel_arities in (* and of the real constructors*) let constr i res = @@ -1395,7 +1397,7 @@ let do_build_inductive (rel_constructors) in let rel_ind i ext_rel_constructors = - ((Loc.ghost,relnames.(i)), + (((Loc.ghost,relnames.(i)), None), rel_params, Some rel_arities.(i), ext_rel_constructors),[] @@ -1460,8 +1462,17 @@ let do_build_inductive let build_inductive evd funconstants funsargs returned_types rtl = + let pu = !Detyping.print_universes in + let cu = !Constrextern.print_universes in try - do_build_inductive evd funconstants funsargs returned_types rtl - with e when Errors.noncritical e -> raise (Building_graph e) + Detyping.print_universes := true; + Constrextern.print_universes := true; + do_build_inductive evd funconstants funsargs returned_types rtl; + Detyping.print_universes := pu; + Constrextern.print_universes := cu + with e when Errors.noncritical e -> + Detyping.print_universes := pu; + Constrextern.print_universes := cu; + raise (Building_graph e) diff --git a/plugins/funind/glob_termops.mli b/plugins/funind/glob_termops.mli index 0f10636f..179e8fe8 100644 --- a/plugins/funind/glob_termops.mli +++ b/plugins/funind/glob_termops.mli @@ -6,7 +6,7 @@ open Misctypes val get_pattern_id : cases_pattern -> Id.t list (* [pattern_to_term pat] returns a glob_constr corresponding to [pat]. - [pat] must not contain occurences of anonymous pattern + [pat] must not contain occurrences of anonymous pattern *) val pattern_to_term : cases_pattern -> glob_constr @@ -64,7 +64,7 @@ val change_vars : Id.t Id.Map.t -> glob_constr -> glob_constr (* [alpha_pat avoid pat] rename all the variables present in [pat] s.t. the result does not share variables with [avoid]. This function create - a fresh variable for each occurence of the anonymous pattern. + a fresh variable for each occurrence of the anonymous pattern. Also returns a mapping from old variables to new ones and the concatenation of [avoid] with the variables appearing in the result. diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index e211b688..3dbd4380 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -27,7 +27,6 @@ let choose_dest_or_ind scheme_info = Tactics.induction_destruct (is_rec_info scheme_info) false let functional_induction with_clean c princl pat = - Dumpglob.pause (); let res = let f,args = decompose_app c in fun g -> @@ -72,11 +71,11 @@ let functional_induction with_clean c princl pat = errorlabstrm "" (str "Cannot find induction principle for " ++Printer.pr_lconstr (mkConst c') ) in - (princ,NoBindings, Tacmach.pf_type_of g' princ,g') + (princ,NoBindings, Tacmach.pf_unsafe_type_of g' princ,g') | _ -> raise (UserError("",str "functional induction must be used with a function" )) end | Some ((princ,binding)) -> - princ,binding,Tacmach.pf_type_of g princ,g + princ,binding,Tacmach.pf_unsafe_type_of g princ,g in let princ_infos = Tactics.compute_elim_sig princ_type in let args_as_induction_constr = @@ -123,9 +122,7 @@ let functional_induction with_clean c princl pat = (args_as_induction_constr,princ'))) subst_and_reduce g' - in - Dumpglob.continue (); - res + in res let rec abstract_glob_constr c = function | [] -> c @@ -145,15 +142,14 @@ let interp_casted_constr_with_implicits env sigma impls c = let build_newrecursive lnameargsardef = - let env0 = Global.env() - and sigma = Evd.empty - in + let env0 = Global.env() in + let sigma = Evd.from_env env0 in let (rec_sign,rec_impls) = List.fold_left - (fun (env,impls) ((_,recname),bl,arityc,_) -> + (fun (env,impls) (((_,recname),_),bl,arityc,_) -> let arityc = Constrexpr_ops.prod_constr_expr arityc bl in let arity,ctx = Constrintern.interp_type env0 sigma arityc in - let evdref = ref (Evd.from_env env0) in + let evdref = ref (Evd.from_env env0) in let _, (_, impls') = Constrintern.interp_context_evars env evdref bl in let impl = Constrintern.compute_internalization_data env0 Constrintern.Recursive arity impls' in (Environ.push_named (recname,None,arity) env, Id.Map.add recname impl impls)) @@ -228,7 +224,7 @@ let process_vernac_interp_error e = let derive_inversion fix_names = try - let evd' = Evd.empty in + let evd' = Evd.from_env (Global.env ()) in (* we first transform the fix_names identifier into their corresponding constant *) let evd',fix_names_as_constant = List.fold_right @@ -323,7 +319,7 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error is_general do_built (fix_rec_l:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) recdefs interactive_proof (continue_proof : int -> Names.constant array -> Term.constr array -> int -> Tacmach.tactic) : unit = - let names = List.map (function ((_, name),_,_,_,_),_ -> name) fix_rec_l in + let names = List.map (function (((_, name),_),_,_,_,_),_ -> name) fix_rec_l in let fun_bodies = List.map2 prepare_body fix_rec_l recdefs in let funs_args = List.map fst fun_bodies in let funs_types = List.map (function ((_,_,_,types,_),_) -> types) fix_rec_l in @@ -343,7 +339,7 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error locate_ind f_R_mut) in - let fname_kn ((fname,_,_,_,_),_) = + let fname_kn (((fname,_),_,_,_,_),_) = let f_ref = Ident fname in locate_with_msg (pr_reference f_ref++str ": Not an inductive type!") @@ -355,9 +351,11 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error List.map_i (fun i x -> let princ = Indrec.lookup_eliminator (ind_kn,i) (InProp) in - let evd',uprinc = Evd.fresh_global (Global.env ()) !evd princ in - let evd',princ_type = Typing.e_type_of ~refresh:true (Global.env ()) evd' uprinc in - let _ = evd := evd' in + let env = Global.env () in + let evd = ref (Evd.from_env env) in + let evd',uprinc = Evd.fresh_global env !evd princ in + let _ = evd := evd' in + let princ_type = Typing.e_type_of ~refresh:true env evd uprinc in Functional_principles_types.generate_functional_principle evd interactive_proof @@ -380,21 +378,21 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = match fixpoint_exprl with - | [((_,fname),_,bl,ret_type,body),_] when not is_rec -> + | [(((_,fname),pl),_,bl,ret_type,body),_] when not is_rec -> let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in Command.do_definition fname - (Decl_kinds.Global,(Flags.is_universe_polymorphism ()),Decl_kinds.Definition) + (Decl_kinds.Global,(Flags.is_universe_polymorphism ()),Decl_kinds.Definition) pl bl None body (Some ret_type) (Lemmas.mk_hook (fun _ _ -> ())); let evd,rev_pconstants = List.fold_left - (fun (evd,l) (((_,fname),_,_,_,_),_) -> + (fun (evd,l) ((((_,fname),_),_,_,_,_),_) -> let evd,c = Evd.fresh_global (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname)) in evd,((destConst c)::l) ) - (Evd.empty,[]) + (Evd.from_env (Global.env ()),[]) fixpoint_exprl in evd,List.rev rev_pconstants @@ -402,13 +400,13 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp Command.do_fixpoint Global (Flags.is_universe_polymorphism ()) fixpoint_exprl; let evd,rev_pconstants = List.fold_left - (fun (evd,l) (((_,fname),_,_,_,_),_) -> + (fun (evd,l) ((((_,fname),_),_,_,_,_),_) -> let evd,c = Evd.fresh_global (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname)) in evd,((destConst c)::l) ) - (Evd.empty,[]) + (Evd.from_env (Global.env ()),[]) fixpoint_exprl in evd,List.rev rev_pconstants @@ -594,9 +592,9 @@ let rebuild_bl (aux,assoc) bl typ = rebuild_bl (aux,assoc) bl typ let recompute_binder_list (fixpoint_exprl : (Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) = let fixl,ntns = Command.extract_fixpoint_components false fixpoint_exprl in - let ((_,_,typel),_,_) = Command.interp_fixpoint fixl ntns in + let ((_,_,typel),_,ctx,_) = Command.interp_fixpoint fixl ntns in let constr_expr_typel = - with_full_print (List.map (Constrextern.extern_constr false (Global.env ()) Evd.empty)) typel in + with_full_print (List.map (Constrextern.extern_constr false (Global.env ()) (Evd.from_ctx ctx))) typel in let fixpoint_exprl_with_new_bl = List.map2 (fun ((lna,(rec_arg_opt,rec_order),bl,ret_typ,opt_body),notation_list) fix_typ -> @@ -614,7 +612,7 @@ let do_generate_principle pconstants on_error register_built interactive_proof let _is_struct = match fixpoint_exprl with | [((_,(wf_x,Constrexpr.CWfRec wf_rel),_,_,_),_) as fixpoint_expr] -> - let ((((_,name),_,args,types,body)),_) as fixpoint_expr = + let (((((_,name),pl),_,args,types,body)),_) as fixpoint_expr = match recompute_binder_list [fixpoint_expr] with | [e] -> e | _ -> assert false @@ -625,7 +623,7 @@ let do_generate_principle pconstants on_error register_built interactive_proof let using_lemmas = [] in let pre_hook pconstants = generate_principle - (ref (Evd.empty)) + (ref (Evd.from_env (Global.env ()))) pconstants on_error true @@ -638,7 +636,7 @@ let do_generate_principle pconstants on_error register_built interactive_proof then register_wf name rec_impls wf_rel (map_option snd wf_x) using_lemmas args types body pre_hook; false |[((_,(wf_x,Constrexpr.CMeasureRec(wf_mes,wf_rel_opt)),_,_,_),_) as fixpoint_expr] -> - let ((((_,name),_,args,types,body)),_) as fixpoint_expr = + let (((((_,name),_),_,args,types,body)),_) as fixpoint_expr = match recompute_binder_list [fixpoint_expr] with | [e] -> e | _ -> assert false @@ -649,7 +647,7 @@ let do_generate_principle pconstants on_error register_built interactive_proof let body = match body with | Some body -> body | None -> user_err_loc (Loc.ghost,"Function",str "Body of Function must be given") in let pre_hook pconstants = generate_principle - (ref Evd.empty) + (ref (Evd.from_env (Global.env ()))) pconstants on_error true @@ -672,7 +670,7 @@ let do_generate_principle pconstants on_error register_built interactive_proof fixpoint_exprl; let fixpoint_exprl = recompute_binder_list fixpoint_exprl in let fix_names = - List.map (function (((_,name),_,_,_,_),_) -> name) fixpoint_exprl + List.map (function ((((_,name),_),_,_,_,_),_) -> name) fixpoint_exprl in (* ok all the expressions are structural *) let recdefs,rec_impls = build_newrecursive fixpoint_exprl in @@ -680,7 +678,7 @@ let do_generate_principle pconstants on_error register_built interactive_proof let evd,pconstants = if register_built then register_struct is_rec fixpoint_exprl - else (Evd.empty,pconstants) + else (Evd.from_env (Global.env ()),pconstants) in let evd = ref evd in generate_principle @@ -830,15 +828,15 @@ let make_graph (f_ref:global_reference) = end | _ -> raise (UserError ("", str "Not a function reference") ) in - Dumpglob.pause (); (match Global.body_of_constant_body c_body with | None -> error "Cannot build a graph over an axiom !" | Some body -> let env = Global.env () in + let sigma = Evd.from_env env in let extern_body,extern_type = with_full_print (fun () -> - (Constrextern.extern_constr false env Evd.empty body, - Constrextern.extern_type false env Evd.empty + (Constrextern.extern_constr false env sigma body, + Constrextern.extern_type false env sigma ((*FIXME*) Typeops.type_of_constant_type env c_body.const_type) ) ) @@ -867,22 +865,21 @@ let make_graph (f_ref:global_reference) = ) in let b' = add_args (snd id) new_args b in - (((id, ( Some (Loc.ghost,rec_id),CStructRec),nal_tas@bl,t,Some b'),[]):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) + ((((id,None), ( Some (Loc.ghost,rec_id),CStructRec),nal_tas@bl,t,Some b'),[]):(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list)) ) fixexprl in l | _ -> let id = Label.to_id (con_label c) in - [((Loc.ghost,id),(None,Constrexpr.CStructRec),nal_tas,t,Some b),[]] + [(((Loc.ghost,id),None),(None,Constrexpr.CStructRec),nal_tas,t,Some b),[]] in let mp,dp,_ = repr_con c in do_generate_principle [c,Univ.Instance.empty] error_error false false expr_list; (* We register the infos *) List.iter - (fun (((_,id),_,_,_,_),_) -> add_Function false (make_con mp dp (Label.of_id id))) - expr_list); - Dumpglob.continue () + (fun ((((_,id),_),_,_,_,_),_) -> add_Function false (make_con mp dp (Label.of_id id))) + expr_list) let do_generate_principle = do_generate_principle [] warning_error true diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 738ade8c..aa47e261 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -109,7 +109,9 @@ let const_of_id id = qualid_of_reference (Libnames.Ident (Loc.ghost,id)) in try Constrintern.locate_reference princ_ref - with Not_found -> Errors.error ("cannot find "^ Id.to_string id) + with Not_found -> + Errors.errorlabstrm "IndFun.const_of_id" + (str "cannot find " ++ Nameops.pr_id id) let def_of_const t = match (Term.kind_of_term t) with @@ -147,7 +149,7 @@ let get_locality = function | Global -> false let save with_clean id const (locality,_,kind) hook = - let fix_exn = Future.fix_exn_of const.Entries.const_entry_body in + let fix_exn = Future.fix_exn_of const.const_entry_body in let l,r = match locality with | Discharge when Lib.sections_are_opened () -> let k = Kindops.logical_kind_of_goal_kind kind in @@ -178,9 +180,10 @@ let get_proof_clean do_reduce = let with_full_print f a = let old_implicit_args = Impargs.is_implicit_args () and old_strict_implicit_args = Impargs.is_strict_implicit_args () - and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () - in + and old_contextual_implicit_args = Impargs.is_contextual_implicit_args () in let old_rawprint = !Flags.raw_print in + let old_printuniverses = !Constrextern.print_universes in + Constrextern.print_universes := true; Flags.raw_print := true; Impargs.make_implicit_args false; Impargs.make_strict_implicit_args false; @@ -193,6 +196,7 @@ let with_full_print f a = Impargs.make_strict_implicit_args old_strict_implicit_args; Impargs.make_contextual_implicit_args old_contextual_implicit_args; Flags.raw_print := old_rawprint; + Constrextern.print_universes := old_printuniverses; Dumpglob.continue (); res with @@ -201,6 +205,7 @@ let with_full_print f a = Impargs.make_strict_implicit_args old_strict_implicit_args; Impargs.make_contextual_implicit_args old_contextual_implicit_args; Flags.raw_print := old_rawprint; + Constrextern.print_universes := old_printuniverses; Dumpglob.continue (); raise reraise diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index 10daf6e8..23f1da1b 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -46,7 +46,7 @@ val const_of_id: Id.t -> Globnames.global_reference(* constantyes *) val jmeq : unit -> Term.constr val jmeq_refl : unit -> Term.constr -val save : bool -> Id.t -> Entries.definition_entry -> Decl_kinds.goal_kind -> +val save : bool -> Id.t -> Safe_typing.private_constants Entries.definition_entry -> Decl_kinds.goal_kind -> unit Lemmas.declaration_hook Ephemeron.key -> unit (* [get_proof_clean do_reduce] : returns the proof name, definition, kind and hook and @@ -54,7 +54,7 @@ val save : bool -> Id.t -> Entries.definition_entry -> Decl_kinds.goal_kind -> *) val get_proof_clean : bool -> Names.Id.t * - (Entries.definition_entry * Decl_kinds.goal_kind) + (Safe_typing.private_constants Entries.definition_entry * Decl_kinds.goal_kind) diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index d10924f8..d9794014 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -127,8 +127,8 @@ let generate_type evd g_to_f f graph i = let evd',graph = Evd.fresh_global (Global.env ()) !evd (Globnames.IndRef (fst (destInd graph))) in - let evd',graph_arity = Typing.e_type_of (Global.env ()) evd' graph in evd:=evd'; + let graph_arity = Typing.e_type_of (Global.env ()) evd graph in let ctxt,_ = decompose_prod_assum graph_arity in let fun_ctxt,res_type = match ctxt with @@ -193,7 +193,7 @@ let find_induction_principle evd f = | None -> raise Not_found | Some rect_lemma -> let evd',rect_lemma = Evd.fresh_global (Global.env ()) !evd (Globnames.ConstRef rect_lemma) in - let evd',typ = Typing.e_type_of ~refresh:true (Global.env ()) evd' rect_lemma in + let evd',typ = Typing.type_of ~refresh:true (Global.env ()) evd' rect_lemma in evd:=evd'; rect_lemma,typ @@ -296,7 +296,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes let constructor_args g = List.fold_right (fun hid acc -> - let type_of_hid = pf_type_of g (mkVar hid) in + let type_of_hid = pf_unsafe_type_of g (mkVar hid) in match kind_of_term type_of_hid with | Prod(_,_,t') -> begin @@ -440,7 +440,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes "functional_induction" ( (fun gl -> let term = mkApp (mkVar principle_id,Array.of_list bindings) in - let gl', _ty = pf_eapply (Typing.e_type_of ~refresh:true) gl term in + let gl', _ty = pf_eapply (Typing.type_of ~refresh:true) gl term in Proofview.V82.of_tactic (apply term) gl') )) (fun i g -> observe_tac ("proving branche "^string_of_int i) (prove_branche i) g ) @@ -577,7 +577,7 @@ let rec reflexivity_with_destruct_cases g = match sc with None -> tclIDTAC g | Some id -> - match kind_of_term (pf_type_of g (mkVar id)) with + match kind_of_term (pf_unsafe_type_of g (mkVar id)) with | App(eq,[|_;t1;t2|]) when eq_constr eq eq_ind -> if Equality.discriminable (pf_env g) (project g) t1 t2 then Proofview.V82.of_tactic (Equality.discrHyp id) g @@ -642,7 +642,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = (* We get the constant and the principle corresponding to this lemma *) let f = funcs.(i) in let graph_principle = nf_zeta schemes.(i) in - let princ_type = pf_type_of g graph_principle in + let princ_type = pf_unsafe_type_of g graph_principle in let princ_infos = Tactics.compute_elim_sig princ_type in (* Then we get the number of argument of the function and compute a fresh name for each of them @@ -760,7 +760,8 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( let funs_constr = Array.map mkConstU funs in States.with_state_protection_on_exception (fun () -> - let evd = ref Evd.empty in + let env = Global.env () in + let evd = ref (Evd.from_env env) in let graphs_constr = Array.map mkInd graphs in let lemmas_types_infos = Util.Array.map2_i @@ -772,7 +773,7 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in graphs_constr.(i) <- graph; let type_of_lemma = Termops.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in - let _ = evd := fst (Typing.e_type_of (Global.env ()) !evd type_of_lemma) in + let _ = Typing.e_type_of (Global.env ()) evd type_of_lemma in let type_of_lemma = nf_zeta type_of_lemma in observe (str "type_of_lemma := " ++ Printer.pr_lconstr_env (Global.env ()) !evd type_of_lemma); type_of_lemma,type_info @@ -829,7 +830,6 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( ) funs; - (* let evd = ref Evd.empty in *) let lemmas_types_infos = Util.Array.map2_i (fun i f_constr graph -> @@ -875,7 +875,7 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( i*) let lem_id = mk_complete_id f_id in Lemmas.start_proof lem_id - (Decl_kinds.Global,Flags.is_universe_polymorphism (),(Decl_kinds.Proof Decl_kinds.Theorem)) !evd + (Decl_kinds.Global,Flags.is_universe_polymorphism (),(Decl_kinds.Proof Decl_kinds.Theorem)) sigma (fst lemmas_types_infos.(i)) (Lemmas.mk_hook (fun _ _ -> ())); ignore (Pfedit.by @@ -900,7 +900,7 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( if the type of hypothesis has not this form or if we cannot find the completeness lemma then we do nothing *) let revert_graph kn post_tac hid g = - let typ = pf_type_of g (mkVar hid) in + let typ = pf_unsafe_type_of g (mkVar hid) in match kind_of_term typ with | App(i,args) when isInd i -> let ((kn',num) as ind'),u = destInd i in @@ -951,7 +951,7 @@ let revert_graph kn post_tac hid g = let functional_inversion kn hid fconst f_correct : tactic = fun g -> let old_ids = List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty in - let type_of_h = pf_type_of g (mkVar hid) in + let type_of_h = pf_unsafe_type_of g (mkVar hid) in match kind_of_term type_of_h with | App(eq,args) when eq_constr eq (make_eq ()) -> let pre_tac,f_args,res = @@ -1003,7 +1003,7 @@ let invfun qhyp f g = Proofview.V82.of_tactic begin Tactics.try_intros_until (fun hid -> Proofview.V82.tactic begin fun g -> - let hyp_typ = pf_type_of g (mkVar hid) in + let hyp_typ = pf_unsafe_type_of g (mkVar hid) in match kind_of_term hyp_typ with | App(eq,args) when eq_constr eq (make_eq ()) -> begin diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index ea699580..e3455e77 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -841,7 +841,7 @@ let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = FIXME: params et cstr_expr (arity) *) let glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift (rawlist:(Id.t * glob_constr) list) = - let lident = Loc.ghost, shift.ident in + let lident = (Loc.ghost, shift.ident), None in let bindlist , cstr_expr = (* params , arities *) merge_rec_params_and_arity prms1 prms2 shift mkSet in let lcstor_expr : (bool * (lident * constr_expr)) list = @@ -884,10 +884,10 @@ let merge_inductive (ind1: inductive) (ind2: inductive) let indexpr = glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift_prm rawlist in (* Declare inductive *) let indl,_,_ = Command.extract_mutual_inductive_declaration_components [(indexpr,[])] in - let mie,impls = Command.interp_mutual_inductive indl [] + let mie,pl,impls = Command.interp_mutual_inductive indl [] false (*FIXMEnon-poly *) false (* means not private *) Decl_kinds.Finite (* means: not coinductive *) in (* Declare the mutual inductive block with its associated schemes *) - ignore (Command.declare_mutual_inductive_with_eliminations mie impls) + ignore (Command.declare_mutual_inductive_with_eliminations mie pl impls) (* Find infos on identifier id. *) @@ -902,7 +902,7 @@ let find_Function_infos_safe (id:Id.t): Indfun_common.function_info = (** [merge id1 id2 args1 args2 id] builds and declares a new inductive type called [id], representing the merged graphs of both graphs - [ind1] and [ind2]. identifiers occuring in both arrays [args1] and + [ind1] and [ind2]. identifiers occurring in both arrays [args1] and [args2] are considered linked (i.e. are the same variable) in the new graph. diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 0999b95d..5d41ec72 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -115,7 +115,7 @@ let pf_get_new_ids idl g = let compute_renamed_type gls c = rename_bound_vars_as_displayed (*no avoid*) [] (*no rels*) [] - (pf_type_of gls c) + (pf_unsafe_type_of gls c) let h'_id = Id.of_string "h'" let teq_id = Id.of_string "teq" let ano_id = Id.of_string "anonymous" @@ -194,7 +194,7 @@ let (value_f:constr list -> global_reference -> constr) = Anonymous)], GVar(d0,v_id)]) in - let body = fst (understand env Evd.empty glob_body)(*FIXME*) in + let body = fst (understand env (Evd.from_env env) glob_body)(*FIXME*) in it_mkLambda_or_LetIn body context let (declare_f : Id.t -> logical_kind -> constr list -> global_reference -> global_reference) = @@ -305,7 +305,8 @@ let check_not_nested forbidden e = | Rel _ -> () | Var x -> if Id.List.mem x forbidden - then error ("check_not_nested : failure "^Id.to_string x) + then errorlabstrm "Recdef.check_not_nested" + (str "check_not_nested: failure " ++ pr_id x) | Meta _ | Evar _ | Sort _ -> () | Cast(e,_,t) -> check_not_nested e;check_not_nested t | Prod(_,t,b) -> check_not_nested t;check_not_nested b @@ -399,7 +400,7 @@ let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = thin to_intros; h_intros to_intros; (fun g' -> - let ty_teq = pf_type_of g' (mkVar heq) in + let ty_teq = pf_unsafe_type_of g' (mkVar heq) in let teq_lhs,teq_rhs = let _,args = try destApp ty_teq with DestKO -> assert false in args.(1),args.(2) @@ -513,13 +514,13 @@ let rec prove_lt hyple g = in let h = List.find (fun id -> - match decompose_app (pf_type_of g (mkVar id)) with + match decompose_app (pf_unsafe_type_of g (mkVar id)) with | _, t::_ -> eq_constr t varx | _ -> false ) hyple in let y = - List.hd (List.tl (snd (decompose_app (pf_type_of g (mkVar h))))) in + List.hd (List.tl (snd (decompose_app (pf_unsafe_type_of g (mkVar h))))) in observe_tclTHENLIST (str "prove_lt1")[ Proofview.V82.of_tactic (apply (mkApp(le_lt_trans (),[|varx;y;varz;mkVar h|]))); observe_tac (str "prove_lt") (prove_lt hyple) @@ -654,7 +655,7 @@ let terminate_letin (na,b,t,e) expr_info continuation_tac info = continuation_tac {info with info = new_e; forbidden_ids = new_forbidden} let pf_type c tac gl = - let evars, ty = Typing.e_type_of (pf_env gl) (project gl) c in + let evars, ty = Typing.type_of (pf_env gl) (project gl) c in tclTHEN (Refiner.tclEVARS evars) (tac ty) gl let pf_typel l tac = @@ -679,7 +680,7 @@ let mkDestructEq : if Id.List.mem id not_on_hyp || not (Termops.occur_term expr t) then None else Some id) hyps in let to_revert_constr = List.rev_map mkVar to_revert in - let type_of_expr = pf_type_of g expr in + let type_of_expr = pf_unsafe_type_of g expr in let new_hyps = mkApp(Lazy.force refl_equal, [|type_of_expr; expr|]):: to_revert_constr in pf_typel new_hyps (fun _ -> @@ -1292,8 +1293,9 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp ref_ := Some lemma ; let lid = ref [] in let h_num = ref (-1) in + let env = Global.env () in Proof_global.discard_all (); - build_proof Evd.empty + build_proof (Evd.from_env env) ( fun gls -> let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in observe_tclTHENLIST (str "") @@ -1397,9 +1399,7 @@ let com_terminate start_proof ctx tclIDTAC tclIDTAC; try let sigma, new_goal_type = build_new_goal_type () in - let sigma = - Evd.from_env ~ctx:(Evd.evar_universe_context sigma) Environ.empty_env - in + let sigma = Evd.from_ctx (Evd.evar_universe_context sigma) in open_new_goal start_proof sigma using_lemmas tcc_lemma_ref (Some tcc_lemma_name) @@ -1436,9 +1436,7 @@ let (com_eqn : int -> Id.t -> | _ -> anomaly ~label:"terminate_lemma" (Pp.str "not a constant") in let (evmap, env) = Lemmas.get_current_context() in - let evmap = - Evd.from_env ~ctx:(Evd.evar_universe_context evmap) Environ.empty_env - in + let evmap = Evd.from_ctx (Evd.evar_universe_context evmap) in let f_constr = constr_of_global f_ref in let equation_lemma_type = subst1 f_constr equation_lemma_type in (Lemmas.start_proof eq_name (Global, false, Proof Lemma) @@ -1511,12 +1509,12 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let equation_id = add_suffix function_name "_equation" in let functional_id = add_suffix function_name "_F" in let term_id = add_suffix function_name "_terminate" in - let functional_ref = declare_fun functional_id (IsDefinition Decl_kinds.Definition) ~ctx:(Evd.universe_context evm) res in + let functional_ref = declare_fun functional_id (IsDefinition Decl_kinds.Definition) ~ctx:(snd (Evd.universe_context evm)) res in let env_with_pre_rec_args = push_rel_context(List.map (function (x,t) -> (x,None,t)) pre_rec_args) env in let relation = fst (*FIXME*)(interp_constr env_with_pre_rec_args - Evd.empty + (Evd.from_env env_with_pre_rec_args) r) in let tcc_lemma_name = add_suffix function_name "_tcc" in diff --git a/plugins/micromega/mfourier.ml b/plugins/micromega/mfourier.ml index 88c1a783..a36369d2 100644 --- a/plugins/micromega/mfourier.ml +++ b/plugins/micromega/mfourier.ml @@ -23,7 +23,7 @@ struct - None , Some v -> \]-oo,v\] - Some v, None -> \[v,+oo\[ - Some v, Some v' -> \[v,v'\] - Intervals needs to be explicitely normalised. + Intervals needs to be explicitly normalised. *) type who = Left | Right diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 37428c39..aac9a7d3 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -539,7 +539,7 @@ let context operation path (t : constr) = in loop 1 path t -let occurence path (t : constr) = +let occurrence path (t : constr) = let rec loop p0 t = match (p0,kind_of_term t) with | (p, Cast (c,_,_)) -> loop p c | ([], _) -> t @@ -555,7 +555,7 @@ let occurence path (t : constr) = | ((P_TYPE :: p), Lambda (n,term,c)) -> loop p term | ((P_TYPE :: p), LetIn (n,b,term,c)) -> loop p term | (p, _) -> - failwith ("occurence " ^ string_of_int(List.length p)) + failwith ("occurrence " ^ string_of_int(List.length p)) in loop path t @@ -660,7 +660,7 @@ let clever_rewrite_gen_nat p result (t,args) = let clever_rewrite p vpath t gl = let full = pf_concl gl in let (abstracted,occ) = abstract_path (Lazy.force coq_Z) (List.rev p) full in - let vargs = List.map (fun p -> occurence p occ) vpath in + let vargs = List.map (fun p -> occurrence p occ) vpath in let t' = applist(t, (vargs @ [abstracted])) in exact (applist(t',[mkNewMeta()])) gl @@ -1462,7 +1462,7 @@ let coq_omega = let path = simplify_strong (new_id,new_var_num,display_var) system in if !display_action_flag then display_action display_var path; Tacticals.New.tclTHEN prelude (replay_history tactic_normalisation path) - with NO_CONTRADICTION -> Proofview.tclZERO (UserError ("" , Pp.str"Omega can't solve this system")) + with NO_CONTRADICTION -> Tacticals.New.tclZEROMSG (Pp.str"Omega can't solve this system") end end @@ -1689,7 +1689,7 @@ let onClearedName2 id tac = let destructure_hyps = Proofview.Goal.nf_enter begin fun gl -> - let type_of = Tacmach.New.pf_type_of gl in + let type_of = Tacmach.New.pf_unsafe_type_of gl in let decidability = Tacmach.New.of_old decidability gl in let pf_nf = Tacmach.New.of_old pf_nf gl in let rec loop = function diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index 8156e841..95407c5f 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -44,7 +44,7 @@ let occ_step_eq s1 s2 = match s1, s2 with (* chemin identifiant une proposition sous forme du nom de l'hypothèse et d'une liste de pas à partir de la racine de l'hypothèse *) -type occurence = {o_hyp : Names.Id.t; o_path : occ_path} +type occurrence = {o_hyp : Names.Id.t; o_path : occ_path} (* \subsection{refiable formulas} *) type oformula = @@ -81,7 +81,7 @@ and oequation = { e_left: oformula; (* formule brute gauche *) e_right: oformula; (* formule brute droite *) e_trace: Term.constr; (* tactique de normalisation *) - e_origin: occurence; (* l'hypothèse dont vient le terme *) + e_origin: occurrence; (* l'hypothèse dont vient le terme *) e_negated: bool; (* vrai si apparait en position nié après normalisation *) e_depends: direction list; (* liste des points de disjonction dont @@ -111,7 +111,7 @@ type environment = { real_indices : (int,int) Hashtbl.t; mutable cnt_connectors : int; equations : (int,oequation) Hashtbl.t; - constructors : (int, occurence) Hashtbl.t + constructors : (int, occurrence) Hashtbl.t } (* \subsection{Solution tree} @@ -136,7 +136,7 @@ type solution_tree = chemins pour extraire des equations ou d'hypothèses *) type context_content = - CCHyp of occurence + CCHyp of occurrence | CCEqua of int (* \section{Specific utility functions to handle base types} *) diff --git a/plugins/setoid_ring/newring.ml4 b/plugins/setoid_ring/newring.ml4 index 2f9e8509..c7185ff2 100644 --- a/plugins/setoid_ring/newring.ml4 +++ b/plugins/setoid_ring/newring.ml4 @@ -155,14 +155,19 @@ let _ = add_tacdef false ((Loc.ghost,Id.of_string"ring_closed_term" (****************************************************************************) let ic c = - let env = Global.env() and sigma = Evd.empty in + let env = Global.env() in + let sigma = Evd.from_env env in Constrintern.interp_open_constr env sigma c let ic_unsafe c = (*FIXME remove *) - let env = Global.env() and sigma = Evd.empty in + let env = Global.env() in + let sigma = Evd.from_env env in fst (Constrintern.interp_constr env sigma c) -let ty c = Typing.type_of (Global.env()) Evd.empty c +let ty c = + let env = Global.env() in + let sigma = Evd.from_env env in + Typing.unsafe_type_of env sigma c let decl_constant na ctx c = let vars = Universes.universes_of_constr c in @@ -215,7 +220,7 @@ let exec_tactic env evd n f args = let gl = dummy_goal env evd in let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic(ltac_call f (args@[getter]))) gl in let evd, nf = Evarutil.nf_evars_and_universes (Refiner.project gls) in - Array.map (fun x -> nf (constr_of x)) !res, Evd.universe_context evd + Array.map (fun x -> nf (constr_of x)) !res, snd (Evd.universe_context evd) let stdlib_modules = [["Coq";"Setoids";"Setoid"]; diff --git a/pretyping/cases.ml b/pretyping/cases.ml index fcbe90b6..a5a7ace2 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -1077,7 +1077,7 @@ let rec ungeneralize n ng body = let p = prod_applist p [mkRel (n+List.length sign+ng)] in it_mkLambda_or_LetIn (it_mkProd_or_LetIn p sign2) sign in mkCase (ci,p,c,Array.map2 (fun q c -> - let sign,b = decompose_lam_n_assum q c in + let sign,b = decompose_lam_n_decls q c in it_mkLambda_or_LetIn (ungeneralize (n+q) ng b) sign) ci.ci_cstr_ndecls brs) | App (f,args) -> @@ -1102,7 +1102,8 @@ let rec is_dependent_generalization ng body = | Case (ci,p,c,brs) -> (* We traverse a split *) Array.exists2 (fun q c -> - let _,b = decompose_lam_n_assum q c in is_dependent_generalization ng b) + let _,b = decompose_lam_n_decls q c in + is_dependent_generalization ng b) ci.ci_cstr_ndecls brs | App (g,args) -> (* We traverse an inner generalization *) @@ -1466,6 +1467,14 @@ and compile_alias initial pb (na,orig,(expanded,expanded_typ)) rest = compile pb in let sigma = !(pb.evdref) in + (* If the "match" was orginally over a variable, as in "match x with + O => true | n => n end", we give preference to non-expansion in + the default clause (i.e. "match x with O => true | n => n end" + rather than "match x with O => true | S p => S p end"; + computationally, this avoids reallocating constructors in cbv + evaluation; the drawback is that it might duplicate the instances + of the term to match when the corresponding variable is + substituted by a non-evaluated expression *) if not (Flags.is_program_mode ()) && (isRel orig || isVar orig) then (* Try to compile first using non expanded alias *) try @@ -1473,6 +1482,7 @@ and compile_alias initial pb (na,orig,(expanded,expanded_typ)) rest = else just_pop () with e when precatchable_exception e -> (* Try then to compile using expanded alias *) + (* Could be needed in case of dependent return clause *) pb.evdref := sigma; f expanded expanded_typ else @@ -1480,6 +1490,8 @@ and compile_alias initial pb (na,orig,(expanded,expanded_typ)) rest = try f expanded expanded_typ with e when precatchable_exception e -> (* Try then to compile using non expanded alias *) + (* Could be needed in case of a recursive call which requires to + be on a variable for size reasons *) pb.evdref := sigma; if initial then f orig (Retyping.get_type_of pb.env !(pb.evdref) orig) else just_pop () @@ -1668,7 +1680,7 @@ let build_tycon loc env tycon_env s subst tycon extenv evdref t = (lift (n'-n) impossible_case_type, mkSort u) | Some t -> let t = abstract_tycon loc tycon_env evdref subst tycon extenv t in - let evd,tt = Typing.e_type_of extenv !evdref t in + let evd,tt = Typing.type_of extenv !evdref t in evdref := evd; (t,tt) in let b = e_cumul env evdref tt (mkSort s) (* side effect *) in @@ -1854,10 +1866,10 @@ let inh_conv_coerce_to_tycon loc env evdref j tycon = (* We put the tycon inside the arity signature, possibly discovering dependencies. *) -let prepare_predicate_from_arsign_tycon loc tomatchs arsign c = +let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c = let nar = List.fold_left (fun n sign -> List.length sign + n) 0 arsign in let subst, len = - List.fold_left2 (fun (subst, len) (tm, tmtype) sign -> + List.fold_right2 (fun (tm, tmtype) sign (subst, len) -> let signlen = List.length sign in match kind_of_term tm with | Rel n when dependent tm c @@ -1868,19 +1880,21 @@ let prepare_predicate_from_arsign_tycon loc tomatchs arsign c = (match tmtype with NotInd _ -> (subst, len - signlen) | IsInd (_, IndType(indf,realargs),_) -> - let subst = - if dependent tm c && List.for_all isRel realargs - then (n, 1) :: subst else subst - in + let subst, len = List.fold_left (fun (subst, len) arg -> match kind_of_term arg with | Rel n when dependent arg c -> ((n, len) :: subst, pred len) | _ -> (subst, pred len)) - (subst, len) realargs) + (subst, len) realargs + in + let subst = + if dependent tm c && List.for_all isRel realargs + then (n, len) :: subst else subst + in (subst, pred len)) | _ -> (subst, len - signlen)) - ([], nar) tomatchs arsign + (List.rev tomatchs) arsign ([], nar) in let rec predicate lift c = match kind_of_term c with @@ -1894,8 +1908,13 @@ let prepare_predicate_from_arsign_tycon loc tomatchs arsign c = mkRel (n + nar)) | _ -> map_constr_with_binders succ predicate lift c - in predicate 0 c - + in + assert (len == 0); + let p = predicate 0 c in + let env' = List.fold_right push_rel_context arsign env in + try let sigma' = fst (Typing.type_of env' sigma p) in + Some (sigma', p) + with e when precatchable_exception e -> None (* Builds the predicate. If the predicate is dependent, its context is * made of 1+nrealargs assumptions for each matched term in an inductive @@ -1916,11 +1935,13 @@ let prepare_predicate loc typing_fun env sigma tomatchs arsign tycon pred = (* If the tycon is not closed w.r.t real variables, we try *) (* two different strategies *) (* First strategy: we abstract the tycon wrt to the dependencies *) - let pred1 = - prepare_predicate_from_arsign_tycon loc tomatchs arsign t in + let p1 = + prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign t in (* Second strategy: we build an "inversion" predicate *) let sigma2,pred2 = build_inversion_problem loc env sigma tomatchs t in - [sigma, pred1; sigma2, pred2] + (match p1 with + | Some (sigma1,pred1) -> [sigma1, pred1; sigma2, pred2] + | None -> [sigma2, pred2]) | None, _ -> (* No dependent type constraint, or no constraints at all: *) (* we use two strategies *) @@ -2014,7 +2035,7 @@ let constr_of_pat env evdref arsign pat avoid = let IndType (indf, _) = try find_rectype env ( !evdref) (lift (-(List.length realargs)) ty) with Not_found -> error_case_not_inductive env - {uj_val = ty; uj_type = Typing.type_of env !evdref ty} + {uj_val = ty; uj_type = Typing.unsafe_type_of env !evdref ty} in let (ind,u), params = dest_ind_family indf in if not (eq_ind ind cind) then error_bad_constructor_loc l env cstr ind; @@ -2214,7 +2235,7 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity = let j = typing_fun (mk_tycon tycon) rhs_env eqn.rhs.it in let bbody = it_mkLambda_or_LetIn j.uj_val rhs_rels' and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' in - let _btype = evd_comb1 (Typing.e_type_of env) evdref bbody in + let _btype = evd_comb1 (Typing.type_of env) evdref bbody in let branch_name = Id.of_string ("program_branch_" ^ (string_of_int !i)) in let branch_decl = (Name branch_name, Some (lift !i bbody), (lift !i btype)) in let branch = @@ -2392,14 +2413,11 @@ let compile_program_cases loc style (typing_function, evdref) tycon env | None -> let ev = mkExistential env evdref in ev, ev | Some t -> let pred = - try - let pred = prepare_predicate_from_arsign_tycon loc tomatchs sign t in - (* The tycon may be ill-typed after abstraction. *) - let env' = push_rel_context (context_of_arsign sign) env in - ignore(Typing.sort_of env' evdref pred); pred - with e when Errors.noncritical e -> - let nar = List.fold_left (fun n sign -> List.length sign + n) 0 sign in - lift nar t + match prepare_predicate_from_arsign_tycon env !evdref loc tomatchs sign t with + | Some (evd, pred) -> evdref := evd; pred + | None -> + let nar = List.fold_left (fun n sign -> List.length sign + n) 0 sign in + lift nar t in Option.get tycon, pred in let neqs, arity = diff --git a/pretyping/classops.mli b/pretyping/classops.mli index c421b450..e2bb2d1a 100644 --- a/pretyping/classops.mli +++ b/pretyping/classops.mli @@ -78,9 +78,9 @@ val coercion_value : coe_index -> (unsafe_judgment * bool * bool) Univ.in_univer (** {6 Lookup functions for coercion paths } *) -val lookup_path_between_class : cl_index * cl_index -> inheritance_path -(** @raise Not_found when no such path exists *) +(** @raise Not_found in the following functions when no path exists *) +val lookup_path_between_class : cl_index * cl_index -> inheritance_path val lookup_path_between : env -> evar_map -> types * types -> types * types * inheritance_path val lookup_path_to_fun_from : env -> evar_map -> types -> diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 8ebb8cd2..e61e52c1 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -295,8 +295,8 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) let evm = !evdref in (try subco () with NoSubtacCoercion -> - let typ = Typing.type_of env evm c in - let typ' = Typing.type_of env evm c' in + let typ = Typing.unsafe_type_of env evm c in + let typ' = Typing.unsafe_type_of env evm c' in (* if not (is_arity env evm typ) then *) coerce_application typ typ' c c' l l') (* else subco () *) @@ -305,8 +305,8 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) | x, y when Constr.equal c c' -> if Int.equal (Array.length l) (Array.length l') then let evm = !evdref in - let lam_type = Typing.type_of env evm c in - let lam_type' = Typing.type_of env evm c' in + let lam_type = Typing.unsafe_type_of env evm c in + let lam_type' = Typing.unsafe_type_of env evm c' in (* if not (is_arity env evm lam_type) then ( *) coerce_application lam_type lam_type' c c' l l' (* ) else subco () *) @@ -345,7 +345,7 @@ let saturate_evd env evd = Typeclasses.resolve_typeclasses ~filter:Typeclasses.no_goals ~split:false ~fail:false env evd -(* appliquer le chemin de coercions p à hj *) +(* Apply coercion path from p to hj; raise NoCoercion if not applicable *) let apply_coercion env sigma p hj typ_cl = try let j,t,evd = @@ -367,7 +367,8 @@ let apply_coercion env sigma p hj typ_cl = with NoCoercion as e -> raise e | e when Errors.noncritical e -> anomaly (Pp.str "apply_coercion") -let inh_app_fun env evd j = +(* Try to coerce to a funclass; raise NoCoercion if not possible *) +let inh_app_fun_core env evd j = let t = whd_betadeltaiota env evd j.uj_type in match kind_of_term t with | Prod (_,_,_) -> (evd,j) @@ -378,7 +379,8 @@ let inh_app_fun env evd j = try let t,p = lookup_path_to_fun_from env evd j.uj_type in apply_coercion env evd p j t - with Not_found | NoCoercion when Flags.is_program_mode () -> + with Not_found | NoCoercion -> + if Flags.is_program_mode () then try let evdref = ref evd in let coercef, t = mu env evdref t in @@ -386,15 +388,17 @@ let inh_app_fun env evd j = (!evdref, res) with NoSubtacCoercion | NoCoercion -> (evd,j) + else raise NoCoercion +(* Try to coerce to a funclass; returns [j] if no coercion is applicable *) let inh_app_fun resolve_tc env evd j = - try inh_app_fun env evd j + try inh_app_fun_core env evd j with - | Not_found when not resolve_tc + | NoCoercion when not resolve_tc || not !use_typeclasses_for_conversion -> (evd, j) - | Not_found -> - try inh_app_fun env (saturate_evd env evd) j - with Not_found -> (evd, j) + | NoCoercion -> + try inh_app_fun_core env (saturate_evd env evd) j + with NoCoercion -> (evd, j) let inh_tosort_force loc env evd j = try diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 161cffa8..5e99521a 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -56,10 +56,6 @@ let warn_bound_meta name = let warn_bound_bound name = msg_warning (str "Collision between bound variables of name " ++ pr_id name) -let warn_bound_again name = - msg_warning (str "Collision between bound variable " ++ pr_id name ++ - str " and another bound variable of same name.") - let constrain n (ids, m as x) (names, terms as subst) = try let (ids', m') = Id.Map.find n terms in @@ -69,32 +65,33 @@ let constrain n (ids, m as x) (names, terms as subst) = let () = if Id.Map.mem n names then warn_bound_meta n in (names, Id.Map.add n x terms) -let add_binders na1 na2 (names, terms as subst) = match na1, na2 with -| Name id1, Name id2 -> - if Id.Map.mem id1 names then - let () = warn_bound_bound id1 in - (names, terms) - else - let names = Id.Map.add id1 id2 names in - let () = if Id.Map.mem id1 terms then warn_bound_again id1 in - (names, terms) -| _ -> subst - -let rec build_lambda vars stk m = match vars with +let add_binders na1 na2 binding_vars (names, terms as subst) = + match na1, na2 with + | Name id1, Name id2 when Id.Set.mem id1 binding_vars -> + if Id.Map.mem id1 names then + let () = warn_bound_bound id1 in + (names, terms) + else + let names = Id.Map.add id1 id2 names in + let () = if Id.Map.mem id1 terms then warn_bound_meta id1 in + (names, terms) + | _ -> subst + +let rec build_lambda vars ctx m = match vars with | [] -> - let len = List.length stk in + let len = List.length ctx in lift (-1 * len) m | n :: vars -> (* change [ x1 ... xn y z1 ... zm |- t ] into [ x1 ... xn z1 ... zm |- lam y. t ] *) - let len = List.length stk in + let len = List.length ctx in let init i = if i < pred n then mkRel (i + 2) else if Int.equal i (pred n) then mkRel 1 else mkRel (i + 1) in let m = substl (List.init len init) m in - let pre, suf = List.chop (pred n) stk in + let pre, suf = List.chop (pred n) ctx in match suf with | [] -> assert false | (_, na, t) :: suf -> @@ -108,21 +105,21 @@ let rec build_lambda vars stk m = match vars with let m = mkLambda (na, t, m) in build_lambda vars (pre @ suf) m -let rec extract_bound_aux k accu frels stk = match stk with +let rec extract_bound_aux k accu frels ctx = match ctx with | [] -> accu -| (na1, na2, _) :: stk -> +| (na1, na2, _) :: ctx -> if Int.Set.mem k frels then begin match na1 with | Name id -> let () = assert (match na2 with Anonymous -> false | Name _ -> true) in let () = if Id.Set.mem id accu then raise PatternMatchingFailure in - extract_bound_aux (k + 1) (Id.Set.add id accu) frels stk + extract_bound_aux (k + 1) (Id.Set.add id accu) frels ctx | Anonymous -> raise PatternMatchingFailure end - else extract_bound_aux (k + 1) accu frels stk + else extract_bound_aux (k + 1) accu frels ctx -let extract_bound_vars frels stk = - extract_bound_aux 1 Id.Set.empty frels stk +let extract_bound_vars frels ctx = + extract_bound_aux 1 Id.Set.empty frels ctx let dummy_constr = mkProp @@ -134,20 +131,20 @@ let make_renaming ids = function end | _ -> dummy_constr -let merge_binding allow_bound_rels stk n cT subst = - let c = match stk with +let merge_binding allow_bound_rels ctx n cT subst = + let c = match ctx with | [] -> (* Optimization *) ([], cT) | _ -> let frels = free_rels cT in if allow_bound_rels then - let vars = extract_bound_vars frels stk in + let vars = extract_bound_vars frels ctx in let ordered_vars = Id.Set.elements vars in let rename binding = make_renaming ordered_vars binding in - let renaming = List.map rename stk in + let renaming = List.map rename ctx in (ordered_vars, substl renaming cT) else - let depth = List.length stk in + let depth = List.length ctx in let min_elt = try Int.Set.min_elt frels with Not_found -> succ depth in if depth < min_elt then ([], lift (- depth) cT) @@ -155,7 +152,8 @@ let merge_binding allow_bound_rels stk n cT subst = in constrain n c subst -let matches_core env sigma convert allow_partial_app allow_bound_rels pat c = +let matches_core env sigma convert allow_partial_app allow_bound_rels + (binding_vars,pat) c = let convref ref c = match ref, kind_of_term c with | VarRef id, Var id' -> Names.id_eq id id' @@ -168,7 +166,7 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels pat c = is_conv env sigma c' c else false) in - let rec sorec stk env subst p t = + let rec sorec ctx env subst p t = let cT = strip_outer_cast t in match p,kind_of_term cT with | PSoApp (n,args),m -> @@ -181,11 +179,11 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels pat c = let relargs, relset = List.fold_left fold ([], Int.Set.empty) args in let frels = free_rels cT in if Int.Set.subset frels relset then - constrain n ([], build_lambda relargs stk cT) subst + constrain n ([], build_lambda relargs ctx cT) subst else raise PatternMatchingFailure - | PMeta (Some n), m -> merge_binding allow_bound_rels stk n cT subst + | PMeta (Some n), m -> merge_binding allow_bound_rels ctx n cT subst | PMeta None, m -> subst @@ -203,10 +201,10 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels pat c = | PSort (GType _), Sort (Type _) -> subst - | PApp (p, [||]), _ -> sorec stk env subst p t + | PApp (p, [||]), _ -> sorec ctx env subst p t | PApp (PApp (h, a1), a2), _ -> - sorec stk env subst (PApp(h,Array.append a1 a2)) t + sorec ctx env subst (PApp(h,Array.append a1 a2)) t | PApp (PMeta meta,args1), App (c2,args2) when allow_partial_app -> (let diff = Array.length args2 - Array.length args1 in @@ -216,13 +214,13 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels pat c = let subst = match meta with | None -> subst - | Some n -> merge_binding allow_bound_rels stk n c subst in - Array.fold_left2 (sorec stk env) subst args1 args22 + | Some n -> merge_binding allow_bound_rels ctx n c subst in + Array.fold_left2 (sorec ctx env) subst args1 args22 else (* Might be a projection on the right *) match kind_of_term c2 with | Proj (pr, c) when not (Projection.unfolded pr) -> (try let term = Retyping.expand_projection env sigma pr c (Array.to_list args2) in - sorec stk env subst p term + sorec ctx env subst p term with Retyping.RetypeError _ -> raise PatternMatchingFailure) | _ -> raise PatternMatchingFailure) @@ -233,15 +231,15 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels pat c = raise PatternMatchingFailure | PProj (pr1,c1), Proj (pr,c) -> if Projection.equal pr1 pr then - try Array.fold_left2 (sorec stk env) (sorec stk env subst c1 c) arg1 arg2 + try Array.fold_left2 (sorec ctx env) (sorec ctx env subst c1 c) arg1 arg2 with Invalid_argument _ -> raise PatternMatchingFailure else raise PatternMatchingFailure | _, Proj (pr,c) when not (Projection.unfolded pr) -> (try let term = Retyping.expand_projection env sigma pr c (Array.to_list arg2) in - sorec stk env subst p term + sorec ctx env subst p term with Retyping.RetypeError _ -> raise PatternMatchingFailure) | _, _ -> - try Array.fold_left2 (sorec stk env) (sorec stk env subst c1 c2) arg1 arg2 + try Array.fold_left2 (sorec ctx env) (sorec ctx env subst c1 c2) arg1 arg2 with Invalid_argument _ -> raise PatternMatchingFailure) | PApp (PRef (ConstRef c1), _), Proj (pr, c2) @@ -250,37 +248,37 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels pat c = | PApp (c, args), Proj (pr, c2) -> (try let term = Retyping.expand_projection env sigma pr c2 [] in - sorec stk env subst p term + sorec ctx env subst p term with Retyping.RetypeError _ -> raise PatternMatchingFailure) | PProj (p1,c1), Proj (p2,c2) when Projection.equal p1 p2 -> - sorec stk env subst c1 c2 + sorec ctx env subst c1 c2 | PProd (na1,c1,d1), Prod(na2,c2,d2) -> - sorec ((na1,na2,c2)::stk) (Environ.push_rel (na2,None,c2) env) - (add_binders na1 na2 (sorec stk env subst c1 c2)) d1 d2 + sorec ((na1,na2,c2)::ctx) (Environ.push_rel (na2,None,c2) env) + (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 | PLambda (na1,c1,d1), Lambda(na2,c2,d2) -> - sorec ((na1,na2,c2)::stk) (Environ.push_rel (na2,None,c2) env) - (add_binders na1 na2 (sorec stk env subst c1 c2)) d1 d2 + sorec ((na1,na2,c2)::ctx) (Environ.push_rel (na2,None,c2) env) + (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 | PLetIn (na1,c1,d1), LetIn(na2,c2,t2,d2) -> - sorec ((na1,na2,t2)::stk) (Environ.push_rel (na2,Some c2,t2) env) - (add_binders na1 na2 (sorec stk env subst c1 c2)) d1 d2 + sorec ((na1,na2,t2)::ctx) (Environ.push_rel (na2,Some c2,t2) env) + (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 | PIf (a1,b1,b1'), Case (ci,_,a2,[|b2;b2'|]) -> - let ctx,b2 = decompose_lam_n_assum ci.ci_cstr_ndecls.(0) b2 in - let ctx',b2' = decompose_lam_n_assum ci.ci_cstr_ndecls.(1) b2' in - let n = rel_context_length ctx in - let n' = rel_context_length ctx' in + let ctx_b2,b2 = decompose_lam_n_decls ci.ci_cstr_ndecls.(0) b2 in + let ctx_b2',b2' = decompose_lam_n_decls ci.ci_cstr_ndecls.(1) b2' in + let n = rel_context_length ctx_b2 in + let n' = rel_context_length ctx_b2' in if noccur_between 1 n b2 && noccur_between 1 n' b2' then - let s = - List.fold_left (fun l (na,_,t) -> (Anonymous,na,t)::l) stk ctx in - let s' = - List.fold_left (fun l (na,_,t) -> (Anonymous,na,t)::l) stk ctx' in + let f l (na,_,t) = (Anonymous,na,t)::l in + let ctx_br = List.fold_left f ctx ctx_b2 in + let ctx_br' = List.fold_left f ctx ctx_b2' in let b1 = lift_pattern n b1 and b1' = lift_pattern n' b1' in - sorec s' (Environ.push_rel_context ctx' env) - (sorec s (Environ.push_rel_context ctx env) (sorec stk env subst a1 a2) b1 b2) b1' b2' + sorec ctx_br' (Environ.push_rel_context ctx_b2' env) + (sorec ctx_br (Environ.push_rel_context ctx_b2 env) + (sorec ctx env subst a1 a2) b1 b2) b1' b2' else raise PatternMatchingFailure @@ -301,9 +299,9 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels pat c = (* (ind,j+1) is normally known to be a correct constructor and br2 a correct match over the same inductive *) assert (j < n2); - sorec stk env subst c br2.(j) + sorec ctx env subst c br2.(j) in - let chk_head = sorec stk env (sorec stk env subst a1 a2) p1 p2 in + let chk_head = sorec ctx env (sorec ctx env subst a1 a2) p1 p2 in List.fold_left chk_branch chk_head br1 | PFix c1, Fix _ when eq_constr (mkFix c1) cT -> subst @@ -319,7 +317,8 @@ let matches_core_closed env sigma convert allow_partial_app pat c = let extended_matches env sigma = matches_core env sigma false true true -let matches env sigma pat c = snd (matches_core_closed env sigma false true pat c) +let matches env sigma pat c = + snd (matches_core_closed env sigma false true (Id.Set.empty,pat) c) let special_meta = (-1) @@ -343,56 +342,49 @@ let matches_head env sigma pat c = matches env sigma pat head (* Tells if it is an authorized occurrence and if the instance is closed *) -let authorized_occ env sigma partial_app closed pat c mk_ctx next = +let authorized_occ env sigma partial_app closed pat c mk_ctx = try let subst = matches_core_closed env sigma false partial_app pat c in if closed && Id.Map.exists (fun _ c -> not (closed0 c)) (snd subst) - then next () - else mkresult subst (mk_ctx (mkMeta special_meta)) next - with PatternMatchingFailure -> next () + then (fun next -> next ()) + else (fun next -> mkresult subst (mk_ctx (mkMeta special_meta)) next) + with PatternMatchingFailure -> (fun next -> next ()) let subargs env v = Array.map_to_list (fun c -> (env, c)) v (* Tries to match a subterm of [c] with [pat] *) let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c = let rec aux env c mk_ctx next = - match kind_of_term c with + let here = authorized_occ env sigma partial_app closed pat c mk_ctx in + let next () = match kind_of_term c with | Cast (c1,k,c2) -> let next_mk_ctx = function | [c1] -> mk_ctx (mkCast (c1, k, c2)) | _ -> assert false in - let next () = try_aux [env, c1] next_mk_ctx next in - authorized_occ env sigma partial_app closed pat c mk_ctx next + try_aux [env, c1] next_mk_ctx next | Lambda (x,c1,c2) -> let next_mk_ctx = function | [c1; c2] -> mk_ctx (mkLambda (x, c1, c2)) | _ -> assert false in - let next () = - let env' = Environ.push_rel (x,None,c1) env in - try_aux [(env, c1); (env', c2)] next_mk_ctx next in - authorized_occ env sigma partial_app closed pat c mk_ctx next + let env' = Environ.push_rel (x,None,c1) env in + try_aux [(env, c1); (env', c2)] next_mk_ctx next | Prod (x,c1,c2) -> let next_mk_ctx = function | [c1; c2] -> mk_ctx (mkProd (x, c1, c2)) | _ -> assert false in - let next () = - let env' = Environ.push_rel (x,None,c1) env in - try_aux [(env, c1); (env', c2)] next_mk_ctx next in - authorized_occ env sigma partial_app closed pat c mk_ctx next + let env' = Environ.push_rel (x,None,c1) env in + try_aux [(env, c1); (env', c2)] next_mk_ctx next | LetIn (x,c1,t,c2) -> let next_mk_ctx = function | [c1; c2] -> mk_ctx (mkLetIn (x, c1, t, c2)) | _ -> assert false in - let next () = - let env' = Environ.push_rel (x,Some c1,t) env in - try_aux [(env, c1); (env', c2)] next_mk_ctx next in - authorized_occ env sigma partial_app closed pat c mk_ctx next + let env' = Environ.push_rel (x,Some c1,t) env in + try_aux [(env, c1); (env', c2)] next_mk_ctx next | App (c1,lc) -> - let next () = let topdown = true in if partial_app then if topdown then @@ -421,45 +413,40 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c = mk_ctx (mkApp (List.hd le, Array.of_list (List.tl le))) in let sub = (env, c1) :: subargs env lc in try_aux sub mk_ctx next - in - authorized_occ env sigma partial_app closed pat c mk_ctx next | Case (ci,hd,c1,lc) -> let next_mk_ctx = function - | [] -> assert false - | c1 :: lc -> mk_ctx (mkCase (ci,hd,c1,Array.of_list lc)) + | c1 :: hd :: lc -> mk_ctx (mkCase (ci,hd,c1,Array.of_list lc)) + | _ -> assert false in - let sub = (env, c1) :: subargs env lc in - let next () = try_aux sub next_mk_ctx next in - authorized_occ env sigma partial_app closed pat c mk_ctx next + let sub = (env, c1) :: (env, hd) :: subargs env lc in + try_aux sub next_mk_ctx next | Fix (indx,(names,types,bodies)) -> let nb_fix = Array.length types in let next_mk_ctx le = let (ntypes,nbodies) = CList.chop nb_fix le in mk_ctx (mkFix (indx,(names, Array.of_list ntypes, Array.of_list nbodies))) in let sub = subargs env types @ subargs env bodies in - let next () = try_aux sub next_mk_ctx next in - authorized_occ env sigma partial_app closed pat c mk_ctx next + try_aux sub next_mk_ctx next | CoFix (i,(names,types,bodies)) -> let nb_fix = Array.length types in let next_mk_ctx le = let (ntypes,nbodies) = CList.chop nb_fix le in mk_ctx (mkCoFix (i,(names, Array.of_list ntypes, Array.of_list nbodies))) in let sub = subargs env types @ subargs env bodies in - let next () = try_aux sub next_mk_ctx next in - authorized_occ env sigma partial_app closed pat c mk_ctx next + try_aux sub next_mk_ctx next | Proj (p,c') -> let next_mk_ctx le = mk_ctx (mkProj (p,List.hd le)) in - let next () = if partial_app then try let term = Retyping.expand_projection env sigma p c' [] in aux env term mk_ctx next with Retyping.RetypeError _ -> next () else - try_aux [env, c'] next_mk_ctx next in - authorized_occ env sigma partial_app closed pat c mk_ctx next + try_aux [env, c'] next_mk_ctx next | Construct _| Ind _|Evar _|Const _ | Rel _|Meta _|Var _|Sort _ -> - authorized_occ env sigma partial_app closed pat c mk_ctx next + next () + in + here next (* Tries [sub_match] for all terms in the list *) and try_aux lc mk_ctx next = @@ -476,10 +463,10 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c = let result () = aux env c (fun x -> x) lempty in IStream.thunk result -let match_subterm env sigma pat c = sub_match env sigma pat c +let match_subterm env sigma pat c = sub_match env sigma (Id.Set.empty,pat) c let match_appsubterm env sigma pat c = - sub_match ~partial_app:true env sigma pat c + sub_match ~partial_app:true env sigma (Id.Set.empty,pat) c let match_subterm_gen env sigma app pat c = sub_match ~partial_app:app env sigma pat c @@ -493,11 +480,12 @@ let is_matching_head env sigma pat c = with PatternMatchingFailure -> false let is_matching_appsubterm ?(closed=true) env sigma pat c = + let pat = (Id.Set.empty,pat) in let results = sub_match ~partial_app:true ~closed env sigma pat c in not (IStream.is_empty results) -let matches_conv env sigma c p = - snd (matches_core_closed env sigma true false c p) +let matches_conv env sigma p c = + snd (matches_core_closed env sigma true false (Id.Set.empty,p) c) let is_matching_conv env sigma pat n = try let _ = matches_conv env sigma pat n in true diff --git a/pretyping/constr_matching.mli b/pretyping/constr_matching.mli index 67854a89..b9dcb0af 100644 --- a/pretyping/constr_matching.mli +++ b/pretyping/constr_matching.mli @@ -41,7 +41,8 @@ val matches_head : env -> Evd.evar_map -> constr_pattern -> constr -> patvar_map variables or metavariables have the same name, the metavariable, or else the rightmost bound variable, takes precedence *) val extended_matches : - env -> Evd.evar_map -> constr_pattern -> constr -> bound_ident_map * extended_patvar_map + env -> Evd.evar_map -> Tacexpr.binding_bound_vars * constr_pattern -> + constr -> bound_ident_map * extended_patvar_map (** [is_matching pat c] just tells if [c] matches against [pat] *) val is_matching : env -> Evd.evar_map -> constr_pattern -> constr -> bool @@ -72,8 +73,10 @@ val match_subterm : env -> Evd.evar_map -> constr_pattern -> constr -> matching_ val match_appsubterm : env -> Evd.evar_map -> constr_pattern -> constr -> matching_result IStream.t (** [match_subterm_gen] calls either [match_subterm] or [match_appsubterm] *) -val match_subterm_gen : env -> Evd.evar_map -> bool (** true = with app context *) -> - constr_pattern -> constr -> matching_result IStream.t +val match_subterm_gen : env -> Evd.evar_map -> + bool (** true = with app context *) -> + Tacexpr.binding_bound_vars * constr_pattern -> constr -> + matching_result IStream.t (** [is_matching_appsubterm pat c] tells if a subterm of [c] matches against [pat] taking partial subterms into consideration *) diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 28fb8cbe..b5228094 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -276,6 +276,7 @@ and align_tree nal isgoal (e,c as rhs) = match nal with match kind_of_term c with | Case (ci,p,c,cl) when eq_constr c (mkRel (List.index Name.equal na (fst (snd e)))) + && not (Int.equal (Array.length cl) 0) && (* don't contract if p dependent *) computable p (List.length ci.ci_pp_info.ind_tags) (* FIXME: can do better *) -> let clauses = build_tree na isgoal e ci cl in @@ -301,7 +302,7 @@ and contract_branch isgoal e (cdn,can,mkpat,b) = let is_nondep_branch c l = try (* FIXME: do better using tags from l *) - let sign,ccl = decompose_lam_n_assum (List.length l) c in + let sign,ccl = decompose_lam_n_decls (List.length l) c in noccur_between 1 (rel_context_length sign) ccl with e when Errors.noncritical e -> (* Not eta-expanded or not reduced *) false @@ -400,7 +401,7 @@ let detype_sort sigma = function | Type u -> GType (if !print_universes - then [Pp.string_of_ppcmds (Univ.Universe.pr_with (Evd.pr_evd_level sigma) u)] + then [dl, Pp.string_of_ppcmds (Univ.Universe.pr_with (Evd.pr_evd_level sigma) u)] else []) type binder_kind = BProd | BLambda | BLetIn @@ -412,7 +413,7 @@ let detype_anonymous = ref (fun loc n -> anomaly ~label:"detype" (Pp.str "index let set_detype_anonymous f = detype_anonymous := f let detype_level sigma l = - GType (Some (Pp.string_of_ppcmds (Evd.pr_evd_level sigma l))) + GType (Some (dl, Pp.string_of_ppcmds (Evd.pr_evd_level sigma l))) let detype_instance sigma l = if Univ.Instance.is_empty l then None @@ -512,7 +513,7 @@ let rec detype flags avoid env sigma t = id,l with Not_found -> Id.of_string ("X" ^ string_of_int (Evar.repr evk)), - (Array.map_to_list (fun c -> (Id.of_string "A",c)) cl) + (Array.map_to_list (fun c -> (Id.of_string "__",c)) cl) in GEvar (dl,id, List.map (on_snd (detype flags avoid env sigma)) l) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index f388f900..bb07bf05 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -201,13 +201,6 @@ let ise_and evd l = | UnifFailure _ as x -> x in ise_and evd l -(* This function requires to get the outermost arguments first. It is - a fold_right for backward compatibility. - - It tries to unify the suffix of 2 lists element by element and if - it reaches the end of a list, it returns the remaining elements in - the other list if there are some. -*) let ise_exact ise x1 x2 = match ise x1 x2 with | None, out -> out @@ -559,13 +552,14 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | MaybeFlexible v1, MaybeFlexible v2 -> begin match kind_of_term term1, kind_of_term term2 with - | LetIn (na,b1,t1,c'1), LetIn (_,b2,t2,c'2) -> + | LetIn (na1,b1,t1,c'1), LetIn (na2,b2,t2,c'2) -> let f1 i = ise_and i [(fun i -> evar_conv_x ts env i CONV b1 b2); (fun i -> let b = nf_evar i b1 in let t = nf_evar i t1 in + let na = Nameops.name_max na1 na2 in evar_conv_x ts (push_rel (na,Some b,t) env) i pbty c'1 c'2); (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] and f2 i = @@ -673,13 +667,14 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty end | Rigid, Rigid when isLambda term1 && isLambda term2 -> - let (na,c1,c'1) = destLambda term1 in - let (_,c2,c'2) = destLambda term2 in + let (na1,c1,c'1) = destLambda term1 in + let (na2,c2,c'2) = destLambda term2 in assert app_empty; ise_and evd [(fun i -> evar_conv_x ts env i CONV c1 c2); (fun i -> let c = nf_evar i c1 in + let na = Nameops.name_max na1 na2 in evar_conv_x ts (push_rel (na,None,c) env) i CONV c'1 c'2)] | Flexible ev1, Rigid -> flex_rigid true ev1 appr1 appr2 @@ -733,12 +728,13 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty UnifFailure (evd,UnifUnivInconsistency p) | e when Errors.noncritical e -> UnifFailure (evd,NotSameHead)) - | Prod (n,c1,c'1), Prod (_,c2,c'2) when app_empty -> + | Prod (n1,c1,c'1), Prod (n2,c2,c'2) when app_empty -> ise_and evd [(fun i -> evar_conv_x ts env i CONV c1 c2); (fun i -> let c = nf_evar i c1 in - evar_conv_x ts (push_rel (n,None,c) env) i pbty c'1 c'2)] + let na = Nameops.name_max n1 n2 in + evar_conv_x ts (push_rel (na,None,c) env) i pbty c'1 c'2)] | Rel x1, Rel x2 -> if Int.equal x1 x2 then diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index bfd19c6c..35bc1de5 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -42,21 +42,20 @@ let get_polymorphic_positions f = templ.template_param_levels) | _ -> assert false -(** - forall A (l : list A) -> typeof A = Type i <= Datatypes.j -> i not refreshed - hd ?A (l : list t) -> A = t +let refresh_level evd s = + match Evd.is_sort_variable evd s with + | None -> true + | Some l -> not (Evd.is_flexible_level evd l) -*) let refresh_universes ?(inferred=false) ?(onlyalg=false) pbty env evd t = let evdref = ref evd in let modified = ref false in - let rec refresh dir t = + let rec refresh status dir t = match kind_of_term t with | Sort (Type u as s) when (match Univ.universe_level u with - | None -> true - | Some l -> not onlyalg && Option.is_empty (Evd.is_sort_variable evd s)) -> - let status = if inferred then Evd.univ_flexible_alg else Evd.univ_flexible in + | None -> true + | Some l -> not onlyalg && refresh_level evd s) -> let s' = evd_comb0 (new_sort_variable status) evdref in let evd = if dir then set_leq_sort env !evdref s' s @@ -64,11 +63,11 @@ let refresh_universes ?(inferred=false) ?(onlyalg=false) pbty env evd t = in modified := true; evdref := evd; mkSort s' | Prod (na,u,v) -> - mkProd (na,u,refresh dir v) + mkProd (na,u,refresh status dir v) | _ -> t (** Refresh the types of evars under template polymorphic references *) and refresh_term_evars onevars top t = - match kind_of_term t with + match kind_of_term (whd_evar !evdref t) with | App (f, args) when is_template_polymorphic env f -> let pos = get_polymorphic_positions f in refresh_polymorphic_positions args pos @@ -77,7 +76,7 @@ let refresh_universes ?(inferred=false) ?(onlyalg=false) pbty env evd t = Array.iter (refresh_term_evars onevars false) args | Evar (ev, a) when onevars -> let evi = Evd.find !evdref ev in - let ty' = refresh true evi.evar_concl in + let ty' = refresh univ_flexible true evi.evar_concl in if !modified then evdref := Evd.add !evdref ev {evi with evar_concl = ty'} else () @@ -99,7 +98,7 @@ let refresh_universes ?(inferred=false) ?(onlyalg=false) pbty env evd t = if isArity t then (match pbty with | None -> t - | Some dir -> refresh dir t) + | Some dir -> refresh univ_rigid dir t) else (refresh_term_evars false true t; t) in if !modified then !evdref, t' else !evdref, t @@ -107,6 +106,7 @@ let refresh_universes ?(inferred=false) ?(onlyalg=false) pbty env evd t = let get_type_of_refresh ?(polyprop=true) ?(lax=false) env sigma c = let ty = Retyping.get_type_of ~polyprop ~lax env sigma c in refresh_universes (Some false) env sigma ty + (************************) (* Unification results *) @@ -127,6 +127,34 @@ let add_conv_oriented_pb ?(tail=true) (pbty,env,t1,t2) evd = | Some false -> add_conv_pb ~tail (Reduction.CUMUL,env,t2,t1) evd | None -> add_conv_pb ~tail (Reduction.CONV,env,t1,t2) evd +(* We retype applications to ensure the universe constraints are collected *) + +exception IllTypedInstance of env * types * types + +let recheck_applications conv_algo env evdref t = + let rec aux env t = + match kind_of_term t with + | App (f, args) -> + let () = aux env f in + let fty = Retyping.get_type_of env !evdref f in + let argsty = Array.map (fun x -> aux env x; Retyping.get_type_of env !evdref x) args in + let rec aux i ty = + if i < Array.length argsty then + match kind_of_term (whd_betadeltaiota env !evdref ty) with + | Prod (na, dom, codom) -> + (match conv_algo env !evdref Reduction.CUMUL argsty.(i) dom with + | Success evd -> evdref := evd; + aux (succ i) (subst1 args.(i) codom) + | UnifFailure (evd, reason) -> + Pretype_errors.error_cannot_unify env evd ~reason (argsty.(i), dom)) + | _ -> raise (IllTypedInstance (env, ty, argsty.(i))) + else () + in aux 0 fty + | _ -> + iter_constr_with_full_binders (fun d env -> push_rel d env) aux env t + in aux env t + + (*------------------------------------* * Restricting existing evars * *------------------------------------*) @@ -157,6 +185,7 @@ let restrict_evar_key evd evk filter candidates = end (* Restrict an applied evar and returns its restriction in the same context *) +(* (the filter is assumed to be at least stronger than the original one) *) let restrict_applied_evar evd (evk,argsv) filter candidates = let evd,newevk = restrict_evar_key evd evk filter candidates in let newargsv = match filter with @@ -693,7 +722,8 @@ let rec find_projectable_vars with_evars aliases sigma y subst = (* Then test if [idc] is (indirectly) bound in [subst] to some evar *) (* projectable on [y] *) if with_evars then - let idcl' = List.filter (fun (c,_,id) -> isEvar c) idcl in + let f (c,_,id) = isEvar c && is_undefined sigma (fst (destEvar c)) in + let idcl' = List.filter f idcl in match idcl' with | [c,_,id] -> begin @@ -885,6 +915,9 @@ let filter_candidates evd evk filter candidates_update = else UpdateWith l' +(* Given a filter refinement for the evar [evk], restrict it so that + dependencies are preserved *) + let closure_of_filter evd evk = function | None -> None | Some filter -> @@ -892,8 +925,11 @@ let closure_of_filter evd evk = function let vars = collect_vars (Evarutil.nf_evar evd (evar_concl evi)) in let test b (id,c,_) = b || Idset.mem id vars || match c with None -> false | Some c -> not (isRel c || isVar c) in let newfilter = Filter.map_along test filter (evar_context evi) in + (* Now ensure that restriction is at least what is was originally *) + let newfilter = Option.cata (Filter.map_along (&&) newfilter) newfilter (Filter.repr (evar_filter evi)) in if Filter.equal newfilter (evar_filter evi) then None else Some newfilter +(* The filter is assumed to be at least stronger than the original one *) let restrict_hyps evd evk filter candidates = (* What to do with dependencies? Assume we have x:A, y:B(x), z:C(x,y) |- ?e:T(x,y,z) and restrict on y. @@ -1099,8 +1135,6 @@ let project_evar_on_evar force g env evd aliases k2 pbty (evk1,argsv1 as ev1) (e else raise (CannotProject (evd,ev1')) -exception IllTypedInstance of env * types * types - let check_evar_instance evd evk1 body conv_algo = let evi = Evd.find evd evk1 in let evenv = evar_env evi in @@ -1114,10 +1148,19 @@ let check_evar_instance evd evk1 body conv_algo = | Success evd -> evd | UnifFailure _ -> raise (IllTypedInstance (evenv,ty,evi.evar_concl)) +let update_evar_source ev1 ev2 evd = + let loc, evs2 = evar_source ev2 evd in + match evs2 with + | (Evar_kinds.QuestionMark _ | Evar_kinds.ImplicitArg (_, _, false)) -> + let evi = Evd.find evd ev1 in + Evd.add evd ev1 {evi with evar_source = loc, evs2} + | _ -> evd + let solve_evar_evar_l2r force f g env evd aliases pbty ev1 (evk2,_ as ev2) = try let evd,body = project_evar_on_evar force g env evd aliases 0 pbty ev1 ev2 in let evd' = Evd.define evk2 body evd in + let evd' = update_evar_source (fst (destEvar body)) evk2 evd' in check_evar_instance evd' evk2 body g with EvarSolvedOnTheFly (evd,c) -> f env evd pbty ev2 c @@ -1129,8 +1172,8 @@ let preferred_orientation evd evk1 evk2 = let _,src2 = (Evd.find_undefined evd evk2).evar_source in (* This is a heuristic useful for program to work *) match src1,src2 with - | Evar_kinds.QuestionMark _, _ -> true - | _,Evar_kinds.QuestionMark _ -> false + | (Evar_kinds.QuestionMark _ | Evar_kinds.ImplicitArg (_, _, false)) , _ -> true + | _, (Evar_kinds.QuestionMark _ | Evar_kinds.ImplicitArg (_, _, false)) -> false | _ -> true let solve_evar_evar_aux force f g env evd pbty (evk1,args1 as ev1) (evk2,args2 as ev2) = @@ -1231,12 +1274,24 @@ let solve_candidates conv_algo env evd (evk,argsv) rhs = | [c,evd] -> (* solve_candidates might have been called recursively in the mean *) (* time and the evar been solved by the filtering process *) - if Evd.is_undefined evd evk then Evd.define evk c evd else evd + if Evd.is_undefined evd evk then + let evd' = Evd.define evk c evd in + check_evar_instance evd' evk c conv_algo + else evd | l when List.length l < List.length l' -> let candidates = List.map fst l in restrict_evar evd evk None (UpdateWith candidates) | l -> evd +let occur_evar_upto_types sigma n c = + let rec occur_rec c = match kind_of_term c with + | Evar (sp,_) when Evar.equal sp n -> raise Occur + | Evar e -> Option.iter occur_rec (existential_opt_value sigma e); + occur_rec (existential_type sigma e) + | _ -> iter_constr occur_rec c + in + try occur_rec c; false with Occur -> true + (* We try to instantiate the evar assuming the body won't depend * on arguments that are not Rels or Vars, or appearing several times * (i.e. we tackle a generalization of Miller-Pfenning patterns unification) @@ -1396,10 +1451,10 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = evdref := restrict_evar evd (fst ev'') None (UpdateWith candidates); evar'') | None -> - (* Evar/Rigid problem (or assimilated if not normal): we "imitate" *) - map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1) - imitate envk t in - + (* Evar/Rigid problem (or assimilated if not normal): we "imitate" *) + map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1) + imitate envk t + in let rhs = whd_beta evd rhs (* heuristic *) in let fast rhs = let filter_ctxt = evar_filtered_context evi in @@ -1418,9 +1473,13 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = in let body = if fast rhs then nf_evar evd rhs - else imitate (env,0) rhs - in (!evdref,body) - + else + let t' = imitate (env,0) rhs in + if !progress then + (recheck_applications conv_algo (evar_env evi) evdref t'; t') + else t' + in (!evdref,body) + (* [define] tries to solve the problem "?ev[args] = rhs" when "?ev" is * an (uninstantiated) evar such that "hyps |- ?ev : typ". Otherwise said, * [define] tries to find an instance lhs such that @@ -1445,7 +1504,7 @@ and evar_define conv_algo ?(choose=false) env evd pbty (evk,argsv as ev) rhs = if occur_meta body then raise MetaOccurInBodyInternal; (* invert_definition may have instantiate some evars of rhs with evk *) (* so we recheck acyclicity *) - if occur_evar evk body then raise (OccurCheckIn (evd',body)); + if occur_evar_upto_types evd' evk body then raise (OccurCheckIn (evd',body)); (* needed only if an inferred type *) let evd', body = refresh_universes pbty env evd' body in (* Cannot strictly type instantiations since the unification algorithm diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index 201a16eb..b27803bd 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -525,7 +525,7 @@ let rec check_and_clear_in_constr env evdref err ids c = let clear_hyps_in_evi_main env evdref hyps terms ids = (* clear_hyps_in_evi erases hypotheses ids in hyps, checking if some hypothesis does not depend on a element of ids, and erases ids in - the contexts of the evars occuring in evi *) + the contexts of the evars occurring in evi *) let terms = List.map (check_and_clear_in_constr env evdref (OccurHypInSimpleClause None) ids) terms in let nhyps = @@ -713,9 +713,10 @@ let define_pure_evar_as_product evd evk = let evi = Evd.find_undefined evd evk in let evenv = evar_env evi in let id = next_ident_away idx (ids_of_named_context (evar_context evi)) in - let concl = whd_evar evd evi.evar_concl in + let concl = whd_betadeltaiota evenv evd evi.evar_concl in let s = destSort concl in - let evd1,(dom,u1) = new_type_evar evenv evd univ_flexible_alg ~filter:(evar_filter evi) in + let evd1,(dom,u1) = + new_type_evar evenv evd univ_flexible_alg ~filter:(evar_filter evi) in let evd2,rng = let newenv = push_named (id, None, dom) evenv in let src = evar_source evk evd1 in @@ -724,8 +725,9 @@ let define_pure_evar_as_product evd evk = (* Impredicative product, conclusion must fall in [Prop]. *) new_evar newenv evd1 concl ~src ~filter else + let status = univ_flexible_alg in let evd3, (rng, srng) = - new_type_evar newenv evd1 univ_flexible_alg ~src ~filter in + new_type_evar newenv evd1 status ~src ~filter in let prods = Univ.sup (univ_of_sort u1) (univ_of_sort srng) in let evd3 = Evd.set_leq_sort evenv evd3 (Type prods) s in evd3, rng @@ -757,7 +759,7 @@ let define_evar_as_product evd (evk,args) = let define_pure_evar_as_lambda env evd evk = let evi = Evd.find_undefined evd evk in let evenv = evar_env evi in - let typ = whd_betadeltaiota env evd (evar_concl evi) in + let typ = whd_betadeltaiota evenv evd (evar_concl evi) in let evd1,(na,dom,rng) = match kind_of_term typ with | Prod (na,dom,rng) -> (evd,(na,dom,rng)) | Evar ev' -> let evd,typ = define_evar_as_product evd ev' in evd,destProd typ @@ -795,8 +797,10 @@ let define_evar_as_sort env evd (ev,args) = let evd, u = new_univ_variable univ_rigid evd in let evi = Evd.find_undefined evd ev in let s = Type u in + let concl = whd_betadeltaiota (evar_env evi) evd evi.evar_concl in + let sort = destSort concl in let evd' = Evd.define ev (mkSort s) evd in - Evd.set_leq_sort env evd' (Type (Univ.super u)) (destSort evi.evar_concl), s + Evd.set_leq_sort env evd' (Type (Univ.super u)) sort, s (* We don't try to guess in which sort the type should be defined, since any type has type Type. May cause some trouble, but not so far... *) @@ -844,6 +848,25 @@ let subterm_source evk (loc,k) = (loc,Evar_kinds.SubEvar evk) -(** Term exploration up to isntantiation. *) +(** Term exploration up to instantiation. *) let kind_of_term_upto sigma t = Constr.kind (Reductionops.whd_evar sigma t) + +(** [eq_constr_univs_test sigma1 sigma2 t u] tests equality of [t] and + [u] up to existential variable instantiation and equalisable + universes. The term [t] is interpreted in [sigma1] while [u] is + interpreted in [sigma2]. The universe constraints in [sigma2] are + assumed to be an extention of those in [sigma1]. *) +let eq_constr_univs_test sigma1 sigma2 t u = + (* spiwack: mild code duplication with {!Evd.eq_constr_univs}. *) + let open Evd in + let b, c = + Universes.eq_constr_univs_infer_with + (fun t -> kind_of_term_upto sigma1 t) + (fun u -> kind_of_term_upto sigma2 u) + (universes sigma2) t u + in + if b then + try let _ = add_universe_constraints sigma2 c in true + with Univ.UniverseInconsistency _ | UniversesDiffer -> false + else false diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli index 49036798..f1d94b0a 100644 --- a/pretyping/evarutil.mli +++ b/pretyping/evarutil.mli @@ -206,6 +206,13 @@ val flush_and_check_evars : evar_map -> constr -> constr value of [e] in [sigma] is (recursively) used. *) val kind_of_term_upto : evar_map -> constr -> (constr,types) kind_of_term +(** [eq_constr_univs_test sigma1 sigma2 t u] tests equality of [t] and + [u] up to existential variable instantiation and equalisable + universes. The term [t] is interpreted in [sigma1] while [u] is + interpreted in [sigma2]. The universe constraints in [sigma2] are + assumed to be an extention of those in [sigma1]. *) +val eq_constr_univs_test : evar_map -> evar_map -> constr -> constr -> bool + (** {6 debug pretty-printer:} *) val pr_tycon : env -> type_constraint -> Pp.std_ppcmds diff --git a/pretyping/evd.ml b/pretyping/evd.ml index bf519fb7..4a9466f4 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -277,15 +277,14 @@ end type evar_universe_context = { uctx_names : Univ.Level.t UNameMap.t * string Univ.LMap.t; uctx_local : Univ.universe_context_set; (** The local context of variables *) - uctx_univ_variables : Universes.universe_opt_subst; - (** The local universes that are unification variables *) - uctx_univ_algebraic : Univ.universe_set; - (** The subset of unification variables that - can be instantiated with algebraic universes as they appear in types - and universe instances only. *) - uctx_universes : Univ.universes; (** The current graph extended with the local constraints *) - uctx_initial_universes : Univ.universes; (** The graph at the creation of the evar_map *) - } + uctx_univ_variables : Universes.universe_opt_subst; + (** The local universes that are unification variables *) + uctx_univ_algebraic : Univ.universe_set; + (** The subset of unification variables that can be instantiated with + algebraic universes as they appear in inferred types only. *) + uctx_universes : Univ.universes; (** The current graph extended with the local constraints *) + uctx_initial_universes : Univ.universes; (** The graph at the creation of the evar_map *) + } let empty_evar_universe_context = { uctx_names = UNameMap.empty, Univ.LMap.empty; @@ -310,6 +309,12 @@ let union_evar_universe_context ctx ctx' = else let local = Univ.ContextSet.union ctx.uctx_local ctx'.uctx_local in let names = UNameMap.union (fst ctx.uctx_names) (fst ctx'.uctx_names) in + let newus = Univ.LSet.diff (Univ.ContextSet.levels ctx'.uctx_local) + (Univ.ContextSet.levels ctx.uctx_local) in + let newus = Univ.LSet.diff newus (Univ.LMap.domain ctx.uctx_univ_variables) in + let declarenew g = + Univ.LSet.fold (fun u g -> Univ.add_universe u false g) newus g + in let names_rev = Univ.LMap.union (snd ctx.uctx_names) (snd ctx'.uctx_names) in { uctx_names = (names, names_rev); uctx_local = local; @@ -317,12 +322,12 @@ let union_evar_universe_context ctx ctx' = Univ.LMap.subst_union ctx.uctx_univ_variables ctx'.uctx_univ_variables; uctx_univ_algebraic = Univ.LSet.union ctx.uctx_univ_algebraic ctx'.uctx_univ_algebraic; - uctx_initial_universes = ctx.uctx_initial_universes; + uctx_initial_universes = declarenew ctx.uctx_initial_universes; uctx_universes = if local == ctx.uctx_local then ctx.uctx_universes else let cstrsr = Univ.ContextSet.constraints ctx'.uctx_local in - Univ.merge_constraints cstrsr ctx.uctx_universes } + Univ.merge_constraints cstrsr (declarenew ctx.uctx_universes) } (* let union_evar_universe_context_key = Profile.declare_profile "union_evar_universe_context";; *) (* let union_evar_universe_context = *) @@ -330,17 +335,38 @@ let union_evar_universe_context ctx ctx' = type 'a in_evar_universe_context = 'a * evar_universe_context -let evar_universe_context_set ctx = ctx.uctx_local +let evar_universe_context_set diff ctx = + let initctx = ctx.uctx_local in + let cstrs = + Univ.LSet.fold + (fun l cstrs -> + try + match Univ.LMap.find l ctx.uctx_univ_variables with + | Some u -> Univ.Constraint.add (l, Univ.Eq, Option.get (Univ.Universe.level u)) cstrs + | None -> cstrs + with Not_found | Option.IsNone -> cstrs) + (Univ.Instance.levels (Univ.UContext.instance diff)) Univ.Constraint.empty + in + Univ.ContextSet.add_constraints cstrs initctx + let evar_universe_context_constraints ctx = snd ctx.uctx_local let evar_context_universe_context ctx = Univ.ContextSet.to_context ctx.uctx_local + let evar_universe_context_of ctx = { empty_evar_universe_context with uctx_local = ctx } let evar_universe_context_subst ctx = ctx.uctx_univ_variables +let add_uctx_names s l (names, names_rev) = + (UNameMap.add s l names, Univ.LMap.add l s names_rev) + +let evar_universe_context_of_binders b = + let ctx = empty_evar_universe_context in + let names = + List.fold_left (fun acc (id, l) -> add_uctx_names (Id.to_string id) l acc) + ctx.uctx_names b + in { ctx with uctx_names = names } + let instantiate_variable l b v = - (* let b = Univ.subst_large_constraint (Univ.Universe.make l) Univ.type0m_univ b in *) - (* if Univ.univ_depends (Univ.Universe.make l) b then *) - (* error ("Occur-check in universe variable instantiation") *) - (* else *) v := Univ.LMap.add l (Some b) !v + v := Univ.LMap.add l (Some b) !v exception UniversesDiffer @@ -374,7 +400,7 @@ let process_universe_constraints univs vars alg cstrs = let levels = Univ.Universe.levels l in Univ.LSet.fold (fun l local -> if Univ.Level.is_small l || Univ.LMap.mem l !vars then - Univ.enforce_eq (Univ.Universe.make l) r local + unify_universes fo (Univ.Universe.make l) Universes.UEq r local else raise (Univ.UniverseInconsistency (Univ.Le, Univ.Universe.make l, r, None))) levels local else @@ -406,7 +432,16 @@ let process_universe_constraints univs vars alg cstrs = raise UniversesDiffer in Univ.enforce_eq_level l' r' local - | _, _ (* One of the two is algebraic or global *) -> + | Inr (l, loc, alg), Inl r + | Inl r, Inr (l, loc, alg) -> + let inst = Univ.univ_level_rem l r r in + if alg then (instantiate_variable l inst vars; local) + else + let lu = Univ.Universe.make l in + if Univ.univ_level_mem l r then + Univ.enforce_leq inst lu local + else raise (Univ.UniverseInconsistency (Univ.Eq, lu, r, None)) + | _, _ (* One of the two is algebraic or global *) -> if Univ.check_eq univs l r then local else raise (Univ.UniverseInconsistency (Univ.Eq, l, r, None)) in @@ -433,7 +468,7 @@ let add_constraints_context ctx cstrs = in { ctx with uctx_local = (univs, Univ.Constraint.union local local'); uctx_univ_variables = vars; - uctx_universes = Univ.merge_constraints cstrs ctx.uctx_universes } + uctx_universes = Univ.merge_constraints local' ctx.uctx_universes } (* let addconstrkey = Profile.declare_profile "add_constraints_context";; *) (* let add_constraints_context = Profile.profile2 addconstrkey add_constraints_context;; *) @@ -553,7 +588,7 @@ type evar_map = { (** Metas *) metas : clbinding Metamap.t; (** Interactive proofs *) - effects : Declareops.side_effects; + effects : Safe_typing.private_constants; future_goals : Evar.t list; (** list of newly created evars, to be eventually turned into goals if not solved.*) principal_future_goal : Evar.t option; (** if [Some e], [e] must be @@ -564,6 +599,7 @@ type evar_map = { name) of the evar which will be instantiated with a term containing [e]. *) + extras : Store.t; } (*** Lifting primitive from Evar.Map. ***) @@ -723,7 +759,7 @@ let cmap f evd = { evd with metas = Metamap.map (map_clb f) evd.metas; defn_evars = EvMap.map (map_evar_info f) evd.defn_evars; - undf_evars = EvMap.map (map_evar_info f) evd.defn_evars + undf_evars = EvMap.map (map_evar_info f) evd.undf_evars } (* spiwack: deprecated *) @@ -741,16 +777,17 @@ let empty = { conv_pbs = []; last_mods = Evar.Set.empty; metas = Metamap.empty; - effects = Declareops.no_seff; + effects = Safe_typing.empty_private_constants; evar_names = (EvMap.empty,Idmap.empty); (* id<->key for undefined evars *) future_goals = []; principal_future_goal = None; + extras = Store.empty; } -let from_env ?ctx e = - match ctx with - | None -> { empty with universes = evar_universe_context_from e } - | Some ctx -> { empty with universes = ctx } +let from_env e = + { empty with universes = evar_universe_context_from e } + +let from_ctx ctx = { empty with universes = ctx } let has_undefined evd = not (EvMap.is_empty evd.undf_evars) @@ -914,38 +951,6 @@ let evars_of_filtered_evar_info evi = (evars_of_named_context (evar_filtered_context evi))) (**********************************************************) -(* Side effects *) - -let emit_side_effects eff evd = - { evd with effects = Declareops.union_side_effects eff evd.effects; } - -let drop_side_effects evd = - { evd with effects = Declareops.no_seff; } - -let eval_side_effects evd = evd.effects - -(* Future goals *) -let declare_future_goal evk evd = - { evd with future_goals = evk::evd.future_goals } - -let declare_principal_goal evk evd = - match evd.principal_future_goal with - | None -> { evd with - future_goals = evk::evd.future_goals; - principal_future_goal=Some evk; } - | Some _ -> Errors.error "Only one main subgoal per instantiation." - -let future_goals evd = evd.future_goals - -let principal_future_goal evd = evd.principal_future_goal - -let reset_future_goals evd = - { evd with future_goals = [] ; principal_future_goal=None } - -let restore_future_goals evd gls pgl = - { evd with future_goals = gls ; principal_future_goal = pgl } - -(**********************************************************) (* Sort variables *) type rigid = @@ -960,19 +965,56 @@ let evar_universe_context d = d.universes let universe_context_set d = d.universes.uctx_local -let universe_context evd = - Univ.ContextSet.to_context evd.universes.uctx_local +let pr_uctx_level uctx = + let map, map_rev = uctx.uctx_names in + fun l -> + try str(Univ.LMap.find l map_rev) + with Not_found -> + Universes.pr_with_global_universes l +let universe_context ?names evd = + match names with + | None -> [], Univ.ContextSet.to_context evd.universes.uctx_local + | Some pl -> + let levels = Univ.ContextSet.levels evd.universes.uctx_local in + let newinst, map, left = + List.fold_right + (fun (loc,id) (newinst, map, acc) -> + let l = + try UNameMap.find (Id.to_string id) (fst evd.universes.uctx_names) + with Not_found -> + user_err_loc (loc, "universe_context", + str"Universe " ++ pr_id id ++ str" is not bound anymore.") + in (l :: newinst, (id, l) :: map, Univ.LSet.remove l acc)) + pl ([], [], levels) + in + if not (Univ.LSet.is_empty left) then + let n = Univ.LSet.cardinal left in + errorlabstrm "universe_context" + (str(CString.plural n "Universe") ++ spc () ++ + Univ.LSet.pr (pr_uctx_level evd.universes) left ++ + spc () ++ str (CString.conjugate_verb_to_be n) ++ str" unbound.") + else + let inst = Univ.Instance.of_array (Array.of_list newinst) in + let ctx = Univ.UContext.make (inst, + Univ.ContextSet.constraints evd.universes.uctx_local) + in map, ctx + +let restrict_universe_context evd vars = + let uctx = evd.universes in + let uctx' = Universes.restrict_universe_context uctx.uctx_local vars in + { evd with universes = { uctx with uctx_local = uctx' } } + let universe_subst evd = evd.universes.uctx_univ_variables -let merge_uctx rigid uctx ctx' = +let merge_uctx sideff rigid uctx ctx' = let open Univ in - let uctx = + let levels = ContextSet.levels ctx' in + let uctx = if sideff then uctx else match rigid with | UnivRigid -> uctx | UnivFlexible b -> - let levels = ContextSet.levels ctx' in let fold u accu = if LMap.mem u accu then accu else LMap.add u None accu @@ -983,12 +1025,23 @@ let merge_uctx rigid uctx ctx' = uctx_univ_algebraic = LSet.union uctx.uctx_univ_algebraic levels } else { uctx with uctx_univ_variables = uvars' } in - let uctx_local = ContextSet.append ctx' uctx.uctx_local in - let uctx_universes = merge_constraints (ContextSet.constraints ctx') uctx.uctx_universes in - { uctx with uctx_local; uctx_universes } + let uctx_local = + if sideff then uctx.uctx_local + else ContextSet.append ctx' uctx.uctx_local + in + let declare g = + LSet.fold (fun u g -> + try Univ.add_universe u false g + with Univ.AlreadyDeclared when sideff -> g) + levels g + in + let initial = declare uctx.uctx_initial_universes in + let univs = declare uctx.uctx_universes in + let uctx_universes = merge_constraints (ContextSet.constraints ctx') univs in + { uctx with uctx_local; uctx_universes; uctx_initial_universes = initial } -let merge_context_set rigid evd ctx' = - {evd with universes = merge_uctx rigid evd.universes ctx'} +let merge_context_set ?(sideff=false) rigid evd ctx' = + {evd with universes = merge_uctx sideff rigid evd.universes ctx'} let merge_uctx_subst uctx s = { uctx with uctx_univ_variables = Univ.LMap.subst_union uctx.uctx_univ_variables s } @@ -999,41 +1052,61 @@ let merge_universe_subst evd subst = let with_context_set rigid d (a, ctx) = (merge_context_set rigid d ctx, a) -let add_uctx_names s l (names, names_rev) = - (UNameMap.add s l names, Univ.LMap.add l s names_rev) - -let uctx_new_univ_variable rigid name +let emit_universe_side_effects eff u = + let uctxs = Safe_typing.universes_of_private eff in + List.fold_left (merge_uctx true univ_rigid) u uctxs + +let uctx_new_univ_variable rigid name predicative ({ uctx_local = ctx; uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as uctx) = let u = Universes.new_univ_level (Global.current_dirpath ()) in let ctx' = Univ.ContextSet.add_universe u ctx in - let uctx' = + let uctx', pred = match rigid with - | UnivRigid -> uctx + | UnivRigid -> uctx, true | UnivFlexible b -> let uvars' = Univ.LMap.add u None uvars in if b then {uctx with uctx_univ_variables = uvars'; - uctx_univ_algebraic = Univ.LSet.add u avars} - else {uctx with uctx_univ_variables = Univ.LMap.add u None uvars} in + uctx_univ_algebraic = Univ.LSet.add u avars}, false + else {uctx with uctx_univ_variables = uvars'}, false + in let names = match name with | Some n -> add_uctx_names n u uctx.uctx_names | None -> uctx.uctx_names in + let initial = + Univ.add_universe u false uctx.uctx_initial_universes + in + let uctx' = {uctx' with uctx_names = names; uctx_local = ctx'; - uctx_universes = Univ.add_universe u uctx.uctx_universes}, u - -let new_univ_level_variable ?name rigid evd = - let uctx', u = uctx_new_univ_variable rigid name evd.universes in + uctx_universes = Univ.add_universe u false uctx.uctx_universes; + uctx_initial_universes = initial} + in uctx', u + +let new_univ_level_variable ?name ?(predicative=true) rigid evd = + let uctx', u = uctx_new_univ_variable rigid name predicative evd.universes in ({evd with universes = uctx'}, u) -let new_univ_variable ?name rigid evd = - let uctx', u = uctx_new_univ_variable rigid name evd.universes in +let new_univ_variable ?name ?(predicative=true) rigid evd = + let uctx', u = uctx_new_univ_variable rigid name predicative evd.universes in ({evd with universes = uctx'}, Univ.Universe.make u) -let new_sort_variable ?name rigid d = - let (d', u) = new_univ_variable rigid ?name d in +let new_sort_variable ?name ?(predicative=true) rigid d = + let (d', u) = new_univ_variable rigid ?name ~predicative d in (d', Type u) +let add_global_univ d u = + let uctx = d.universes in + let initial = + Univ.add_universe u true uctx.uctx_initial_universes + in + let univs = + Univ.add_universe u true uctx.uctx_universes + in + { d with universes = { uctx with uctx_local = Univ.ContextSet.add_universe u uctx.uctx_local; + uctx_initial_universes = initial; + uctx_universes = univs } } + let make_flexible_variable evd b u = let {uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as ctx = evd.universes in let uvars' = Univ.LMap.add u None uvars in @@ -1050,6 +1123,16 @@ let make_flexible_variable evd b u = {evd with universes = {ctx with uctx_univ_variables = uvars'; uctx_univ_algebraic = avars'}} +let make_evar_universe_context e l = + let uctx = evar_universe_context_from e in + match l with + | None -> uctx + | Some us -> + List.fold_left + (fun uctx (loc,id) -> + fst (uctx_new_univ_variable univ_rigid (Some (Id.to_string id)) true uctx)) + uctx us + (****************************************) (* Operations on constants *) (****************************************) @@ -1213,12 +1296,16 @@ let refresh_undefined_univ_variables uctx = Univ.LMap.add (Univ.subst_univs_level_level subst u) (Option.map (Univ.subst_univs_level_universe subst) v) acc) uctx.uctx_univ_variables Univ.LMap.empty - in + in + let declare g = Univ.LSet.fold (fun u g -> Univ.add_universe u false g) + (Univ.ContextSet.levels ctx') g in + let initial = declare uctx.uctx_initial_universes in + let univs = declare Univ.initial_universes in let uctx' = {uctx_names = uctx.uctx_names; uctx_local = ctx'; uctx_univ_variables = vars; uctx_univ_algebraic = alg; - uctx_universes = Univ.initial_universes; - uctx_initial_universes = uctx.uctx_initial_universes } in + uctx_universes = univs; + uctx_initial_universes = initial } in uctx', subst let refresh_undefined_universes evd = @@ -1232,8 +1319,7 @@ let normalize_evar_universe_context uctx = Universes.normalize_context_set uctx.uctx_local uctx.uctx_univ_variables uctx.uctx_univ_algebraic in - if Univ.LSet.equal (fst us') (fst uctx.uctx_local) then - uctx + if Univ.ContextSet.equal us' uctx.uctx_local then uctx else let us', universes = Universes.refresh_constraints uctx.uctx_initial_universes us' in let uctx' = @@ -1271,9 +1357,18 @@ let add_universe_name evd s l = let universes evd = evd.universes.uctx_universes +let update_sigma_env evd env = + let univs = Environ.universes env in + let eunivs = + { evd.universes with uctx_initial_universes = univs; + uctx_universes = univs } + in + let eunivs = merge_uctx true univ_rigid eunivs eunivs.uctx_local in + { evd with universes = eunivs } + (* Conversion w.r.t. an evar map and its local universes. *) -let conversion_gen env evd pb t u = +let test_conversion_gen env evd pb t u = match pb with | Reduction.CONV -> Reduction.trans_conv_universes @@ -1283,14 +1378,8 @@ let conversion_gen env evd pb t u = full_transparent_state ~evars:(existential_opt_value evd) env evd.universes.uctx_universes t u -(* let conversion_gen_key = Profile.declare_profile "conversion_gen" *) -(* let conversion_gen = Profile.profile5 conversion_gen_key conversion_gen *) - -let conversion env d pb t u = - conversion_gen env d pb t u; d - let test_conversion env d pb t u = - try conversion_gen env d pb t u; true + try test_conversion_gen env d pb t u; true with _ -> false let eq_constr_univs evd t u = @@ -1304,8 +1393,38 @@ let e_eq_constr_univs evdref t u = let evd, b = eq_constr_univs !evdref t u in evdref := evd; b -let eq_constr_univs_test evd t u = - snd (eq_constr_univs evd t u) +(**********************************************************) +(* Side effects *) + +let emit_side_effects eff evd = + { evd with effects = Safe_typing.concat_private eff evd.effects; + universes = emit_universe_side_effects eff evd.universes } + +let drop_side_effects evd = + { evd with effects = Safe_typing.empty_private_constants; } + +let eval_side_effects evd = evd.effects + +(* Future goals *) +let declare_future_goal evk evd = + { evd with future_goals = evk::evd.future_goals } + +let declare_principal_goal evk evd = + match evd.principal_future_goal with + | None -> { evd with + future_goals = evk::evd.future_goals; + principal_future_goal=Some evk; } + | Some _ -> Errors.error "Only one main subgoal per instantiation." + +let future_goals evd = evd.future_goals + +let principal_future_goal evd = evd.principal_future_goal + +let reset_future_goals evd = + { evd with future_goals = [] ; principal_future_goal=None } + +let restore_future_goals evd gls pgl = + { evd with future_goals = gls ; principal_future_goal = pgl } (**********************************************************) (* Accessing metas *) @@ -1323,6 +1442,7 @@ let set_metas evd metas = { evar_names = evd.evar_names; future_goals = evd.future_goals; principal_future_goal = evd.principal_future_goal; + extras = evd.extras; } let meta_list evd = metamap_to_list evd.metas @@ -1471,6 +1591,12 @@ let dependent_evar_ident ev evd = | (_,Evar_kinds.VarInstance id) -> id | _ -> anomaly (str "Not an evar resulting of a dependent binding") +(**********************************************************) +(* Extra data *) + +let get_extra_data evd = evd.extras +let set_extra_data extras evd = { evd with extras } + (*******************************************************************) type pending = (* before: *) evar_map * (* after: *) evar_map @@ -1677,13 +1803,6 @@ let evar_dependency_closure n sigma = let has_no_evar sigma = EvMap.is_empty sigma.defn_evars && EvMap.is_empty sigma.undf_evars -let pr_uctx_level uctx = - let map, map_rev = uctx.uctx_names in - fun l -> - try str(Univ.LMap.find l map_rev) - with Not_found -> - Universes.pr_with_global_universes l - let pr_evd_level evd = pr_uctx_level evd.universes let pr_evar_universe_context ctx = diff --git a/pretyping/evd.mli b/pretyping/evd.mli index fe785a83..5c508419 100644 --- a/pretyping/evd.mli +++ b/pretyping/evd.mli @@ -129,10 +129,13 @@ type evar_map val empty : evar_map (** The empty evar map. *) -val from_env : ?ctx:evar_universe_context -> env -> evar_map +val from_env : env -> evar_map (** The empty evar map with given universe context, taking its initial universes from env. *) +val from_ctx : evar_universe_context -> evar_map +(** The empty evar map with given universe context *) + val is_empty : evar_map -> bool (** Whether an evarmap is empty. *) @@ -258,10 +261,10 @@ val dependent_evar_ident : existential_key -> evar_map -> Id.t (** {5 Side-effects} *) -val emit_side_effects : Declareops.side_effects -> evar_map -> evar_map +val emit_side_effects : Safe_typing.private_constants -> evar_map -> evar_map (** Push a side-effect into the evar map. *) -val eval_side_effects : evar_map -> Declareops.side_effects +val eval_side_effects : evar_map -> Safe_typing.private_constants (** Return the effects contained in the evar map. *) val drop_side_effects : evar_map -> evar_map @@ -310,6 +313,19 @@ val add_universe_constraints : evar_map -> Universes.universe_constraints -> eva @raises UniversesDiffer in case a first-order unification fails. @raises UniverseInconsistency *) + +(** {5 Extra data} + + Evar maps can contain arbitrary data, allowing to use an extensible state. + As evar maps are theoretically used in a strict state-passing style, such + additional data should be passed along transparently. Some old and bug-prone + code tends to drop them nonetheless, so you should keep cautious. + +*) + +val get_extra_data : evar_map -> Store.t +val set_extra_data : Store.t -> evar_map -> evar_map + (** {5 Enriching with evar maps} *) type 'a sigma = { @@ -462,7 +478,7 @@ val univ_flexible_alg : rigid type 'a in_evar_universe_context = 'a * evar_universe_context -val evar_universe_context_set : evar_universe_context -> Univ.universe_context_set +val evar_universe_context_set : Univ.universe_context -> evar_universe_context -> Univ.universe_context_set val evar_universe_context_constraints : evar_universe_context -> Univ.constraints val evar_context_universe_context : evar_universe_context -> Univ.universe_context val evar_universe_context_of : Univ.universe_context_set -> evar_universe_context @@ -471,6 +487,11 @@ val union_evar_universe_context : evar_universe_context -> evar_universe_context evar_universe_context val evar_universe_context_subst : evar_universe_context -> Universes.universe_opt_subst +val evar_universe_context_of_binders : + Universes.universe_binders -> evar_universe_context + +val make_evar_universe_context : env -> (Id.t located) list option -> evar_universe_context +val restrict_universe_context : evar_map -> Univ.universe_set -> evar_map (** Raises Not_found if not a name for a universe in this map. *) val universe_of_name : evar_map -> string -> Univ.universe_level val add_universe_name : evar_map -> string -> Univ.universe_level -> evar_map @@ -487,9 +508,11 @@ val normalize_evar_universe_context_variables : evar_universe_context -> val normalize_evar_universe_context : evar_universe_context -> evar_universe_context -val new_univ_level_variable : ?name:string -> rigid -> evar_map -> evar_map * Univ.universe_level -val new_univ_variable : ?name:string -> rigid -> evar_map -> evar_map * Univ.universe -val new_sort_variable : ?name:string -> rigid -> evar_map -> evar_map * sorts +val new_univ_level_variable : ?name:string -> ?predicative:bool -> rigid -> evar_map -> evar_map * Univ.universe_level +val new_univ_variable : ?name:string -> ?predicative:bool -> rigid -> evar_map -> evar_map * Univ.universe +val new_sort_variable : ?name:string -> ?predicative:bool -> rigid -> evar_map -> evar_map * sorts +val add_global_univ : evar_map -> Univ.Level.t -> evar_map + val make_flexible_variable : evar_map -> bool -> Univ.universe_level -> evar_map val is_sort_variable : evar_map -> sorts -> Univ.universe_level option (** [is_sort_variable evm s] returns [Some u] or [None] if [s] is @@ -514,7 +537,8 @@ val check_leq : evar_map -> Univ.universe -> Univ.universe -> bool val evar_universe_context : evar_map -> evar_universe_context val universe_context_set : evar_map -> Univ.universe_context_set -val universe_context : evar_map -> Univ.universe_context +val universe_context : ?names:(Id.t located) list -> evar_map -> + (Id.t * Univ.Level.t) list * Univ.universe_context val universe_subst : evar_map -> Universes.universe_opt_subst val universes : evar_map -> Univ.universes @@ -522,7 +546,7 @@ val universes : evar_map -> Univ.universes val merge_universe_context : evar_map -> evar_universe_context -> evar_map val set_universe_context : evar_map -> evar_universe_context -> evar_map -val merge_context_set : rigid -> evar_map -> Univ.universe_context_set -> evar_map +val merge_context_set : ?sideff:bool -> rigid -> evar_map -> Univ.universe_context_set -> evar_map val merge_universe_subst : evar_map -> Universes.universe_opt_subst -> evar_map val with_context_set : rigid -> evar_map -> 'a Univ.in_universe_context_set -> evar_map * 'a @@ -536,6 +560,8 @@ val refresh_undefined_universes : evar_map -> evar_map * Univ.universe_level_sub val nf_constraints : evar_map -> evar_map +val update_sigma_env : evar_map -> env -> evar_map + (** Polymorphic universes *) val fresh_sort_in_family : ?rigid:rigid -> env -> evar_map -> sorts_family -> evar_map * sorts @@ -547,14 +573,11 @@ val fresh_global : ?rigid:rigid -> ?names:Univ.Instance.t -> env -> evar_map -> Globnames.global_reference -> evar_map * constr (******************************************************************** - Conversion w.r.t. an evar map: might generate universe unifications - that are kept in the evarmap. - Raises [NotConvertible]. *) - -val conversion : env -> evar_map -> conv_pb -> constr -> constr -> evar_map + Conversion w.r.t. an evar map, not unifying universes. See + [Reductionops.infer_conv] for conversion up-to universes. *) val test_conversion : env -> evar_map -> conv_pb -> constr -> constr -> bool -(** This one forgets about the assignemts of universes. *) +(** WARNING: This does not allow unification of universes *) val eq_constr_univs : evar_map -> constr -> constr -> evar_map * bool (** Syntactic equality up to universes, recording the associated constraints *) @@ -562,10 +585,6 @@ val eq_constr_univs : evar_map -> constr -> constr -> evar_map * bool val e_eq_constr_univs : evar_map ref -> constr -> constr -> bool (** Syntactic equality up to universes. *) -val eq_constr_univs_test : evar_map -> constr -> constr -> bool -(** Syntactic equality up to universes, throwing away the (consistent) constraints - in case of success. *) - (********************************************************************) (* constr with holes and pending resolution of classes, conversion *) (* problems, candidates, etc. *) diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index 454d64f0..3a76e8bd 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -8,6 +8,7 @@ open Util open Names +open Nameops open Globnames open Misctypes open Glob_term @@ -183,37 +184,32 @@ let map_glob_constr_left_to_right f = function let map_glob_constr = map_glob_constr_left_to_right -let fold_glob_constr f acc = - let rec fold acc = function +let fold_return_type f acc (na,tyopt) = Option.fold_left f acc tyopt + +let fold_glob_constr f acc = function | GVar _ -> acc - | GApp (_,c,args) -> List.fold_left fold (fold acc c) args + | GApp (_,c,args) -> List.fold_left f (f acc c) args | GLambda (_,_,_,b,c) | GProd (_,_,_,b,c) | GLetIn (_,_,b,c) -> - fold (fold acc b) c + f (f acc b) c | GCases (_,_,rtntypopt,tml,pl) -> - List.fold_left fold_pattern - (List.fold_left fold (Option.fold_left fold acc rtntypopt) (List.map fst tml)) - pl - | GLetTuple (_,_,rtntyp,b,c) -> - fold (fold (fold_return_type acc rtntyp) b) c - | GIf (_,c,rtntyp,b1,b2) -> - fold (fold (fold (fold_return_type acc rtntyp) c) b1) b2 - | GRec (_,_,_,bl,tyl,bv) -> - let acc = Array.fold_left - (List.fold_left (fun acc (na,k,bbd,bty) -> - fold (Option.fold_left fold acc bbd) bty)) acc bl in - Array.fold_left fold (Array.fold_left fold acc tyl) bv - | GCast (_,c,k) -> - let r = match k with - | CastConv t | CastVM t | CastNative t -> fold acc t | CastCoerce -> acc - in - fold r c - | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> acc - - and fold_pattern acc (_,idl,p,c) = fold acc c - - and fold_return_type acc (na,tyopt) = Option.fold_left fold acc tyopt - - in fold acc + let fold_pattern acc (_,idl,p,c) = f acc c in + List.fold_left fold_pattern + (List.fold_left f (Option.fold_left f acc rtntypopt) (List.map fst tml)) + pl + | GLetTuple (_,_,rtntyp,b,c) -> + f (f (fold_return_type f acc rtntyp) b) c + | GIf (_,c,rtntyp,b1,b2) -> + f (f (f (fold_return_type f acc rtntyp) c) b1) b2 + | GRec (_,_,_,bl,tyl,bv) -> + let acc = Array.fold_left + (List.fold_left (fun acc (na,k,bbd,bty) -> + f (Option.fold_left f acc bbd) bty)) acc bl in + Array.fold_left f (Array.fold_left f acc tyl) bv + | GCast (_,c,k) -> + let acc = match k with + | CastConv t | CastVM t | CastNative t -> f acc t | CastCoerce -> acc in + f acc c + | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _) -> acc let iter_glob_constr f = fold_glob_constr (fun () -> f) () @@ -328,6 +324,65 @@ let free_glob_vars = let vs = vars Id.Set.empty Id.Set.empty rt in Id.Set.elements vs +let add_and_check_ident id set = + if Id.Set.mem id set then + Pp.(msg_warning + (str "Collision between bound variables of name " ++ Id.print id)); + Id.Set.add id set + +let bound_glob_vars = + let rec vars bound = function + | GLambda (_,na,_,_,_) | GProd (_,na,_,_,_) | GLetIn (_,na,_,_) as c -> + let bound = name_fold add_and_check_ident na bound in + fold_glob_constr vars bound c + | GCases (loc,sty,rtntypopt,tml,pl) -> + let bound = vars_option bound rtntypopt in + let bound = + List.fold_left (fun bound (tm,_) -> vars bound tm) bound tml in + List.fold_left vars_pattern bound pl + | GLetTuple (loc,nal,rtntyp,b,c) -> + let bound = vars_return_type bound rtntyp in + let bound = vars bound b in + let bound = List.fold_right (name_fold add_and_check_ident) nal bound in + vars bound c + | GIf (loc,c,rtntyp,b1,b2) -> + let bound = vars_return_type bound rtntyp in + let bound = vars bound c in + let bound = vars bound b1 in + vars bound b2 + | GRec (loc,fk,idl,bl,tyl,bv) -> + let bound = Array.fold_right Id.Set.add idl bound in + let vars_fix i bound fid = + let bound = + List.fold_left + (fun bound (na,k,bbd,bty) -> + let bound = vars_option bound bbd in + let bound = vars bound bty in + name_fold add_and_check_ident na bound + ) + bound + bl.(i) + in + let bound = vars bound tyl.(i) in + vars bound bv.(i) + in + Array.fold_left_i vars_fix bound idl + | (GSort _ | GHole _ | GRef _ | GEvar _ | GPatVar _ | GVar _) -> bound + | GApp _ | GCast _ as c -> fold_glob_constr vars bound c + + and vars_pattern bound (loc,idl,p,c) = + let bound = List.fold_right add_and_check_ident idl bound in + vars bound c + + and vars_option bound = function None -> bound | Some p -> vars bound p + + and vars_return_type bound (na,tyopt) = + let bound = name_fold add_and_check_ident na bound in + vars_option bound tyopt + in + fun rt -> + vars Id.Set.empty rt + (** Mapping of names in binders *) (* spiwack: I used a smartmap-style kind of mapping here, because the diff --git a/pretyping/glob_ops.mli b/pretyping/glob_ops.mli index e514fd52..25746323 100644 --- a/pretyping/glob_ops.mli +++ b/pretyping/glob_ops.mli @@ -38,6 +38,7 @@ val fold_glob_constr : ('a -> glob_constr -> 'a) -> 'a -> glob_constr -> 'a val iter_glob_constr : (glob_constr -> unit) -> glob_constr -> unit val occur_glob_constr : Id.t -> glob_constr -> bool val free_glob_vars : glob_constr -> Id.t list +val bound_glob_vars : glob_constr -> Id.Set.t val loc_of_glob_constr : glob_constr -> Loc.t (** [map_pattern_binders f m c] applies [f] to all the binding names diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index dfdc24d4..cb091f2d 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -322,7 +322,8 @@ let instantiate_params t args sign = let get_constructor ((ind,u as indu),mib,mip,params) j = assert (j <= Array.length mip.mind_consnames); let typi = mis_nf_constructor_type (indu,mib,mip) j in - let typi = instantiate_params typi params mib.mind_params_ctxt in + let ctx = Vars.subst_instance_context u mib.mind_params_ctxt in + let typi = instantiate_params typi params ctx in let (args,ccl) = decompose_prod_assum typi in let (_,allargs) = decompose_app ccl in let vargs = List.skipn (List.length params) allargs in @@ -584,6 +585,15 @@ let type_of_inductive_knowing_conclusion env sigma ((mib,mip),u) conclty = env evdref scl ar.template_level (ctx,ar.template_param_levels) in !evdref, mkArity (List.rev ctx,scl) +let type_of_projection_knowing_arg env sigma p c ty = + let IndType(pars,realargs) = + try find_rectype env sigma ty + with Not_found -> + raise (Invalid_argument "type_of_projection_knowing_arg_type: not an inductive type") + in + let (_,u), pars = dest_ind_family pars in + substl (c :: List.rev pars) (Typeops.type_of_projection env (p,u)) + (***********************************************) (* Guard condition *) diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index 7959759a..757599a3 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -126,6 +126,8 @@ val allowed_sorts : env -> inductive -> sorts_family list (** Primitive projections *) val projection_nparams : projection -> int val projection_nparams_env : env -> projection -> int +val type_of_projection_knowing_arg : env -> evar_map -> Projection.t -> + constr -> types -> types (** Extract information from an inductive family *) diff --git a/pretyping/miscops.ml b/pretyping/miscops.ml index a2c97d2c..a0ec1baa 100644 --- a/pretyping/miscops.ml +++ b/pretyping/miscops.ml @@ -30,7 +30,7 @@ let smartmap_cast_type f c = let glob_sort_eq g1 g2 = match g1, g2 with | GProp, GProp -> true | GSet, GSet -> true -| GType l1, GType l2 -> List.for_all2 CString.equal l1 l2 +| GType l1, GType l2 -> List.equal (fun x y -> CString.equal (snd x) (snd y)) l1 l2 | _ -> false let intro_pattern_naming_eq nam1 nam2 = match nam1, nam2 with diff --git a/pretyping/namegen.ml b/pretyping/namegen.ml index 5aca11ae..a88c2e20 100644 --- a/pretyping/namegen.ml +++ b/pretyping/namegen.ml @@ -278,6 +278,7 @@ let make_all_name_different env = let avoid = ref (ids_of_named_context (named_context env)) in process_rel_context (fun (na,c,t) newenv -> + let na = named_hd newenv t na in let id = next_name_away na !avoid in avoid := id::!avoid; push_rel (Name id,c,t) newenv) diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index bd427ecd..de988aa2 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -22,11 +22,6 @@ open Nativelambda (** This module implements normalization by evaluation to OCaml code *) -let evars_of_evar_map evd = - { evars_val = Evd.existential_opt_value evd; - evars_typ = Evd.existential_type evd; - evars_metas = Evd.meta_type evd } - exception Find_at of int let invert_tag cst tag reloc_tbl = @@ -58,8 +53,8 @@ let find_rectype_a env c = (* Instantiate inductives and parameters in constructor type *) -let type_constructor mind mib typ params = - let s = ind_subst mind mib Univ.Instance.empty (* FIXME *)in +let type_constructor mind mib u typ params = + let s = ind_subst mind mib u in let ctyp = substl s typ in let nparams = Array.length params in if Int.equal nparams 0 then ctyp @@ -73,13 +68,13 @@ let construct_of_constr_notnative const env tag (mind, _ as ind) u allargs = let params = Array.sub allargs 0 nparams in try if const then - let ctyp = type_constructor mind mib (mip.mind_nf_lc.(0)) params in + let ctyp = type_constructor mind mib u (mip.mind_nf_lc.(0)) params in retroknowledge Retroknowledge.get_vm_decompile_constant_info env (mkInd ind) tag, ctyp else raise Not_found with Not_found -> let i = invert_tag const tag mip.mind_reloc_tbl in - let ctyp = type_constructor mind mib (mip.mind_nf_lc.(i-1)) params in + let ctyp = type_constructor mind mib u (mip.mind_nf_lc.(i-1)) params in (mkApp(mkConstructU((ind,i),u), params), ctyp) @@ -95,12 +90,12 @@ let construct_of_constr_const env tag typ = let construct_of_constr_block = construct_of_constr false -let build_branches_type env (mind,_ as _ind) mib mip params dep p = +let build_branches_type env (mind,_ as _ind) mib mip u params dep p = let rtbl = mip.mind_reloc_tbl in (* [build_one_branch i cty] construit le type de la ieme branche (commence a 0) et les lambda correspondant aux realargs *) let build_one_branch i cty = - let typi = type_constructor mind mib cty params in + let typi = type_constructor mind mib u cty params in let decl,indapp = Reductionops.splay_prod env Evd.empty typi in let decl_with_letin,_ = decompose_prod_assum typi in let ind,cargs = find_rectype_a env indapp in @@ -150,14 +145,12 @@ let sort_of_product env domsort rangsort = | (Prop _, Prop Pos) -> rangsort (* Product rule (Type,Set,?) *) | (Type u1, Prop Pos) -> - begin match engagement env with - | Some ImpredicativeSet -> + if is_impredicative_set env then (* Rule is (Type,Set,Set) in the Set-impredicative calculus *) rangsort - | _ -> + else (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *) Type (sup u1 type0_univ) - end (* Product rule (Prop,Type_i,Type_i) *) | (Prop Pos, Type u2) -> Type (sup type0_univ u2) (* Product rule (Prop,Type_i,Type_i) *) @@ -271,7 +264,7 @@ and nf_atom env atom = | Aevar (ev,_) -> mkEvar ev | Aproj(p,c) -> let c = nf_accu env c in - mkProj(Projection.make p false,c) + mkProj(Projection.make p true,c) | _ -> fst (nf_atom_type env atom) and nf_atom_type env atom = @@ -299,7 +292,7 @@ and nf_atom_type env atom = let pT = whd_betadeltaiota env pT in let dep, p = nf_predicate env ind mip params p pT in (* Calcul du type des branches *) - let btypes = build_branches_type env (fst ind) mib mip params dep p in + let btypes = build_branches_type env (fst ind) mib mip u params dep p in (* calcul des branches *) let bsw = branch_of_switch (nb_rel env) ans bs in let mkbranch i v = @@ -377,11 +370,17 @@ and nf_predicate env ind mip params v pT = true, mkLambda(name,dom,body) | _, _ -> false, nf_type env v +let evars_of_evar_map sigma = + { Nativelambda.evars_val = Evd.existential_opt_value sigma; + Nativelambda.evars_typ = Evd.existential_type sigma; + Nativelambda.evars_metas = Evd.meta_type sigma } + let native_norm env sigma c ty = - if !Flags.no_native_compiler then - error "Native_compute reduction has been disabled" + if Coq_config.no_native_compiler then + error "Native_compute reduction has been disabled at configure time." else - let penv = Environ.pre_env env in + let penv = Environ.pre_env env in + let sigma = evars_of_evar_map sigma in (* Format.eprintf "Numbers of free variables (named): %i\n" (List.length vl1); Format.eprintf "Numbers of free variables (rel): %i\n" (List.length vl2); @@ -402,3 +401,10 @@ let native_norm env sigma c ty = if !Flags.debug then Pp.msg_debug (Pp.str time_info); res | _ -> anomaly (Pp.str "Compilation failure") + +let native_conv_generic pb sigma t = + Nativeconv.native_conv_gen pb (evars_of_evar_map sigma) t + +let native_infer_conv ?(pb=Reduction.CUMUL) env sigma t1 t2 = + Reductionops.infer_conv_gen (fun pb ~l2r sigma ts -> native_conv_generic pb sigma) + ~catch_incon:true ~pb env sigma t1 t2 diff --git a/pretyping/nativenorm.mli b/pretyping/nativenorm.mli index c854e8c9..03520383 100644 --- a/pretyping/nativenorm.mli +++ b/pretyping/nativenorm.mli @@ -12,6 +12,8 @@ open Nativelambda (** This module implements normalization by evaluation to OCaml code *) -val evars_of_evar_map : evar_map -> evars +val native_norm : env -> evar_map -> constr -> types -> constr -val native_norm : env -> evars -> constr -> types -> constr +(** Conversion with inference of universe constraints *) +val native_infer_conv : ?pb:conv_pb -> env -> evar_map -> constr -> constr -> + evar_map * bool diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 705e594a..fb629d04 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -395,7 +395,9 @@ let rec pat_of_raw metas vars = function | Some p, Some (_,_,nal) -> let nvars = na :: List.rev nal @ vars in rev_it_mkPLambda nal (mkPLambda na (pat_of_raw metas nvars p)) - | _ -> PMeta None + | (None | Some (GHole _)), _ -> PMeta None + | Some p, None -> + user_err_loc (loc,"",strbrk "Clause \"in\" expected in patterns over \"match\" expressions with an explicit \"return\" clause.") in let info = { cip_style = sty; diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 0cadffa4..d354a6c3 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -99,17 +99,56 @@ let search_guard loc env possible_indexes fixdefs = let ((constr_in : constr -> Dyn.t), (constr_out : Dyn.t -> constr)) = Dyn.create "constr" +(* To force universe name declaration before use *) + +let strict_universe_declarations = ref true +let is_strict_universe_declarations () = !strict_universe_declarations + +let _ = + Goptions.(declare_bool_option + { optsync = true; + optdepr = false; + optname = "strict universe declaration"; + optkey = ["Strict";"Universe";"Declaration"]; + optread = is_strict_universe_declarations; + optwrite = (:=) strict_universe_declarations }) + +let _ = + Goptions.(declare_bool_option + { optsync = true; + optdepr = false; + optname = "minimization to Set"; + optkey = ["Universe";"Minimization";"ToSet"]; + optread = Universes.is_set_minimization; + optwrite = (:=) Universes.set_minimization }) + (** Miscellaneous interpretation functions *) -let interp_universe_level_name evd s = +let interp_universe_level_name evd (loc,s) = let names, _ = Universes.global_universe_names () in - try - let id = try Id.of_string s with _ -> raise Not_found in - evd, Idmap.find id names - with Not_found -> - try let level = Evd.universe_of_name evd s in - evd, level - with Not_found -> - new_univ_level_variable ~name:s univ_rigid evd + if CString.string_contains s "." then + match List.rev (CString.split '.' s) with + | [] -> anomaly (str"Invalid universe name " ++ str s) + | n :: dp -> + let num = int_of_string n in + let dp = DirPath.make (List.map Id.of_string dp) in + let level = Univ.Level.make dp num in + let evd = + try Evd.add_global_univ evd level + with Univ.AlreadyDeclared -> evd + in evd, level + else + try + let id = + try Id.of_string s with _ -> raise Not_found in + evd, Idmap.find id names + with Not_found -> + try let level = Evd.universe_of_name evd s in + evd, level + with Not_found -> + if not (is_strict_universe_declarations ()) then + new_univ_level_variable ~name:s univ_rigid evd + else user_err_loc (loc, "interp_universe_level_name", + Pp.(str "Undeclared universe: " ++ str s)) let interp_universe evd = function | [] -> let evd, l = new_univ_level_variable univ_rigid evd in @@ -122,7 +161,7 @@ let interp_universe evd = function let interp_universe_level evd = function | None -> new_univ_level_variable univ_rigid evd - | Some s -> interp_universe_level_name evd s + | Some (loc,s) -> interp_universe_level_name evd (loc,s) let interp_sort evd = function | GProp -> evd, Prop Null @@ -270,9 +309,21 @@ let ltac_interp_name { ltac_idents ; ltac_genargs } = function str"It cannot be used in a binder.") else n +let ltac_interp_name_env k0 lvar env = + (* envhd is the initial part of the env when pretype was called first *) + (* (in practice is is probably 0, but we have to grant the + specification of pretype which accepts to start with a non empty + rel_context) *) + (* tail is the part of the env enriched by pretyping *) + let n = rel_context_length (rel_context env) - k0 in + let ctxt,_ = List.chop n (rel_context env) in + let env = pop_rel_context n env in + let ctxt = List.map (fun (na,c,t) -> ltac_interp_name lvar na,c,t) ctxt in + push_rel_context ctxt env + let invert_ltac_bound_name lvar env id0 id = - let id = Id.Map.find id lvar.ltac_idents in - try mkRel (pi1 (lookup_rel_id id (rel_context env))) + let id' = Id.Map.find id lvar.ltac_idents in + try mkRel (pi1 (lookup_rel_id id' (rel_context env))) with Not_found -> errorlabstrm "" (str "Ltac variable " ++ pr_id id0 ++ str " depends on pattern variable name " ++ pr_id id ++ @@ -285,17 +336,14 @@ let protected_get_type_of env sigma c = (str "Cannot reinterpret " ++ quote (print_constr c) ++ str " in the current environment.") -let pretype_id pretype loc env evdref lvar id = +let pretype_id pretype k0 loc env evdref lvar id = let sigma = !evdref in (* Look for the binder of [id] *) try - let id = - try Id.Map.find id lvar.ltac_idents - with Not_found -> id - in let (n,_,typ) = lookup_rel_id id (rel_context env) in { uj_val = mkRel n; uj_type = lift n typ } with Not_found -> + let env = ltac_interp_name_env k0 lvar env in (* Check if [id] is an ltac variable *) try let (ids,c) = Id.Map.find id lvar.ltac_constrs in @@ -335,7 +383,8 @@ let evar_kind_of_term sigma c = (*************************************************************************) (* Main pretyping function *) -let interp_universe_level_name evd = function +let interp_universe_level_name evd l = + match l with | GProp -> evd, Univ.Level.prop | GSet -> evd, Univ.Level.set | GType s -> interp_universe_level evd s @@ -374,7 +423,7 @@ let pretype_ref loc evdref env ref us = | ref -> let evd, c = pretype_global loc univ_flexible env !evdref ref us in let () = evdref := evd in - let ty = Typing.type_of env evd c in + let ty = Typing.unsafe_type_of env evd c in make_judge c ty let judge_of_Type evd s = @@ -413,10 +462,10 @@ let is_GHole = function let evars = ref Id.Map.empty -let rec pretype resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_var_map) t = +let rec pretype k0 resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_var_map) t = let inh_conv_coerce_to_tycon = inh_conv_coerce_to_tycon resolve_tc in - let pretype_type = pretype_type resolve_tc in - let pretype = pretype resolve_tc in + let pretype_type = pretype_type k0 resolve_tc in + let pretype = pretype k0 resolve_tc in match t with | GRef (loc,ref,u) -> inh_conv_coerce_to_tycon loc env evdref @@ -425,7 +474,7 @@ let rec pretype resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_var | GVar (loc, id) -> inh_conv_coerce_to_tycon loc env evdref - (pretype_id (fun e r l t -> pretype tycon e r l t) loc env evdref lvar id) + (pretype_id (fun e r l t -> pretype tycon e r l t) k0 loc env evdref lvar id) tycon | GEvar (loc, id, inst) -> @@ -436,12 +485,13 @@ let rec pretype resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_var with Not_found -> user_err_loc (loc,"",str "Unknown existential variable.") in let hyps = evar_filtered_context (Evd.find !evdref evk) in - let args = pretype_instance resolve_tc env evdref lvar loc hyps evk inst in + let args = pretype_instance k0 resolve_tc env evdref lvar loc hyps evk inst in let c = mkEvar (evk, args) in let j = (Retyping.get_judgment_of env !evdref c) in inh_conv_coerce_to_tycon loc env evdref j tycon | GPatVar (loc,(someta,n)) -> + let env = ltac_interp_name_env k0 lvar env in let ty = match tycon with | Some ty -> ty @@ -450,6 +500,7 @@ let rec pretype resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_var { uj_val = e_new_evar env evdref ~src:(loc,k) ty; uj_type = ty } | GHole (loc, k, naming, None) -> + let env = ltac_interp_name_env k0 lvar env in let ty = match tycon with | Some ty -> ty @@ -458,6 +509,7 @@ let rec pretype resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_var { uj_val = e_new_evar env evdref ~src:(loc,k) ~naming ty; uj_type = ty } | GHole (loc, k, _naming, Some arg) -> + let env = ltac_interp_name_env k0 lvar env in let ty = match tycon with | Some ty -> ty @@ -474,12 +526,14 @@ let rec pretype resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_var | (na,bk,None,ty)::bl -> let ty' = pretype_type empty_valcon env evdref lvar ty in let dcl = (na,None,ty'.utj_val) in - type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl + let dcl' = (ltac_interp_name lvar na,None,ty'.utj_val) in + type_bl (push_rel dcl env) (add_rel_decl dcl' ctxt) bl | (na,bk,Some bd,ty)::bl -> let ty' = pretype_type empty_valcon env evdref lvar ty in let bd' = pretype (mk_tycon ty'.utj_val) env evdref lvar bd in let dcl = (na,Some bd'.uj_val,ty'.utj_val) in - type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl in + let dcl' = (ltac_interp_name lvar na,Some bd'.uj_val,ty'.utj_val) in + type_bl (push_rel dcl env) (add_rel_decl dcl' ctxt) bl in let ctxtv = Array.map (type_bl env empty_rel_context) bl in let larj = Array.map2 @@ -618,7 +672,7 @@ let rec pretype resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_var match evar_kind_of_term !evdref resj.uj_val with | App (f,args) -> let f = whd_evar !evdref f in - if isInd f && is_template_polymorphic env f then + if is_template_polymorphic env f then (* Special case for inductive type applications that must be refreshed right away. *) let sigma = !evdref in @@ -647,9 +701,9 @@ let rec pretype resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_var (* The name specified by ltac is used also to create bindings. So the substitution must also be applied on variables before they are looked up in the rel context. *) - let name = ltac_interp_name lvar name in let var = (name,None,j.utj_val) in let j' = pretype rng (push_rel var env) evdref lvar c2 in + let name = ltac_interp_name lvar name in let resj = judge_of_abstraction env (orelse_name name name') j j' in inh_conv_coerce_to_tycon loc env evdref resj tycon @@ -658,7 +712,6 @@ let rec pretype resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_var (* The name specified by ltac is used also to create bindings. So the substitution must also be applied on variables before they are looked up in the rel context. *) - let name = ltac_interp_name lvar name in let j' = match name with | Anonymous -> let j = pretype_type empty_valcon env evdref lvar c2 in @@ -668,6 +721,7 @@ let rec pretype resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_var let env' = push_rel_assum var env in pretype_type empty_valcon env' evdref lvar c2 in + let name = ltac_interp_name lvar name in let resj = try judge_of_product env name j j' @@ -689,10 +743,10 @@ let rec pretype resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_var (* The name specified by ltac is used also to create bindings. So the substitution must also be applied on variables before they are looked up in the rel context. *) - let name = ltac_interp_name lvar name in let var = (name,Some j.uj_val,t) in let tycon = lift_tycon 1 tycon in let j' = pretype tycon (push_rel var env) evdref lvar c2 in + let name = ltac_interp_name lvar name in { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ; uj_type = subst1 j.uj_val j'.uj_type } @@ -712,8 +766,6 @@ let rec pretype resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_var if not (Int.equal (List.length nal) cs.cs_nargs) then user_err_loc (loc,"", str "Destructing let on this type expects " ++ int cs.cs_nargs ++ str " variables."); - let nal = List.map (fun na -> ltac_interp_name lvar na) nal in - let na = ltac_interp_name lvar na in let fsign, record = match get_projections env indf with | None -> List.map2 (fun na (_,c,t) -> (na,c,t)) @@ -729,10 +781,12 @@ let rec pretype resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_var (na, c, t) :: aux (n+1) k names l | [], [] -> [] | _ -> assert false - in aux 1 1 (List.rev nal) cs.cs_args, true - in + in aux 1 1 (List.rev nal) cs.cs_args, true in let obj ind p v f = if not record then + let nal = List.map (fun na -> ltac_interp_name lvar na) nal in + let nal = List.rev nal in + let fsign = List.map2 (fun na (_,b,t) -> (na,b,t)) nal fsign in let f = it_mkLambda_or_LetIn f fsign in let ci = make_case_info env (fst ind) LetStyle in mkCase (ci, p, cj.uj_val,[|f|]) @@ -818,7 +872,9 @@ let rec pretype resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_var | None -> let p = match tycon with | Some ty -> ty - | None -> new_type_evar env evdref loc + | None -> + let env = ltac_interp_name_env k0 lvar env in + new_type_evar env evdref loc in it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in let pred = nf_evar !evdref pred in @@ -854,9 +910,6 @@ let rec pretype resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_var inh_conv_coerce_to_tycon loc env evdref cj tycon | GCases (loc,sty,po,tml,eqns) -> - let (tml,eqns) = - Glob_ops.map_pattern_binders (fun na -> ltac_interp_name lvar na) tml eqns - in Cases.compile_cases loc sty ((fun vtyc env evdref -> pretype vtyc env evdref lvar),evdref) tycon env (* loc *) (po,tml,eqns) @@ -876,23 +929,20 @@ let rec pretype resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_var let cj = pretype empty_tycon env evdref lvar c in let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in if not (occur_existential cty || occur_existential tval) then - begin - try - ignore (Reduction.vm_conv Reduction.CUMUL env cty tval); cj - with Reduction.NotConvertible -> - error_actual_type_loc loc env !evdref cj tval + let (evd,b) = Reductionops.vm_infer_conv env !evdref cty tval in + if b then (evdref := evd; cj) + else + error_actual_type_loc loc env !evdref cj tval (ConversionFailed (env,cty,tval)) - end else user_err_loc (loc,"",str "Cannot check cast with vm: " ++ str "unresolved arguments remain.") | NATIVEcast -> let cj = pretype empty_tycon env evdref lvar c in let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in - let evars = Nativenorm.evars_of_evar_map !evdref in begin - try - ignore (Nativeconv.native_conv Reduction.CUMUL evars env cty tval); cj - with Reduction.NotConvertible -> + let (evd,b) = Nativenorm.native_infer_conv env !evdref cty tval in + if b then (evdref := evd; cj) + else error_actual_type_loc loc env !evdref cj tval (ConversionFailed (env,cty,tval)) end @@ -903,13 +953,13 @@ let rec pretype resolve_tc (tycon : type_constraint) env evdref (lvar : ltac_var { uj_val = v; uj_type = tval } in inh_conv_coerce_to_tycon loc env evdref cj tycon -and pretype_instance resolve_tc env evdref lvar loc hyps evk update = +and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update = let f (id,_,t) (subst,update) = let t = replace_vars subst t in let c, update = try let c = List.assoc id update in - let c = pretype resolve_tc (mk_tycon t) env evdref lvar c in + let c = pretype k0 resolve_tc (mk_tycon t) env evdref lvar c in c.uj_val, List.remove_assoc id update with Not_found -> try @@ -929,7 +979,7 @@ and pretype_instance resolve_tc env evdref lvar loc hyps evk update = Array.map_of_list snd subst (* [pretype_type valcon env evdref lvar c] coerces [c] into a type *) -and pretype_type resolve_tc valcon env evdref lvar = function +and pretype_type k0 resolve_tc valcon env evdref lvar = function | GHole (loc, knd, naming, None) -> (match valcon with | Some v -> @@ -945,11 +995,12 @@ and pretype_type resolve_tc valcon env evdref lvar = function { utj_val = v; utj_type = s } | None -> + let env = ltac_interp_name_env k0 lvar env in let s = evd_comb0 (new_sort_variable univ_flexible_alg) evdref in { utj_val = e_new_evar env evdref ~src:(loc, knd) ~naming (mkSort s); utj_type = s}) | c -> - let j = pretype resolve_tc empty_tycon env evdref lvar c in + let j = pretype k0 resolve_tc empty_tycon env evdref lvar c in let loc = loc_of_glob_constr c in let tj = evd_comb1 (Coercion.inh_coerce_to_sort loc env) evdref j in match valcon with @@ -962,13 +1013,14 @@ and pretype_type resolve_tc valcon env evdref lvar = function let ise_pretype_gen flags env sigma lvar kind c = let evdref = ref sigma in + let k0 = rel_context_length (rel_context env) in let c' = match kind with | WithoutTypeConstraint -> - (pretype flags.use_typeclasses empty_tycon env evdref lvar c).uj_val + (pretype k0 flags.use_typeclasses empty_tycon env evdref lvar c).uj_val | OfType exptyp -> - (pretype flags.use_typeclasses (mk_tycon exptyp) env evdref lvar c).uj_val + (pretype k0 flags.use_typeclasses (mk_tycon exptyp) env evdref lvar c).uj_val | IsType -> - (pretype_type flags.use_typeclasses empty_valcon env evdref lvar c).utj_val + (pretype_type k0 flags.use_typeclasses empty_valcon env evdref lvar c).utj_val in process_inference_flags flags env sigma (!evdref,c') @@ -1003,14 +1055,16 @@ let on_judgment f j = let understand_judgment env sigma c = let evdref = ref sigma in - let j = pretype true empty_tycon env evdref empty_lvar c in + let k0 = rel_context_length (rel_context env) in + let j = pretype k0 true empty_tycon env evdref empty_lvar c in let j = on_judgment (fun c -> let evd, c = process_inference_flags all_and_fail_flags env sigma (!evdref,c) in evdref := evd; c) j in j, Evd.evar_universe_context !evdref let understand_judgment_tcc env evdref c = - let j = pretype true empty_tycon env evdref empty_lvar c in + let k0 = rel_context_length (rel_context env) in + let j = pretype k0 true empty_tycon env evdref empty_lvar c in on_judgment (fun c -> let (evd,c) = process_inference_flags all_no_fail_flags env Evd.empty (!evdref,c) in evdref := evd; c) j diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index 142b5451..5f0e19cf 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -66,9 +66,12 @@ val all_and_fail_flags : inference_flags (** Allow references to syntactically nonexistent variables (i.e., if applied on an inductive) *) val allow_anonymous_refs : bool ref -(** Generic call to the interpreter from glob_constr to open_constr, leaving - unresolved holes as evars and returning the typing contexts of - these evars. Work as [understand_gen] for the rest. *) +(** Generic calls to the interpreter from glob_constr to open_constr; + by default, inference_flags tell to use type classes and + heuristics (but no external tactic solver hooks), as well as to + ensure that conversion problems are all solved and expand evars, + but unresolved evars can remain. The difference is in whether the + evar_map is modified explicitly or by side-effect. *) val understand_tcc : ?flags:inference_flags -> env -> evar_map -> ?expected_type:typing_constraint -> glob_constr -> open_constr @@ -92,7 +95,12 @@ val understand_ltac : inference_flags -> env -> evar_map -> ltac_var_map -> typing_constraint -> glob_constr -> pure_open_constr -(** Standard call to get a constr from a glob_constr, resolving implicit args *) +(** Standard call to get a constr from a glob_constr, resolving + implicit arguments and coercions, and compiling pattern-matching; + the default inference_flags tells to use type classes and + heuristics (but no external tactic solver hook), as well as to + ensure that conversion problems are all solved and that no + unresolved evar remains, expanding evars. *) val understand : ?flags:inference_flags -> ?expected_type:typing_constraint -> env -> evar_map -> glob_constr -> constr Evd.in_evar_universe_context @@ -102,12 +110,13 @@ val understand : ?flags:inference_flags -> ?expected_type:typing_constraint -> val understand_judgment : env -> evar_map -> glob_constr -> unsafe_judgment Evd.in_evar_universe_context -(** Idem but do not fail on unresolved evars *) +(** Idem but do not fail on unresolved evars (type cl*) val understand_judgment_tcc : env -> evar_map ref -> glob_constr -> unsafe_judgment (** Trying to solve remaining evars and remaining conversion problems - with type classes, heuristics, and possibly an external solver *) + possibly using type classes, heuristics, external tactic solver + hook depending on given flags. *) (* For simplicity, it is assumed that current map has no other evars with candidate and no other conversion problems that the one in [pending], however, it can contain more evars than the pending ones. *) @@ -115,7 +124,8 @@ val understand_judgment_tcc : env -> evar_map ref -> val solve_remaining_evars : inference_flags -> env -> (* initial map *) evar_map -> (* map to solve *) pending -> evar_map -(** Checking evars are all solved and reporting an appropriate error message *) +(** Checking evars and pending conversion problems are all solved, + reporting an appropriate error message *) val check_evars_are_solved : env -> (* current map: *) evar_map -> (* map to check: *) pending -> unit @@ -123,11 +133,11 @@ val check_evars_are_solved : (**/**) (** Internal of Pretyping... *) val pretype : - bool -> type_constraint -> env -> evar_map ref -> + int -> bool -> type_constraint -> env -> evar_map ref -> ltac_var_map -> glob_constr -> unsafe_judgment val pretype_type : - bool -> val_constraint -> env -> evar_map ref -> + int -> bool -> val_constraint -> env -> evar_map ref -> ltac_var_map -> glob_constr -> unsafe_type_judgment val ise_pretype_gen : diff --git a/pretyping/pretyping.mllib b/pretyping/pretyping.mllib index 25d17c7c..a644e3d1 100644 --- a/pretyping/pretyping.mllib +++ b/pretyping/pretyping.mllib @@ -3,8 +3,8 @@ Termops Namegen Evd Reductionops -Vnorm Inductiveops +Vnorm Arguments_renaming Nativenorm Retyping diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 6dc0d1f3..7fde7b7a 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -190,7 +190,7 @@ let cs_pattern_of_constr t = (* Intended to always succeed *) let compute_canonical_projections (con,ind) = let env = Global.env () in - let ctx = Environ.constant_context env con in + let ctx = Univ.instantiate_univ_context (Environ.constant_context env con) in let u = Univ.UContext.instance ctx in let v = (mkConstU (con,u)) in let ctx = Univ.ContextSet.of_context ctx in diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index dd671f11..0714c93b 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -1251,9 +1251,6 @@ let pb_equal = function | Reduction.CUMUL -> Reduction.CONV | Reduction.CONV -> Reduction.CONV -let sort_cmp cv_pb s1 s2 u = - Reduction.check_sort_cmp_universes cv_pb s1 s2 u - let test_trans_conversion (f: ?l2r:bool-> ?evars:'a->'b) reds env sigma x y = try let evars ev = safe_evar_value sigma ev in @@ -1285,16 +1282,18 @@ let sigma_compare_sorts env pb s0 s1 sigma = | Reduction.CONV -> Evd.set_eq_sort env sigma s0 s1 | Reduction.CUMUL -> Evd.set_leq_sort env sigma s0 s1 -let sigma_compare_instances flex i0 i1 sigma = +let sigma_compare_instances ~flex i0 i1 sigma = try Evd.set_eq_instances ~flex sigma i0 i1 - with Evd.UniversesDiffer -> raise Reduction.NotConvertible + with Evd.UniversesDiffer + | Univ.UniverseInconsistency _ -> + raise Reduction.NotConvertible let sigma_univ_state = { Reduction.compare = sigma_compare_sorts; Reduction.compare_instances = sigma_compare_instances } -let infer_conv ?(catch_incon=true) ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) - env sigma x y = +let infer_conv_gen conv_fun ?(catch_incon=true) ?(pb=Reduction.CUMUL) + ?(ts=full_transparent_state) env sigma x y = try let b, sigma = let b, cstrs = @@ -1311,14 +1310,23 @@ let infer_conv ?(catch_incon=true) ?(pb=Reduction.CUMUL) ?(ts=full_transparent_s if b then sigma, true else let sigma' = - Reduction.generic_conv pb false (safe_evar_value sigma) ts + conv_fun pb ~l2r:false sigma ts env (sigma, sigma_univ_state) x y in sigma', true with | Reduction.NotConvertible -> sigma, false | Univ.UniverseInconsistency _ when catch_incon -> sigma, false | e when is_anomaly e -> error "Conversion test raised an anomaly" - + +let infer_conv = infer_conv_gen (fun pb ~l2r sigma -> + Reduction.generic_conv pb ~l2r (safe_evar_value sigma)) + +(* This reference avoids always having to link C code with the kernel *) +let vm_infer_conv = ref (infer_conv ~catch_incon:true ~ts:full_transparent_state) +let set_vm_infer_conv f = vm_infer_conv := f +let vm_infer_conv ?(pb=Reduction.CUMUL) env t1 t2 = + !vm_infer_conv ~pb env t1 t2 + (********************************************************************) (* Special-Purpose Reduction *) (********************************************************************) diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 1df2a73b..d5a84484 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -251,8 +251,6 @@ type conversion_test = constraints -> constraints val pb_is_equal : conv_pb -> bool val pb_equal : conv_pb -> conv_pb -val sort_cmp : env -> conv_pb -> sorts -> sorts -> universes -> unit - val is_conv : env -> evar_map -> constr -> constr -> bool val is_conv_leq : env -> evar_map -> constr -> constr -> bool val is_fconv : conv_pb -> env -> evar_map -> constr -> constr -> bool @@ -266,7 +264,7 @@ val is_trans_fconv : conv_pb -> transparent_state -> env -> evar_map -> constr *) val check_conv : ?pb:conv_pb -> ?ts:transparent_state -> env -> evar_map -> constr -> constr -> bool -(** [infer_fconv] Adds necessary universe constraints to the evar map. +(** [infer_conv] Adds necessary universe constraints to the evar map. pb defaults to CUMUL and ts to a full transparent state. @raises UniverseInconsistency iff catch_incon is set to false, otherwise returns false in that case. @@ -274,6 +272,20 @@ val check_conv : ?pb:conv_pb -> ?ts:transparent_state -> env -> evar_map -> con val infer_conv : ?catch_incon:bool -> ?pb:conv_pb -> ?ts:transparent_state -> env -> evar_map -> constr -> constr -> evar_map * bool +(** Conversion with inference of universe constraints *) +val set_vm_infer_conv : (?pb:conv_pb -> env -> evar_map -> constr -> constr -> + evar_map * bool) -> unit +val vm_infer_conv : ?pb:conv_pb -> env -> evar_map -> constr -> constr -> + evar_map * bool + + +(** [infer_conv_gen] behaves like [infer_conv] but is parametrized by a +conversion function. Used to pretype vm and native casts. *) +val infer_conv_gen : (conv_pb -> l2r:bool -> evar_map -> transparent_state -> + (constr, evar_map) Reduction.generic_conversion_function) -> + ?catch_incon:bool -> ?pb:conv_pb -> ?ts:transparent_state -> env -> + evar_map -> constr -> constr -> evar_map * bool + (** {6 Special-Purpose Reduction Functions } *) val whd_meta : evar_map -> constr -> constr diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index a56861c6..fb552655 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -126,14 +126,11 @@ let retype ?(polyprop=true) sigma = | App(f,args) -> strip_outer_cast (subst_type env sigma (type_of env f) (Array.to_list args)) - | Proj (p,c) -> - let Inductiveops.IndType(pars,realargs) = - let ty = type_of env c in - try Inductiveops.find_rectype env sigma ty - with Not_found -> retype_error BadRecursiveType - in - let (_,u), pars = dest_ind_family pars in - substl (c :: List.rev pars) (Typeops.type_of_projection env (p,u)) + | Proj (p,c) -> + let ty = type_of env c in + (try + Inductiveops.type_of_projection_knowing_arg env sigma p c ty + with Invalid_argument _ -> retype_error BadRecursiveType) | Cast (c,_, t) -> t | Sort _ | Prod _ -> mkSort (sort_of env cstr) diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 372b26aa..48911a5a 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -1011,8 +1011,8 @@ let contextually byhead occs f env sigma t = snd (e_contextually byhead occs f' env sigma t) (* linear bindings (following pretty-printer) of the value of name in c. - * n is the number of the next occurence of name. - * ol is the occurence list to find. *) + * n is the number of the next occurrence of name. + * ol is the occurrence list to find. *) let match_constr_evaluable_ref sigma c evref = match kind_of_term c, evref with @@ -1061,7 +1061,7 @@ let is_projection env = function (* [unfoldoccs : (readable_constraints -> (int list * full_path) -> constr -> constr)] * Unfolds the constant name in a term c following a list of occurrences occl. - * at the occurrences of occ_list. If occ_list is empty, unfold all occurences. + * at the occurrences of occ_list. If occ_list is empty, unfold all occurrences. * Performs a betaiota reduction after unfolding. *) let unfoldoccs env sigma (occs,name) c = let unfo nowhere_except_in locs = @@ -1134,7 +1134,7 @@ let abstract_scheme env (locc,a) (c, sigma) = let pattern_occs loccs_trm env sigma c = let abstr_trm, sigma = List.fold_right (abstract_scheme env) loccs_trm (c,sigma) in try - let _ = Typing.type_of env sigma abstr_trm in + let _ = Typing.unsafe_type_of env sigma abstr_trm in sigma, applist(abstr_trm, List.map snd loccs_trm) with Type_errors.TypeError (env',t) -> raise (ReductionTacticError (InvalidAbstraction (env,sigma,abstr_trm,(env',t)))) diff --git a/pretyping/termops.ml b/pretyping/termops.ml index 9f04faa8..5a55d47f 100644 --- a/pretyping/termops.ml +++ b/pretyping/termops.ml @@ -453,26 +453,29 @@ let map_constr_with_full_binders g f l cstr = match kind_of_term cstr with index) which is processed by [g] (which typically add 1 to [n]) at each binder traversal; it is not recursive *) -let fold_constr_with_binders g f n acc c = match kind_of_term c with +let fold_constr_with_full_binders g f n acc c = match kind_of_term c with | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _) -> acc | Cast (c,_, t) -> f n (f n acc c) t - | Prod (_,t,c) -> f (g n) (f n acc t) c - | Lambda (_,t,c) -> f (g n) (f n acc t) c - | LetIn (_,b,t,c) -> f (g n) (f n (f n acc b) t) c + | Prod (na,t,c) -> f (g (na,None,t) n) (f n acc t) c + | Lambda (na,t,c) -> f (g (na,None,t) n) (f n acc t) c + | LetIn (na,b,t,c) -> f (g (na,Some b,t) n) (f n (f n acc b) t) c | App (c,l) -> Array.fold_left (f n) (f n acc c) l | Proj (p,c) -> f n acc c | Evar (_,l) -> Array.fold_left (f n) acc l | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl | Fix (_,(lna,tl,bl)) -> - let n' = iterate g (Array.length tl) n in + let n' = CArray.fold_left2 (fun c n t -> g (n,None,t) c) n lna tl in let fd = Array.map2 (fun t b -> (t,b)) tl bl in Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd | CoFix (_,(lna,tl,bl)) -> - let n' = iterate g (Array.length tl) n in + let n' = CArray.fold_left2 (fun c n t -> g (n,None,t) c) n lna tl in let fd = Array.map2 (fun t b -> (t,b)) tl bl in Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd +let fold_constr_with_binders g f n acc c = + fold_constr_with_full_binders (fun _ x -> g x) f n acc c + (* [iter_constr_with_full_binders g f acc c] iters [f acc] on the immediate subterms of [c]; it carries an extra data [acc] which is processed by [g] at each binder traversal; it is not recursive and the order with which @@ -558,7 +561,7 @@ let free_rels m = in frec 1 Int.Set.empty m -(* collects all metavar occurences, in left-to-right order, preserving +(* collects all metavar occurrences, in left-to-right order, preserving * repetitions and all. *) let collect_metas c = diff --git a/pretyping/termops.mli b/pretyping/termops.mli index 2552c67e..4581e231 100644 --- a/pretyping/termops.mli +++ b/pretyping/termops.mli @@ -84,6 +84,10 @@ val map_constr_with_full_binders : val fold_constr_with_binders : ('a -> 'a) -> ('a -> 'b -> constr -> 'b) -> 'a -> 'b -> constr -> 'b +val fold_constr_with_full_binders : + (rel_declaration -> 'a -> 'a) -> ('a -> 'b -> constr -> 'b) -> + 'a -> 'b -> constr -> 'b + val iter_constr_with_full_binders : (rel_declaration -> 'a -> 'a) -> ('a -> constr -> unit) -> 'a -> constr -> unit diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 18e83056..2ef28965 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -370,7 +370,7 @@ let add_instance check inst = List.iter (fun (path, pri, c) -> add_instance_hint (IsConstr c) path (is_local inst) pri poly) (build_subclasses ~check:(check && not (isVarRef inst.is_impl)) - (Global.env ()) Evd.empty inst.is_impl inst.is_pri) + (Global.env ()) (Evd.from_env (Global.env ())) inst.is_impl inst.is_pri) let rebuild_instance (action, inst) = let () = match action with diff --git a/pretyping/typing.ml b/pretyping/typing.ml index c6209cc3..fb5927db 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -270,7 +270,7 @@ let check env evdref c t = (* Type of a constr *) -let type_of env evd c = +let unsafe_type_of env evd c = let j = execute env (ref evd) c in j.uj_type @@ -283,7 +283,7 @@ let sort_of env evdref c = (* Try to solve the existential variables by typing *) -let e_type_of ?(refresh=false) env evd c = +let type_of ?(refresh=false) env evd c = let evdref = ref evd in let j = execute env evdref c in (* side-effect on evdref *) @@ -291,6 +291,15 @@ let e_type_of ?(refresh=false) env evd c = Evarsolve.refresh_universes ~onlyalg:true (Some false) env !evdref j.uj_type else !evdref, j.uj_type +let e_type_of ?(refresh=false) env evdref c = + let j = execute env evdref c in + (* side-effect on evdref *) + if refresh then + let evd, c = Evarsolve.refresh_universes ~onlyalg:true (Some false) env !evdref j.uj_type in + let () = evdref := evd in + c + else j.uj_type + let solve_evars env evdref c = let c = (execute env evdref c).uj_val in (* side-effect on evdref *) diff --git a/pretyping/typing.mli b/pretyping/typing.mli index 1f822f1a..bfae46ff 100644 --- a/pretyping/typing.mli +++ b/pretyping/typing.mli @@ -13,12 +13,15 @@ open Evd (** This module provides the typing machine with existential variables and universes. *) -(** Typecheck a term and return its type *) -val type_of : env -> evar_map -> constr -> types +(** Typecheck a term and return its type. May trigger an evarmap leak. *) +val unsafe_type_of : env -> evar_map -> constr -> types (** Typecheck a term and return its type + updated evars, optionally refreshing universes *) -val e_type_of : ?refresh:bool -> env -> evar_map -> constr -> evar_map * types +val type_of : ?refresh:bool -> env -> evar_map -> constr -> evar_map * types + +(** Variant of [type_of] using references instead of state-passing. *) +val e_type_of : ?refresh:bool -> env -> evar_map ref -> constr -> types (** Typecheck a type and return its sort *) val sort_of : env -> evar_map ref -> types -> sorts diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 01e1154e..24e06007 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -93,7 +93,7 @@ let abstract_list_all env evd typ c l = let l_with_all_occs = List.map (function a -> (LikeFirst,a)) l in let p,evd = abstract_scheme env evd c l_with_all_occs ctxt in let evd,typp = - try Typing.e_type_of env evd p + try Typing.type_of env evd p with | UserError _ -> error_cannot_find_well_typed_abstraction env evd p l None @@ -676,7 +676,11 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb | Evar (evk,_ as ev), Evar (evk',_) when not (Evar.Set.mem evk flags.frozen_evars) && Evar.equal evk evk' -> - sigma,metasubst,((curenv,ev,cN)::evarsubst) + let sigma',b = constr_cmp cv_pb sigma flags cM cN in + if b then + sigma',metasubst,evarsubst + else + sigma,metasubst,((curenv,ev,cN)::evarsubst) | Evar (evk,_ as ev), _ when not (Evar.Set.mem evk flags.frozen_evars) && not (occur_evar evk cN) -> @@ -1150,7 +1154,7 @@ let applyHead env evd n c = apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) evd' | _ -> error "Apply_Head_Then" in - apprec n c (Typing.type_of env evd c) evd + apprec n c (Typing.unsafe_type_of env evd c) evd let is_mimick_head ts f = match kind_of_term f with @@ -1528,7 +1532,8 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = let ids = ids_of_named_context (named_context env) in if name == Anonymous then next_ident_away_in_goal x ids else if mem_named_context x (named_context env) then - error ("The variable "^(Id.to_string x)^" is already declared.") + errorlabstrm "Unification.make_abstraction_core" + (str "The variable " ++ Nameops.pr_id x ++ str " is already declared.") else x in diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 8198db1b..c4c85a62 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -93,19 +93,6 @@ let construct_of_constr_const env tag typ = let construct_of_constr_block = construct_of_constr false -let constr_type_of_idkey env idkey = - match idkey with - | ConstKey cst -> - let const_type = Typeops.type_of_constant_in env cst in - mkConstU cst, const_type - | VarKey id -> - let (_,_,ty) = lookup_named id env in - mkVar id, ty - | RelKey i -> - let n = (nb_rel env - i) in - let (_,_,ty) = lookup_rel n env in - mkRel n, lift n ty - let type_of_ind env (ind, u) = type_of_inductive env (Inductive.lookup_mind_specif env ind, u) @@ -164,7 +151,8 @@ and nf_whd env whd typ = let t = ta.(i) in let _, args = nf_args env vargs t in mkApp(cfd,args) - | Vconstr_const n -> construct_of_constr_const env n typ + | Vconstr_const n -> + construct_of_constr_const env n typ | Vconstr_block b -> let tag = btag b in let (tag,ofs) = @@ -177,24 +165,72 @@ and nf_whd env whd typ = let args = nf_bargs env b ofs ctyp in mkApp(capp,args) | Vatom_stk(Aid idkey, stk) -> - let c,typ = constr_type_of_idkey env idkey in - nf_stk env c typ stk - | Vatom_stk(Aiddef(idkey,v), stk) -> - nf_whd env (whd_stack v stk) typ - | Vatom_stk(Aind ind, stk) -> - nf_stk env (mkIndU ind) (type_of_ind env ind) stk - -and nf_stk env c t stk = + constr_type_of_idkey env idkey stk + | Vatom_stk(Aind ((mi,i) as ind), stk) -> + let mib = Environ.lookup_mind mi env in + let nb_univs = + if mib.mind_polymorphic then Univ.UContext.size mib.mind_universes + else 0 + in + let mk u = + let pind = (ind, u) in (mkIndU pind, type_of_ind env pind) + in + nf_univ_args ~nb_univs mk env stk + | Vatom_stk(Atype u, stk) -> assert false + | Vuniv_level lvl -> + assert false + +and nf_univ_args ~nb_univs mk env stk = + let u = + if Int.equal nb_univs 0 then Univ.Instance.empty + else match stk with + | Zapp args :: _ -> + let inst = + Array.init nb_univs (fun i -> Vm.uni_lvl_val (arg args i)) + in + Univ.Instance.of_array inst + | _ -> assert false + in + let (t,ty) = mk u in + nf_stk ~from:nb_univs env t ty stk + +and constr_type_of_idkey env (idkey : Vars.id_key) stk = + match idkey with + | ConstKey cst -> + let cbody = Environ.lookup_constant cst env in + let nb_univs = + if cbody.const_polymorphic then Univ.UContext.size cbody.const_universes + else 0 + in + let mk u = + let pcst = (cst, u) in (mkConstU pcst, Typeops.type_of_constant_in env pcst) + in + nf_univ_args ~nb_univs mk env stk + | VarKey id -> + let (_,_,ty) = lookup_named id env in + nf_stk env (mkVar id) ty stk + | RelKey i -> + let n = (nb_rel env - i) in + let (_,_,ty) = lookup_rel n env in + nf_stk env (mkRel n) (lift n ty) stk + +and nf_stk ?from:(from=0) env c t stk = match stk with | [] -> c | Zapp vargs :: stk -> - let t, args = nf_args env vargs t in - nf_stk env (mkApp(c,args)) t stk + if nargs vargs >= from then + let t, args = nf_args ~from:from env vargs t in + nf_stk env (mkApp(c,args)) t stk + else + let rest = from - nargs vargs in + nf_stk ~from:rest env c t stk | Zfix (f,vargs) :: stk -> + assert (from = 0) ; let fa, typ = nf_fix_app env f vargs in let _,_,codom = decompose_prod env typ in nf_stk env (mkApp(fa,[|c|])) (subst1 c codom) stk | Zswitch sw :: stk -> + assert (from = 0) ; let ((mind,_ as ind), u), allargs = find_rectype_a env t in let (mib,mip) = Inductive.lookup_mind_specif env ind in let nparams = mib.mind_nparams in @@ -216,6 +252,11 @@ and nf_stk env c t stk = let tcase = build_case_type dep p realargs c in let ci = case_info sw in nf_stk env (mkCase(ci, p, c, branchs)) tcase stk + | Zproj p :: stk -> + assert (from = 0) ; + let p' = Projection.make p true in + let ty = Inductiveops.type_of_projection_knowing_arg env Evd.empty p' c t in + nf_stk env (mkProj(p',c)) ty stk and nf_predicate env ind mip params v pT = match whd_val v, kind_of_term pT with @@ -238,14 +279,14 @@ and nf_predicate env ind mip params v pT = true, mkLambda(name,dom,body) | _, _ -> false, nf_val env v crazy_type -and nf_args env vargs t = +and nf_args env vargs ?from:(f=0) t = let t = ref t in - let len = nargs vargs in + let len = nargs vargs - f in let args = Array.init len (fun i -> let _,dom,codom = decompose_prod env !t in - let c = nf_val env (arg vargs i) dom in + let c = nf_val env (arg vargs (f+i)) dom in t := subst1 c codom; c) in !t,args @@ -308,10 +349,11 @@ and nf_cofix env cf = mkCoFix (init,(name,cft,cfb)) let cbv_vm env c t = - let transp = transp_values () in - if not transp then set_transp_values true; let v = Vconv.val_of_constr env c in - let c = nf_val env v t in - if not transp then set_transp_values false; - c + nf_val env v t + +let vm_infer_conv ?(pb=Reduction.CUMUL) env sigma t1 t2 = + Reductionops.infer_conv_gen (fun pb ~l2r sigma ts -> Vconv.vm_conv_gen pb) + ~catch_incon:true ~pb env sigma t1 t2 +let _ = Reductionops.set_vm_infer_conv vm_infer_conv diff --git a/pretyping/vnorm.mli b/pretyping/vnorm.mli index 7dabbc6c..9421b2d8 100644 --- a/pretyping/vnorm.mli +++ b/pretyping/vnorm.mli @@ -8,7 +8,7 @@ open Term open Environ +open Evd (** {6 Reduction functions } *) val cbv_vm : env -> constr -> types -> constr - diff --git a/printing/ppconstr.ml b/printing/ppconstr.ml index d9d8af66..ea705e33 100644 --- a/printing/ppconstr.ml +++ b/printing/ppconstr.ml @@ -140,8 +140,8 @@ end) = struct let pr_univ l = match l with - | [x] -> str x - | l -> str"max(" ++ prlist_with_sep (fun () -> str",") str l ++ str")" + | [_,x] -> str x + | l -> str"max(" ++ prlist_with_sep (fun () -> str",") (fun x -> str (snd x)) l ++ str")" let pr_univ_annot pr x = str "@{" ++ pr x ++ str "}" @@ -174,7 +174,7 @@ end) = struct tag_type (str "Set") | GType u -> (match u with - | Some u -> str u + | Some (_,u) -> str u | None -> tag_type (str "Type")) let pr_universe_instance l = @@ -676,11 +676,11 @@ end) = struct return (pr_glob_sort s, latom) | CCast (_,a,b) -> return ( - hv 0 (pr mt (lcast,L) a ++ cut () ++ + hv 0 (pr mt (lcast,L) a ++ spc () ++ match b with - | CastConv b -> str ":" ++ pr mt (-lcast,E) b - | CastVM b -> str "<:" ++ pr mt (-lcast,E) b - | CastNative b -> str "<<:" ++ pr mt (-lcast,E) b + | CastConv b -> str ":" ++ ws 1 ++ pr mt (-lcast,E) b + | CastVM b -> str "<:" ++ ws 1 ++ pr mt (-lcast,E) b + | CastNative b -> str "<<:" ++ ws 1 ++ pr mt (-lcast,E) b | CastCoerce -> str ":>"), lcast ) diff --git a/printing/pptactic.ml b/printing/pptactic.ml index f8264e5a..a669aef9 100644 --- a/printing/pptactic.ml +++ b/printing/pptactic.ml @@ -1260,13 +1260,12 @@ module Make and pr_tacarg = function | TacDynamic (loc,t) -> - pr_with_comments loc ( - str "<" ++ keyword "dynamic" ++ str (" [" ^ (Dyn.tag t)^"]>") - ) + pr_with_comments loc + (str "<" ++ keyword "dynamic" ++ str " [" ++ str (Dyn.tag t) ++ str "]>") | MetaIdArg (loc,true,s) -> - pr_with_comments loc (str ("$" ^ s)) + pr_with_comments loc (str "$" ++ str s) | MetaIdArg (loc,false,s) -> - pr_with_comments loc (keyword "constr:" ++ str(" $" ^ s)) + pr_with_comments loc (keyword "constr:" ++ str " $" ++ str s) | Reference r -> pr.pr_reference r | ConstrMayEval c -> diff --git a/printing/ppvernac.ml b/printing/ppvernac.ml index 89ffae4b..72b9cafe 100644 --- a/printing/ppvernac.ml +++ b/printing/ppvernac.ml @@ -43,6 +43,12 @@ module Make else pr_id id + let pr_plident (lid, l) = + pr_lident lid ++ + (match l with + | Some l -> prlist_with_sep spc pr_lident l + | None -> mt()) + let string_of_fqid fqid = String.concat "." (List.map Id.to_string fqid) @@ -160,6 +166,8 @@ module Make (* This should not happen because of the grammar *) | IntValue (Some n) -> spc() ++ int n | StringValue s -> spc() ++ str s + | StringOptValue None -> mt() + | StringOptValue (Some s) -> spc() ++ str s | BoolValue b -> mt() in pr_printoption a None ++ pr_opt_value b @@ -348,6 +356,7 @@ module Make | l -> prlist_with_sep spc (fun p -> hov 1 (str "(" ++ pr_params pr_c p ++ str ")")) l + (* prlist_with_sep pr_semicolon (pr_params pr_c) *) @@ -387,10 +396,16 @@ module Make hov 0 (prlist_with_sep sep pr_production_item pil ++ spc() ++ str":=" ++ spc() ++ pr_raw_tactic t)) - let pr_statement head (id,(bl,c,guard)) = - assert (not (Option.is_empty id)); + let pr_univs pl = + match pl with + | None -> mt () + | Some pl -> str"@{" ++ prlist_with_sep spc pr_lident pl ++ str"}" + + let pr_statement head (idpl,(bl,c,guard)) = + assert (not (Option.is_empty idpl)); + let id, pl = Option.get idpl in hov 2 - (head ++ spc() ++ pr_lident (Option.get id) ++ spc() ++ + (head ++ spc() ++ pr_lident id ++ pr_univs pl ++ spc() ++ (match bl with [] -> mt() | _ -> pr_binders bl ++ spc()) ++ pr_opt (pr_guard_annot pr_lconstr_expr bl) guard ++ str":" ++ pr_spc_lconstr c) @@ -579,7 +594,8 @@ module Make let pr_goal_reference = function | OpenSubgoals -> mt () | NthGoal n -> spc () ++ int n - | GoalId n -> spc () ++ str n in + | GoalId id -> spc () ++ pr_id id + | GoalUid n -> spc () ++ str n in let pr_showable = function | ShowGoal n -> keyword "Show" ++ pr_goal_reference n | ShowGoalImplicitly n -> keyword "Show Implicit Arguments" ++ pr_opt int n @@ -627,6 +643,8 @@ module Make ) | VernacTime v -> return (keyword "Time" ++ spc() ++ pr_vernac_list v) + | VernacRedirect (s, v) -> + return (keyword "Redirect" ++ spc() ++ qs s ++ spc() ++ pr_vernac_list v) | VernacTimeout(n,v) -> return (keyword "Timeout " ++ int n ++ spc() ++ pr_vernac v) | VernacFail v -> @@ -642,11 +660,15 @@ module Make keyword (if opening then "Open " else "Close ") ++ keyword "Scope" ++ spc() ++ str sc ) - | VernacDelimiters (sc,key) -> + | VernacDelimiters (sc,Some key) -> return ( keyword "Delimit Scope" ++ spc () ++ str sc ++ spc() ++ keyword "with" ++ spc () ++ str key ) + | VernacDelimiters (sc, None) -> + return ( + keyword "Undelimit Scope" ++ spc () ++ str sc + ) | VernacBindScope (sc,cll) -> return ( keyword "Bind Scope" ++ spc () ++ str sc ++ @@ -723,7 +745,7 @@ module Make return ( hov 2 ( pr_def_token d ++ spc() - ++ pr_lident id ++ binds ++ typ + ++ pr_plident id ++ binds ++ typ ++ (match c with | None -> mt() | Some cc -> str" :=" ++ spc() ++ cc)) @@ -754,11 +776,12 @@ module Make return (hov 2 (keyword "Proof" ++ pr_lconstrarg c)) | VernacAssumption (stre,_,l) -> let n = List.length (List.flatten (List.map fst (List.map snd l))) in - return ( - hov 2 - (pr_assumption_token (n > 1) stre ++ spc() ++ - pr_ne_params_list pr_lconstr_expr l) - ) + let pr_params (c, (xl, t)) = + hov 2 (prlist_with_sep sep pr_plident xl ++ spc() ++ + (if c then str":>" else str":" ++ spc() ++ pr_lconstr_expr t)) + in + let assumptions = prlist_with_sep spc (fun p -> hov 1 (str "(" ++ pr_params p ++ str ")")) l in + return (hov 2 (pr_assumption_token (n > 1) stre ++ spc() ++ assumptions)) | VernacInductive (p,f,l) -> let pr_constructor (coe,(id,c)) = hov 2 (pr_lident id ++ str" " ++ @@ -775,10 +798,10 @@ module Make | RecordDecl (c,fs) -> pr_record_decl b c fs in - let pr_oneind key (((coe,id),indpar,s,k,lc),ntn) = + let pr_oneind key (((coe,(id,pl)),indpar,s,k,lc),ntn) = hov 0 ( str key ++ spc() ++ - (if coe then str"> " else str"") ++ pr_lident id ++ + (if coe then str"> " else str"") ++ pr_lident id ++ pr_univs pl ++ pr_and_type_binders_arg indpar ++ spc() ++ Option.cata (fun s -> str":" ++ spc() ++ pr_lconstr_expr s) (mt()) s ++ str" :=") ++ pr_constructor_list k lc ++ @@ -802,9 +825,9 @@ module Make | None | Some Global -> "" in let pr_onerec = function - | ((loc,id),ro,bl,type_,def),ntn -> + | (((loc,id),pl),ro,bl,type_,def),ntn -> let annot = pr_guard_annot pr_lconstr_expr bl ro in - pr_id id ++ pr_binders_arg bl ++ annot + pr_id id ++ pr_univs pl ++ pr_binders_arg bl ++ annot ++ pr_type_option (fun c -> spc() ++ pr_lconstr_expr c) type_ ++ pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_lconstr def) def ++ prlist (pr_decl_notation pr_constr) ntn @@ -820,8 +843,8 @@ module Make | Some Local -> keyword "Local" ++ spc () | None | Some Global -> str "" in - let pr_onecorec (((loc,id),bl,c,def),ntn) = - pr_id id ++ spc() ++ pr_binders bl ++ spc() ++ str":" ++ + let pr_onecorec ((((loc,id),pl),bl,c,def),ntn) = + pr_id id ++ pr_univs pl ++ spc() ++ pr_binders bl ++ spc() ++ str":" ++ spc() ++ pr_lconstr_expr c ++ pr_opt (fun def -> str":=" ++ brk(1,2) ++ pr_lconstr def) def ++ prlist (pr_decl_notation pr_constr) ntn @@ -1253,7 +1276,7 @@ module Make and pr_extend s cl = let pr_arg a = try pr_gen a - with Failure _ -> str ("<error in "^fst s^">") in + with Failure _ -> str "<error in " ++ str (fst s) ++ str ">" in try let rl = Egramml.get_extend_vernac_rule s in let start,rl,cl = @@ -1271,7 +1294,7 @@ module Make (start,cl) rl in hov 1 pp with Not_found -> - hov 1 (str ("TODO("^fst s) ++ prlist_with_sep sep pr_arg cl ++ str ")") + hov 1 (str "TODO(" ++ str (fst s) ++ prlist_with_sep sep pr_arg cl ++ str ")") in pr_vernac diff --git a/printing/prettyp.ml b/printing/prettyp.ml index 4a66c33d..84649e6e 100644 --- a/printing/prettyp.ml +++ b/printing/prettyp.ml @@ -73,8 +73,15 @@ let print_ref reduce ref = in it_mkProd_or_LetIn ccl ctx else typ in let univs = Global.universes_of_global ref in - hov 0 (pr_global ref ++ str " :" ++ spc () ++ pr_ltype typ ++ - Printer.pr_universe_ctx univs) + let env = Global.env () in + let bl = Universes.universe_binders_of_global ref in + let sigma = Evd.from_ctx (Evd.evar_universe_context_of_binders bl) in + let inst = + if Global.is_polymorphic ref then Printer.pr_universe_instance sigma univs + else mt () + in + hov 0 (pr_global ref ++ inst ++ str " :" ++ spc () ++ pr_ltype_env env sigma typ ++ + Printer.pr_universe_ctx sigma univs) (********************************) (** Printing implicit arguments *) @@ -180,16 +187,16 @@ let print_opacity ref = | None -> [] | Some s -> [pr_global ref ++ str " is " ++ - str (match s with - | FullyOpaque -> "opaque" + match s with + | FullyOpaque -> str "opaque" | TransparentMaybeOpacified Conv_oracle.Opaque -> - "basically transparent but considered opaque for reduction" + str "basically transparent but considered opaque for reduction" | TransparentMaybeOpacified lev when Conv_oracle.is_transparent lev -> - "transparent" + str "transparent" | TransparentMaybeOpacified (Conv_oracle.Level n) -> - "transparent (with expansion weight "^string_of_int n^")" + str "transparent (with expansion weight " ++ int n ++ str ")" | TransparentMaybeOpacified Conv_oracle.Expand -> - "transparent (with minimal expansion weight)")] + str "transparent (with minimal expansion weight)"] (*******************) (* *) @@ -205,16 +212,20 @@ let print_polymorphism ref = else "not universe polymorphic") ] else [] -let print_primitive_record mipv = function +let print_primitive_record recflag mipv = function | Some (Some (_, ps,_)) -> - [pr_id mipv.(0).mind_typename ++ str" is primitive and has eta conversion."] + let eta = match recflag with + | Decl_kinds.CoFinite -> mt () + | Decl_kinds.Finite | Decl_kinds.BiFinite -> str " and has eta conversion" + in + [pr_id mipv.(0).mind_typename ++ str" is primitive" ++ eta ++ str"."] | _ -> [] let print_primitive ref = match ref with | IndRef ind -> let mib,_ = Global.lookup_inductive ind in - print_primitive_record mib.mind_packets mib.mind_record + print_primitive_record mib.mind_finite mib.mind_packets mib.mind_record | _ -> [] let print_name_infos ref = @@ -386,9 +397,9 @@ let print_located_qualid name flags ref = | [] -> let (dir,id) = repr_qualid qid in if DirPath.is_empty dir then - str ("No " ^ name ^ " of basename") ++ spc () ++ pr_id id + str "No " ++ str name ++ str " of basename" ++ spc () ++ pr_id id else - str ("No " ^ name ^ " of suffix") ++ spc () ++ pr_qualid qid + str "No " ++ str name ++ str " of suffix" ++ spc () ++ pr_qualid qid | l -> prlist_with_sep fnl (fun (o,oqid) -> @@ -447,7 +458,7 @@ let gallina_print_inductive sp = let mipv = mib.mind_packets in pr_mutual_inductive_body env sp mib ++ with_line_skip - (print_primitive_record mipv mib.mind_record @ + (print_primitive_record mib.mind_finite mipv mib.mind_record @ print_inductive_renames sp mipv @ print_inductive_implicit_args sp mipv @ print_inductive_argument_scopes sp mipv) @@ -459,16 +470,21 @@ let gallina_print_section_variable id = print_named_decl id ++ with_line_skip (print_name_infos (VarRef id)) -let print_body = function - | Some c -> pr_lconstr c +let print_body env evd = function + | Some c -> pr_lconstr_env env evd c | None -> (str"<no body>") -let print_typed_body (val_0,typ) = - (print_body val_0 ++ fnl () ++ str " : " ++ pr_ltype typ) +let print_typed_body env evd (val_0,typ) = + (print_body env evd val_0 ++ fnl () ++ str " : " ++ pr_ltype_env env evd typ) let ungeneralized_type_of_constant_type t = Typeops.type_of_constant_type (Global.env ()) t +let print_instance sigma cb = + if cb.const_polymorphic then + pr_universe_instance sigma cb.const_universes + else mt() + let print_constant with_values sep sp = let cb = Global.lookup_constant sp in let val_0 = Global.body_of_constant_body cb in @@ -477,17 +493,23 @@ let print_constant with_values sep sp = let univs = Univ.instantiate_univ_context (Global.universes_of_constant_body cb) in + let ctx = + Evd.evar_universe_context_of_binders + (Universes.universe_binders_of_global (ConstRef sp)) + in + let env = Global.env () and sigma = Evd.from_ctx ctx in + let pr_ltype = pr_ltype_env env sigma in hov 0 (pr_polymorphic cb.const_polymorphic ++ match val_0 with | None -> str"*** [ " ++ - print_basename sp ++ str " : " ++ cut () ++ pr_ltype typ ++ + print_basename sp ++ print_instance sigma cb ++ str " : " ++ cut () ++ pr_ltype typ ++ str" ]" ++ - Printer.pr_universe_ctx univs + Printer.pr_universe_ctx sigma univs | _ -> - print_basename sp ++ str sep ++ cut () ++ - (if with_values then print_typed_body (val_0,typ) else pr_ltype typ)++ - Printer.pr_universe_ctx univs) + print_basename sp ++ print_instance sigma cb ++ str sep ++ cut () ++ + (if with_values then print_typed_body env sigma (val_0,typ) else pr_ltype typ)++ + Printer.pr_universe_ctx sigma univs) let gallina_print_constant_with_infos sp = print_constant true " = " sp ++ diff --git a/printing/printer.ml b/printing/printer.ml index 0d3a1c17..2e112f9a 100644 --- a/printing/printer.ml +++ b/printing/printer.ml @@ -208,10 +208,10 @@ let safe_pr_constr t = let (sigma, env) = get_current_context () in safe_pr_constr_env env sigma t -let pr_universe_ctx c = +let pr_universe_ctx sigma c = if !Detyping.print_universes && not (Univ.UContext.is_empty c) then fnl()++pr_in_comment (fun c -> v 0 - (Univ.pr_universe_context Universes.pr_with_global_universes c)) c + (Univ.pr_universe_context (Evd.pr_evd_level sigma) c)) c else mt() @@ -455,14 +455,17 @@ let pr_ne_evar_set hd tl sigma l = else mt () +let pr_selected_subgoal name sigma g = + let pg = default_pr_goal { sigma=sigma ; it=g; } in + v 0 (str "subgoal " ++ name ++ pr_goal_tag g ++ pr_goal_name sigma g + ++ str " is:" ++ cut () ++ pg) + let default_pr_subgoal n sigma = let rec prrec p = function | [] -> error "No such goal." | g::rest -> if Int.equal p 1 then - let pg = default_pr_goal { sigma=sigma ; it=g; } in - v 0 (str "subgoal " ++ int n ++ pr_goal_tag g ++ pr_goal_name sigma g - ++ str " is:" ++ cut () ++ pg) + pr_selected_subgoal (int n) sigma g else prrec (p-1) rest in @@ -559,8 +562,8 @@ let default_pr_subgoals ?(pr_first=true) close_cmd sigma seeds shelf stack goals ++ emacs_print_dependent_evars sigma seeds) else let pei = pr_evars_int sigma 1 exl in - (str "No more subgoals but non-instantiated existential " ++ - str "variables:" ++ fnl () ++ (hov 0 pei) + (str "No more subgoals, but there are non-instantiated existential variables:" + ++ fnl () ++ (hov 0 pei) ++ emacs_print_dependent_evars sigma seeds ++ fnl () ++ str "You can use Grab Existential Variables.") end @@ -625,17 +628,17 @@ let pr_open_subgoals ?(proof=Proof_global.give_me_the_proof ()) () = begin match bgoals,shelf,given_up with | [] , [] , [] -> pr_subgoals None sigma seeds shelf stack goals | [] , [] , _ -> - msg_info (str "No more goals, however there are goals you gave up. You need to go back and solve them."); + msg_info (str "No more subgoals, but there are some goals you gave up:"); fnl () ++ pr_subgoals ~pr_first:false None bsigma seeds [] [] given_up + ++ fnl () ++ str "You need to go back and solve them." | [] , _ , _ -> msg_info (str "All the remaining goals are on the shelf."); fnl () ++ pr_subgoals ~pr_first:false None bsigma seeds [] [] shelf | _ , _, _ -> let end_cmd = - strbrk "This subproof is complete, but there are still \ - unfocused goals." ++ + str "This subproof is complete, but there are some unfocused goals." ++ (match Proof_global.Bullet.suggest p with None -> str"" | Some s -> fnl () ++ str s) ++ fnl () @@ -652,9 +655,17 @@ let pr_nth_open_subgoal n = let pr_goal_by_id id = let p = Proof_global.give_me_the_proof () in - let g = Goal.get_by_uid id in + try + Proof.in_proof p (fun sigma -> + let g = Evd.evar_key id sigma in + pr_selected_subgoal (pr_id id) sigma g) + with Not_found -> error "No such goal." + +let pr_goal_by_uid uid = + let p = Proof_global.give_me_the_proof () in + let g = Goal.get_by_uid uid in let pr gs = - v 0 (str ("goal / evar " ^ id ^ " is:") ++ cut () + v 0 (str "goal / evar " ++ str uid ++ str " is:" ++ cut () ++ pr_goal gs) in try @@ -713,31 +724,72 @@ let prterm = pr_lconstr (* Printer function for sets of Assumptions.assumptions. It is used primarily by the Print Assumptions command. *) -open Assumptions +type context_object = + | Variable of Id.t (* A section variable or a Let definition *) + | Axiom of constant * (Label.t * Context.rel_context * types) list + | Opaque of constant (* An opaque constant. *) + | Transparent of constant + +(* Defines a set of [assumption] *) +module OrderedContextObject = +struct + type t = context_object + let compare x y = + match x , y with + | Variable i1 , Variable i2 -> Id.compare i1 i2 + | Axiom (k1,_) , Axiom (k2, _) -> con_ord k1 k2 + | Opaque k1 , Opaque k2 -> con_ord k1 k2 + | Transparent k1 , Transparent k2 -> con_ord k1 k2 + | Axiom _ , Variable _ -> 1 + | Opaque _ , Variable _ + | Opaque _ , Axiom _ -> 1 + | Transparent _ , Variable _ + | Transparent _ , Axiom _ + | Transparent _ , Opaque _ -> 1 + | _ , _ -> -1 +end + +module ContextObjectSet = Set.Make (OrderedContextObject) +module ContextObjectMap = Map.Make (OrderedContextObject) let pr_assumptionset env s = - if ContextObjectMap.is_empty s then + if ContextObjectMap.is_empty s && + engagement env = (PredicativeSet, StratifiedType) then str "Closed under the global context" else let safe_pr_constant env kn = try pr_constant env kn with Not_found -> let mp,_,lab = repr_con kn in - str (string_of_mp mp ^ "." ^ Label.to_string lab) + str (string_of_mp mp) ++ str "." ++ pr_label lab in let safe_pr_ltype typ = try str " : " ++ pr_ltype typ with e when Errors.noncritical e -> mt () in + let safe_pr_ltype_relctx (rctx, typ) = + let sigma, env = get_current_context () in + let env = Environ.push_rel_context rctx env in + try str " " ++ pr_ltype_env env sigma typ + with e when Errors.noncritical e -> mt () + in let fold t typ accu = let (v, a, o, tr) = accu in match t with | Variable id -> let var = str (Id.to_string id) ++ str " : " ++ pr_ltype typ in (var :: v, a, o, tr) - | Axiom kn -> + | Axiom (kn,[]) -> let ax = safe_pr_constant env kn ++ safe_pr_ltype typ in (v, ax :: a, o, tr) + | Axiom (kn,l) -> + let ax = safe_pr_constant env kn ++ safe_pr_ltype typ ++ + cut() ++ + prlist_with_sep cut (fun (lbl, ctx, ty) -> + str " used in " ++ str (Names.Label.to_string lbl) ++ + str " to prove:" ++ safe_pr_ltype_relctx (ctx,ty)) + l in + (v, ax :: a, o, tr) | Opaque kn -> let opq = safe_pr_constant env kn ++ safe_pr_ltype typ in (v, a, opq :: o, tr) @@ -748,6 +800,16 @@ let pr_assumptionset env s = let (vars, axioms, opaque, trans) = ContextObjectMap.fold fold s ([], [], [], []) in + let theory = + if is_impredicative_set env then + [str "Set is impredicative"] + else [] + in + let theory = + if type_in_type env then + str "Type hierarchy is collapsed (logic is inconsistent)" :: theory + else theory + in let opt_list title = function | [] -> None | l -> @@ -761,6 +823,7 @@ let pr_assumptionset env s = opt_list (str "Section Variables:") vars; opt_list (str "Axioms:") axioms; opt_list (str "Opaque constants:") opaque; + opt_list (str "Theory:") theory; ] in prlist_with_sep fnl (fun x -> x) (Option.List.flatten assums) @@ -773,3 +836,7 @@ let pr_polymorphic b = if b then str"Polymorphic " else str"Monomorphic " else mt () +let pr_universe_instance evd ctx = + let inst = Univ.UContext.instance ctx in + str"@{" ++ Univ.Instance.pr (Evd.pr_evd_level evd) inst ++ str"}" + diff --git a/printing/printer.mli b/printing/printer.mli index a469a8db..5c60b893 100644 --- a/printing/printer.mli +++ b/printing/printer.mli @@ -84,7 +84,8 @@ val pr_sort : evar_map -> sorts -> std_ppcmds (** Universe constraints *) val pr_polymorphic : bool -> std_ppcmds -val pr_universe_ctx : Univ.universe_context -> std_ppcmds +val pr_universe_instance : evar_map -> Univ.universe_context -> std_ppcmds +val pr_universe_ctx : evar_map -> Univ.universe_context -> std_ppcmds (** Printing global references using names as short as possible *) @@ -160,12 +161,23 @@ val emacs_str : string -> string val prterm : constr -> std_ppcmds (** = pr_lconstr *) -(** spiwack: printer function for sets of Environ.assumption. - It is used primarily by the Print Assumption command. *) +(** Declarations for the "Print Assumption" command *) +type context_object = + | Variable of Id.t (** A section variable or a Let definition *) + (** An axiom and the type it inhabits (if an axiom of the empty type) *) + | Axiom of constant * (Label.t * Context.rel_context * types) list + | Opaque of constant (** An opaque constant. *) + | Transparent of constant (** A transparent constant *) + +module ContextObjectSet : Set.S with type elt = context_object +module ContextObjectMap : CMap.ExtS + with type key = context_object and module Set := ContextObjectSet + val pr_assumptionset : - env -> Term.types Assumptions.ContextObjectMap.t ->std_ppcmds + env -> Term.types ContextObjectMap.t -> std_ppcmds -val pr_goal_by_id : string -> std_ppcmds +val pr_goal_by_id : Id.t -> std_ppcmds +val pr_goal_by_uid : string -> std_ppcmds type printer_pr = { pr_subgoals : ?pr_first:bool -> std_ppcmds option -> evar_map -> evar list -> Goal.goal list -> int list -> goal list -> std_ppcmds; diff --git a/printing/printing.mllib b/printing/printing.mllib index 7b4c71a8..652a34fa 100644 --- a/printing/printing.mllib +++ b/printing/printing.mllib @@ -1,6 +1,5 @@ Genprint Pputils -Ppstyle Ppannotation Ppconstr Ppconstrsig diff --git a/printing/printmod.ml b/printing/printmod.ml index 295d8aaa..1d275c1a 100644 --- a/printing/printmod.ml +++ b/printing/printmod.ml @@ -72,10 +72,10 @@ let print_params env sigma params = if List.is_empty params then mt () else Printer.pr_rel_context env sigma params ++ brk(1,2) -let print_constructors envpar names types = +let print_constructors envpar sigma names types = let pc = prlist_with_sep (fun () -> brk(1,0) ++ str "| ") - (fun (id,c) -> pr_id id ++ str " : " ++ Printer.pr_lconstr_env envpar Evd.empty c) + (fun (id,c) -> pr_id id ++ str " : " ++ Printer.pr_lconstr_env envpar sigma c) (Array.to_list (Array.map2 (fun n t -> (n,t)) names types)) in hv 0 (str " " ++ pc) @@ -83,7 +83,7 @@ let print_constructors envpar names types = let build_ind_type env mip = Inductive.type_of_inductive env mip -let print_one_inductive env mib ((_,i) as ind) = +let print_one_inductive env sigma mib ((_,i) as ind) = let u = if mib.mind_polymorphic then Univ.UContext.instance mib.mind_universes else Univ.Instance.empty in @@ -94,10 +94,15 @@ let print_one_inductive env mib ((_,i) as ind) = let cstrtypes = Inductive.type_of_constructors (ind,u) (mib,mip) in let cstrtypes = Array.map (fun c -> hnf_prod_applist env c args) cstrtypes in let envpar = push_rel_context params env in + let inst = + if mib.mind_polymorphic then + Printer.pr_universe_instance sigma mib.mind_universes + else mt () + in hov 0 ( - pr_id mip.mind_typename ++ brk(1,4) ++ print_params env Evd.empty params ++ - str ": " ++ Printer.pr_lconstr_env envpar Evd.empty arity ++ str " :=") ++ - brk(0,2) ++ print_constructors envpar mip.mind_consnames cstrtypes + pr_id mip.mind_typename ++ inst ++ brk(1,4) ++ print_params env sigma params ++ + str ": " ++ Printer.pr_lconstr_env envpar sigma arity ++ str " :=") ++ + brk(0,2) ++ print_constructors envpar sigma mip.mind_consnames cstrtypes let print_mutual_inductive env mind mib = let inds = List.init (Array.length mib.mind_packets) (fun x -> (mind, x)) @@ -109,11 +114,13 @@ let print_mutual_inductive env mind mib = | BiFinite -> "Variant" | CoFinite -> "CoInductive" in + let bl = Universes.universe_binders_of_global (IndRef (mind, 0)) in + let sigma = Evd.from_ctx (Evd.evar_universe_context_of_binders bl) in hov 0 (Printer.pr_polymorphic mib.mind_polymorphic ++ def keyword ++ spc () ++ prlist_with_sep (fun () -> fnl () ++ str" with ") - (print_one_inductive env mib) inds ++ - Printer.pr_universe_ctx (Univ.instantiate_univ_context mib.mind_universes)) + (print_one_inductive env sigma mib) inds ++ + Printer.pr_universe_ctx sigma (Univ.instantiate_univ_context mib.mind_universes)) let get_fields = let rec prodec_rec l subst c = @@ -142,6 +149,8 @@ let print_record env mind mib = let cstrtype = hnf_prod_applist env cstrtypes.(0) args in let fields = get_fields cstrtype in let envpar = push_rel_context params env in + let bl = Universes.universe_binders_of_global (IndRef (mind,0)) in + let sigma = Evd.from_ctx (Evd.evar_universe_context_of_binders bl) in let keyword = let open Decl_kinds in match mib.mind_finite with @@ -153,16 +162,16 @@ let print_record env mind mib = hov 0 ( Printer.pr_polymorphic mib.mind_polymorphic ++ def keyword ++ spc () ++ pr_id mip.mind_typename ++ brk(1,4) ++ - print_params env Evd.empty params ++ - str ": " ++ Printer.pr_lconstr_env envpar Evd.empty arity ++ brk(1,2) ++ + print_params env sigma params ++ + str ": " ++ Printer.pr_lconstr_env envpar sigma arity ++ brk(1,2) ++ str ":= " ++ pr_id mip.mind_consnames.(0)) ++ brk(1,2) ++ hv 2 (str "{ " ++ prlist_with_sep (fun () -> str ";" ++ brk(2,0)) (fun (id,b,c) -> pr_id id ++ str (if b then " : " else " := ") ++ - Printer.pr_lconstr_env envpar Evd.empty c) fields) ++ str" }" ++ - Printer.pr_universe_ctx (Univ.instantiate_univ_context mib.mind_universes)) + Printer.pr_lconstr_env envpar sigma c) fields) ++ str" }" ++ + Printer.pr_universe_ctx sigma (Univ.instantiate_univ_context mib.mind_universes)) let pr_mutual_inductive_body env mind mib = if mib.mind_record <> None && not !Flags.raw_print then @@ -259,6 +268,11 @@ let print_body is_impl env mp (l,body) = | SFBmodule _ -> keyword "Module" ++ spc () ++ name | SFBmodtype _ -> keyword "Module Type" ++ spc () ++ name | SFBconst cb -> + let u = + if cb.const_polymorphic then Univ.UContext.instance cb.const_universes + else Univ.Instance.empty + in + let sigma = Evd.empty in (match cb.const_body with | Def _ -> def "Definition" ++ spc () | OpaqueDef _ when is_impl -> def "Theorem" ++ spc () @@ -267,15 +281,17 @@ let print_body is_impl env mp (l,body) = | None -> mt () | Some env -> str " :" ++ spc () ++ - hov 0 (Printer.pr_ltype_env env Evd.empty (* No evars in modules *) - (Typeops.type_of_constant_type env cb.const_type)) ++ + hov 0 (Printer.pr_ltype_env env sigma + (Vars.subst_instance_constr u + (Typeops.type_of_constant_type env cb.const_type))) ++ (match cb.const_body with | Def l when is_impl -> spc () ++ hov 2 (str ":= " ++ - Printer.pr_lconstr_env env Evd.empty (Mod_subst.force_constr l)) + Printer.pr_lconstr_env env sigma + (Vars.subst_instance_constr u (Mod_subst.force_constr l))) | _ -> mt ()) ++ str "." ++ - Printer.pr_universe_ctx cb.const_universes) + Printer.pr_universe_ctx sigma (Univ.instantiate_univ_context cb.const_universes)) | SFBmind mib -> try let env = Option.get env in @@ -315,15 +331,17 @@ let rec print_typ_expr env mp locals mty = let mapp = List.tl lapp in hov 3 (str"(" ++ (print_kn locals fapp) ++ spc () ++ prlist_with_sep spc (print_modpath locals) mapp ++ str")") - | MEwith(me,WithDef(idl,c))-> + | MEwith(me,WithDef(idl,(c, _)))-> let env' = None in (* TODO: build a proper environment if env <> None *) let s = String.concat "." (List.map Id.to_string idl) in hov 2 (print_typ_expr env' mp locals me ++ spc() ++ str "with" ++ spc() - ++ def "Definition"++ spc() ++ str s ++ spc() ++ str ":="++ spc()) - | MEwith(me,WithMod(idl,mp))-> + ++ def "Definition"++ spc() ++ str s ++ spc() ++ str ":="++ spc() + ++ Printer.pr_lconstr c) + | MEwith(me,WithMod(idl,mp'))-> let s = String.concat "." (List.map Id.to_string idl) in hov 2 (print_typ_expr env mp locals me ++ spc() ++ str "with" ++ spc() ++ - keyword "Module"++ spc() ++ str s ++ spc() ++ str ":="++ spc()) + keyword "Module"++ spc() ++ str s ++ spc() ++ str ":="++ spc() + ++ print_modpath locals mp') let print_mod_expr env mp locals = function | MEident mp -> print_modpath locals mp diff --git a/proofs/clenv.ml b/proofs/clenv.ml index 2c9c695b..a2cccc0e 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -28,7 +28,7 @@ open Misctypes (* Abbreviations *) let pf_env = Refiner.pf_env -let pf_type_of gls c = Typing.type_of (pf_env gls) gls.sigma c +let pf_type_of gls c = Typing.unsafe_type_of (pf_env gls) gls.sigma c (******************************************************************) (* Clausal environments *) diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index 18883df2..aaa49f11 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -125,7 +125,5 @@ let unify ?(flags=fail_quick_unif_flags) m = try let evd' = w_unify env evd CONV ~flags m n in Proofview.Unsafe.tclEVARSADVANCE evd' - with e when Errors.noncritical e -> - (** This is Tacticals.tclFAIL *) - Proofview.tclZERO (FailError (0, lazy (Errors.print e))) + with e when Errors.noncritical e -> Proofview.tclZERO e end diff --git a/proofs/evar_refiner.ml b/proofs/evar_refiner.ml index c8cb1d1c..9b358210 100644 --- a/proofs/evar_refiner.ml +++ b/proofs/evar_refiner.ml @@ -12,6 +12,7 @@ open Names open Evd open Evarutil open Evarsolve +open Pp (******************************************) (* Instantiation of existential variables *) @@ -54,8 +55,8 @@ let w_refine (evk,evi) (ltac_var,rawc) sigma = with e when Errors.noncritical e -> let loc = Glob_ops.loc_of_glob_constr rawc in user_err_loc - (loc,"",Pp.str ("Instance is not well-typed in the environment of " ^ - string_of_existential evk)) + (loc,"", str "Instance is not well-typed in the environment of " ++ + str (string_of_existential evk)) in define_and_solve_constraints evk typed_c env (evars_reset_evd sigma' sigma) diff --git a/proofs/logic.ml b/proofs/logic.ml index b8206ca1..3273c957 100644 --- a/proofs/logic.ml +++ b/proofs/logic.ml @@ -83,7 +83,7 @@ let apply_to_hyp sign id f = else sign let check_typability env sigma c = - if !check then let _ = type_of env sigma c in () + if !check then let _ = unsafe_type_of env sigma c in () (************************************************************************) (************************************************************************) @@ -179,7 +179,8 @@ let check_decl_position env sign (x,_,_ as d) = let needed = global_vars_set_of_decl env d in let deps = dependency_closure env (named_context_of_val sign) needed in if Id.List.mem x deps then - error ("Cannot create self-referring hypothesis "^Id.to_string x); + errorlabstrm "Logic.check_decl_position" + (str "Cannot create self-referring hypothesis " ++ pr_id x); x::deps (* Auxiliary functions for primitive MOVE tactic @@ -316,7 +317,7 @@ let meta_free_prefix a = with Stop acc -> Array.rev_of_list acc let goal_type_of env sigma c = - if !check then type_of env sigma c + if !check then unsafe_type_of env sigma c else Retyping.get_type_of env sigma c let rec mk_refgoals sigma goal goalacc conclty trm = @@ -355,9 +356,11 @@ let rec mk_refgoals sigma goal goalacc conclty trm = | App (f,l) -> let (acc',hdty,sigma,applicand) = if is_template_polymorphic env f then - let sigma, ty = + let ty = (* Template sort-polymorphism of definition and inductive types *) - type_of_global_reference_knowing_conclusion env sigma f conclty + let firstmeta = Array.findi (fun i x -> occur_meta x) l in + let args, _ = Option.cata (fun i -> CArray.chop i l) (l, [||]) firstmeta in + type_of_global_reference_knowing_parameters env sigma f args in goalacc, ty, sigma, f else @@ -488,9 +491,11 @@ let convert_hyp check sign sigma (id,b,bt as d) = (fun _ (_,c,ct) _ -> let env = Global.env_of_context sign in if check && not (is_conv env sigma bt ct) then - error ("Incorrect change of the type of "^(Id.to_string id)^"."); + errorlabstrm "Logic.convert_hyp" + (str "Incorrect change of the type of " ++ pr_id id ++ str "."); if check && not (Option.equal (is_conv env sigma) b c) then - error ("Incorrect change of the body of "^(Id.to_string id)^"."); + errorlabstrm "Logic.convert_hyp" + (str "Incorrect change of the body of "++ pr_id id ++ str "."); if check then reorder := check_decl_position env sign d; d) in reorder_val_context env sign' !reorder @@ -522,7 +527,8 @@ let prim_refiner r sigma goal = t,cl,sigma else (if !check && mem_named_context id (named_context_of_val sign) then - error ("Variable " ^ Id.to_string id ^ " is already declared."); + errorlabstrm "Logic.prim_refiner" + (str "Variable " ++ pr_id id ++ str " is already declared."); push_named_context_val (id,None,t) sign,t,cl,sigma) in let (sg2,ev2,sigma) = Goal.V82.mk_goal sigma sign cl (Goal.V82.extra sigma goal) in @@ -550,11 +556,10 @@ let prim_refiner r sigma goal = | (f,n,ar)::oth -> let ((sp',_),u') = check_ind env n ar in if not (eq_mind sp sp') then - error ("Fixpoints should be on the same " ^ - "mutual inductive declaration."); + error "Fixpoints should be on the same mutual inductive declaration."; if !check && mem_named_context f (named_context_of_val sign) then - error - ("Name "^Id.to_string f^" already used in the environment"); + errorlabstrm "Logic.prim_refiner" + (str "Name " ++ pr_id f ++ str " already used in the environment"); mk_sign (push_named_context_val (f,None,ar) sign) oth | [] -> Evd.Monad.List.map (fun (_,_,c) sigma -> @@ -584,8 +589,7 @@ let prim_refiner r sigma goal = try let _ = find_coinductive env sigma b in () with Not_found -> - error ("All methods must construct elements " ^ - "in coinductive types.") + error "All methods must construct elements in coinductive types." in let firsts,lasts = List.chop j others in let all = firsts@(f,cl)::lasts in diff --git a/proofs/logic_monad.ml b/proofs/logic_monad.ml index d509670e..e3caa886 100644 --- a/proofs/logic_monad.ml +++ b/proofs/logic_monad.ml @@ -94,10 +94,6 @@ struct let print_char = fun c -> (); fun () -> print_char c - (** {!Pp.pp}. The buffer is also flushed. *) - let print = fun s -> (); fun () -> try Pp.msg_info s; Pp.pp_flush () with e -> - let (e, info) = Errors.push e in raise ~info e () - let timeout = fun n t -> (); fun () -> Control.timeout n t (Exception Timeout) @@ -107,6 +103,13 @@ struct let (e, info) = Errors.push e in Util.iraise (Exception e, info) + (** Use the current logger. The buffer is also flushed. *) + let print_debug s = make (fun _ -> Pp.msg_info s;Pp.pp_flush ()) + let print_info s = make (fun _ -> Pp.msg_info s;Pp.pp_flush ()) + let print_warning s = make (fun _ -> Pp.msg_warning s;Pp.pp_flush ()) + let print_error s = make (fun _ -> Pp.msg_error s;Pp.pp_flush ()) + let print_notice s = make (fun _ -> Pp.msg_notice s;Pp.pp_flush ()) + let run = fun x -> try x () with Exception e as src -> let (src, info) = Errors.push src in @@ -184,7 +187,7 @@ struct shape of the monadic type is reminiscent of that of the continuation monad transformer. - The paper also contains the rational for the [split] abstraction. + The paper also contains the rationale for the [split] abstraction. An explanation of how to derive such a monad from mathematical principles can be found in "Kan Extensions for Program @@ -208,118 +211,110 @@ struct type rich_exn = Exninfo.iexn type 'a iolist = - { iolist : 'r. (rich_exn -> 'r NonLogical.t) -> - ('a -> (rich_exn -> 'r NonLogical.t) -> 'r NonLogical.t) -> - 'r NonLogical.t } + { iolist : 'r. state -> (rich_exn -> 'r NonLogical.t) -> + ('a -> state -> (rich_exn -> 'r NonLogical.t) -> 'r NonLogical.t) -> + 'r NonLogical.t } include Monad.Make(struct - type 'a t = state -> ('a * state) iolist - let return x : 'a t = (); fun s -> - { iolist = fun nil cons -> cons (x, s) nil } + type 'a t = 'a iolist + + let return x = + { iolist = fun s nil cons -> cons x s nil } - let (>>=) (m : 'a t) (f : 'a -> 'b t) : 'b t = (); fun s -> - let m = m s in - { iolist = fun nil cons -> - m.iolist nil (fun (x, s) next -> (f x s).iolist next cons) } + let (>>=) m f = + { iolist = fun s nil cons -> + m.iolist s nil (fun x s next -> (f x).iolist s next cons) } - let (>>) (m : unit t) (f : 'a t) : 'a t = (); fun s -> - let m = m s in - { iolist = fun nil cons -> - m.iolist nil (fun ((), s) next -> (f s).iolist next cons) } + let (>>) m f = + { iolist = fun s nil cons -> + m.iolist s nil (fun () s next -> f.iolist s next cons) } - let map (f : 'a -> 'b) (m : 'a t) : 'b t = (); fun s -> - let m = m s in - { iolist = fun nil cons -> m.iolist nil (fun (x, s) next -> cons (f x, s) next) } + let map f m = + { iolist = fun s nil cons -> m.iolist s nil (fun x s next -> cons (f x) s next) } end) - let zero e : 'a t = (); fun s -> - { iolist = fun nil cons -> nil e } + let zero e = + { iolist = fun _ nil cons -> nil e } - let plus m1 m2 : 'a t = (); fun s -> - let m1 = m1 s in - { iolist = fun nil cons -> m1.iolist (fun e -> (m2 e s).iolist nil cons) cons } + let plus m1 m2 = + { iolist = fun s nil cons -> m1.iolist s (fun e -> (m2 e).iolist s nil cons) cons } - let ignore (m : 'a t) : unit t = (); fun s -> - let m = m s in - { iolist = fun nil cons -> m.iolist nil (fun (_, s) next -> cons ((), s) next) } + let ignore m = + { iolist = fun s nil cons -> m.iolist s nil (fun _ s next -> cons () s next) } - let lift (m : 'a NonLogical.t) : 'a t = (); fun s -> - { iolist = fun nil cons -> NonLogical.(m >>= fun x -> cons (x, s) nil) } + let lift m = + { iolist = fun s nil cons -> NonLogical.(m >>= fun x -> cons x s nil) } (** State related *) - let get : P.s t = (); fun s -> - { iolist = fun nil cons -> cons (s.sstate, s) nil } + let get = + { iolist = fun s nil cons -> cons s.sstate s nil } - let set (sstate : P.s) : unit t = (); fun s -> - { iolist = fun nil cons -> cons ((), { s with sstate }) nil } + let set (sstate : P.s) = + { iolist = fun s nil cons -> cons () { s with sstate } nil } - let modify (f : P.s -> P.s) : unit t = (); fun s -> - { iolist = fun nil cons -> cons ((), { s with sstate = f s.sstate }) nil } + let modify (f : P.s -> P.s) = + { iolist = fun s nil cons -> cons () { s with sstate = f s.sstate } nil } - let current : P.e t = (); fun s -> - { iolist = fun nil cons -> cons (s.rstate, s) nil } + let current = + { iolist = fun s nil cons -> cons s.rstate s nil } - let local (type a) (e:P.e) (m:a t) : a t = (); fun s -> - let m = m { s with rstate = e } in - { iolist = fun nil cons -> - m.iolist nil (fun (x,s') next -> cons (x,{s' with rstate=s.rstate}) next) } + let local e m = + { iolist = fun s nil cons -> + m.iolist { s with rstate = e } nil + (fun x s' next -> cons x {s' with rstate = s.rstate} next) } - let put (w : P.w) : unit t = (); fun s -> - { iolist = fun nil cons -> cons ((), { s with wstate = P.wprod s.wstate w }) nil } + let put w = + { iolist = fun s nil cons -> cons () { s with wstate = P.wprod s.wstate w } nil } - let update (f : P.u -> P.u) : unit t = (); fun s -> - { iolist = fun nil cons -> cons ((), { s with ustate = f s.ustate }) nil } + let update (f : P.u -> P.u) = + { iolist = fun s nil cons -> cons () { s with ustate = f s.ustate } nil } (** List observation *) - let once (m : 'a t) : 'a t = (); fun s -> - let m = m s in - { iolist = fun nil cons -> m.iolist nil (fun x _ -> cons x nil) } + let once m = + { iolist = fun s nil cons -> m.iolist s nil (fun x s _ -> cons x s nil) } - let break (f : rich_exn -> rich_exn option) (m : 'a t) : 'a t = (); fun s -> - let m = m s in - { iolist = fun nil cons -> - m.iolist nil (fun x next -> cons x (fun e -> match f e with None -> next e | Some e -> nil e)) + let break f m = + { iolist = fun s nil cons -> + m.iolist s nil (fun x s next -> cons x s (fun e -> match f e with None -> next e | Some e -> nil e)) } (** For [reflect] and [split] see the "Backtracking, Interleaving, and Terminating Monad Transformers" paper. *) type 'a reified = ('a, rich_exn -> 'a reified) list_view NonLogical.t - let rec reflect (m : 'a reified) : 'a iolist = - { iolist = fun nil cons -> + let rec reflect (m : ('a * state) reified) : 'a iolist = + { iolist = fun s0 nil cons -> let next = function | Nil e -> nil e - | Cons (x, l) -> cons x (fun e -> (reflect (l e)).iolist nil cons) + | Cons ((x, s), l) -> cons x s (fun e -> (reflect (l e)).iolist s0 nil cons) in NonLogical.(m >>= next) } - let split (m : 'a t) : ('a, rich_exn -> 'a t) list_view t = (); fun s -> - let m = m s in + let split m : ('a, rich_exn -> 'a t) list_view t = let rnil e = NonLogical.return (Nil e) in - let rcons p l = NonLogical.return (Cons (p, l)) in - { iolist = fun nil cons -> + let rcons p s l = NonLogical.return (Cons ((p, s), l)) in + { iolist = fun s nil cons -> let open NonLogical in - m.iolist rnil rcons >>= begin function - | Nil e -> cons (Nil e, s) nil + m.iolist s rnil rcons >>= begin function + | Nil e -> cons (Nil e) s nil | Cons ((x, s), l) -> - let l e = (); fun _ -> reflect (l e) in - cons (Cons (x, l), s) nil + let l e = reflect (l e) in + cons (Cons (x, l)) s nil end } let run m r s = let s = { wstate = P.wunit; ustate = P.uunit; rstate = r; sstate = s } in - let m = m s in let rnil e = NonLogical.return (Nil e) in - let rcons (x, s) l = + let rcons x s l = let p = (x, s.sstate, s.wstate, s.ustate) in NonLogical.return (Cons (p, l)) in - m.iolist rnil rcons + m.iolist s rnil rcons let repr x = x diff --git a/proofs/logic_monad.mli b/proofs/logic_monad.mli index ab729aff..84ffda75 100644 --- a/proofs/logic_monad.mli +++ b/proofs/logic_monad.mli @@ -55,8 +55,13 @@ module NonLogical : sig val read_line : string t val print_char : char -> unit t - (** {!Pp.pp}. The buffer is also flushed. *) - val print : Pp.std_ppcmds -> unit t + + (** Loggers. The buffer is also flushed. *) + val print_debug : Pp.std_ppcmds -> unit t + val print_warning : Pp.std_ppcmds -> unit t + val print_notice : Pp.std_ppcmds -> unit t + val print_info : Pp.std_ppcmds -> unit t + val print_error : Pp.std_ppcmds -> unit t (** [Pervasives.raise]. Except that exceptions are wrapped with {!Exception}. *) diff --git a/proofs/pfedit.ml b/proofs/pfedit.ml index d1b6afe2..02dbd1fd 100644 --- a/proofs/pfedit.ml +++ b/proofs/pfedit.ml @@ -42,7 +42,7 @@ let cook_this_proof p = let cook_proof () = cook_this_proof (fst - (Proof_global.close_proof ~keep_body_ucst_sepatate:false (fun x -> x))) + (Proof_global.close_proof ~keep_body_ucst_separate:false (fun x -> x))) let get_pftreestate () = Proof_global.give_me_the_proof () @@ -108,7 +108,7 @@ let solve ?with_end_tac gi info_lvl tac pr = let () = match info_lvl with | None -> () - | Some i -> Pp.ppnl (hov 0 (Proofview.Trace.pr_info ~lvl:i info)) + | Some i -> Pp.msg_info (hov 0 (Proofview.Trace.pr_info ~lvl:i info)) in (p,status) with @@ -133,7 +133,7 @@ open Decl_kinds let next = let n = ref 0 in fun () -> incr n; !n let build_constant_by_tactic id ctx sign ?(goal_kind = Global, false, Proof Theorem) typ tac = - let evd = Evd.from_env ~ctx Environ.empty_env in + let evd = Evd.from_ctx ctx in start_proof id goal_kind evd sign typ (fun _ -> ()); try let status = by tac in @@ -145,16 +145,20 @@ let build_constant_by_tactic id ctx sign ?(goal_kind = Global, false, Proof Theo delete_current_proof (); iraise reraise -let build_by_tactic env ctx ?(poly=false) typ tac = +let build_by_tactic ?(side_eff=true) env ctx ?(poly=false) typ tac = let id = Id.of_string ("temporary_proof"^string_of_int (next())) in let sign = val_of_named_context (named_context env) in let gk = Global, poly, Proof Theorem in let ce, status, univs = build_constant_by_tactic id ctx sign ~goal_kind:gk typ tac in - let ce = Term_typing.handle_entry_side_effects env ce in + let ce = + if side_eff then Safe_typing.inline_private_constants_in_definition_entry env ce + else { ce with + const_entry_body = Future.chain ~pure:true ce.const_entry_body + (fun (pt, _) -> pt, Safe_typing.empty_private_constants) } in let (cb, ctx), se = Future.force ce.const_entry_body in - assert(Declareops.side_effects_is_empty se); - assert(Univ.ContextSet.is_empty ctx); - cb, status, univs + let univs' = Evd.merge_context_set Evd.univ_rigid (Evd.from_ctx univs) ctx in + assert(Safe_typing.empty_private_constants = se); + cb, status, Evd.evar_universe_context univs' let refine_by_tactic env sigma ty tac = (** Save the initial side-effects to restore them afterwards. We set the @@ -188,7 +192,7 @@ let refine_by_tactic env sigma ty tac = other goals that were already present during its invocation, so that those goals rely on effects that are not present anymore. Hopefully, this hack will work in most cases. *) - let ans = Term_typing.handle_side_effects env ans neff in + let ans = Safe_typing.inline_private_constants_in_constr env ans neff in ans, sigma (**********************************************************************) diff --git a/proofs/pfedit.mli b/proofs/pfedit.mli index 5e0fb4dd..fc521ea4 100644 --- a/proofs/pfedit.mli +++ b/proofs/pfedit.mli @@ -69,11 +69,11 @@ val start_proof : val cook_this_proof : Proof_global.proof_object -> (Id.t * - (Entries.definition_entry * Proof_global.proof_universes * goal_kind)) + (Safe_typing.private_constants Entries.definition_entry * Proof_global.proof_universes * goal_kind)) val cook_proof : unit -> (Id.t * - (Entries.definition_entry * Proof_global.proof_universes * goal_kind)) + (Safe_typing.private_constants Entries.definition_entry * Proof_global.proof_universes * goal_kind)) (** {6 ... } *) (** [get_pftreestate ()] returns the current focused pending proof. @@ -117,7 +117,8 @@ val set_end_tac : Tacexpr.raw_tactic_expr -> unit (** {6 ... } *) (** [set_used_variables l] declares that section variables [l] will be used in the proof *) -val set_used_variables : Id.t list -> Context.section_context +val set_used_variables : + Id.t list -> Context.section_context * (Loc.t * Names.Id.t) list val get_used_variables : unit -> Context.section_context option (** {6 ... } *) @@ -151,9 +152,9 @@ val instantiate_nth_evar_com : int -> Constrexpr.constr_expr -> unit val build_constant_by_tactic : Id.t -> Evd.evar_universe_context -> named_context_val -> ?goal_kind:goal_kind -> types -> unit Proofview.tactic -> - Entries.definition_entry * bool * Evd.evar_universe_context + Safe_typing.private_constants Entries.definition_entry * bool * Evd.evar_universe_context -val build_by_tactic : env -> Evd.evar_universe_context -> ?poly:polymorphic -> +val build_by_tactic : ?side_eff:bool -> env -> Evd.evar_universe_context -> ?poly:polymorphic -> types -> unit Proofview.tactic -> constr * bool * Evd.evar_universe_context diff --git a/proofs/proof.ml b/proofs/proof.ml index 828f9fa7..c7aa5bad 100644 --- a/proofs/proof.ml +++ b/proofs/proof.ml @@ -111,6 +111,8 @@ type proof = { shelf : Goal.goal list; (* List of goals that have been given up *) given_up : Goal.goal list; + (* The initial universe context (for the statement) *) + initial_euctx : Evd.evar_universe_context } (*** General proof functions ***) @@ -171,6 +173,12 @@ let is_done p = (* spiwack: for compatibility with <= 8.2 proof engine *) let has_unresolved_evar p = Proofview.V82.has_unresolved_evar p.proofview +let has_shelved_goals p = not (CList.is_empty (p.shelf)) +let has_given_up_goals p = not (CList.is_empty (p.given_up)) + +let is_complete p = + is_done p && not (has_unresolved_evar p) && + not (has_shelved_goals p) && not (has_given_up_goals p) (* Returns the list of partial proofs to initial goals *) let partial_proof p = Proofview.partial_proof p.entry p.proofview @@ -271,7 +279,9 @@ let start sigma goals = entry; focus_stack = [] ; shelf = [] ; - given_up = [] } in + given_up = []; + initial_euctx = + Evd.evar_universe_context (snd (Proofview.proofview proofview)) } in _focus end_of_stack (Obj.repr ()) 1 (List.length goals) pr let dependent_start goals = let entry, proofview = Proofview.dependent_init goals in @@ -280,7 +290,9 @@ let dependent_start goals = entry; focus_stack = [] ; shelf = [] ; - given_up = [] } in + given_up = []; + initial_euctx = + Evd.evar_universe_context (snd (Proofview.proofview proofview)) } in let number_of_goals = List.length (Proofview.initial_goals pr.entry) in _focus end_of_stack (Obj.repr ()) 1 number_of_goals pr @@ -299,9 +311,9 @@ end let return p = if not (is_done p) then raise UnfinishedProof - else if not (CList.is_empty (p.shelf)) then + else if has_shelved_goals p then raise HasShelvedGoals - else if not (CList.is_empty (p.given_up)) then + else if has_given_up_goals p then raise HasGivenUpGoals else if has_unresolved_evar p then (* spiwack: for compatibility with <= 8.3 proof engine *) @@ -311,6 +323,7 @@ let return p = Proofview.return p.proofview let initial_goals p = Proofview.initial_goals p.entry +let initial_euctx p = p.initial_euctx let compact p = let entry, proofview = Proofview.compact p.entry p.proofview in diff --git a/proofs/proof.mli b/proofs/proof.mli index 2b85ec87..a0ed0654 100644 --- a/proofs/proof.mli +++ b/proofs/proof.mli @@ -69,11 +69,15 @@ val map_structured_proof : proof -> (Evd.evar_map -> Goal.goal -> 'a) -> ('a pre val start : Evd.evar_map -> (Environ.env * Term.types) list -> proof val dependent_start : Proofview.telescope -> proof val initial_goals : proof -> (Term.constr * Term.types) list +val initial_euctx : proof -> Evd.evar_universe_context (* Returns [true] if the considered proof is completed, that is if no goal remain to be considered (this does not require that all evars have been solved). *) val is_done : proof -> bool +(* Like is_done, but this time it really means done (i.e. nothing left to do) *) +val is_complete : proof -> bool + (* Returns the list of partial proofs to initial goals. *) val partial_proof : proof -> Term.constr list diff --git a/proofs/proof_global.ml b/proofs/proof_global.ml index 5bff3c81..c303f486 100644 --- a/proofs/proof_global.ml +++ b/proofs/proof_global.ml @@ -67,14 +67,14 @@ type proof_universes = Evd.evar_universe_context type proof_object = { id : Names.Id.t; - entries : Entries.definition_entry list; + entries : Safe_typing.private_constants Entries.definition_entry list; persistence : Decl_kinds.goal_kind; universes: proof_universes; (* constraints : Univ.constraints; *) } type proof_ending = - | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry + | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry * proof_universes | Proved of Vernacexpr.opacity_flag * (Vernacexpr.lident * Decl_kinds.theorem_kind option) option * proof_object @@ -250,17 +250,43 @@ let start_dependent_proof id str goals terminator = let get_used_variables () = (cur_pstate ()).section_vars +let proof_using_auto_clear = ref true +let _ = Goptions.declare_bool_option + { Goptions.optsync = true; + Goptions.optdepr = false; + Goptions.optname = "Proof using Clear Unused"; + Goptions.optkey = ["Proof";"Using";"Clear";"Unused"]; + Goptions.optread = (fun () -> !proof_using_auto_clear); + Goptions.optwrite = (fun b -> proof_using_auto_clear := b) } + let set_used_variables l = let env = Global.env () in let ids = List.fold_right Id.Set.add l Id.Set.empty in let ctx = Environ.keep_hyps env ids in + let ctx_set = + List.fold_right Id.Set.add (List.map pi1 ctx) Id.Set.empty in + let vars_of = Environ.global_vars_set in + let aux env entry (ctx, all_safe, to_clear as orig) = + match entry with + | (x,None,_) -> + if Id.Set.mem x all_safe then orig + else (ctx, all_safe, (Loc.ghost,x)::to_clear) + | (x,Some bo, ty) as decl -> + if Id.Set.mem x all_safe then orig else + let vars = Id.Set.union (vars_of env bo) (vars_of env ty) in + if Id.Set.subset vars all_safe + then (decl :: ctx, Id.Set.add x all_safe, to_clear) + else (ctx, all_safe, (Loc.ghost,x) :: to_clear) in + let ctx, _, to_clear = + Environ.fold_named_context aux env ~init:(ctx,ctx_set,[]) in + let to_clear = if !proof_using_auto_clear then to_clear else [] in match !pstates with | [] -> raise NoCurrentProof | p :: rest -> if not (Option.is_empty p.section_vars) then Errors.error "Used section variables can be declared only once"; pstates := { p with section_vars = Some ctx} :: rest; - ctx + ctx, to_clear let get_open_goals () = let gl, gll, shelf , _ , _ = Proof.proof (cur_pstate ()).proof in @@ -269,16 +295,14 @@ let get_open_goals () = (List.map (fun (l1,l2) -> List.length l1 + List.length l2) gll) + List.length shelf -let close_proof ~keep_body_ucst_sepatate ?feedback_id ~now fpl = +let close_proof ~keep_body_ucst_separate ?feedback_id ~now fpl = let { pid; section_vars; strength; proof; terminator } = cur_pstate () in let poly = pi2 strength (* Polymorphic *) in let initial_goals = Proof.initial_goals proof in + let initial_euctx = Proof.initial_euctx proof in let fpl, univs = Future.split2 fpl in - let universes = - if poly || now then Future.force univs - else Proof.in_proof proof (fun x -> Evd.evar_universe_context x) - in - (* Because of dependent subgoals at the begining of proofs, we could + let universes = if poly || now then Future.force univs else initial_euctx in + (* Because of dependent subgoals at the beginning of proofs, we could have existential variables in the initial types of goals, we need to normalise them for the kernel. *) let subst_evar k = @@ -289,19 +313,26 @@ let close_proof ~keep_body_ucst_sepatate ?feedback_id ~now fpl = if poly || now then let make_body t (c, eff) = let open Universes in - let body = c and typ = nf t in + let body = c in + let typ = + if not (keep_body_ucst_separate || not (Safe_typing.empty_private_constants = eff)) then + nf t + else t + in let used_univs_body = Universes.universes_of_constr body in - let used_univs_typ = Universes.universes_of_constr typ in - let ctx = Evd.evar_universe_context_set universes in - if keep_body_ucst_sepatate then + let used_univs_typ = Universes.universes_of_constr typ in + if keep_body_ucst_separate || + not (Safe_typing.empty_private_constants = eff) then + let initunivs = Evd.evar_context_universe_context initial_euctx in + let ctx = Evd.evar_universe_context_set initunivs universes in (* For vi2vo compilation proofs are computed now but we need to * complement the univ constraints of the typ with the ones of * the body. So we keep the two sets distinct. *) let ctx_body = restrict_universe_context ctx used_univs_body in - let ctx_typ = restrict_universe_context ctx used_univs_typ in - let univs_typ = Univ.ContextSet.to_context ctx_typ in - (univs_typ, typ), ((body, ctx_body), eff) + (initunivs, typ), ((body, ctx_body), eff) else + let initunivs = Univ.UContext.empty in + let ctx = Evd.evar_universe_context_set initunivs universes in (* Since the proof is computed now, we can simply have 1 set of * constraints in which we merge the ones for the body and the ones * for the typ *) @@ -310,14 +341,13 @@ let close_proof ~keep_body_ucst_sepatate ?feedback_id ~now fpl = let univs = Univ.ContextSet.to_context ctx in (univs, typ), ((body, Univ.ContextSet.empty), eff) in - fun t p -> - Future.split2 (Future.chain ~pure:true p (make_body t)) + fun t p -> Future.split2 (Future.chain ~pure:true p (make_body t)) else fun t p -> - let initunivs = Evd.evar_context_universe_context universes in - Future.from_val (initunivs, nf t), - Future.chain ~pure:true p (fun (pt,eff) -> - (pt, Evd.evar_universe_context_set (Future.force univs)), eff) + let initunivs = Evd.evar_context_universe_context initial_euctx in + Future.from_val (initunivs, nf t), + Future.chain ~pure:true p (fun (pt,eff) -> + (pt,Evd.evar_universe_context_set initunivs (Future.force univs)),eff) in let entries = Future.map2 (fun p (_, t) -> @@ -336,15 +366,11 @@ let close_proof ~keep_body_ucst_sepatate ?feedback_id ~now fpl = { id = pid; entries = entries; persistence = strength; universes = universes }, fun pr_ending -> Ephemeron.get terminator pr_ending -type closed_proof_output = (Term.constr * Declareops.side_effects) list * Evd.evar_universe_context +type closed_proof_output = (Term.constr * Safe_typing.private_constants) list * Evd.evar_universe_context let return_proof ?(allow_partial=false) () = let { pid; proof; strength = (_,poly,_) } = cur_pstate () in if allow_partial then begin - if Proof.is_done proof then begin - msg_warning (str"The proof of " ++ str (Names.Id.to_string pid) ++ - str" is complete, no need to end it with Admitted"); - end; let proofs = Proof.partial_proof proof in let _,_,_,_, evd = Proof.proof proof in let eff = Evd.eval_side_effects evd in @@ -370,10 +396,7 @@ let return_proof ?(allow_partial=false) () = | Proof.HasUnresolvedEvar-> error(strbrk"Attempt to save a proof with existential variables still non-instantiated") in let eff = Evd.eval_side_effects evd in - let evd = - if poly || !Flags.compilation_mode = Flags.BuildVo - then Evd.nf_constraints evd - else evd in + let evd = Evd.nf_constraints evd in (** ppedrot: FIXME, this is surely wrong. There is no reason to duplicate side-effects... This may explain why one need to uniquize side-effects thereafter... *) @@ -382,9 +405,9 @@ let return_proof ?(allow_partial=false) () = proofs, Evd.evar_universe_context evd let close_future_proof ~feedback_id proof = - close_proof ~keep_body_ucst_sepatate:true ~feedback_id ~now:false proof -let close_proof ~keep_body_ucst_sepatate fix_exn = - close_proof ~keep_body_ucst_sepatate ~now:true + close_proof ~keep_body_ucst_separate:true ~feedback_id ~now:false proof +let close_proof ~keep_body_ucst_separate fix_exn = + close_proof ~keep_body_ucst_separate ~now:true (Future.from_val ~fix_exn (return_proof ())) (** Gets the current terminator without checking that the proof has @@ -668,4 +691,13 @@ let freeze ~marshallable = | `No -> !pstates let unfreeze s = pstates := s; update_proof_mode () let proof_of_state = function { proof }::_ -> proof | _ -> raise NoCurrentProof - +let copy_terminators ~src ~tgt = + assert(List.length src = List.length tgt); + List.map2 (fun op p -> { p with terminator = op.terminator }) src tgt + +let update_global_env () = + with_current_proof (fun _ p -> + Proof.in_proof p (fun sigma -> + let tac = Proofview.Unsafe.tclEVARS (Evd.update_sigma_env sigma (Global.env ())) in + let (p,(status,info)) = Proof.run_tactic (Global.env ()) tac p in + (p, ()))) diff --git a/proofs/proof_global.mli b/proofs/proof_global.mli index 9d5038a3..a2254508 100644 --- a/proofs/proof_global.mli +++ b/proofs/proof_global.mli @@ -58,7 +58,7 @@ type lemma_possible_guards = int list list type proof_universes = Evd.evar_universe_context type proof_object = { id : Names.Id.t; - entries : Entries.definition_entry list; + entries : Safe_typing.private_constants Entries.definition_entry list; persistence : Decl_kinds.goal_kind; universes: proof_universes; (* constraints : Univ.constraints; *) @@ -66,7 +66,7 @@ type proof_object = { } type proof_ending = - | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry + | Admitted of Names.Id.t * Decl_kinds.goal_kind * Entries.parameter_entry * proof_universes | Proved of Vernacexpr.opacity_flag * (Vernacexpr.lident * Decl_kinds.theorem_kind option) option * proof_object @@ -89,15 +89,20 @@ val start_dependent_proof : Names.Id.t -> Decl_kinds.goal_kind -> Proofview.telescope -> proof_terminator -> unit +(** Update the proofs global environment after a side-effecting command + (e.g. a sublemma definition) has been run inside it. Assumes + there_are_pending_proofs. *) +val update_global_env : unit -> unit + (* Takes a function to add to the exceptions data relative to the state in which the proof was built *) -val close_proof : keep_body_ucst_sepatate:bool -> Future.fix_exn -> closed_proof +val close_proof : keep_body_ucst_separate:bool -> Future.fix_exn -> closed_proof (* Intermediate step necessary to delegate the future. - * Both access the current proof state. The formes is supposed to be + * Both access the current proof state. The former is supposed to be * chained with a computation that completed the proof *) -type closed_proof_output = (Term.constr * Declareops.side_effects) list * Evd.evar_universe_context +type closed_proof_output = (Term.constr * Safe_typing.private_constants) list * Evd.evar_universe_context (* If allow_partial is set (default no) then an incomplete proof * is allowed (no error), and a warn is given if the proof is complete. *) @@ -129,8 +134,10 @@ val set_interp_tac : -> unit (** Sets the section variables assumed by the proof, returns its closure - * (w.r.t. type dependencies *) -val set_used_variables : Names.Id.t list -> Context.section_context + * (w.r.t. type dependencies and let-ins covered by it) + a list of + * ids to be cleared *) +val set_used_variables : + Names.Id.t list -> Context.section_context * (Loc.t * Names.Id.t) list val get_used_variables : unit -> Context.section_context option (**********************************************************) @@ -197,3 +204,4 @@ type state val freeze : marshallable:[`Yes | `No | `Shallow] -> state val unfreeze : state -> unit val proof_of_state : state -> Proof.proof +val copy_terminators : src:state -> tgt:state -> state diff --git a/proofs/proof_using.ml b/proofs/proof_using.ml index f66e9657..7eed1cb3 100644 --- a/proofs/proof_using.ml +++ b/proofs/proof_using.ml @@ -11,20 +11,15 @@ open Environ open Util open Vernacexpr -let to_string = function - | SsAll -> "All" - | SsType -> "Type" - | SsExpr(SsSet l)-> String.concat " " (List.map Id.to_string (List.map snd l)) - | SsExpr e -> - let rec aux = function - | SsSet [] -> "( )" - | SsSet [_,x] -> Id.to_string x - | SsSet l -> - "(" ^ String.concat " " (List.map Id.to_string (List.map snd l)) ^ ")" - | SsCompl e -> "-" ^ aux e^"" - | SsUnion(e1,e2) -> "("^aux e1 ^" + "^ aux e2^")" - | SsSubstr(e1,e2) -> "("^aux e1 ^" - "^ aux e2^")" - in aux e +let to_string e = + let rec aux = function + | SsEmpty -> "()" + | SsSingl (_,id) -> "("^Id.to_string id^")" + | SsCompl e -> "-" ^ aux e^"" + | SsUnion(e1,e2) -> "("^aux e1 ^" + "^ aux e2^")" + | SsSubstr(e1,e2) -> "("^aux e1 ^" - "^ aux e2^")" + | SsFwdClose e -> "("^aux e^")*" + in aux e let known_names = Summary.ref [] ~name:"proofusing-nameset" @@ -36,30 +31,48 @@ let in_nameset = discharge_function = (fun _ -> None) } +let rec close_fwd e s = + let s' = + List.fold_left (fun s (id,b,ty) -> + let vb = Option.(default Id.Set.empty (map (global_vars_set e) b)) in + let vty = global_vars_set e ty in + let vbty = Id.Set.union vb vty in + if Id.Set.exists (fun v -> Id.Set.mem v s) vbty + then Id.Set.add id (Id.Set.union s vbty) else s) + s (named_context e) + in + if Id.Set.equal s s' then s else close_fwd e s' +;; + let rec process_expr env e ty = - match e with - | SsAll -> - List.fold_right Id.Set.add (List.map pi1 (named_context env)) Id.Set.empty - | SsExpr e -> - let rec aux = function - | SsSet l -> set_of_list env (List.map snd l) - | SsUnion(e1,e2) -> Id.Set.union (aux e1) (aux e2) - | SsSubstr(e1,e2) -> Id.Set.diff (aux e1) (aux e2) - | SsCompl e -> Id.Set.diff (full_set env) (aux e) - in - aux e - | SsType -> - List.fold_left (fun acc ty -> + let rec aux = function + | SsEmpty -> Id.Set.empty + | SsSingl (_,id) -> set_of_id env ty id + | SsUnion(e1,e2) -> Id.Set.union (aux e1) (aux e2) + | SsSubstr(e1,e2) -> Id.Set.diff (aux e1) (aux e2) + | SsCompl e -> Id.Set.diff (full_set env) (aux e) + | SsFwdClose e -> close_fwd env (aux e) + in + aux e + +and set_of_id env ty id = + if Id.to_string id = "Type" then + List.fold_left (fun acc ty -> Id.Set.union (global_vars_set env ty) acc) Id.Set.empty ty -and set_of_list env = function - | [x] when CList.mem_assoc_f Id.equal x !known_names -> - process_expr env (CList.assoc_f Id.equal x !known_names) [] - | l -> List.fold_right Id.Set.add l Id.Set.empty -and full_set env = set_of_list env (List.map pi1 (named_context env)) + else if Id.to_string id = "All" then + List.fold_right Id.Set.add (List.map pi1 (named_context env)) Id.Set.empty + else if CList.mem_assoc_f Id.equal id !known_names then + process_expr env (CList.assoc_f Id.equal id !known_names) [] + else Id.Set.singleton id + +and full_set env = + List.fold_right Id.Set.add (List.map pi1 (named_context env)) Id.Set.empty let process_expr env e ty = - let s = Id.Set.union (process_expr env SsType ty) (process_expr env e []) in + let ty_expr = SsSingl(Loc.ghost, Id.of_string "Type") in + let v_ty = process_expr env ty_expr ty in + let s = Id.Set.union v_ty (process_expr env e ty) in Id.Set.elements s let name_set id expr = Lib.add_anonymous_leaf (in_nameset (id,expr)) @@ -77,62 +90,49 @@ let minimize_hyps env ids = in aux ids -let minimize_unused_hyps env ids = - let all_ids = List.map pi1 (named_context env) in - let deps_of = - let cache = - List.map (fun id -> id,really_needed env (Id.Set.singleton id)) all_ids in - fun id -> List.assoc id cache in - let inv_dep_of = - let cache_sum cache id stuff = - try Id.Map.add id (Id.Set.add stuff (Id.Map.find id cache)) cache - with Not_found -> Id.Map.add id (Id.Set.singleton stuff) cache in - let cache = - List.fold_left (fun cache id -> - Id.Set.fold (fun d cache -> cache_sum cache d id) - (Id.Set.remove id (deps_of id)) cache) - Id.Map.empty all_ids in - fun id -> try Id.Map.find id cache with Not_found -> Id.Set.empty in - let rec aux s = - let s' = - Id.Set.fold (fun id s -> - if Id.Set.subset (inv_dep_of id) s then Id.Set.diff s (inv_dep_of id) - else s) - s s in - if Id.Set.equal s s' then s else aux s' in - aux ids - -let suggest_Proof_using kn env vars ids_typ context_ids = +let remove_ids_and_lets env s ids = + let not_ids id = not (Id.Set.mem id ids) in + let no_body id = named_body id env = None in + let deps id = really_needed env (Id.Set.singleton id) in + (Id.Set.filter (fun id -> + not_ids id && + (no_body id || + Id.Set.exists not_ids (Id.Set.filter no_body (deps id)))) s) + +let suggest_Proof_using name env vars ids_typ context_ids = let module S = Id.Set in let open Pp in - let used = S.union vars ids_typ in - let needed = minimize_hyps env used in - let all_needed = really_needed env needed in - let all = List.fold_right S.add context_ids S.empty in - let unneeded = minimize_unused_hyps env (S.diff all needed) in - let pr_set s = + let print x = prerr_endline (string_of_ppcmds x) in + let pr_set parens s = let wrap ppcmds = - if S.cardinal s > 1 || S.equal s (S.singleton (Id.of_string "All")) - then str "(" ++ ppcmds ++ str ")" + if parens && S.cardinal s > 1 then str "(" ++ ppcmds ++ str ")" else ppcmds in wrap (prlist_with_sep (fun _ -> str" ") Id.print (S.elements s)) in + let used = S.union vars ids_typ in + let needed = minimize_hyps env (remove_ids_and_lets env used ids_typ) in + let all_needed = really_needed env needed in + let all = List.fold_right S.add context_ids S.empty in + let fwd_typ = close_fwd env ids_typ in if !Flags.debug then begin - prerr_endline (string_of_ppcmds (str "All " ++ pr_set all)); - prerr_endline (string_of_ppcmds (str "Type" ++ pr_set ids_typ)); - prerr_endline (string_of_ppcmds (str "needed " ++ pr_set needed)); - prerr_endline (string_of_ppcmds (str "unneeded " ++ pr_set unneeded)); + print (str "All " ++ pr_set false all); + print (str "Type " ++ pr_set false ids_typ); + print (str "needed " ++ pr_set false needed); + print (str "all_needed " ++ pr_set false all_needed); + print (str "Type* " ++ pr_set false fwd_typ); end; + let valid_exprs = ref [] in + let valid e = valid_exprs := e :: !valid_exprs in + if S.is_empty needed then valid (str "Type"); + if S.equal all_needed fwd_typ then valid (str "Type*"); + if S.equal all all_needed then valid(str "All"); + valid (pr_set false needed); msg_info ( - str"The proof of "++ - Names.Constant.print kn ++ spc() ++ str "should start with:"++spc()++ - str"Proof using " ++ - if S.is_empty needed then str "." - else if S.subset needed ids_typ then str "Type." - else if S.equal all all_needed then str "All." - else - let s1 = string_of_ppcmds (str "-" ++ pr_set unneeded ++ str".") in - let s2 = string_of_ppcmds (pr_set needed ++ str".") in - if String.length s1 < String.length s2 then str s1 else str s2) + str"The proof of "++ str name ++ spc() ++ + str "should start with one of the following commands:"++spc()++ + v 0 ( + prlist_with_sep cut (fun x->str"Proof using " ++x++ str". ") !valid_exprs)); + string_of_ppcmds (prlist_with_sep (fun _ -> str";") (fun x->x) !valid_exprs) +;; let value = ref false @@ -146,13 +146,13 @@ let _ = Goptions.optwrite = (fun b -> value := b; if b then Term_typing.set_suggest_proof_using suggest_Proof_using - else Term_typing.set_suggest_proof_using (fun _ _ _ _ _ -> ()) + else Term_typing.set_suggest_proof_using (fun _ _ _ _ _ -> "") ) } -let value = ref "_unset_" +let value = ref None let _ = - Goptions.declare_string_option + Goptions.declare_stringopt_option { Goptions.optsync = true; Goptions.optdepr = false; Goptions.optname = "default value for Proof using"; @@ -161,6 +161,4 @@ let _ = Goptions.optwrite = (fun b -> value := b;) } -let get_default_proof_using () = - if !value = "_unset_" then None - else Some !value +let get_default_proof_using () = !value diff --git a/proofs/proof_using.mli b/proofs/proof_using.mli index fb3497f1..dcf8a0fc 100644 --- a/proofs/proof_using.mli +++ b/proofs/proof_using.mli @@ -6,21 +6,12 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) - -(* [minimize_hyps e s1] gives [s2] s.t. [Id.Set.subset s2 s1] is [true] - * and [keep_hyps e s1] is equal to [keep_hyps e s2]. Inefficient. *) -val minimize_hyps : Environ.env -> Names.Id.Set.t -> Names.Id.Set.t - -(* [minimize_unused_hyps e s1] gives [s2] s.t. [Id.Set.subset s2 s1] is [true] - * and s.t. calling [clear s1] would do the same as [clear s2]. Inefficient. *) -val minimize_unused_hyps : Environ.env -> Names.Id.Set.t -> Names.Id.Set.t - val process_expr : - Environ.env -> Vernacexpr.section_subset_descr -> Constr.types list -> + Environ.env -> Vernacexpr.section_subset_expr -> Constr.types list -> Names.Id.t list -val name_set : Names.Id.t -> Vernacexpr.section_subset_descr -> unit +val name_set : Names.Id.t -> Vernacexpr.section_subset_expr -> unit -val to_string : Vernacexpr.section_subset_descr -> string +val to_string : Vernacexpr.section_subset_expr -> string val get_default_proof_using : unit -> string option diff --git a/proofs/proofview.ml b/proofs/proofview.ml index 6f626341..4fc0c164 100644 --- a/proofs/proofview.ml +++ b/proofs/proofview.ml @@ -384,20 +384,23 @@ let tclTRYFOCUS i j t = tclFOCUS_gen (tclUNIT ()) i j t let tclFOCUSID id t = let open Proof in Pv.get >>= fun initial -> - let rec aux n = function - | [] -> tclZERO (NoSuchGoals 1) - | g::l -> - if Names.Id.equal (Evd.evar_ident g initial.solution) id then - let (focused,context) = focus n n initial in - Pv.set focused >> - t >>= fun result -> - Pv.modify (fun next -> unfocus context next) >> - return result - else - aux (n+1) l in - aux 1 initial.comb - - + try + let ev = Evd.evar_key id initial.solution in + try + let n = CList.index Evar.equal ev initial.comb in + (* goal is already under focus *) + let (focused,context) = focus n n initial in + Pv.set focused >> + t >>= fun result -> + Pv.modify (fun next -> unfocus context next) >> + return result + with Not_found -> + (* otherwise, save current focus and work purely on the shelve *) + Comb.set [ev] >> + t >>= fun result -> + Comb.set initial.comb >> + return result + with Not_found -> tclZERO (NoSuchGoals 1) (** {7 Dispatching on goals} *) @@ -648,7 +651,7 @@ let goodmod p m = let cycle n = let open Proof in - InfoL.leaf (Info.Tactic (fun () -> Pp.(str"cycle"++spc()++int n))) >> + InfoL.leaf (Info.Tactic (fun () -> Pp.(str"cycle "++int n))) >> Comb.modify begin fun initial -> let l = CList.length initial in let n' = goodmod n l in @@ -658,7 +661,7 @@ let cycle n = let swap i j = let open Proof in - InfoL.leaf (Info.Tactic (fun () -> Pp.(str"swap"++spc()++int i++spc()++int j))) >> + InfoL.leaf (Info.Tactic (fun () -> Pp.(hov 2 (str"swap"++spc()++int i++spc()++int j)))) >> Comb.modify begin fun initial -> let l = CList.length initial in let i = if i>0 then i-1 else i and j = if j>0 then j-1 else j in @@ -722,19 +725,7 @@ let give_up = module Progress = struct - (** equality function up to evar instantiation in heterogeneous - contexts. *) - (* spiwack (2015-02-19): In the previous version of progress an - equality which considers two universes equal when it is consistent - tu unify them ([Evd.eq_constr_univs_test]) was used. Maybe this - behaviour has to be restored as well. This has to be established by - practice. *) - - let rec eq_constr sigma1 sigma2 t1 t2 = - Constr.equal_with - (fun t -> Evarutil.kind_of_term_upto sigma1 t) - (fun t -> Evarutil.kind_of_term_upto sigma2 t) - t1 t2 + let eq_constr = Evarutil.eq_constr_univs_test (** equality function on hypothesis contexts *) let eq_named_context_val sigma1 sigma2 ctx1 ctx2 = @@ -1069,7 +1060,7 @@ struct let comb = undefined sigma (CList.rev evs) in let sigma = CList.fold_left Unsafe.mark_as_goal_evm sigma comb in let open Proof in - InfoL.leaf (Info.Tactic (fun () -> Pp.(str"refine"++spc()++ Hook.get pr_constrv env sigma c))) >> + InfoL.leaf (Info.Tactic (fun () -> Pp.(hov 2 (str"refine"++spc()++ Hook.get pr_constrv env sigma c)))) >> Pv.set { solution = sigma; comb; } end diff --git a/proofs/proofview.mli b/proofs/proofview.mli index 5a9e7f39..927df33a 100644 --- a/proofs/proofview.mli +++ b/proofs/proofview.mli @@ -336,7 +336,7 @@ val tclENV : Environ.env tactic (** {7 Put-like primitives} *) (** [tclEFFECTS eff] add the effects [eff] to the current state. *) -val tclEFFECTS : Declareops.side_effects -> unit tactic +val tclEFFECTS : Safe_typing.private_constants -> unit tactic (** [mark_as_unsafe] declares the current tactic is unsafe. *) val mark_as_unsafe : unit tactic diff --git a/proofs/redexpr.ml b/proofs/redexpr.ml index 1383d755..be92f2b0 100644 --- a/proofs/redexpr.ml +++ b/proofs/redexpr.ml @@ -30,9 +30,12 @@ let cbv_vm env sigma c = Vnorm.cbv_vm env c ctyp let cbv_native env sigma c = - let ctyp = Retyping.get_type_of env sigma c in - let evars = Nativenorm.evars_of_evar_map sigma in - Nativenorm.native_norm env evars c ctyp + if Coq_config.no_native_compiler then + let () = msg_warning (str "native_compute disabled at configure time; falling back to vm_compute.") in + cbv_vm env sigma c + else + let ctyp = Retyping.get_type_of env sigma c in + Nativenorm.native_norm env sigma c ctyp let whd_cbn flags env sigma t = let (state,_) = @@ -167,18 +170,20 @@ let red_expr_tab = Summary.ref String.Map.empty ~name:"Declare Reduction" let declare_reduction s f = if String.Map.mem s !reduction_tab || String.Map.mem s !red_expr_tab - then error ("There is already a reduction expression of name "^s) + then errorlabstrm "Redexpr.declare_reduction" + (str "There is already a reduction expression of name " ++ str s) else reduction_tab := String.Map.add s f !reduction_tab let check_custom = function | ExtraRedExpr s -> if not (String.Map.mem s !reduction_tab || String.Map.mem s !red_expr_tab) - then error ("Reference to undefined reduction expression "^s) + then errorlabstrm "Redexpr.check_custom" (str "Reference to undefined reduction expression " ++ str s) |_ -> () let decl_red_expr s e = if String.Map.mem s !reduction_tab || String.Map.mem s !red_expr_tab - then error ("There is already a reduction expression of name "^s) + then errorlabstrm "Redexpr.decl_red_expr" + (str "There is already a reduction expression of name " ++ str s) else begin check_custom e; red_expr_tab := String.Map.add s e !red_expr_tab @@ -232,7 +237,8 @@ let reduction_of_red_expr env = with Not_found -> (try reduction_of_red_expr (String.Map.find s !red_expr_tab) with Not_found -> - error("unknown user-defined reduction \""^s^"\""))) + errorlabstrm "Redexpr.reduction_of_red_expr" + (str "unknown user-defined reduction \"" ++ str s ++ str "\""))) | CbvVm o -> (contextualize cbv_vm cbv_vm o, VMcast) | CbvNative o -> (contextualize cbv_native cbv_native o, NATIVEcast) in diff --git a/proofs/refiner.ml b/proofs/refiner.ml index 974fa212..ba62b2cb 100644 --- a/proofs/refiner.ml +++ b/proofs/refiner.ml @@ -186,10 +186,15 @@ let tclNOTSAMEGOAL (tac : tactic) goal = (str"Tactic generated a subgoal identical to the original goal.") else rslt -(* Execute tac and show the names of hypothesis create by tac in - the "as" format. The resulting goals are printed *after* the - as-expression, which forces pg to some gymnastic. TODO: Have - something similar (better?) in the xml protocol. *) +(* Execute tac, show the names of new hypothesis names created by tac + in the "as" format and then forget everything. From the logical + point of view [tclSHOWHYPS tac] is therefore equivalent to idtac, + except that it takes the time and memory of tac and prints "as" + information). The resulting (unchanged) goals are printed *after* + the as-expression, which forces pg to some gymnastic. + TODO: Have something similar (better?) in the xml protocol. + NOTE: some tactics delete hypothesis and reuse names (induction, + destruct), this is not detected by this tactical. *) let tclSHOWHYPS (tac : tactic) (goal: Goal.goal Evd.sigma) :Proof_type.goal list Evd.sigma = let oldhyps:Context.named_context = pf_hyps goal in @@ -197,9 +202,10 @@ let tclSHOWHYPS (tac : tactic) (goal: Goal.goal Evd.sigma) let { it = gls; sigma = sigma; } = rslt in let hyps:Context.named_context list = List.map (fun gl -> pf_hyps { it = gl; sigma=sigma; }) gls in + let cmp (i1, c1, t1) (i2, c2, t2) = Names.Id.equal i1 i2 in let newhyps = List.map - (fun hypl -> List.subtract Context.eq_named_declaration hypl oldhyps) + (fun hypl -> List.subtract cmp hypl oldhyps) hyps in let emacs_str s = @@ -215,7 +221,7 @@ let tclSHOWHYPS (tac : tactic) (goal: Goal.goal Evd.sigma) pp (str (emacs_str "<infoH>") ++ (hov 0 (str s)) ++ (str (emacs_str "</infoH>")) ++ fnl()); - rslt;; + tclIDTAC goal;; let catch_failerror (e, info) = diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index fa0d0362..4238d1e3 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -84,6 +84,7 @@ let pf_nf = pf_reduce simpl let pf_nf_betaiota = pf_reduce (fun _ -> nf_betaiota) let pf_compute = pf_reduce compute let pf_unfoldn ubinds = pf_reduce (unfoldn ubinds) +let pf_unsafe_type_of = pf_reduce unsafe_type_of let pf_type_of = pf_reduce type_of let pf_get_type_of = pf_reduce Retyping.get_type_of @@ -172,6 +173,9 @@ module New = struct let pf_env = Proofview.Goal.env let pf_concl = Proofview.Goal.concl + let pf_unsafe_type_of gl t = + pf_apply unsafe_type_of gl t + let pf_type_of gl t = pf_apply type_of gl t diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index f7fc6b54..a0e1a015 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -41,7 +41,8 @@ val pf_nth_hyp_id : goal sigma -> int -> Id.t val pf_last_hyp : goal sigma -> named_declaration val pf_ids_of_hyps : goal sigma -> Id.t list val pf_global : goal sigma -> Id.t -> constr -val pf_type_of : goal sigma -> constr -> types +val pf_unsafe_type_of : goal sigma -> constr -> types +val pf_type_of : goal sigma -> constr -> evar_map * types val pf_hnf_type_of : goal sigma -> constr -> types val pf_get_hyp : goal sigma -> Id.t -> named_declaration @@ -112,7 +113,8 @@ module New : sig val pf_env : 'a Proofview.Goal.t -> Environ.env val pf_concl : [ `NF ] Proofview.Goal.t -> types - val pf_type_of : 'a Proofview.Goal.t -> Term.constr -> Term.types + val pf_unsafe_type_of : 'a Proofview.Goal.t -> Term.constr -> Term.types + val pf_type_of : 'a Proofview.Goal.t -> Term.constr -> evar_map * Term.types val pf_conv_x : 'a Proofview.Goal.t -> Term.constr -> Term.constr -> bool val pf_get_new_id : identifier -> [ `NF ] Proofview.Goal.t -> identifier diff --git a/proofs/tactic_debug.ml b/proofs/tactic_debug.ml index 3cc81daf..6d6215c5 100644 --- a/proofs/tactic_debug.ml +++ b/proofs/tactic_debug.ml @@ -11,6 +11,7 @@ open Names open Pp open Tacexpr open Termops +open Nameops let (prtac, tactic_printer) = Hook.make () let (prmatchpatt, match_pattern_printer) = Hook.make () @@ -31,7 +32,8 @@ let explain_logic_error = ref (fun e -> mt()) let explain_logic_error_no_anomaly = ref (fun e -> mt()) -let msg_tac_debug s = Proofview.NonLogical.print (s++fnl()) +let msg_tac_debug s = Proofview.NonLogical.print_debug (s++fnl()) +let msg_tac_notice s = Proofview.NonLogical.print_notice (s++fnl()) (* Prints the goal *) @@ -47,7 +49,7 @@ let db_pr_goal gl = let db_pr_goal = Proofview.Goal.nf_enter begin fun gl -> let pg = db_pr_goal gl in - Proofview.tclLIFT (msg_tac_debug (str "Goal:" ++ fnl () ++ pg)) + Proofview.tclLIFT (msg_tac_notice (str "Goal:" ++ fnl () ++ pg)) end @@ -120,7 +122,7 @@ let run ini = let open Proofview.NonLogical in if not ini then begin - Proofview.NonLogical.print (str"\b\r\b\r") >> + Proofview.NonLogical.print_notice (str"\b\r\b\r") >> !skipped >>= fun skipped -> msg_tac_debug (str "Executed expressions: " ++ int skipped ++ fnl()) end >> @@ -135,7 +137,7 @@ let rec prompt level = let runtrue = run true in begin let open Proofview.NonLogical in - Proofview.NonLogical.print (fnl () ++ str "TcDebug (" ++ int level ++ str ") > ") >> + Proofview.NonLogical.print_notice (fnl () ++ str "TcDebug (" ++ int level ++ str ") > ") >> let exit = (skip:=0) >> (skipped:=0) >> raise Sys.Break in Proofview.NonLogical.catch Proofview.NonLogical.read_line begin function (e, info) -> match e with @@ -231,17 +233,16 @@ let db_pattern_rule debug num r = (* Prints the hypothesis pattern identifier if it exists *) let hyp_bound = function - | Anonymous -> " (unbound)" - | Name id -> " (bound to "^(Names.Id.to_string id)^")" + | Anonymous -> str " (unbound)" + | Name id -> str " (bound to " ++ pr_id id ++ str ")" (* Prints a matched hypothesis *) let db_matched_hyp debug env (id,_,c) ido = let open Proofview.NonLogical in is_debug debug >>= fun db -> if db then - msg_tac_debug (str "Hypothesis " ++ - str ((Names.Id.to_string id)^(hyp_bound ido)^ - " has been matched: ") ++ print_constr_env env c) + msg_tac_debug (str "Hypothesis " ++ pr_id id ++ hyp_bound ido ++ + str " has been matched: " ++ print_constr_env env c) else return () (* Prints the matched conclusion *) @@ -266,8 +267,8 @@ let db_hyp_pattern_failure debug env sigma (na,hyp) = let open Proofview.NonLogical in is_debug debug >>= fun db -> if db then - msg_tac_debug (str ("The pattern hypothesis"^(hyp_bound na)^ - " cannot match: ") ++ + msg_tac_debug (str "The pattern hypothesis" ++ hyp_bound na ++ + str " cannot match: " ++ Hook.get prmatchpatt env sigma hyp) else return () diff --git a/stm/lemmas.ml b/stm/lemmas.ml index 6cece32e..6c183268 100644 --- a/stm/lemmas.ml +++ b/stm/lemmas.ml @@ -70,11 +70,12 @@ let adjust_guardness_conditions const = function try ignore(Environ.lookup_constant c e); true with Not_found -> false in if exists c e then e else Environ.add_constant c cb e in - let env = Declareops.fold_side_effects (fun env -> function + let env = List.fold_left (fun env { eff } -> + match eff with | SEsubproof (c, cb,_) -> add c cb env | SEscheme (l,_) -> List.fold_left (fun e (_,c,cb,_) -> add c cb e) env l) - env (Declareops.uniquize_side_effects eff) in + env (Safe_typing.side_effects_of_private_constants eff) in let indexes = search_guard Loc.ghost env possible_indexes fixdecls in @@ -212,7 +213,7 @@ let save ?export_seff id const cstrs do_guard (locality,poly,kind) hook = let default_thm_id = Id.of_string "Unnamed_thm" let compute_proof_name locality = function - | Some (loc,id) -> + | Some ((loc,id),pl) -> (* We check existence here: it's a bit late at Qed time *) if Nametab.exists_cci (Lib.make_path id) || is_section_variable id || locality == Global && Nametab.exists_cci (Lib.make_path_except_section id) @@ -326,29 +327,10 @@ let check_exist = user_err_loc (loc,"",pr_id id ++ str " does not exist.") ) -let standard_proof_terminator compute_guard hook = - let open Proof_global in function - | Admitted (id,k,pe) -> - admit (id,k,pe) hook (); - Pp.feedback Feedback.AddedAxiom - | Proved (opaque,idopt,proof) -> - let is_opaque, export_seff, exports = match opaque with - | Vernacexpr.Transparent -> false, true, [] - | Vernacexpr.Opaque None -> true, false, [] - | Vernacexpr.Opaque (Some l) -> true, true, l in - let proof = get_proof proof compute_guard hook is_opaque in - begin match idopt with - | None -> save_named ~export_seff proof - | Some ((_,id),None) -> save_anonymous ~export_seff proof id - | Some ((_,id),Some kind) -> - save_anonymous_with_strength ~export_seff proof kind id - end; - check_exist exports - let universe_proof_terminator compute_guard hook = let open Proof_global in function - | Admitted (id,k,pe) -> - admit (id,k,pe) (hook None) (); + | Admitted (id,k,pe,ctx) -> + admit (id,k,pe) (hook (Some ctx)) (); Pp.feedback Feedback.AddedAxiom | Proved (opaque,idopt,proof) -> let is_opaque, export_seff, exports = match opaque with @@ -365,6 +347,9 @@ let universe_proof_terminator compute_guard hook = end; check_exist exports +let standard_proof_terminator compute_guard hook = + universe_proof_terminator compute_guard (fun _ -> hook) + let start_proof id kind sigma ?sign c ?init_tac ?(compute_guard=[]) hook = let terminator = standard_proof_terminator compute_guard hook in let sign = @@ -436,7 +421,7 @@ let start_proof_with_initialization kind ctx recguard thms snl hook = let body,opaq = retrieve_first_recthm ref in let subst = Evd.evar_universe_context_subst ctx in let norm c = Universes.subst_opt_univs_constr subst c in - let ctx = Evd.evar_universe_context_set ctx in + let ctx = Evd.evar_universe_context_set (*FIXME*) Univ.UContext.empty ctx in let body = Option.map norm body in List.map_i (save_remaining_recthms kind norm ctx body opaq) 1 other_thms in let thms_data = (strength,ref,imps)::other_thms_data in @@ -447,11 +432,15 @@ let start_proof_with_initialization kind ctx recguard thms snl hook = let start_proof_com kind thms hook = let env0 = Global.env () in - let evdref = ref (Evd.from_env env0) in + let levels = Option.map snd (fst (List.hd thms)) in + let evdref = ref (match levels with + | None -> Evd.from_env env0 + | Some l -> Evd.from_ctx (Evd.make_evar_universe_context env0 l)) + in let thms = List.map (fun (sopt,(bl,t,guard)) -> let impls, ((env, ctx), imps) = interp_context_evars env0 evdref bl in let t', imps' = interp_type_evars_impls ~impls env evdref t in - check_evars_are_solved env !evdref (Evd.empty,!evdref); + evdref := solve_remaining_evars all_and_fail_flags env !evdref (Evd.empty,!evdref); let ids = List.map pi1 ctx in (compute_proof_name (pi1 kind) sopt, (nf_evar !evdref (it_mkProd_or_LetIn t' ctx), @@ -461,8 +450,12 @@ let start_proof_com kind thms hook = let recguard,thms,snl = look_for_possibly_mutual_statements thms in let evd, nf = Evarutil.nf_evars_and_universes !evdref in let thms = List.map (fun (n, (t, info)) -> (n, (nf t, info))) thms in - start_proof_with_initialization kind evd - recguard thms snl hook + let evd = + if pi2 kind then evd + else (* We fix the variables to ensure they won't be lowered to Set *) + Evd.fix_undefined_variables evd + in + start_proof_with_initialization kind evd recguard thms snl hook (* Saving a proof *) @@ -480,14 +473,13 @@ let save_proof ?proof = function error "Admitted requires an explicit statement"; let typ = Option.get const_entry_type in let ctx = Evd.evar_context_universe_context universes in - Admitted(id, k, (const_entry_secctx, pi2 k, (typ, ctx), None)) + Admitted(id, k, (const_entry_secctx, pi2 k, (typ, ctx), None), universes) | None -> let id, k, typ = Pfedit.current_proof_statement () in - let ctx = - let evd, _ = Pfedit.get_current_goal_context () in - Evd.universe_context evd in (* This will warn if the proof is complete *) - let pproofs,_ = Proof_global.return_proof ~allow_partial:true () in + let pproofs, universes = + Proof_global.return_proof ~allow_partial:true () in + let ctx = Evd.evar_context_universe_context universes in let sec_vars = match Pfedit.get_used_variables(), pproofs with | Some _ as x, _ -> x @@ -497,14 +489,14 @@ let save_proof ?proof = function let ids_def = Environ.global_vars_set env pproof in Some (Environ.keep_hyps env (Idset.union ids_typ ids_def)) | _ -> None in - Admitted(id,k,(sec_vars, pi2 k, (typ, ctx), None)) + Admitted(id,k,(sec_vars, pi2 k, (typ, ctx), None),universes) in Proof_global.get_terminator() pe | Vernacexpr.Proved (is_opaque,idopt) -> let (proof_obj,terminator) = match proof with | None -> - Proof_global.close_proof ~keep_body_ucst_sepatate:false (fun x -> x) + Proof_global.close_proof ~keep_body_ucst_separate:false (fun x -> x) | Some proof -> proof in (* if the proof is given explicitly, nothing has to be deleted *) @@ -516,4 +508,5 @@ let save_proof ?proof = function let get_current_context () = try Pfedit.get_current_goal_context () with e when Logic.catchable_exception e -> - (Evd.empty, Global.env()) + let env = Global.env () in + (Evd.from_env env, env) diff --git a/stm/lemmas.mli b/stm/lemmas.mli index a0ddd265..6556aa22 100644 --- a/stm/lemmas.mli +++ b/stm/lemmas.mli @@ -32,8 +32,7 @@ val start_proof_univs : Id.t -> goal_kind -> Evd.evar_map -> ?sign:Environ.named ?init_tac:unit Proofview.tactic -> ?compute_guard:lemma_possible_guards -> (Proof_global.proof_universes option -> unit declaration_hook) -> unit -val start_proof_com : goal_kind -> - (lident option * (local_binder list * constr_expr * (lident option * recursion_order_expr) option)) list -> +val start_proof_com : goal_kind -> Vernacexpr.proof_expr list -> unit declaration_hook -> unit val start_proof_with_initialization : diff --git a/stm/spawned.ml b/stm/spawned.ml index a8372195..66fe07db 100644 --- a/stm/spawned.ml +++ b/stm/spawned.ml @@ -11,7 +11,7 @@ open Spawn let pr_err s = Printf.eprintf "(Spawned,%d) %s\n%!" (Unix.getpid ()) s let prerr_endline s = if !Flags.debug then begin pr_err s end else () -type chandescr = AnonPipe | Socket of string * int +type chandescr = AnonPipe | Socket of string * int * int let handshake cin cout = try @@ -26,18 +26,19 @@ let handshake cin cout = | End_of_file -> pr_err "Handshake failed: End_of_file"; raise (Failure "handshake") -let open_bin_connection h p = +let open_bin_connection h pr pw = let open Unix in - let cin, cout = open_connection (ADDR_INET (inet_addr_of_string h,p)) in + let _, cout = open_connection (ADDR_INET (inet_addr_of_string h,pr)) in + let cin, _ = open_connection (ADDR_INET (inet_addr_of_string h,pw)) in set_binary_mode_in cin true; set_binary_mode_out cout true; let cin = CThread.prepare_in_channel_for_thread_friendly_io cin in cin, cout -let controller h p = +let controller h pr pw = prerr_endline "starting controller thread"; let main () = - let ic, oc = open_bin_connection h p in + let ic, oc = open_bin_connection h pr pw in let rec loop () = try match CThread.thread_friendly_input_value ic with @@ -61,8 +62,8 @@ let init_channels () = if !channels <> None then Errors.anomaly(Pp.str "init_channels called twice"); let () = match !main_channel with | None -> () - | Some (Socket(mh,mp)) -> - channels := Some (open_bin_connection mh mp); + | Some (Socket(mh,mpr,mpw)) -> + channels := Some (open_bin_connection mh mpr mpw); | Some AnonPipe -> let stdin = Unix.in_channel_of_descr (Unix.dup Unix.stdin) in let stdout = Unix.out_channel_of_descr (Unix.dup Unix.stdout) in @@ -74,8 +75,8 @@ let init_channels () = in match !control_channel with | None -> () - | Some (Socket (ch, cp)) -> - controller ch cp + | Some (Socket (ch, cpr, cpw)) -> + controller ch cpr cpw | Some AnonPipe -> Errors.anomaly (Pp.str "control channel cannot be a pipe") diff --git a/stm/spawned.mli b/stm/spawned.mli index d9e7baff..d0183e08 100644 --- a/stm/spawned.mli +++ b/stm/spawned.mli @@ -8,7 +8,7 @@ (* To link this file, threads are needed *) -type chandescr = AnonPipe | Socket of string * int +type chandescr = AnonPipe | Socket of string * int * int (* Argument parsing should set these *) val main_channel : chandescr option ref @@ -51,7 +51,7 @@ let execution_error, execution_error_hook = Hook.make feedback ~state_id (Feedback.ErrorMsg (loc, string_of_ppcmds msg))) () let unreachable_state, unreachable_state_hook = Hook.make - ~default:(fun _ -> ()) () + ~default:(fun _ _ -> ()) () include Hook @@ -86,7 +86,7 @@ let vernac_interp ?proof id ?route { verbose; loc; expr } = | VernacResetName _ | VernacResetInitial | VernacBack _ | VernacBackTo _ | VernacRestart | VernacUndo _ | VernacUndoTo _ | VernacBacktrack _ | VernacAbortAll | VernacAbort _ -> true - | VernacTime el -> List.for_all (fun (_,e) -> internal_command e) el + | VernacTime el | VernacRedirect (_,el) -> List.for_all (fun (_,e) -> internal_command e) el | _ -> false in if internal_command expr then begin prerr_endline ("ignoring " ^ string_of_ppcmds(pr_vernac expr)) @@ -123,6 +123,10 @@ let pr_open_cur_subgoals () = try Printer.pr_open_subgoals () with Proof_global.NoCurrentProof -> str"" +let update_global_env () = + if Proof_global.there_are_pending_proofs () then + Proof_global.update_global_env () + module Vcs_ = Vcs.Make(Stateid) type future_proof = Proof_global.closed_proof_output Future.computation type proof_mode = string @@ -131,9 +135,11 @@ type cancel_switch = bool ref type branch_type = [ `Master | `Proof of proof_mode * depth - | `Edit of proof_mode * Stateid.t * Stateid.t * vernac_qed_type ] + | `Edit of + proof_mode * Stateid.t * Stateid.t * vernac_qed_type * Vcs_.Branch.t ] type cmd_t = { ctac : bool; (* is a tactic, needed by the 8.4 semantics of Undo *) + ceff : bool; (* is a side-effecting command *) cast : ast; cids : Id.t list; cqueue : [ `MainQueue | `TacQueue of cancel_switch | `QueryQueue of cancel_switch ] } @@ -371,7 +377,7 @@ end = struct (* {{{ *) (try let n = Hashtbl.find clus c in from::n with Not_found -> [from]); true in let oc = open_out fname_dot in - output_string oc "digraph states {\nsplines=ortho\n"; + 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) -> @@ -423,8 +429,8 @@ end = struct (* {{{ *) let reachable id = reachable !vcs id let mk_branch_name { expr = x } = Branch.make (match x with - | VernacDefinition (_,(_,i),_) -> string_of_id i - | VernacStartTheoremProof (_,[Some (_,i),_],_) -> string_of_id i + | VernacDefinition (_,((_,i),_),_) -> string_of_id i + | VernacStartTheoremProof (_,[Some ((_,i),_),_],_) -> string_of_id i | _ -> "branch") let edit_branch = Branch.make "edit" let branch ?root ?pos name kind = vcs := branch !vcs ?root ?pos name kind @@ -449,7 +455,7 @@ end = struct (* {{{ *) if List.mem edit_branch (Vcs_.branches !vcs) then begin checkout edit_branch; match get_branch edit_branch with - | { kind = `Edit (mode, _,_,_) } -> Proof_global.activate_proof_mode mode + | { kind = `Edit (mode, _,_,_,_) } -> Proof_global.activate_proof_mode mode | _ -> assert false end else let pl = proof_nesting () in @@ -590,6 +596,7 @@ module State : sig ?safe_id:Stateid.t -> ?redefine:bool -> ?cache:Summary.marshallable -> ?feedback_processed:bool -> (unit -> unit) -> Stateid.t -> unit + val fix_exn_ref : (iexn -> iexn) ref val install_cached : Stateid.t -> unit val is_cached : ?cache:Summary.marshallable -> Stateid.t -> bool @@ -613,6 +620,7 @@ end = struct (* {{{ *) (* cur_id holds Stateid.dummy in case the last attempt to define a state * failed, so the global state may contain garbage *) let cur_id = ref Stateid.dummy + let fix_exn_ref = ref (fun x -> x) (* helpers *) let freeze_global_state marshallable = @@ -638,7 +646,7 @@ end = struct (* {{{ *) proof, Summary.project_summary (States.summary_of_state system) summary_pstate - let freeze marhallable id = VCS.set_state id (freeze_global_state marhallable) + let freeze marshallable id = VCS.set_state id (freeze_global_state marshallable) let is_cached ?(cache=`No) id = if Stateid.equal id !cur_id then @@ -670,11 +678,22 @@ end = struct (* {{{ *) let assign id what = if VCS.get_state id <> None then () else try match what with - | `Full s -> VCS.set_state id s + | `Full s -> + let s = + try + let prev = (VCS.visit id).next in + if is_cached 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 | `Proof(ontop,(pstate,counters)) -> if is_cached ontop then let s = get_cached ontop in - let s = { s with proof = pstate } in + let s = { s with proof = + Proof_global.copy_terminators ~src:s.proof ~tgt:pstate } in let s = { s with system = States.replace_summary s.system (Summary.surgery_summary @@ -709,7 +728,10 @@ end = struct (* {{{ *) try prerr_endline("defining "^str_id^" (cache="^ if cache = `Yes then "Y)" else if cache = `Shallow then "S)" else "N)"); + let good_id = match safe_id with None -> !cur_id | Some id -> id in + fix_exn_ref := exn_on id ~valid:good_id; f (); + fix_exn_ref := (fun x -> x); if cache = `Yes then freeze `No id else if cache = `Shallow then freeze `Shallow id; prerr_endline ("setting cur id to "^str_id); @@ -718,13 +740,13 @@ end = struct (* {{{ *) Hooks.(call state_computed id ~in_cache:false); VCS.reached id true; if Proof_global.there_are_pending_proofs () then - VCS.goals id (Proof_global.get_open_goals ()); + 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); + 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)) @@ -846,7 +868,8 @@ end = struct (* {{{ *) | None, _ -> anomaly(str"Backtrack: tip with no vcs_backup") | Some vcs, _ -> vcs in let cb, _ = - Vcs_aux.find_proof_at_depth vcs (Vcs_aux.proof_nesting vcs) in + try Vcs_aux.find_proof_at_depth vcs (Vcs_aux.proof_nesting vcs) + with Failure _ -> raise Proof_global.NoCurrentProof in let n = fold_until (fun n (_,vcs,_,_,_) -> if List.mem cb (Vcs_.branches vcs) then `Cont (n+1) else `Stop n) 0 id in @@ -875,9 +898,16 @@ let set_compilation_hints file = hints := Aux_file.load_aux_file_for file let get_hint_ctx loc = let s = Aux_file.get !hints loc "context_used" in - let ids = List.map Names.Id.of_string (Str.split (Str.regexp " ") s) in - let ids = List.map (fun id -> Loc.ghost, id) ids in - SsExpr (SsSet ids) + match Str.split (Str.regexp ";") s with + | ids :: _ -> + let ids = List.map Names.Id.of_string (Str.split (Str.regexp " ") ids) in + let ids = List.map (fun id -> Loc.ghost, id) ids in + begin match ids with + | [] -> SsEmpty + | x :: xs -> + List.fold_left (fun a x -> SsUnion (SsSingl x,a)) (SsSingl x) xs + end + | _ -> raise Not_found let get_hint_bp_time proof_name = try float_of_string (Aux_file.get !hints Loc.ghost proof_name) @@ -1117,7 +1147,7 @@ end = struct (* {{{ *) when is_tac expr && State.same_env o n -> (* A pure tactic *) Some (id, `Proof (prev, State.proof_part_of_frozen n)) | Some _, Some s -> - msg_warning (str "Sending back a fat state"); + msg_warning (str "STM: sending back a fat state"); Some (id, `Full s) | _, Some s -> Some (id, `Full s) in let rec aux seen = function @@ -1207,7 +1237,7 @@ end = struct (* {{{ *) (Lemmas.standard_proof_terminator [] (Lemmas.mk_hook (fun _ _ -> ()))); let proof = - Proof_global.close_proof ~keep_body_ucst_sepatate:true (fun x -> x) in + Proof_global.close_proof ~keep_body_ucst_separate:true (fun x -> x) in (* We jump at the beginning since the kernel handles side effects by also * looking at the ones that happen to be present in the current env *) Reach.known_state ~cache:`No start; @@ -1472,7 +1502,7 @@ end = struct (* {{{ *) let e, etac, time, fail = let rec find time fail = function | VernacSolve(_,_,re,b) -> re, b, time, fail - | VernacTime [_,e] -> find true fail e + | VernacTime [_,e] | VernacRedirect (_,[_,e]) -> find true fail e | VernacFail e -> find time true e | _ -> errorlabstrm "Stm" (str"unsupported") in find false false e in Hooks.call Hooks.with_fail fail (fun () -> @@ -1564,7 +1594,8 @@ end = struct (* {{{ *) vernac_interp r_for { r_what with verbose = true }; feedback ~state_id:r_for Feedback.Processed with e when Errors.noncritical e -> - let msg = string_of_ppcmds (print e) in + let e = Errors.push e in + let msg = string_of_ppcmds (iprint e) in feedback ~state_id:r_for (Feedback.ErrorMsg (Loc.ghost, msg)) let name_of_task { t_what } = string_of_ppcmds (pr_ast t_what) @@ -1675,7 +1706,10 @@ let collect_proof keep cur hd brkind id = assert (VCS.Branch.equal hd hd' || VCS.Branch.equal hd VCS.edit_branch); let name = name ids in `MaybeASync (parent last, None, accn, name, delegate name) - | `Sideff _ -> `Sync (no_name,None,`NestedProof) + | `Sideff _ -> + Pp.(msg_warning (strbrk ("Nested proofs are deprecated and will "^ + "stop working in the next Coq version"))); + `Sync (no_name,None,`NestedProof) | _ -> `Sync (no_name,None,`Unknown) in let make_sync why = function | `Sync(name,pua,_) -> `Sync (name,pua,why) @@ -1729,8 +1763,9 @@ let known_state ?(redefine_qed=false) ~cache id = let cherry_pick_non_pstate () = Summary.freeze_summary ~marshallable:`No ~complement:true pstate, Lib.freeze ~marshallable:`No in - let inject_non_pstate (s,l) = Summary.unfreeze_summary s; Lib.unfreeze l in - + let inject_non_pstate (s,l) = + Summary.unfreeze_summary s; Lib.unfreeze l; update_global_env () + in let rec pure_cherry_pick_non_pstate id = Future.purify (fun id -> prerr_endline ("cherry-pick non pstate " ^ Stateid.to_string id); reach id; @@ -1757,12 +1792,12 @@ let known_state ?(redefine_qed=false) ~cache id = ), cache, true | `Cmd { cast = x; cqueue = `QueryQueue cancel } when Flags.async_proofs_is_master () -> (fun () -> - reach ~cache:`Shallow view.next; + reach view.next; Query.vernac_interp cancel view.next id x ), cache, false - | `Cmd { cast = x } -> (fun () -> - reach view.next; vernac_interp id x - ), cache, true + | `Cmd { cast = x; ceff = eff } -> (fun () -> + reach view.next; vernac_interp id x; + if eff then update_global_env ()), cache, true | `Fork ((x,_,_,_), None) -> (fun () -> reach view.next; vernac_interp id x; wall_clock_last_fork := Unix.gettimeofday () @@ -1787,7 +1822,7 @@ let known_state ?(redefine_qed=false) ~cache id = VCS.create_cluster nodes ~qed:id ~start; begin match brinfo, qed.fproof with | { VCS.kind = `Edit _ }, None -> assert false - | { VCS.kind = `Edit (_,_,_, okeep) }, Some (ofp, cancel) -> + | { VCS.kind = `Edit (_,_,_, okeep, _) }, Some (ofp, cancel) -> assert(redefine_qed = true); if okeep != keep then msg_error(strbrk("The command closing the proof changed. " @@ -1824,7 +1859,6 @@ let known_state ?(redefine_qed=false) ~cache id = Proof_global.discard_all () ), (if redefine_qed then `No else `Yes), true | `Sync (name, _, `Immediate) -> (fun () -> - assert (Stateid.equal view.next eop); reach eop; vernac_interp id x; Proof_global.discard_all () ), `Yes, true | `Sync (name, pua, reason) -> (fun () -> @@ -1841,11 +1875,10 @@ let known_state ?(redefine_qed=false) ~cache id = qed.fproof <- Some (fp, ref false); None | VtKeep -> Some(Proof_global.close_proof - ~keep_body_ucst_sepatate:false + ~keep_body_ucst_separate:false (State.exn_on id ~valid:eop)) in - reach view.next; - if keep == VtKeepAsAxiom then - Option.iter (vernac_interp id) pua; + if keep != VtKeepAsAxiom then + reach view.next; let wall_clock2 = Unix.gettimeofday () in vernac_interp id ?proof x; let wall_clock3 = Unix.gettimeofday () in @@ -1863,7 +1896,7 @@ let known_state ?(redefine_qed=false) ~cache id = in aux (collect_proof keep (view.next, x) brname brinfo eop) | `Sideff (`Ast (x,_)) -> (fun () -> - reach view.next; vernac_interp id x; + reach view.next; vernac_interp id x; update_global_env () ), cache, true | `Sideff (`Id origin) -> (fun () -> reach view.next; @@ -1890,7 +1923,7 @@ let init () = Backtrack.record (); Slaves.init (); if Flags.async_proofs_is_master () then begin - prerr_endline "Initialising workers"; + prerr_endline "Initializing workers"; Query.init (); let opts = match !Flags.async_proofs_private_flags with | None -> [] @@ -1921,7 +1954,7 @@ let finish ?(print_goals=false) () = VCS.print (); (* Some commands may by side effect change the proof mode *) match VCS.get_branch head with - | { VCS.kind = `Edit (mode, _,_,_) } -> Proof_global.activate_proof_mode mode + | { VCS.kind = `Edit (mode,_,_,_,_) } -> Proof_global.activate_proof_mode mode | { VCS.kind = `Proof (mode, _) } -> Proof_global.activate_proof_mode mode | _ -> () @@ -1989,7 +2022,7 @@ let merge_proof_branch ?valid ?id qast keep brname = VCS.delete_branch brname; if keep <> VtDrop then VCS.propagate_sideff None; `Ok - | { VCS.kind = `Edit (mode, qed_id, master_id, _) } -> + | { VCS.kind = `Edit (mode, qed_id, master_id, _,_) } -> let ofp = match VCS.visit qed_id with | { step = `Qed ({ fproof }, _) } -> fproof @@ -2018,7 +2051,7 @@ let handle_failure (e, info) vcs tty = end; VCS.print (); anomaly(str"error with no safe_id attached:" ++ spc() ++ - Errors.print_no_report e) + Errors.iprint_no_report (e, info)) | Some (safe_id, id) -> prerr_endline ("Failed at state " ^ Stateid.to_string id); VCS.restore vcs; @@ -2104,7 +2137,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) = iraise (State.exn_on report_id e)); `Ok | VtQuery (false,(report_id,route)), VtNow -> (try vernac_interp report_id ~route x - with e when Errors.noncritical e -> + with e -> let e = Errors.push e in iraise (State.exn_on report_id e)); `Ok | VtQuery (true,(report_id,_)), w -> @@ -2113,7 +2146,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) = let queue = if !Flags.async_proofs_full then `QueryQueue (ref false) else `MainQueue in - VCS.commit id (Cmd {ctac=false;cast = x; cids = []; cqueue = queue }); + VCS.commit id (Cmd {ctac=false;ceff=false;cast = x; cids = []; cqueue = queue }); Backtrack.record (); if w == VtNow then finish (); `Ok | VtQuery (false,_), VtLater -> anomaly(str"classifier: VtQuery + VtLater must imply part_of_script") @@ -2136,16 +2169,16 @@ 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;cast = x;cids=[];cqueue = `MainQueue}); + VCS.commit id (Cmd {ctac=false;ceff=false;cast = x;cids=[];cqueue = `MainQueue}); List.iter (fun bn -> match VCS.get_branch bn with | { VCS.root; kind = `Master; pos } -> () | { VCS.root; kind = `Proof(_,d); pos } -> VCS.delete_branch bn; VCS.branch ~root ~pos bn (`Proof(mode,d)) - | { VCS.root; kind = `Edit(_,f,q,k); pos } -> + | { VCS.root; kind = `Edit(_,f,q,k,ob); pos } -> VCS.delete_branch bn; - VCS.branch ~root ~pos bn (`Edit(mode,f,q,k))) + VCS.branch ~root ~pos bn (`Edit(mode,f,q,k,ob))) (VCS.branches ()); VCS.checkout_shallowest_proof_branch (); Backtrack.record (); @@ -2154,7 +2187,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) = | VtProofStep paral, 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;cast = x;cids = [];cqueue = queue }); + VCS.commit id (Cmd {ctac = true;ceff = false;cast = x;cids = [];cqueue = queue }); 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 @@ -2170,7 +2203,7 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) = | VtSideff l, w -> let id = VCS.new_node ~id:newtip () in VCS.checkout VCS.Branch.master; - VCS.commit id (Cmd {ctac=false;cast=x;cids=l;cqueue=`MainQueue}); + VCS.commit id (Cmd {ctac=false;ceff=true;cast=x;cids=l;cqueue=`MainQueue}); VCS.propagate_sideff (Some x); VCS.checkout_shallowest_proof_branch (); Backtrack.record (); if w == VtNow then finish (); `Ok @@ -2194,7 +2227,8 @@ let process_transaction ?(newtip=Stateid.fresh ()) ~tty verbose c (loc, expr) = VCS.branch bname (`Proof ("Classic", VCS.proof_nesting () + 1)); Proof_global.activate_proof_mode "Classic"; end else begin - VCS.commit id (Cmd {ctac=false; cast = x; cids = []; cqueue = `MainQueue}); + VCS.commit id (Cmd {ctac = false; ceff = true; + cast = x; cids = []; cqueue = `MainQueue}); VCS.propagate_sideff (Some x); VCS.checkout_shallowest_proof_branch (); end in @@ -2283,6 +2317,17 @@ let edit_at id = | { step = `Fork _ } -> false | { next } -> aux next in aux (VCS.get_branch_pos (VCS.current_branch ())) in + let rec is_pure_aux id = + let view = VCS.visit id in + match view.step with + | `Cmd _ -> is_pure_aux view.next + | `Fork _ -> true + | _ -> false in + let is_pure id = + match (VCS.visit id).step with + | `Qed (_,last_step) -> is_pure_aux last_step + | _ -> assert false + in let is_ancestor_of_cur_branch id = Vcs_.NodeSet.mem id (VCS.reachable (VCS.get_branch_pos (VCS.current_branch ()))) in @@ -2293,24 +2338,27 @@ let edit_at id = let rec master_for_br root tip = if Stateid.equal tip Stateid.initial then tip else match VCS.visit tip with - | { next } when next = root -> root - | { step = `Fork _ } -> tip - | { step = `Sideff (`Ast(_,id)|`Id id) } -> id + | { step = (`Fork _ | `Qed _) } -> tip + | { step = `Sideff (`Ast(_,id)) } -> id + | { step = `Sideff _ } -> tip | { next } -> master_for_br root next in - let reopen_branch start at_id mode qed_id tip = + 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 *) match VCS.visit qed_id with | { step = `Qed ({ fproof = Some (_,cs); keep },_) } -> start, cs, keep | _ -> anomaly (str "Cluster not ending with Qed") in VCS.branch ~root:master_id ~pos:id - VCS.edit_branch (`Edit (mode, qed_id, master_id, keep)); + VCS.edit_branch (`Edit (mode, qed_id, master_id, keep, old_branch)); VCS.delete_cluster_of id; cancel_switch := true; Reach.known_state ~cache:(interactive ()) id; VCS.checkout_shallowest_proof_branch (); `Focus { stop = qed_id; start = master_id; tip } in - let backto id = + let no_edit = function + | `Edit (pm, _,_,_,_) -> `Proof(pm,1) + | x -> x in + let backto id bn = List.iter VCS.delete_branch (VCS.branches ()); let ancestors = VCS.reachable id in let { mine = brname, brinfo; others } = Backtrack.branches_of id in @@ -2320,10 +2368,14 @@ let edit_at id = 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 brname brinfo.VCS.kind; + 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.gc (); - Reach.known_state ~cache:(interactive ()) id; + VCS.print (); + if not !Flags.async_proofs_full then + Reach.known_state ~cache:(interactive ()) id; VCS.checkout_shallowest_proof_branch (); `NewTip in try @@ -2331,20 +2383,21 @@ let edit_at id = let focused = List.exists ((=) VCS.edit_branch) (VCS.branches ()) in let branch_info = match snd (VCS.get_info id).vcs_backup with - | Some{ mine = _, { VCS.kind = (`Proof(m,_)|`Edit(m,_,_,_)) }} -> Some m + | 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 | _, Some _, None -> assert false - | false, Some (qed_id,start), Some mode -> + | false, Some (qed_id,start), Some(mode,bn) -> let tip = VCS.cur_tip () in - if has_failed qed_id && not !Flags.async_proofs_never_reopen_branch - then reopen_branch start id mode qed_id tip - else backto id - | true, Some (qed_id,_), Some mode -> + 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) -> if on_cur_branch id then begin assert false end else if is_ancestor_of_cur_branch id then begin - backto id + backto id (Some bn) end else begin anomaly(str"Cannot leave an `Edit branch open") end @@ -2355,11 +2408,12 @@ let edit_at id = VCS.checkout_shallowest_proof_branch (); `NewTip end else if is_ancestor_of_cur_branch id then begin - backto id + backto id None end else begin anomaly(str"Cannot leave an `Edit branch open") end - | false, None, _ -> backto id + | false, None, Some(_,bn) -> backto id (Some bn) + | false, None, None -> backto id None in VCS.print (); rc @@ -2376,6 +2430,9 @@ let edit_at id = VCS.print (); iraise (e, info) +let backup () = VCS.backup () +let restore d = VCS.restore d + (*********************** TTY API (PG, coqtop, coqc) ***************************) (******************************************************************************) @@ -2430,7 +2487,7 @@ let get_script prf = let branch, test = match prf with | None -> VCS.Branch.master, fun _ -> true - | Some name -> VCS.current_branch (), List.mem name in + | Some name -> VCS.current_branch (),fun nl -> nl=[] || List.mem name nl in let rec find acc id = if Stateid.equal id Stateid.initial || Stateid.equal id Stateid.dummy then acc else @@ -2441,7 +2498,9 @@ let get_script prf = | `Sideff (`Ast (x,_)) -> find ((x.expr, (VCS.get_info id).n_goals)::acc) view.next | `Sideff (`Id id) -> find acc id - | `Cmd {cast = x} -> find ((x.expr, (VCS.get_info id).n_goals)::acc) view.next + | `Cmd {cast = x; ctac} when ctac -> (* skip non-tactics *) + find ((x.expr, (VCS.get_info id).n_goals)::acc) view.next + | `Cmd _ -> find acc view.next | `Alias (id,_) -> find acc id | `Fork _ -> find acc view.next in @@ -2517,5 +2576,5 @@ let process_error_hook = Hooks.process_error_hook let interp_hook = Hooks.interp_hook let with_fail_hook = Hooks.with_fail_hook let unreachable_state_hook = Hooks.unreachable_state_hook - +let get_fix_exn () = !State.fix_exn_ref (* vim:set foldmethod=marker: *) diff --git a/stm/stm.mli b/stm/stm.mli index 1d926e99..0c05c93d 100644 --- a/stm/stm.mli +++ b/stm/stm.mli @@ -35,7 +35,9 @@ val query : new document tip, the document between [id] and [fo.stop] has been dropped. The portion between [fo.stop] and [fo.tip] has been kept. [fo.start] is just to tell the gui where the editing zone starts, in case it wants to - graphically denote it. All subsequent [add] happen on top of [id]. *) + graphically denote it. All subsequent [add] happen on top of [id]. + If Flags.async_proofs_full is set, then [id] is not [observe]d, else it is. +*) type focus = { start : Stateid.t; stop : Stateid.t; tip : Stateid.t } val edit_at : Stateid.t -> [ `NewTip | `Focus of focus ] @@ -49,11 +51,11 @@ val stop_worker : string -> unit (* Joins the entire document. Implies finish, but also checks proofs *) val join : unit -> unit -(* Saves on the dist a .vio corresponding to the current status: - - if the worker prool is empty, all tasks are saved +(* Saves on the disk a .vio corresponding to the current status: + - if the worker pool is empty, all tasks are saved - if the worker proof is not empty, then it waits until all workers are done with their current jobs and then dumps (or fails if one - of the completed tasks is a failuere) *) + of the completed tasks is a failure) *) val snapshot_vio : DirPath.t -> string -> unit (* Empties the task queue, can be used only if the worker pool is empty (E.g. @@ -81,6 +83,10 @@ val set_compilation_hints : string -> unit (* Reorders the task queue putting forward what is in the perspective *) val set_perspective : Stateid.t list -> unit +type document +val backup : unit -> document +val restore : document -> unit + (** workers **************************************************************** **) module ProofTask : AsyncTaskQueue.Task @@ -98,7 +104,7 @@ val state_computed_hook : (Stateid.t -> in_cache:bool -> unit) Hook.t val parse_error_hook : (Feedback.edit_or_state_id -> Loc.t -> Pp.std_ppcmds -> unit) Hook.t val execution_error_hook : (Stateid.t -> Loc.t -> Pp.std_ppcmds -> unit) Hook.t -val unreachable_state_hook : (Stateid.t -> unit) Hook.t +val unreachable_state_hook : (Stateid.t -> Exninfo.iexn -> unit) Hook.t (* ready means that master has it at hand *) val state_ready_hook : (Stateid.t -> unit) Hook.t @@ -130,3 +136,4 @@ val process_error_hook : Future.fix_exn Hook.t val interp_hook : (?verbosely:bool -> ?proof:Proof_global.closed_proof -> Loc.t * Vernacexpr.vernac_expr -> unit) Hook.t val with_fail_hook : (bool -> (unit -> unit) -> unit) Hook.t +val get_fix_exn : unit -> (Exninfo.iexn -> Exninfo.iexn) diff --git a/stm/tQueue.ml b/stm/tQueue.ml index 6fef895a..2dad962b 100644 --- a/stm/tQueue.ml +++ b/stm/tQueue.ml @@ -15,6 +15,7 @@ module PriorityQueue : sig val pop : ?picky:('a -> bool) -> 'a t -> 'a val push : 'a t -> 'a -> unit val clear : 'a t -> unit + val length : 'a t -> int end = struct type 'a item = int * 'a type 'a rel = 'a item -> 'a item -> int @@ -38,6 +39,7 @@ end = struct let set_rel rel ({ contents = (xs, _) } as t) = let rel (_,x) (_,y) = rel x y in t := (List.sort rel xs, rel) + let length ({ contents = (l, _) }) = List.length l end type 'a t = { @@ -92,11 +94,29 @@ let push { queue = q; lock = m; cond = c; release } x = Condition.broadcast c; Mutex.unlock m +let length { queue = q; lock = m } = + Mutex.lock m; + let n = PriorityQueue.length q in + Mutex.unlock m; + n + let clear { queue = q; lock = m; cond = c } = Mutex.lock m; PriorityQueue.clear q; Mutex.unlock m +let clear_saving { queue = q; lock = m; cond = c } f = + Mutex.lock m; + let saved = ref [] in + while not (PriorityQueue.is_empty q) do + let elem = PriorityQueue.pop q in + match f elem with + | Some x -> saved := x :: !saved + | None -> () + done; + Mutex.unlock m; + List.rev !saved + let is_empty { queue = q } = PriorityQueue.is_empty q let destroy tq = diff --git a/stm/tQueue.mli b/stm/tQueue.mli index 7458de51..1df52d25 100644 --- a/stm/tQueue.mli +++ b/stm/tQueue.mli @@ -22,9 +22,12 @@ val broadcast : 'a t -> unit val wait_until_n_are_waiting_then_snapshot : int -> 'a t -> 'a list val clear : 'a t -> unit +val clear_saving : 'a t -> ('a -> 'b option) -> 'b list val is_empty : 'a t -> bool exception BeingDestroyed (* Threads blocked in pop can get this exception if the queue is being * destroyed *) val destroy : 'a t -> unit + +val length : 'a t -> int diff --git a/stm/texmacspp.ml b/stm/texmacspp.ml index 180f20ae..b9120804 100644 --- a/stm/texmacspp.ml +++ b/stm/texmacspp.ml @@ -244,7 +244,7 @@ and pp_local_decl_expr lde = (* don't know what it is for now *) match lde with | AssumExpr (_, ce) -> pp_expr ce | DefExpr (_, ce, _) -> pp_expr ce -and pp_inductive_expr ((_, (l, id)), lbl, ceo, _, cl_or_rdexpr) = +and pp_inductive_expr ((_, ((l, id),_)), lbl, ceo, _, cl_or_rdexpr) = (* inductive_expr *) let b,e = Loc.unloc l in let location = ["begin", string_of_int b; "end", string_of_int e] in @@ -273,7 +273,7 @@ and pp_recursion_order_expr optid roe = (* don't know what it is for now *) | CMeasureRec (e, None) -> "mesrec", [pp_expr e] | CMeasureRec (e, Some rel) -> "mesrec", [pp_expr e] @ [pp_expr rel] in Element ("recursion_order", ["kind", kind] @ attrs, expr) -and pp_fixpoint_expr ((loc, id), (optid, roe), lbl, ce, ceo) = +and pp_fixpoint_expr (((loc, id), pl), (optid, roe), lbl, ce, ceo) = (* fixpoint_expr *) let start, stop = unlock loc in let id = Id.to_string id in @@ -286,7 +286,7 @@ and pp_fixpoint_expr ((loc, id), (optid, roe), lbl, ce, ceo) = | Some ce -> [pp_expr ce] | None -> [] end -and pp_cofixpoint_expr ((loc, id), lbl, ce, ceo) = (* cofixpoint_expr *) +and pp_cofixpoint_expr (((loc, id), pl), lbl, ce, ceo) = (* cofixpoint_expr *) (* Nota: it is like fixpoint_expr without (optid, roe) * so could be merged if there is no more differences *) let start, stop = unlock loc in @@ -473,7 +473,7 @@ and pp_expr ?(attr=[]) e = xmlApply loc (xmlOperator "fix" loc :: List.flatten (List.map - (fun (a,b,cl,c,d) -> pp_fixpoint_expr (a,b,cl,c,Some d)) + (fun (a,b,cl,c,d) -> pp_fixpoint_expr ((a,None),b,cl,c,Some d)) fel)) let pp_comment (c) = @@ -490,6 +490,9 @@ let rec tmpp v loc = | VernacTime l -> xmlApply loc (Element("time",[],[]) :: List.map (fun(loc,e) ->tmpp e loc) l) + | VernacRedirect (s, l) -> + xmlApply loc (Element("redirect",["path", s],[]) :: + List.map (fun(loc,e) ->tmpp e loc) l) | VernacTimeout (s,e) -> xmlApply loc (Element("timeout",["val",string_of_int s],[]) :: [tmpp e loc]) @@ -506,8 +509,10 @@ let rec tmpp v loc = | VernacOpenCloseScope (_,(true,name)) -> xmlScope loc "open" name [] | VernacOpenCloseScope (_,(false,name)) -> xmlScope loc "close" name [] - | VernacDelimiters (name,tag) -> + | VernacDelimiters (name,Some tag) -> xmlScope loc "delimit" name ~attr:["delimiter",tag] [] + | VernacDelimiters (name,None) -> + xmlScope loc "undelimit" name ~attr:[] [] | VernacBindScope (name,l) -> xmlScope loc "bind" name (List.map (function @@ -535,7 +540,7 @@ let rec tmpp v loc = | VernacConstraint _ | VernacPolymorphic (_, _) as x -> xmlTODO loc x (* Gallina *) - | VernacDefinition (ldk, (_,id), de) -> + | VernacDefinition (ldk, ((_,id),_), de) -> let l, dk = match ldk with | Some l, dk -> (l, dk) @@ -550,7 +555,7 @@ let rec tmpp v loc = let str_dk = Kindops.string_of_definition_kind (l, false, dk) in let str_id = Id.to_string id in (xmlDef str_dk str_id loc [pp_expr e]) - | VernacStartTheoremProof (tk, [ Some (_,id), ([], statement, None) ], b) -> + | VernacStartTheoremProof (tk, [ Some ((_,id),_), ([], statement, None) ], b) -> let str_tk = Kindops.string_of_theorem_kind tk in let str_id = Id.to_string id in (xmlThm str_tk str_id loc [pp_expr statement]) @@ -570,10 +575,11 @@ let rec tmpp v loc = end | VernacExactProof _ as x -> xmlTODO loc x | VernacAssumption ((l, a), _, sbwcl) -> + let binders = List.map (fun (_, (id, c)) -> (List.map fst id, c)) sbwcl in let many = - List.length (List.flatten (List.map fst (List.map snd sbwcl))) > 1 in + List.length (List.flatten (List.map fst binders)) > 1 in let exprs = - List.flatten (List.map pp_simple_binder (List.map snd sbwcl)) in + List.flatten (List.map pp_simple_binder binders) in let l = match l with Some x -> x | None -> Decl_kinds.Global in let kind = string_of_assumption_kind l a many in xmlAssumption kind loc exprs diff --git a/stm/vernac_classifier.ml b/stm/vernac_classifier.ml index 783ff2e1..a898c687 100644 --- a/stm/vernac_classifier.ml +++ b/stm/vernac_classifier.ml @@ -86,7 +86,7 @@ let rec classify_vernac e = make_polymorphic (classify_vernac e) else classify_vernac e | VernacTimeout (_,e) -> classify_vernac e - | VernacTime e -> classify_vernac_list e + | VernacTime e | VernacRedirect (_, e) -> classify_vernac_list e | VernacFail e -> (* Fail Qed or Fail Lemma must not join/fork the DAG *) (match classify_vernac e with | ( VtQuery _ | VtProofStep _ | VtSideff _ @@ -116,36 +116,36 @@ let rec classify_vernac e = | VernacSetOption (["Default";"Proof";"Using"],_) -> VtSideff [], VtNow (* StartProof *) | VernacDefinition ( - (Some Decl_kinds.Discharge,Decl_kinds.Definition),(_,i),ProveBody _) -> + (Some Decl_kinds.Discharge,Decl_kinds.Definition),((_,i),_),ProveBody _) -> VtStartProof("Classic",Doesn'tGuaranteeOpacity,[i]), VtLater - | VernacDefinition (_,(_,i),ProveBody _) -> + | VernacDefinition (_,((_,i),_),ProveBody _) -> VtStartProof("Classic",GuaranteesOpacity,[i]), VtLater | VernacStartTheoremProof (_,l,_) -> let ids = - CList.map_filter (function (Some(_,i), _) -> Some i | _ -> None) l in + CList.map_filter (function (Some ((_,i),pl), _) -> Some i | _ -> None) l in VtStartProof ("Classic",GuaranteesOpacity,ids), VtLater | VernacGoal _ -> VtStartProof ("Classic",GuaranteesOpacity,[]), VtLater | VernacFixpoint (_,l) -> let ids, open_proof = - List.fold_left (fun (l,b) (((_,id),_,_,_,p),_) -> + List.fold_left (fun (l,b) ((((_,id),_),_,_,_,p),_) -> id::l, b || p = None) ([],false) l in if open_proof then VtStartProof ("Classic",GuaranteesOpacity,ids), VtLater else VtSideff ids, VtLater | VernacCoFixpoint (_,l) -> let ids, open_proof = - List.fold_left (fun (l,b) (((_,id),_,_,p),_) -> + List.fold_left (fun (l,b) ((((_,id),_),_,_,p),_) -> id::l, b || p = None) ([],false) l in if open_proof then VtStartProof ("Classic",GuaranteesOpacity,ids), VtLater else VtSideff ids, VtLater (* Sideff: apply to all open branches. usually run on master only *) | VernacAssumption (_,_,l) -> - let ids = List.flatten (List.map (fun (_,(l,_)) -> List.map snd l) l) in + let ids = List.flatten (List.map (fun (_,(l,_)) -> List.map (fun (id, _) -> snd id) l) l) in VtSideff ids, VtLater - | VernacDefinition (_,(_,id),DefineBody _) -> VtSideff [id], VtLater + | VernacDefinition (_,((_,id),_),DefineBody _) -> VtSideff [id], VtLater | VernacInductive (_,_,l) -> - let ids = List.map (fun (((_,(_,id)),_,_,_,cl),_) -> id :: match cl with + let ids = List.map (fun (((_,((_,id),_)),_,_,_,cl),_) -> id :: match cl with | Constructors l -> List.map (fun (_,((_,id),_)) -> id) l | RecordDecl (oid,l) -> (match oid with Some (_,x) -> [x] | _ -> []) @ CList.map_filter (function @@ -173,9 +173,13 @@ let rec classify_vernac e = | VernacDeclareReduction _ | VernacDeclareClass _ | VernacDeclareInstances _ | VernacRegister _ - | VernacDeclareTacticDefinition _ | VernacNameSectionHypSet _ | VernacComments _ -> VtSideff [], VtLater + | VernacDeclareTacticDefinition (_,l) -> + let open Libnames in + VtSideff (List.map (function + | (Ident (_,r),_,_) -> r + | (Qualid (_,q),_,_) -> snd(repr_qualid q)) l), VtLater (* Who knows *) | VernacLoad _ -> VtSideff [], VtNow (* (Local) Notations have to disappear *) diff --git a/stm/vio_checking.ml b/stm/vio_checking.ml index b2072221..06bf955c 100644 --- a/stm/vio_checking.ml +++ b/stm/vio_checking.ml @@ -10,7 +10,7 @@ open Util let check_vio (ts,f) = Dumpglob.noglob (); - let long_f_dot_v, _, _, _, tasks, _ = Library.load_library_todo f in + let long_f_dot_v, _, _, _, _, tasks, _ = Library.load_library_todo f in Stm.set_compilation_hints long_f_dot_v; List.fold_left (fun acc ids -> Stm.check_task f tasks ids && acc) true ts @@ -30,7 +30,7 @@ let schedule_vio_checking j fs = let f = if Filename.check_suffix f ".vio" then Filename.chop_extension f else f in - let long_f_dot_v, _,_,_, tasks, _ = Library.load_library_todo f in + let long_f_dot_v, _,_,_,_, tasks, _ = Library.load_library_todo f in Stm.set_compilation_hints long_f_dot_v; let infos = Stm.info_tasks tasks in let eta = List.fold_left (fun a (_,t,_) -> a +. t) 0.0 infos in @@ -104,9 +104,7 @@ let schedule_vio_compilation j fs = let f = if Filename.check_suffix f ".vio" then Filename.chop_extension f else f in - let paths = Loadpath.get_paths () in - let _, long_f_dot_v = - System.find_file_in_path ~warn:(Flags.is_verbose()) paths (f^".v") in + let long_f_dot_v = Loadpath.locate_file (f^".v") in let aux = Aux_file.load_aux_file_for long_f_dot_v in let eta = try float_of_string (Aux_file.get aux Loc.ghost "vo_compile_time") diff --git a/tactics/auto.ml b/tactics/auto.ml index 46274f83..a6b53d76 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -72,27 +72,44 @@ let auto_flags_of_state st = (* Try unification with the precompiled clause, then use registered Apply *) -let unify_resolve_nodelta poly (c,clenv) = +let connect_hint_clenv poly (c, _, ctx) clenv gl = + (** [clenv] has been generated by a hint-making function, so the only relevant + data in its evarmap is the set of metas. The [evar_reset_evd] function + below just replaces the metas of sigma by those coming from the clenv. *) + let sigma = Proofview.Goal.sigma gl in + let evd = Evd.evars_reset_evd ~with_conv_pbs:true ~with_univs:false sigma clenv.evd in + (** Still, we need to update the universes *) + let clenv, c = + if poly then + (** Refresh the instance of the hint *) + let (subst, ctx) = Universes.fresh_universe_context_set_instance ctx in + let map c = Vars.subst_univs_level_constr subst c in + let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in + let clenv = { clenv with evd = evd ; env = Proofview.Goal.env gl } in + (** FIXME: We're being inefficient here because we substitute the whole + evar map instead of just its metas, which are the only ones + mentioning the old universes. *) + Clenv.map_clenv map clenv, map c + else + let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in + { clenv with evd = evd ; env = Proofview.Goal.env gl }, c + in clenv, c + +let unify_resolve poly flags ((c : raw_hint), clenv) = Proofview.Goal.nf_enter begin fun gl -> - let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in - let clenv' = Tacmach.New.of_old connect_clenv gl clenv' in - let clenv'' = Tacmach.New.of_old (fun gl -> clenv_unique_resolver ~flags:auto_unif_flags clenv' gl) gl in - Clenvtac.clenv_refine false clenv'' + let clenv, c = connect_hint_clenv poly c clenv gl in + let clenv = Tacmach.New.of_old (fun gl -> clenv_unique_resolver ~flags clenv gl) gl in + Clenvtac.clenv_refine false clenv end -let unify_resolve poly flags (c,clenv) = - Proofview.Goal.nf_enter begin fun gl -> - let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in - let clenv' = Tacmach.New.of_old connect_clenv gl clenv' in - let clenv'' = Tacmach.New.of_old (fun gl -> clenv_unique_resolver ~flags clenv' gl) gl in - Clenvtac.clenv_refine false clenv'' - end +let unify_resolve_nodelta poly h = unify_resolve poly auto_unif_flags h let unify_resolve_gen poly = function | None -> unify_resolve_nodelta poly | Some flags -> unify_resolve poly flags let exact poly (c,clenv) = + let (c, _, _) = c in let ctx, c' = if poly then let evd', subst = Evd.refresh_undefined_universes clenv.evd in @@ -131,7 +148,7 @@ let conclPattern concl pat tac = try Proofview.tclUNIT (Constr_matching.matches env sigma pat concl) with Constr_matching.PatternMatchingFailure -> - Proofview.tclZERO (UserError ("conclPattern",str"conclPattern")) + Tacticals.New.tclZEROMSG (str "conclPattern") in Proofview.Goal.enter (fun gl -> let env = Proofview.Goal.env gl in @@ -309,7 +326,8 @@ let rec trivial_fail_db dbg mod_delta db_list local_db = let decl = Tacmach.New.pf_last_hyp (Proofview.Goal.assume gl) in let hyp = Context.map_named_declaration nf decl in let hintl = make_resolve_hyp env sigma hyp - in trivial_fail_db dbg mod_delta db_list (Hint_db.add_list hintl local_db) + in trivial_fail_db dbg mod_delta db_list + (Hint_db.add_list env sigma hintl local_db) end) in Proofview.Goal.enter begin fun gl -> @@ -377,7 +395,7 @@ and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly})) | Extern tacast -> conclPattern concl p tacast in - tclLOG dbg (fun () -> pr_autotactic t) (run_auto_tactic t tactic) + tclLOG dbg (fun () -> pr_hint t) (run_hint t tactic) and trivial_resolve dbg mod_delta db_list local_db cl = try @@ -438,7 +456,9 @@ let possible_resolve dbg mod_delta db_list local_db cl = with Not_found -> [] let extend_local_db decl db gl = - Hint_db.add_list (make_resolve_hyp (Tacmach.New.pf_env gl) (Proofview.Goal.sigma gl) decl) db + let env = Tacmach.New.pf_env gl in + let sigma = Proofview.Goal.sigma gl in + Hint_db.add_list env sigma (make_resolve_hyp env sigma decl) db (* Introduce an hypothesis, then call the continuation tactic [kont] with the hint db extended with the so-obtained hypothesis *) @@ -458,7 +478,7 @@ let search d n mod_delta db_list local_db = (* spiwack: the test of [n] to 0 must be done independently in each goal. Hence the [tclEXTEND] *) Proofview.tclEXTEND [] begin - if Int.equal n 0 then Proofview.tclZERO (Errors.UserError ("",str"BOUND 2")) else + if Int.equal n 0 then Tacticals.New.tclZEROMSG (str"BOUND 2") else Tacticals.New.tclORELSE0 (dbg_assumption d) (Tacticals.New.tclORELSE0 (intro_register d (search d n) local_db) ( Proofview.Goal.enter begin fun gl -> diff --git a/tactics/auto.mli b/tactics/auto.mli index 0cc8a0b1..cae180ce 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -19,16 +19,19 @@ val extern_interp : (** Auto and related automation tactics *) -val priority : ('a * pri_auto_tactic) list -> ('a * pri_auto_tactic) list +val priority : ('a * full_hint) list -> ('a * full_hint) list val default_search_depth : int ref val auto_flags_of_state : transparent_state -> Unification.unify_flags +val connect_hint_clenv : polymorphic -> raw_hint -> clausenv -> + [ `NF ] Proofview.Goal.t -> clausenv * constr + (** Try unification with the precompiled clause, then use registered Apply *) -val unify_resolve_nodelta : polymorphic -> (constr * clausenv) -> unit Proofview.tactic +val unify_resolve_nodelta : polymorphic -> (raw_hint * clausenv) -> unit Proofview.tactic -val unify_resolve : polymorphic -> Unification.unify_flags -> (constr * clausenv) -> unit Proofview.tactic +val unify_resolve : polymorphic -> Unification.unify_flags -> (raw_hint * clausenv) -> unit Proofview.tactic (** [ConclPattern concl pat tacast]: if the term concl matches the pattern pat, (in sense of diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 4eb8a792..3a9d40de 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -66,7 +66,7 @@ let find_base bas = try raw_find_base bas with Not_found -> errorlabstrm "AutoRewrite" - (str ("Rewriting base "^(bas)^" does not exist.")) + (str "Rewriting base " ++ str bas ++ str " does not exist.") let find_rewrites bas = List.rev_map snd (HintDN.find_all (find_base bas)) @@ -174,7 +174,7 @@ let gen_auto_multi_rewrite conds tac_main lbas cl = if cl.concl_occs != AllOccurrences && cl.concl_occs != NoOccurrences then - Proofview.tclZERO (UserError("" , str"The \"at\" syntax isn't available yet for the autorewrite tactic.")) + Tacticals.New.tclZEROMSG (str"The \"at\" syntax isn't available yet for the autorewrite tactic.") else let compose_tac t1 t2 = match cl.onhyps with @@ -204,7 +204,7 @@ let auto_multi_rewrite_with ?(conds=Naive) tac_main lbas cl = *) gen_auto_multi_rewrite conds tac_main lbas cl | _ -> - Proofview.tclZERO (UserError ("autorewrite",strbrk "autorewrite .. in .. using can only be used either with a unique hypothesis or on the conclusion.")) + Tacticals.New.tclZEROMSG (strbrk "autorewrite .. in .. using can only be used either with a unique hypothesis or on the conclusion.") (* Functions necessary to the library object declaration *) let cache_hintrewrite (_,(rbase,lrl)) = @@ -263,7 +263,7 @@ let decompose_applied_relation metas env sigma c ctype left2right = try let others,(c1,c2) = split_last_two args in let ty1, ty2 = - Typing.type_of env eqclause.evd c1, Typing.type_of env eqclause.evd c2 + Typing.unsafe_type_of env eqclause.evd c1, Typing.unsafe_type_of env eqclause.evd c2 in (* if not (evd_convertible env eqclause.evd ty1 ty2) then None *) (* else *) @@ -281,7 +281,7 @@ let decompose_applied_relation metas env sigma c ctype left2right = | None -> None let find_applied_relation metas loc env sigma c left2right = - let ctype = Typing.type_of env sigma c in + let ctype = Typing.unsafe_type_of env sigma c in match decompose_applied_relation metas env sigma c ctype left2right with | Some c -> c | None -> @@ -292,10 +292,13 @@ let find_applied_relation metas loc env sigma c left2right = (* To add rewriting rules to a base *) let add_rew_rules base lrul = let counter = ref 0 in + let env = Global.env () in + let sigma = Evd.from_env env in let lrul = List.fold_left (fun dn (loc,(c,ctx),b,t) -> - let info = find_applied_relation false loc (Global.env ()) Evd.empty c b in + let sigma = Evd.merge_context_set Evd.univ_rigid sigma ctx in + let info = find_applied_relation false loc env sigma c b in let pat = if b then info.hyp_left else info.hyp_right in let rul = { rew_lemma = c; rew_type = info.hyp_ty; rew_pat = pat; rew_ctx = ctx; rew_l2r = b; diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index e11458c0..f3a48634 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -141,6 +141,7 @@ let progress_evars t = let e_give_exact flags poly (c,clenv) gl = + let (c, _, _) = c in let c, gl = if poly then let clenv', subst = Clenv.refresh_undefined_univs clenv in @@ -149,36 +150,35 @@ let e_give_exact flags poly (c,clenv) gl = c, {gl with sigma = clenv'.evd} else c, gl in - let t1 = pf_type_of gl c in + let t1 = pf_unsafe_type_of gl c in tclTHEN (Proofview.V82.of_tactic (Clenvtac.unify ~flags t1)) (exact_no_check c) gl let unify_e_resolve poly flags (c,clenv) gls = - let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in - let clenv' = connect_clenv gls clenv' in - let clenv' = clenv_unique_resolver ~flags clenv' gls in - Proofview.V82.of_tactic (Clenvtac.clenv_refine true ~with_classes:false clenv') gls + let clenv', c = connect_hint_clenv poly c clenv gls in + let clenv' = Tacmach.New.of_old (clenv_unique_resolver ~flags clenv') gls in + Clenvtac.clenv_refine true ~with_classes:false clenv' let unify_resolve poly flags (c,clenv) gls = - let clenv' = if poly then fst (Clenv.refresh_undefined_univs clenv) else clenv in - let clenv' = connect_clenv gls clenv' in - let clenv' = clenv_unique_resolver ~flags clenv' gls in - Proofview.V82.of_tactic - (Clenvtac.clenv_refine false ~with_classes:false clenv') gls + let clenv', _ = connect_hint_clenv poly c clenv gls in + let clenv' = Tacmach.New.of_old (clenv_unique_resolver ~flags clenv') gls in + Clenvtac.clenv_refine false ~with_classes:false clenv' -let clenv_of_prods poly nprods (c, clenv) gls = +let clenv_of_prods poly nprods (c, clenv) gl = + let (c, _, _) = c in if poly || Int.equal nprods 0 then Some clenv else - let ty = pf_type_of gls c in + let ty = Tacmach.New.pf_unsafe_type_of gl c in let diff = nb_prod ty - nprods in if Pervasives.(>=) diff 0 then (* Was Some clenv... *) - Some (mk_clenv_from_n gls (Some diff) (c,ty)) + Some (Tacmach.New.of_old (fun gls -> mk_clenv_from_n gls (Some diff) (c,ty)) gl) else None -let with_prods nprods poly (c, clenv) f gls = - match clenv_of_prods poly nprods (c, clenv) gls with - | None -> tclFAIL 0 (str"Not enough premisses") gls - | Some clenv' -> f (c, clenv') gls +let with_prods nprods poly (c, clenv) f = + Proofview.Goal.nf_enter (fun gl -> + match clenv_of_prods poly nprods (c, clenv) gl with + | None -> Tacticals.New.tclZEROMSG (str"Not enough premisses") + | Some clenv' -> f (c, clenv') gl) (** Hack to properly solve dependent evars that are typeclasses *) @@ -190,7 +190,7 @@ let rec e_trivial_fail_db db_list local_db goal = let d = pf_last_hyp g' in let hintl = make_resolve_hyp (pf_env g') (project g') d in (e_trivial_fail_db db_list - (Hint_db.add_list hintl local_db) g'))) :: + (Hint_db.add_list (pf_env g') (project g') hintl local_db) g'))) :: (List.map (fun (x,_,_,_,_) -> x) (e_trivial_resolve db_list local_db (project goal) (pf_concl goal))) in @@ -205,7 +205,7 @@ and e_my_find_search db_list local_db hdc complete sigma concl = if cl.cl_strict then Evd.evars_of_term concl else Evar.Set.empty - with _ -> Evar.Set.empty + with e when Errors.noncritical e -> Evar.Set.empty in let hintl = List.map_append @@ -222,22 +222,23 @@ and e_my_find_search db_list local_db hdc complete sigma concl = let tac_of_hint = fun (flags, {pri = b; pat = p; poly = poly; code = t; name = name}) -> let tac = function - | Res_pf (term,cl) -> Proofview.V82.tactic (with_prods nprods poly (term,cl) (unify_resolve poly flags)) - | ERes_pf (term,cl) -> Proofview.V82.tactic (with_prods nprods poly (term,cl) (unify_e_resolve poly flags)) + | Res_pf (term,cl) -> with_prods nprods poly (term,cl) (unify_resolve poly flags) + | ERes_pf (term,cl) -> with_prods nprods poly (term,cl) (unify_e_resolve poly flags) | Give_exact c -> Proofview.V82.tactic (e_give_exact flags poly c) | Res_pf_THEN_trivial_fail (term,cl) -> - Proofview.V82.tactic (tclTHEN (with_prods nprods poly (term,cl) (unify_e_resolve poly flags)) - (if complete then tclIDTAC else e_trivial_fail_db db_list local_db)) + Proofview.V82.tactic (tclTHEN + (Proofview.V82.of_tactic ((with_prods nprods poly (term,cl) (unify_e_resolve poly flags)))) + (if complete then tclIDTAC else e_trivial_fail_db db_list local_db)) | Unfold_nth c -> Proofview.V82.tactic (tclWEAK_PROGRESS (unfold_in_concl [AllOccurrences,c])) | Extern tacast -> conclPattern concl p tacast in - let tac = Proofview.V82.of_tactic (run_auto_tactic t tac) in + let tac = Proofview.V82.of_tactic (run_hint t tac) in let tac = if complete then tclCOMPLETE tac else tac in - match repr_auto_tactic t with - | Extern _ -> (tac,b,true, name, lazy (pr_autotactic t)) + match repr_hint t with + | Extern _ -> (tac,b,true, name, lazy (pr_hint t)) | _ -> (* let tac gl = with_pattern (pf_env gl) (project gl) flags p concl tac gl in *) - (tac,b,false, name, lazy (pr_autotactic t)) + (tac,b,false, name, lazy (pr_hint t)) in List.map tac_of_hint hintl and e_trivial_resolve db_list local_db sigma concl = @@ -339,7 +340,7 @@ let make_hints g st only_classes sign = (PathOr (paths, path), hint @ hints) else (paths, hints)) (PathEmpty, []) sign - in Hint_db.add_list hintlist (Hint_db.empty st true) + in Hint_db.add_list (pf_env g) (project g) hintlist (Hint_db.empty st true) let make_autogoal_hints = let cache = ref (true, Environ.empty_named_context_val, @@ -374,7 +375,7 @@ let intro_tac : atac = let context = Environ.named_context_of_val (Goal.V82.hyps s g') in let hint = make_resolve_hyp env s (Hint_db.transparent_state info.hints) (true,false,false) info.only_classes None (List.hd context) in - let ldb = Hint_db.add_list hint info.hints in + let ldb = Hint_db.add_list env s hint info.hints in (g', { info with is_evar = None; hints = ldb; auto_last_tac = lazy (str"intro") })) gls in {it = gls'; sigma = s;}) @@ -397,7 +398,7 @@ let is_unique env concl = try let (cl,u), args = dest_class_app env concl in cl.cl_unique - with _ -> false + with e when Errors.noncritical e -> false let needs_backtrack env evd oev concl = if Option.is_empty oev || is_Prop env evd concl then @@ -490,6 +491,7 @@ let hints_tac hints = let then_list (second : atac) (sk : (auto_result, 'a) sk) : (auto_result, 'a) sk = let rec aux s (acc : autogoal list list) fk = function | (gl,info) :: gls -> + Control.check_for_interrupt (); (match info.is_evar with | Some ev when Evd.is_defined s ev -> aux s acc fk gls | _ -> @@ -842,6 +844,7 @@ let is_ground c gl = let autoapply c i gl = let flags = auto_unif_flags Evar.Set.empty (Hints.Hint_db.transparent_state (Hints.searchtable_map i)) in - let cty = pf_type_of gl c in + let cty = pf_unsafe_type_of gl c in let ce = mk_clenv_from gl (c,cty) in - unify_e_resolve false flags (c,ce) gl + let tac = unify_e_resolve false flags ((c,cty,Univ.ContextSet.empty),ce) in + Proofview.V82.of_tactic (Proofview.Goal.nf_enter tac) gl diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index 9b69481d..22f218b4 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -55,7 +55,7 @@ let contradiction_context = let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let rec seek_neg l = match l with - | [] -> Proofview.tclZERO (UserError ("" , Pp.str"No such contradiction")) + | [] -> Tacticals.New.tclZEROMSG (Pp.str"No such contradiction") | (id,_,typ)::rest -> let typ = nf_evar sigma typ in let typ = whd_betadeltaiota env sigma typ in @@ -90,7 +90,7 @@ let contradiction_term (c,lbind as cl) = Proofview.Goal.nf_enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in - let type_of = Tacmach.New.pf_type_of gl in + let type_of = Tacmach.New.pf_unsafe_type_of gl in let typ = type_of c in let _, ccl = splay_prod env sigma typ in if is_empty_type ccl then @@ -107,7 +107,7 @@ let contradiction_term (c,lbind as cl) = Proofview.tclZERO Not_found end begin function (e, info) -> match e with - | Not_found -> Proofview.tclZERO (Errors.UserError ("",Pp.str"Not a contradiction.")) + | Not_found -> Tacticals.New.tclZEROMSG (Pp.str"Not a contradiction.") | e -> Proofview.tclZERO ~info e end end diff --git a/tactics/eauto.ml4 b/tactics/eauto.ml4 index 27c3569d..ee7b94b0 100644 --- a/tactics/eauto.ml4 +++ b/tactics/eauto.ml4 @@ -33,7 +33,8 @@ DECLARE PLUGIN "eauto" let eauto_unif_flags = auto_flags_of_state full_transparent_state -let e_give_exact ?(flags=eauto_unif_flags) c gl = let t1 = (pf_type_of gl c) and t2 = pf_concl gl in +let e_give_exact ?(flags=eauto_unif_flags) c gl = + let t1 = (pf_unsafe_type_of gl c) and t2 = pf_concl gl in if occur_existential t1 || occur_existential t2 then tclTHEN (Proofview.V82.of_tactic (Clenvtac.unify ~flags t1)) (exact_no_check c) gl else Proofview.V82.of_tactic (exact_check c) gl @@ -94,7 +95,7 @@ let out_term = function | IsGlobRef gr -> fst (Universes.fresh_global_instance (Global.env ()) gr) let prolog_tac l n gl = - let l = List.map (fun x -> out_term (pf_apply (prepare_hint false) gl x)) l in + let l = List.map (fun x -> out_term (pf_apply (prepare_hint false (false,true)) gl x)) l in let n = match n with | ArgArg n -> n @@ -116,14 +117,17 @@ open Unification (***************************************************************************) let priority l = List.map snd (List.filter (fun (pr,_) -> Int.equal pr 0) l) - -let unify_e_resolve poly flags (c,clenv) gls = - let clenv', subst = if poly then Clenv.refresh_undefined_univs clenv - else clenv, Univ.empty_level_subst in - let clenv' = connect_clenv gls clenv' in - let clenv' = clenv_unique_resolver ~flags clenv' gls in - tclTHEN (Refiner.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd)) - (Proofview.V82.of_tactic (Tactics.Simple.eapply (Vars.subst_univs_level_constr subst c))) gls + +let unify_e_resolve poly flags (c,clenv) = + Proofview.Goal.nf_enter begin + fun gl -> + let clenv', c = connect_hint_clenv poly c clenv gl in + Proofview.V82.tactic + (fun gls -> + let clenv' = clenv_unique_resolver ~flags clenv' gls in + tclTHEN (Refiner.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd)) + (Proofview.V82.of_tactic (Tactics.Simple.eapply c)) gls) + end let hintmap_of hdc concl = match hdc with @@ -134,6 +138,7 @@ let hintmap_of hdc concl = (* FIXME: should be (Hint_db.map_eauto hdc concl db) *) let e_exact poly flags (c,clenv) = + let (c, _, _) = c in let clenv', subst = if poly then Clenv.refresh_undefined_univs clenv else clenv, Univ.empty_level_subst @@ -147,7 +152,7 @@ let rec e_trivial_fail_db db_list local_db goal = let d = pf_last_hyp g' in let hintl = make_resolve_hyp (pf_env g') (project g') d in (e_trivial_fail_db db_list - (Hint_db.add_list hintl local_db) g'))) :: + (Hint_db.add_list (pf_env g') (project g') hintl local_db) g'))) :: (List.map fst (e_trivial_resolve db_list local_db (pf_concl goal)) ) in tclFIRST (List.map tclCOMPLETE tacl) goal @@ -164,16 +169,16 @@ and e_my_find_search db_list local_db hdc concl = (b, let tac = function | Res_pf (term,cl) -> unify_resolve poly st (term,cl) - | ERes_pf (term,cl) -> Proofview.V82.tactic (unify_e_resolve poly st (term,cl)) + | ERes_pf (term,cl) -> unify_e_resolve poly st (term,cl) | Give_exact (c,cl) -> Proofview.V82.tactic (e_exact poly st (c,cl)) | Res_pf_THEN_trivial_fail (term,cl) -> - Proofview.V82.tactic (tclTHEN (unify_e_resolve poly st (term,cl)) + Proofview.V82.tactic (tclTHEN (Proofview.V82.of_tactic (unify_e_resolve poly st (term,cl))) (e_trivial_fail_db db_list local_db)) | Unfold_nth c -> Proofview.V82.tactic (reduce (Unfold [AllOccurrences,c]) onConcl) | Extern tacast -> conclPattern concl p tacast in - let tac = Proofview.V82.of_tactic (run_auto_tactic t tac) in - (tac, lazy (pr_autotactic t))) + let tac = Proofview.V82.of_tactic (run_hint t tac) in + (tac, lazy (pr_hint t))) in List.map tac_of_hint hintl @@ -200,7 +205,8 @@ type search_state = { last_tactic : std_ppcmds Lazy.t; dblist : hint_db list; localdb : hint_db list; - prev : prev_search_state + prev : prev_search_state; + local_lemmas : Evd.open_constr list; } and prev_search_state = (* for info eauto *) @@ -259,7 +265,7 @@ module SearchProblem = struct List.map (fun (res, cost, pp) -> { depth = s.depth; priority = cost; tacres = res; last_tactic = pp; dblist = s.dblist; localdb = List.tl s.localdb; - prev = ps}) l + prev = ps; local_lemmas = s.local_lemmas}) l in let intro_tac = let l = filter_tactics s.tacres [Proofview.V82.of_tactic Tactics.intro, (-1), lazy (str "intro")] in @@ -269,10 +275,12 @@ module SearchProblem = struct let hintl = make_resolve_hyp (pf_env g') (project g') (pf_last_hyp g') in - let ldb = Hint_db.add_list hintl (List.hd s.localdb) in + let ldb = Hint_db.add_list (pf_env g') (project g') + hintl (List.hd s.localdb) in { depth = s.depth; priority = cost; tacres = lgls; last_tactic = pp; dblist = s.dblist; - localdb = ldb :: List.tl s.localdb; prev = ps }) + localdb = ldb :: List.tl s.localdb; prev = ps; + local_lemmas = s.local_lemmas}) l in let rec_tacs = @@ -284,7 +292,8 @@ module SearchProblem = struct let nbgl' = List.length (sig_it lgls) in if nbgl' < nbgl then { depth = s.depth; priority = cost; tacres = lgls; last_tactic = pp; - prev = ps; dblist = s.dblist; localdb = List.tl s.localdb } + prev = ps; dblist = s.dblist; localdb = List.tl s.localdb; + local_lemmas = s.local_lemmas } else let newlocal = let hyps = pf_hyps g in @@ -292,12 +301,13 @@ module SearchProblem = struct let gls = {Evd.it = gl; sigma = lgls.Evd.sigma } in let hyps' = pf_hyps gls in if hyps' == hyps then List.hd s.localdb - else make_local_hint_db (pf_env gls) (project gls) ~ts:full_transparent_state true []) + else make_local_hint_db (pf_env gls) (project gls) ~ts:full_transparent_state true s.local_lemmas) (List.firstn ((nbgl'-nbgl) + 1) (sig_it lgls)) in { depth = pred s.depth; priority = cost; tacres = lgls; dblist = s.dblist; last_tactic = pp; prev = ps; - localdb = newlocal @ List.tl s.localdb }) + localdb = newlocal @ List.tl s.localdb; + local_lemmas = s.local_lemmas }) l in List.sort compare (assumption_tacs @ intro_tac @ rec_tacs) @@ -362,7 +372,7 @@ let pr_info dbg s = (** Eauto main code *) -let make_initial_state dbg n gl dblist localdb = +let make_initial_state dbg n gl dblist localdb lems = { depth = n; priority = 0; tacres = tclIDTAC gl; @@ -370,6 +380,7 @@ let make_initial_state dbg n gl dblist localdb = dblist = dblist; localdb = [localdb]; prev = if dbg == Info then Init else Unknown; + local_lemmas = lems; } let e_search_auto debug (in_depth,p) lems db_list gl = @@ -383,7 +394,7 @@ let e_search_auto debug (in_depth,p) lems db_list gl = in try pr_dbg_header d; - let s = tac (make_initial_state d p gl db_list local_db) in + let s = tac (make_initial_state d p gl db_list local_db lems) in pr_info d s; s.tacres with Not_found -> @@ -609,7 +620,7 @@ TACTIC EXTEND unify match table with | None -> let msg = str "Hint table " ++ str base ++ str " not found" in - Proofview.tclZERO (UserError ("", msg)) + Tacticals.New.tclZEROMSG msg | Some t -> let state = Hint_db.transparent_state t in unify ~state x y @@ -621,12 +632,7 @@ TACTIC EXTEND convert_concl_no_check | ["convert_concl_no_check" constr(x) ] -> [ convert_concl_no_check x DEFAULTcast ] END - -let pr_hints_path_atom prc _ _ a = - match a with - | PathAny -> str"." - | PathHints grs -> - pr_sequence Printer.pr_global grs +let pr_hints_path_atom _ _ _ = Hints.pp_hints_path_atom ARGUMENT EXTEND hints_path_atom TYPED AS hints_path_atom @@ -635,15 +641,7 @@ ARGUMENT EXTEND hints_path_atom | [ "*" ] -> [ PathAny ] END -let pr_hints_path prc prx pry c = - let rec aux = function - | PathAtom a -> pr_hints_path_atom prc prx pry a - | PathStar p -> str"(" ++ aux p ++ str")*" - | PathSeq (p, p') -> aux p ++ spc () ++ aux p' - | PathOr (p, p') -> str "(" ++ aux p ++ str"|" ++ aux p' ++ str")" - | PathEmpty -> str"ø" - | PathEpsilon -> str"ε" - in aux c +let pr_hints_path prc prx pry c = Hints.pp_hints_path c ARGUMENT EXTEND hints_path TYPED AS hints_path diff --git a/tactics/elim.ml b/tactics/elim.ml index 3cb4fa9c..4841d2c2 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -85,7 +85,7 @@ let up_to_delta = ref false (* true *) let general_decompose recognizer c = Proofview.Goal.enter begin fun gl -> - let type_of = pf_type_of gl in + let type_of = pf_unsafe_type_of gl in let typc = type_of c in tclTHENS (cut typc) [ tclTHEN (intro_using tmphyp_name) @@ -139,7 +139,7 @@ let induction_trailer abs_i abs_j bargs = (onLastHypId (fun id -> Proofview.Goal.nf_enter begin fun gl -> - let idty = pf_type_of gl (mkVar id) in + let idty = pf_unsafe_type_of gl (mkVar id) in let fvty = global_vars (pf_env gl) idty in let possible_bring_hyps = (List.tl (nLastDecls gl (abs_j - abs_i))) @ bargs.Tacticals.assums diff --git a/tactics/elimschemes.ml b/tactics/elimschemes.ml index 749e0d2b..8a6d93cf 100644 --- a/tactics/elimschemes.ml +++ b/tactics/elimschemes.ml @@ -21,7 +21,7 @@ open Ind_tables (* Induction/recursion schemes *) -let optimize_non_type_induction_scheme kind dep sort ind = +let optimize_non_type_induction_scheme kind dep sort _ ind = let env = Global.env () in let sigma = Evd.from_env env in if check_scheme kind ind then @@ -51,8 +51,8 @@ let optimize_non_type_induction_scheme kind dep sort ind = let u = Univ.UContext.instance ctx in let ctxset = Univ.ContextSet.of_context ctx in let ectx = Evd.evar_universe_context_of ctxset in - let sigma, c = build_induction_scheme env (Evd.from_env ~ctx:ectx env) (ind,u) dep sort in - (c, Evd.evar_universe_context sigma), Declareops.no_seff + let sigma, c = build_induction_scheme env (Evd.from_ctx ectx) (ind,u) dep sort in + (c, Evd.evar_universe_context sigma), Safe_typing.empty_private_constants let build_induction_scheme_in_type dep sort ind = let env = Global.env () in @@ -63,20 +63,20 @@ let build_induction_scheme_in_type dep sort ind = let u = Univ.UContext.instance ctx in let ctxset = Univ.ContextSet.of_context ctx in let ectx = Evd.evar_universe_context_of ctxset in - let sigma, c = build_induction_scheme env (Evd.from_env ~ctx:ectx env) (ind,u) dep sort in + let sigma, c = build_induction_scheme env (Evd.from_ctx ectx) (ind,u) dep sort in c, Evd.evar_universe_context sigma let rect_scheme_kind_from_type = declare_individual_scheme_object "_rect_nodep" - (fun x -> build_induction_scheme_in_type false InType x, Declareops.no_seff) + (fun _ x -> build_induction_scheme_in_type false InType x, Safe_typing.empty_private_constants) let rect_scheme_kind_from_prop = declare_individual_scheme_object "_rect" ~aux:"_rect_from_prop" - (fun x -> build_induction_scheme_in_type false InType x, Declareops.no_seff) + (fun _ x -> build_induction_scheme_in_type false InType x, Safe_typing.empty_private_constants) let rect_dep_scheme_kind_from_type = declare_individual_scheme_object "_rect" ~aux:"_rect_from_type" - (fun x -> build_induction_scheme_in_type true InType x, Declareops.no_seff) + (fun _ x -> build_induction_scheme_in_type true InType x, Safe_typing.empty_private_constants) let ind_scheme_kind_from_type = declare_individual_scheme_object "_ind_nodep" @@ -109,24 +109,24 @@ let build_case_analysis_scheme_in_type dep sort ind = let case_scheme_kind_from_type = declare_individual_scheme_object "_case_nodep" - (fun x -> build_case_analysis_scheme_in_type false InType x, Declareops.no_seff) + (fun _ x -> build_case_analysis_scheme_in_type false InType x, Safe_typing.empty_private_constants) let case_scheme_kind_from_prop = declare_individual_scheme_object "_case" ~aux:"_case_from_prop" - (fun x -> build_case_analysis_scheme_in_type false InType x, Declareops.no_seff) + (fun _ x -> build_case_analysis_scheme_in_type false InType x, Safe_typing.empty_private_constants) let case_dep_scheme_kind_from_type = declare_individual_scheme_object "_case" ~aux:"_case_from_type" - (fun x -> build_case_analysis_scheme_in_type true InType x, Declareops.no_seff) + (fun _ x -> build_case_analysis_scheme_in_type true InType x, Safe_typing.empty_private_constants) let case_dep_scheme_kind_from_type_in_prop = declare_individual_scheme_object "_casep_dep" - (fun x -> build_case_analysis_scheme_in_type true InProp x, Declareops.no_seff) + (fun _ x -> build_case_analysis_scheme_in_type true InProp x, Safe_typing.empty_private_constants) let case_dep_scheme_kind_from_prop = declare_individual_scheme_object "_case_dep" - (fun x -> build_case_analysis_scheme_in_type true InType x, Declareops.no_seff) + (fun _ x -> build_case_analysis_scheme_in_type true InType x, Safe_typing.empty_private_constants) let case_dep_scheme_kind_from_prop_in_prop = declare_individual_scheme_object "_casep" - (fun x -> build_case_analysis_scheme_in_type true InProp x, Declareops.no_seff) + (fun _ x -> build_case_analysis_scheme_in_type true InProp x, Safe_typing.empty_private_constants) diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index c2cd9e47..4fb76bb8 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -104,22 +104,29 @@ let mkGenDecideEqGoal rectype g = (mkDecideEqGoal true (build_coq_sumbool ()) rectype (mkVar xname) (mkVar yname)))) +let rec rewrite_and_clear hyps = match hyps with +| [] -> Proofview.tclUNIT () +| id :: hyps -> + tclTHENLIST [ + Equality.rewriteLR (mkVar id); + clear [id]; + rewrite_and_clear hyps; + ] + let eqCase tac = - (tclTHEN intro - (tclTHEN (onLastHyp Equality.rewriteLR) - (tclTHEN clear_last - tac))) + tclTHEN intro (onLastHypId tac) -let diseqCase eqonleft = +let diseqCase hyps eqonleft = let diseq = Id.of_string "diseq" in let absurd = Id.of_string "absurd" in (tclTHEN (intro_using diseq) (tclTHEN (choose_noteq eqonleft) + (tclTHEN (rewrite_and_clear (List.rev hyps)) (tclTHEN (Proofview.V82.tactic red_in_concl) (tclTHEN (intro_using absurd) (tclTHEN (Simple.apply (mkVar diseq)) (tclTHEN (Extratactics.injHyp absurd) - (full_trivial []))))))) + (full_trivial [])))))))) open Proofview.Notations @@ -131,15 +138,24 @@ let match_eqdec c = (* /spiwack *) -let solveArg eqonleft op a1 a2 tac = +let rec solveArg hyps eqonleft op largs rargs = match largs, rargs with +| [], [] -> + tclTHENLIST [ + choose_eq eqonleft; + rewrite_and_clear (List.rev hyps); + intros_reflexivity; + ] +| a1 :: largs, a2 :: rargs -> Proofview.Goal.enter begin fun gl -> - let rectype = pf_type_of gl a1 in + let rectype = pf_unsafe_type_of gl a1 in let decide = mkDecideEqGoal eqonleft op rectype a1 a2 in + let tac hyp = solveArg (hyp :: hyps) eqonleft op largs rargs in let subtacs = - if eqonleft then [eqCase tac;diseqCase eqonleft;default_auto] - else [diseqCase eqonleft;eqCase tac;default_auto] in + if eqonleft then [eqCase tac;diseqCase hyps eqonleft;default_auto] + else [diseqCase hyps eqonleft;eqCase tac;default_auto] in (tclTHENS (elim_type decide) subtacs) end +| _ -> invalid_arg "List.fold_right2" let solveEqBranch rectype = Proofview.tclORELSE @@ -152,13 +168,11 @@ let solveEqBranch rectype = let getargs l = List.skipn nparams (snd (decompose_app l)) in let rargs = getargs rhs and largs = getargs lhs in - List.fold_right2 - (solveArg eqonleft op) largs rargs - (tclTHEN (choose_eq eqonleft) intros_reflexivity) + solveArg [] eqonleft op largs rargs end end begin function (e, info) -> match e with - | PatternMatchingFailure -> Proofview.tclZERO (UserError ("",Pp.str"Unexpected conclusion!")) + | PatternMatchingFailure -> Tacticals.New.tclZEROMSG (Pp.str"Unexpected conclusion!") | e -> Proofview.tclZERO ~info e end @@ -186,7 +200,7 @@ let decideGralEquality = end begin function (e, info) -> match e with | PatternMatchingFailure -> - Proofview.tclZERO (UserError ("", Pp.str"The goal must be of the form {x<>y}+{x=y} or {x=y}+{x<>y}.")) + Tacticals.New.tclZEROMSG (Pp.str"The goal must be of the form {x<>y}+{x=y} or {x=y}+{x<>y}.") | e -> Proofview.tclZERO ~info e end @@ -203,7 +217,7 @@ let decideEquality rectype = let compare c1 c2 = Proofview.Goal.enter begin fun gl -> - let rectype = pf_type_of gl c1 in + let rectype = pf_unsafe_type_of gl c1 in let decide = mkDecideEqGoal true (build_coq_sumbool ()) rectype c1 c2 in (tclTHENS (cut decide) [(tclTHEN intro diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index 8643fe10..b2603315 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -191,9 +191,9 @@ let build_sym_scheme env ind = let sym_scheme_kind = declare_individual_scheme_object "_sym_internal" - (fun ind -> + (fun _ ind -> let c, ctx = build_sym_scheme (Global.env() (* side-effect! *)) ind in - (c, ctx), Declareops.no_seff) + (c, ctx), Safe_typing.empty_private_constants) (**********************************************************************) (* Build the involutivity of symmetry for an inductive type *) @@ -262,7 +262,7 @@ let build_sym_involutive_scheme env ind = let sym_involutive_scheme_kind = declare_individual_scheme_object "_sym_involutive" - (fun ind -> + (fun _ ind -> build_sym_involutive_scheme (Global.env() (* side-effect! *)) ind) (**********************************************************************) @@ -412,7 +412,8 @@ let build_l2r_rew_scheme dep env ind kind = [|main_body|]) else main_body)))))) - in (c, Evd.evar_universe_context_of ctx), Declareops.union_side_effects eff' eff + in (c, Evd.evar_universe_context_of ctx), + Safe_typing.concat_private eff' eff (**********************************************************************) (* Build the left-to-right rewriting lemma for hypotheses associated *) @@ -650,7 +651,7 @@ let build_r2l_forward_rew_scheme = build_r2l_forward_rew_scheme (**********************************************************************) let rew_l2r_dep_scheme_kind = declare_individual_scheme_object "_rew_r_dep" - (fun ind -> build_l2r_rew_scheme true (Global.env()) ind InType) + (fun _ ind -> build_l2r_rew_scheme true (Global.env()) ind InType) (**********************************************************************) (* Dependent rewrite from right-to-left in conclusion *) @@ -660,7 +661,7 @@ let rew_l2r_dep_scheme_kind = (**********************************************************************) let rew_r2l_dep_scheme_kind = declare_individual_scheme_object "_rew_dep" - (fun ind -> build_r2l_rew_scheme true (Global.env()) ind InType,Declareops.no_seff) + (fun _ ind -> build_r2l_rew_scheme true (Global.env()) ind InType,Safe_typing.empty_private_constants) (**********************************************************************) (* Dependent rewrite from right-to-left in hypotheses *) @@ -670,7 +671,7 @@ let rew_r2l_dep_scheme_kind = (**********************************************************************) let rew_r2l_forward_dep_scheme_kind = declare_individual_scheme_object "_rew_fwd_dep" - (fun ind -> build_r2l_forward_rew_scheme true (Global.env()) ind InType,Declareops.no_seff) + (fun _ ind -> build_r2l_forward_rew_scheme true (Global.env()) ind InType,Safe_typing.empty_private_constants) (**********************************************************************) (* Dependent rewrite from left-to-right in hypotheses *) @@ -680,7 +681,7 @@ let rew_r2l_forward_dep_scheme_kind = (**********************************************************************) let rew_l2r_forward_dep_scheme_kind = declare_individual_scheme_object "_rew_fwd_r_dep" - (fun ind -> build_l2r_forward_rew_scheme true (Global.env()) ind InType,Declareops.no_seff) + (fun _ ind -> build_l2r_forward_rew_scheme true (Global.env()) ind InType,Safe_typing.empty_private_constants) (**********************************************************************) (* Non-dependent rewrite from either left-to-right in conclusion or *) @@ -693,8 +694,8 @@ let rew_l2r_forward_dep_scheme_kind = (**********************************************************************) let rew_l2r_scheme_kind = declare_individual_scheme_object "_rew_r" - (fun ind -> fix_r2l_forward_rew_scheme - (build_r2l_forward_rew_scheme false (Global.env()) ind InType), Declareops.no_seff) + (fun _ ind -> fix_r2l_forward_rew_scheme + (build_r2l_forward_rew_scheme false (Global.env()) ind InType), Safe_typing.empty_private_constants) (**********************************************************************) (* Non-dependent rewrite from either right-to-left in conclusion or *) @@ -704,7 +705,7 @@ let rew_l2r_scheme_kind = (**********************************************************************) let rew_r2l_scheme_kind = declare_individual_scheme_object "_rew" - (fun ind -> build_r2l_rew_scheme false (Global.env()) ind InType, Declareops.no_seff) + (fun _ ind -> build_r2l_rew_scheme false (Global.env()) ind InType, Safe_typing.empty_private_constants) (* End of rewriting schemes *) @@ -780,6 +781,6 @@ let build_congr env (eq,refl,ctx) ind = in c, Evd.evar_universe_context_of ctx let congr_scheme_kind = declare_individual_scheme_object "_congr" - (fun ind -> + (fun _ ind -> (* May fail if equality is not defined *) - build_congr (Global.env()) (get_coq_eq Univ.ContextSet.empty) ind, Declareops.no_seff) + build_congr (Global.env()) (get_coq_eq Univ.ContextSet.empty) ind, Safe_typing.empty_private_constants) diff --git a/tactics/eqschemes.mli b/tactics/eqschemes.mli index 6bb84808..3fe33073 100644 --- a/tactics/eqschemes.mli +++ b/tactics/eqschemes.mli @@ -25,7 +25,7 @@ val rew_r2l_scheme_kind : individual scheme_kind val build_r2l_rew_scheme : bool -> env -> inductive -> sorts_family -> constr Evd.in_evar_universe_context val build_l2r_rew_scheme : bool -> env -> inductive -> sorts_family -> - constr Evd.in_evar_universe_context * Declareops.side_effects + constr Evd.in_evar_universe_context * Safe_typing.private_constants val build_r2l_forward_rew_scheme : bool -> env -> inductive -> sorts_family -> constr Evd.in_evar_universe_context val build_l2r_forward_rew_scheme : @@ -37,7 +37,7 @@ val build_sym_scheme : env -> inductive -> constr Evd.in_evar_universe_context val sym_scheme_kind : individual scheme_kind val build_sym_involutive_scheme : env -> inductive -> - constr Evd.in_evar_universe_context * Declareops.side_effects + constr Evd.in_evar_universe_context * Safe_typing.private_constants val sym_involutive_scheme_kind : individual scheme_kind (** Builds a congruence scheme for an equality type *) diff --git a/tactics/equality.ml b/tactics/equality.ml index 7ab8d0c3..674c85af 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -88,7 +88,7 @@ type freeze_evars_flag = bool (* true = don't instantiate existing evars *) type orientation = bool type conditions = - | Naive (* Only try the first occurence of the lemma (default) *) + | Naive (* Only try the first occurrence of the lemma (default) *) | FirstSolved (* Use the first match whose side-conditions are solved *) | AllMatches (* Rewrite all matches whose side-conditions are solved *) @@ -165,10 +165,10 @@ let instantiate_lemma_all frzevars gl c ty l l2r concl = in List.map try_occ occs let instantiate_lemma gl c ty l l2r concl = - let ct = pf_type_of gl c in - let t = try snd (pf_reduce_to_quantified_ind gl ct) with UserError _ -> ct in - let eqclause = pf_apply Clenv.make_clenv_binding gl (c,t) l in - [eqclause] + let sigma, ct = pf_type_of gl c in + let t = try snd (reduce_to_quantified_ind (pf_env gl) sigma ct) with UserError _ -> ct in + let eqclause = Clenv.make_clenv_binding (pf_env gl) sigma (c,t) l in + [eqclause] let rewrite_conv_closed_core_unif_flags = { modulo_conv_on_closed_terms = Some full_transparent_state; @@ -306,8 +306,8 @@ let find_elim hdcncl lft2rgt dep cls ot gl = let _ = Global.lookup_constant c1' in c1' with Not_found -> - let rwr_thm = Label.to_string l' in - error ("Cannot find rewrite principle "^rwr_thm^".") + errorlabstrm "Equality.find_elim" + (str "Cannot find rewrite principle " ++ pr_label l' ++ str ".") end | _ -> destConstRef pr1 end @@ -317,7 +317,7 @@ let find_elim hdcncl lft2rgt dep cls ot gl = assert false in let sigma, elim = Evd.fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) in - sigma, elim, Declareops.no_seff + sigma, elim, Safe_typing.empty_private_constants else let scheme_name = match dep, lft2rgt, inccl with (* Non dependent case *) @@ -335,7 +335,9 @@ let find_elim hdcncl lft2rgt dep cls ot gl = | Ind (ind,u) -> let c, eff = find_scheme scheme_name ind in (* MS: cannot use pf_constr_of_global as the eliminator might be generated by side-effect *) - let sigma, elim = Evd.fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) in + let sigma, elim = + Evd.fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) + in sigma, elim, eff | _ -> assert false @@ -454,7 +456,7 @@ let general_rewrite_clause l2r with_evars ?tac c cl = (* Otherwise, if we are told to rewrite in all hypothesis via the syntax "* |-", we fail iff all the different rewrites fail *) let rec do_hyps_atleastonce = function - | [] -> Proofview.tclZERO (Errors.UserError ("",Pp.str"Nothing to rewrite.")) + | [] -> tclZEROMSG (Pp.str"Nothing to rewrite.") | id :: l -> tclIFTHENTRYELSEMUST (general_rewrite_ebindings_in l2r AllOccurrences false true ?tac id c with_evars) @@ -540,7 +542,7 @@ let replace_core clause l2r eq = if check_setoid clause then init_setoid (); tclTHENFIRST - (assert_as false None eq) + (assert_as false None None eq) (onLastHypId (fun id -> tclTHEN (tclTRY (general_rewrite_clause l2r false (mkVar id,NoBindings) clause)) @@ -874,7 +876,7 @@ let gen_absurdity id = then simplest_elim (mkVar id) else - Proofview.tclZERO (Errors.UserError ("Equality.gen_absurdity" , str "Not the negation of an equality.")) + tclZEROMSG (str "Not the negation of an equality.") end (* Precondition: eq is leibniz equality @@ -899,7 +901,7 @@ let discrimination_pf env sigma e (t,t1,t2) discriminator lbeq = let i = build_coq_I () in let absurd_term = build_coq_False () in let eq_elim, eff = ind_scheme_of_eq lbeq in - let sigma, eq_elim = Evd.fresh_global env sigma eq_elim in + let sigma, eq_elim = Evd.fresh_global (Global.env ()) sigma eq_elim in sigma, (applist (eq_elim, [t;t1;mkNamedLambda e t discriminator;i;t2]), absurd_term), eff @@ -936,7 +938,7 @@ let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause = let concl = Proofview.Goal.concl gl in match find_positions env sigma t1 t2 with | Inr _ -> - Proofview.tclZERO (Errors.UserError ("discr" , str"Not a discriminable equality.")) + tclZEROMSG (str"Not a discriminable equality.") | Inl (cpath, (_,dirn), _) -> let sort = pf_apply get_type_of gl concl in discr_positions env sigma u eq_clause cpath dirn sort @@ -944,7 +946,7 @@ let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause = let onEquality with_evars tac (c,lbindc) = Proofview.Goal.nf_enter begin fun gl -> - let type_of = pf_type_of gl in + let type_of = pf_unsafe_type_of gl in let reduce_to_quantified_ind = pf_apply Tacred.reduce_to_quantified_ind gl in let t = type_of c in let t' = try snd (reduce_to_quantified_ind t) with UserError _ -> t in @@ -968,7 +970,7 @@ let onNegatedEquality with_evars tac = (onLastHypId (fun id -> onEquality with_evars tac (mkVar id,NoBindings))) | _ -> - Proofview.tclZERO (Errors.UserError ("" , str "Not a negated primitive equality.")) + tclZEROMSG (str "Not a negated primitive equality.") end let discrSimpleClause with_evars = function @@ -1019,7 +1021,7 @@ let find_sigma_data env s = build_sigma_type () let make_tuple env sigma (rterm,rty) lind = assert (dependent (mkRel lind) rty); let sigdata = find_sigma_data env (get_sort_of env sigma rty) in - let sigma, a = e_type_of ~refresh:true env sigma (mkRel lind) in + let sigma, a = type_of ~refresh:true env sigma (mkRel lind) in let (na,_,_) = lookup_rel lind env in (* We move [lind] to [1] and lift other rels > [lind] by 1 *) let rty = lift (1-lind) (liftn lind (lind+1) rty) in @@ -1053,7 +1055,7 @@ let minimal_free_rels_rec env sigma = let rec minimalrec_free_rels_rec prev_rels (c,cty) = let (cty,direct_rels) = minimal_free_rels env sigma (c,cty) in let combined_rels = Int.Set.union prev_rels direct_rels in - let folder rels i = snd (minimalrec_free_rels_rec rels (c, type_of env sigma (mkRel i))) + let folder rels i = snd (minimalrec_free_rels_rec rels (c, unsafe_type_of env sigma (mkRel i))) in (cty, List.fold_left folder combined_rels (Int.Set.elements (Int.Set.diff direct_rels prev_rels))) in minimalrec_free_rels_rec Int.Set.empty @@ -1099,7 +1101,7 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = let rec sigrec_clausal_form siglen p_i = if Int.equal siglen 0 then (* is the default value typable with the expected type *) - let dflt_typ = type_of env sigma dflt in + let dflt_typ = unsafe_type_of env sigma dflt in try let () = evdref := Evarconv.the_conv_x_leq env dflt_typ p_i !evdref in let () = evdref := Evarconv.consider_remaining_unif_problems env !evdref in @@ -1118,13 +1120,20 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = (destEvar ev) with | Some w -> - let w_type = type_of env sigma w in + let w_type = unsafe_type_of env sigma w in if Evarconv.e_cumul env evdref w_type a then let exist_term = Evarutil.evd_comb1 (Evd.fresh_global env) evdref sigdata.intro in applist(exist_term,[a;p_i_minus_1;w;tuple_tail]) else error "Cannot solve a unification problem." - | None -> anomaly (Pp.str "Not enough components to build the dependent tuple") + | None -> + (* This at least happens if what has been detected as a + dependency is not one; use an evasive error message; + even if the problem is upwards: unification should be + tried in the first place in make_iterated_tuple instead + of approximatively computing the free rels; then + unsolved evars would mean not binding rel *) + error "Cannot solve a unification problem." in let scf = sigrec_clausal_form siglen ty in !evdref, Evarutil.nf_evar !evdref scf @@ -1200,7 +1209,7 @@ let make_iterated_tuple env sigma dflt (z,zty) = sigma, (tuple,tuplety,dfltval) let rec build_injrec env sigma dflt c = function - | [] -> make_iterated_tuple env sigma dflt (c,type_of env sigma c) + | [] -> make_iterated_tuple env sigma dflt (c,unsafe_type_of env sigma c) | ((sp,cnum),argnum)::l -> try let (cnum_nlams,cnum_env,kont) = descend_then env sigma c cnum in @@ -1253,7 +1262,7 @@ let inject_if_homogenous_dependent_pair ty = if not (Ind_tables.check_scheme (!eq_dec_scheme_kind_name()) (fst ind) && pf_apply is_conv gl ar1.(2) ar2.(2)) then raise Exit; Coqlib.check_required_library ["Coq";"Logic";"Eqdep_dec"]; - let new_eq_args = [|pf_type_of gl ar1.(3);ar1.(3);ar2.(3)|] in + let new_eq_args = [|pf_unsafe_type_of gl ar1.(3);ar1.(3);ar2.(3)|] in let inj2 = Coqlib.coq_constant "inj_pair2_eq_dec is missing" ["Logic";"Eqdep_dec"] "inj_pair2_eq_dec" in let c, eff = find_scheme (!eq_dec_scheme_kind_name()) (Univ.out_punivs ind) in @@ -1293,7 +1302,7 @@ let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = let injfun = mkNamedLambda e t injbody in let sigma,congr = Evd.fresh_global env sigma eq.congr in let pf = applist(congr,[t;resty;injfun;t1;t2]) in - let sigma, pf_typ = Typing.e_type_of env sigma pf in + let sigma, pf_typ = Typing.type_of env sigma pf in let inj_clause = apply_on_clause (pf,pf_typ) eq_clause in let pf = Clenvtac.clenv_value_cast_meta inj_clause in let ty = simplify_args env sigma (clenv_type inj_clause) in @@ -1303,7 +1312,7 @@ let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = in let injectors = List.map_filter filter posns in if List.is_empty injectors then - Proofview.tclZERO (Errors.UserError ("Equality.inj" , str "Failed to decompose the equality.")) + tclZEROMSG (str "Failed to decompose the equality.") else Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (Proofview.tclBIND @@ -1319,12 +1328,12 @@ let injEqThen tac l2r (eq,_,(t,t1,t2) as u) eq_clause = let env = eq_clause.env in match find_positions env sigma t1 t2 with | Inl _ -> - Proofview.tclZERO (Errors.UserError ("Inj",strbrk"This equality is discriminable. You should use the discriminate tactic to solve the goal.")) + tclZEROMSG (strbrk"This equality is discriminable. You should use the discriminate tactic to solve the goal.") | Inr [] -> let suggestion = if !injection_on_proofs then "" else " You can try to use option Set Injection On Proofs." in - Proofview.tclZERO (Errors.UserError ("Equality.inj",strbrk("No information can be deduced from this equality and the injectivity of constructors. This may be because the terms are convertible, or due to pattern matching restrictions in the sort Prop." ^ suggestion))) + tclZEROMSG (strbrk("No information can be deduced from this equality and the injectivity of constructors. This may be because the terms are convertible, or due to pattern matching restrictions in the sort Prop." ^ suggestion)) | Inr [([],_,_)] when Flags.version_strictly_greater Flags.V8_3 -> - Proofview.tclZERO (Errors.UserError ("Equality.inj" , str"Nothing to inject.")) + tclZEROMSG (str"Nothing to inject.") | Inr posns -> inject_at_positions env sigma l2r u eq_clause posns (tac (clenv_value eq_clause)) @@ -1460,8 +1469,8 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b = (* Simulate now the normalisation treatment made by Logic.mk_refgoals *) let expected_goal = nf_betaiota sigma expected_goal in (* Retype to get universes right *) - let sigma, expected_goal_ty = Typing.e_type_of env sigma expected_goal in - let sigma, _ = Typing.e_type_of env sigma body in + let sigma, expected_goal_ty = Typing.type_of env sigma expected_goal in + let sigma, _ = Typing.type_of env sigma body in sigma,body,expected_goal (* Like "replace" but decompose dependent equalities *) @@ -1575,7 +1584,7 @@ let restrict_to_eq_and_identity eq = (* compatibility *) exception FoundHyp of (Id.t * constr * bool) -(* tests whether hyp [c] is [x = t] or [t = x], [x] not occuring in [t] *) +(* tests whether hyp [c] is [x = t] or [t = x], [x] not occurring in [t] *) let is_eq_x gl x (id,_,c) = try let c = pf_nf_evar gl c in @@ -1589,10 +1598,10 @@ let is_eq_x gl x (id,_,c) = erase hyp and x; proceed by generalizing all dep hyps *) let subst_one dep_proof_ok x (hyp,rhs,dir) = - Proofview.Goal.nf_enter begin fun gl -> + Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in - let hyps = Proofview.Goal.hyps gl in - let concl = Proofview.Goal.concl gl in + let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in + let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in (* The set of hypotheses using x *) let dephyps = List.rev (snd (List.fold_right (fun (id,b,_ as dcl) (deps,allhyps) -> @@ -1662,7 +1671,70 @@ let default_subst_tactic_flags () = else { only_leibniz = true; rewrite_dependent_proof = false } +let regular_subst_tactic = ref false + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "more regular behavior of tactic subst"; + optkey = ["Regular";"Subst";"Tactic"]; + optread = (fun () -> !regular_subst_tactic); + optwrite = (:=) regular_subst_tactic } + let subst_all ?(flags=default_subst_tactic_flags ()) () = + + if !regular_subst_tactic then + + (* First step: find hypotheses to treat in linear time *) + let find_equations gl = + let gl = Proofview.Goal.assume gl in + let env = Proofview.Goal.env gl in + let find_eq_data_decompose = find_eq_data_decompose gl in + let test (hyp,_,c) = + try + let lbeq,u,(_,x,y) = find_eq_data_decompose c in + let eq = Universes.constr_of_global_univ (lbeq.eq,u) in + if flags.only_leibniz then restrict_to_eq_and_identity eq; + match kind_of_term x, kind_of_term y with + | Var z, _ | _, Var z when not (is_evaluable env (EvalVarRef z)) -> + Some hyp + | _ -> + None + with Constr_matching.PatternMatchingFailure -> None + in + let hyps = Proofview.Goal.hyps gl in + List.rev (List.map_filter test hyps) + in + + (* Second step: treat equations *) + let process hyp = + Proofview.Goal.enter begin fun gl -> + let gl = Proofview.Goal.assume gl in + let find_eq_data_decompose = find_eq_data_decompose gl in + let (_,_,c) = pf_get_hyp hyp gl in + let _,_,(_,x,y) = find_eq_data_decompose c in + (* J.F.: added to prevent failure on goal containing x=x as an hyp *) + if Term.eq_constr x y then Proofview.tclUNIT () else + match kind_of_term x, kind_of_term y with + | Var x', _ when not (occur_term x y) -> + subst_one flags.rewrite_dependent_proof x' (hyp,y,true) + | _, Var y' when not (occur_term y x) -> + subst_one flags.rewrite_dependent_proof y' (hyp,x,false) + | _ -> + Proofview.tclUNIT () + end + in + Proofview.Goal.nf_enter begin fun gl -> + let ids = find_equations gl in + tclMAP process ids + end + + else + +(* Old implementation, not able to manage configurations like a=b, a=t, + or situations like "a = S b, b = S a", or also accidentally unfolding + let-ins *) Proofview.Goal.nf_enter begin fun gl -> let find_eq_data_decompose = find_eq_data_decompose gl in let test (_,c) = @@ -1674,8 +1746,7 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = if Term.eq_constr x y then failwith "caught"; match kind_of_term x with Var x -> x | _ -> match kind_of_term y with Var y -> y | _ -> failwith "caught" - with Constr_matching.PatternMatchingFailure -> failwith "caught" - in + with Constr_matching.PatternMatchingFailure -> failwith "caught" in let test p = try Some (test p) with Failure _ -> None in let hyps = pf_hyps_types gl in let ids = List.map_filter test hyps in diff --git a/tactics/equality.mli b/tactics/equality.mli index 3e13ee57..840ede7d 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -23,7 +23,7 @@ type freeze_evars_flag = bool (* true = don't instantiate existing evars *) type orientation = bool type conditions = - | Naive (* Only try the first occurence of the lemma (default) *) + | Naive (* Only try the first occurrence of the lemma (default) *) | FirstSolved (* Use the first match whose side-conditions are solved *) | AllMatches (* Rewrite all matches whose side-conditions are solved *) diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4 index 891e2dba..cab74968 100644 --- a/tactics/extratactics.ml4 +++ b/tactics/extratactics.ml4 @@ -262,16 +262,15 @@ TACTIC EXTEND rewrite_star (* Hint Rewrite *) let add_rewrite_hint bases ort t lcsr = - let env = Global.env() and sigma = Evd.empty in + let env = Global.env() in + let sigma = Evd.from_env env in let poly = Flags.is_universe_polymorphism () in let f ce = let c, ctx = Constrintern.interp_constr env sigma ce in let ctx = - if poly then - Evd.evar_universe_context_set ctx - else - let cstrs = Evd.evar_universe_context_constraints ctx in - (Global.add_constraints cstrs; Univ.ContextSet.empty) + let ctx = Evd.evar_universe_context_set Univ.UContext.empty ctx in + if poly then ctx + else (Global.push_context_set false ctx; Univ.ContextSet.empty) in Constrexpr_ops.constr_loc ce, (c, ctx), ort, t in let eqs = List.map f lcsr in @@ -320,7 +319,7 @@ let project_hint pri l2r r = Nameops.add_suffix (Nametab.basename_of_global gr) ("_proj_" ^ (if l2r then "l2r" else "r2l")) in let ctx = Evd.universe_context_set sigma in - let c = Declare.declare_definition ~internal:Declare.KernelSilent id (c,ctx) in + let c = Declare.declare_definition ~internal:Declare.InternalTacticRequest id (c,ctx) in (pri,false,true,Hints.PathAny, Hints.IsGlobRef (Globnames.ConstRef c)) let add_hints_iff l2r lc n bl = @@ -490,7 +489,9 @@ let inTransitivity : bool * constr -> obj = (* Main entry points *) let add_transitivity_lemma left lem = - let lem',ctx (*FIXME*) = Constrintern.interp_constr (Global.env ()) Evd.empty lem in + let env = Global.env () in + let sigma = Evd.from_env env in + let lem',ctx (*FIXME*) = Constrintern.interp_constr env sigma lem in add_anonymous_leaf (inTransitivity (left,lem')) (* Vernacular syntax *) @@ -704,7 +705,7 @@ let refl_equal = call it before it is defined. *) let mkCaseEq a : unit Proofview.tactic = Proofview.Goal.nf_enter begin fun gl -> - let type_of_a = Tacmach.New.of_old (fun g -> Tacmach.pf_type_of g a) gl in + let type_of_a = Tacmach.New.of_old (fun g -> Tacmach.pf_unsafe_type_of g a) gl in Tacticals.New.tclTHENLIST [Proofview.V82.tactic (Tactics.Simple.generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])]); Proofview.Goal.nf_enter begin fun gl -> @@ -750,12 +751,12 @@ let rec find_a_destructable_match t = let destauto t = try find_a_destructable_match t; - Proofview.tclZERO (UserError ("", str"No destructable match found")) + Tacticals.New.tclZEROMSG (str "No destructable match found") with Found tac -> tac let destauto_in id = Proofview.Goal.nf_enter begin fun gl -> - let ctype = Tacmach.New.of_old (fun g -> Tacmach.pf_type_of g (mkVar id)) gl in + let ctype = Tacmach.New.of_old (fun g -> Tacmach.pf_unsafe_type_of g (mkVar id)) gl in (* Pp.msgnl (Printer.pr_lconstr (mkVar id)); *) (* Pp.msgnl (Printer.pr_lconstr (ctype)); *) destauto ctype @@ -772,7 +773,7 @@ END let eq_constr x y = Proofview.Goal.enter (fun gl -> let evd = Proofview.Goal.sigma gl in - if Evd.eq_constr_univs_test evd x y then Proofview.tclUNIT () + if Evarutil.eq_constr_univs_test evd evd x y then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "Not equal")) TACTIC EXTEND constr_eq @@ -966,7 +967,7 @@ let guard tst = Proofview.tclUNIT () else let msg = Pp.(str"Condition not satisfied:"++ws 1++(pr_itest tst)) in - Proofview.tclZERO (Errors.UserError("guard",msg)) + Tacticals.New.tclZEROMSG msg TACTIC EXTEND guard diff --git a/tactics/hints.ml b/tactics/hints.ml index 55d62e15..5630d20b 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -68,7 +68,7 @@ let decompose_app_bound t = (* The Type of Constructions Autotactic Hints *) (************************************************************************) -type 'a auto_tactic_ast = +type 'a hint_ast = | Res_pf of 'a (* Hint Apply *) | ERes_pf of 'a (* Hint EApply *) | Give_exact of 'a @@ -92,23 +92,66 @@ type hint_term = | IsGlobRef of global_reference | IsConstr of constr * Univ.universe_context_set -type 'a auto_tactic = 'a auto_tactic_ast +type 'a with_uid = { + obj : 'a; + uid : KerName.t; +} + +type raw_hint = constr * types * Univ.universe_context_set -type 'a gen_auto_tactic = { +type hint = (raw_hint * clausenv) hint_ast with_uid + +type 'a with_metadata = { pri : int; (* A number lower is higher priority *) poly : polymorphic; (** Is the hint polymorpic and hence should be refreshed at each application *) pat : constr_pattern option; (* A pattern for the concl of the Goal *) name : hints_path_atom; (* A potential name to refer to the hint *) - code : 'a (* the tactic to apply when the concl matches pat *) + code : 'a; (* the tactic to apply when the concl matches pat *) } -type pri_auto_tactic = (constr * clausenv) auto_tactic gen_auto_tactic +type full_hint = hint with_metadata type hint_entry = global_reference option * - (constr * types * Univ.universe_context_set) auto_tactic_ast gen_auto_tactic - -let run_auto_tactic tac k = k tac -let repr_auto_tactic tac = tac + raw_hint hint_ast with_uid with_metadata + +type import_level = [ `LAX | `WARN | `STRICT ] + +let warn_hint : import_level ref = ref `LAX +let read_warn_hint () = match !warn_hint with +| `LAX -> "Lax" +| `WARN -> "Warn" +| `STRICT -> "Strict" + +let write_warn_hint = function +| "Lax" -> warn_hint := `LAX +| "Warn" -> warn_hint := `WARN +| "Strict" -> warn_hint := `STRICT +| _ -> error "Only the following flags are accepted: Lax, Warn, Strict." + +let _ = + Goptions.declare_string_option + { Goptions.optsync = true; + Goptions.optdepr = false; + Goptions.optname = "behavior of non-imported hints"; + Goptions.optkey = ["Loose"; "Hint"; "Behavior"]; + Goptions.optread = read_warn_hint; + Goptions.optwrite = write_warn_hint; + } + +let fresh_key = + let id = Summary.ref ~name:"HINT-COUNTER" 0 in + fun () -> + let cur = incr id; !id in + let lbl = Id.of_string ("_" ^ string_of_int cur) in + let kn = Lib.make_kn lbl in + let (mp, dir, _) = KerName.repr kn in + (** We embed the full path of the kernel name in the label so that the + identifier should be unique. This ensures that including two modules + together won't confuse the corresponding labels. *) + let lbl = Id.of_string_soft (Printf.sprintf "%s#%s#%i" + (ModPath.to_string mp) (DirPath.to_string dir) cur) + in + KerName.make mp dir (Label.of_id lbl) let eq_hints_path_atom p1 p2 = match p1, p2 with | PathHints gr1, PathHints gr2 -> List.equal eq_gr gr1 gr2 @@ -125,7 +168,7 @@ let eq_auto_tactic t1 t2 = match t1, t2 with | (Res_pf _ | ERes_pf _ | Give_exact _ | Res_pf_THEN_trivial_fail _ | Unfold_nth _ | Extern _), _ -> false -let eq_gen_auto_tactic t1 t2 = +let eq_hint_metadata t1 t2 = Int.equal t1.pri t2.pri && Option.equal constr_pattern_eq t1.pat t2.pat && eq_hints_path_atom t1.name t2.name && @@ -153,7 +196,7 @@ let pri_order t1 t2 = pri_order_int t1 t2 <= 0 - un discrimination net borné (Btermdn.t) constitué de tous les patterns de la seconde liste de tactiques *) -type stored_data = int * pri_auto_tactic +type stored_data = int * full_hint (* First component is the index of insertion in the table, to keep most recent first semantics. *) module Bounded_net = Btermdn.Make(struct @@ -175,21 +218,7 @@ let empty_se = { sentry_mode = []; } -let eq_pri_auto_tactic (_, x) (_, y) = - if Int.equal x.pri y.pri && Option.equal constr_pattern_eq x.pat y.pat then - match x.code,y.code with - | Res_pf (cstr,_),Res_pf (cstr1,_) -> - Term.eq_constr cstr cstr1 - | ERes_pf (cstr,_),ERes_pf (cstr1,_) -> - Term.eq_constr cstr cstr1 - | Give_exact (cstr,_),Give_exact (cstr1,_) -> - Term.eq_constr cstr cstr1 - | Res_pf_THEN_trivial_fail (cstr,_) - ,Res_pf_THEN_trivial_fail (cstr1,_) -> - Term.eq_constr cstr cstr1 - | _,_ -> false - else - false +let eq_pri_auto_tactic (_, x) (_, y) = KerName.equal x.code.uid y.code.uid let add_tac pat t st se = match pat with @@ -239,24 +268,24 @@ let strip_params env c = | _ -> c) | _ -> c -let instantiate_hint p = - let mk_clenv c cty ctx = - let env = Global.env () in - let sigma = Evd.merge_context_set univ_flexible (Evd.from_env env) ctx in - let cl = mk_clenv_from_env (Global.env()) sigma None (c,cty) in +let instantiate_hint env sigma p = + let mk_clenv (c, cty, ctx) = + let sigma = Evd.merge_context_set univ_flexible sigma ctx in + let cl = mk_clenv_from_env env sigma None (c,cty) in {cl with templval = { cl.templval with rebus = strip_params env cl.templval.rebus }; env = empty_env} in - let code = match p.code with - | Res_pf (c, cty, ctx) -> Res_pf (c, mk_clenv c cty ctx) - | ERes_pf (c, cty, ctx) -> ERes_pf (c, mk_clenv c cty ctx) - | Res_pf_THEN_trivial_fail (c, cty, ctx) -> - Res_pf_THEN_trivial_fail (c, mk_clenv c cty ctx) - | Give_exact (c, cty, ctx) -> Give_exact (c, mk_clenv c cty ctx) + let code = match p.code.obj with + | Res_pf c -> Res_pf (c, mk_clenv c) + | ERes_pf c -> ERes_pf (c, mk_clenv c) + | Res_pf_THEN_trivial_fail c -> + Res_pf_THEN_trivial_fail (c, mk_clenv c) + | Give_exact c -> Give_exact (c, mk_clenv c) | Unfold_nth e -> Unfold_nth e | Extern t -> Extern t - in { pri = p.pri; poly = p.poly; name = p.name; pat = p.pat; code = code } + in + { p with code = { p.code with obj = code } } let hints_path_atom_eq h1 h2 = match h1, h2 with | PathHints l1, PathHints l2 -> List.equal eq_gr l1 l2 @@ -353,15 +382,19 @@ let rec normalize_path h = let path_derivate hp hint = normalize_path (path_derivate hp hint) +let pp_hints_path_atom a = + match a with + | PathAny -> str"*" + | PathHints grs -> pr_sequence pr_global grs + let rec pp_hints_path = function - | PathAtom (PathAny) -> str"." - | PathAtom (PathHints grs) -> pr_sequence pr_global grs - | PathStar p -> str "(" ++ pp_hints_path p ++ str")*" + | PathAtom pa -> pp_hints_path_atom pa + | PathStar p -> str "!(" ++ pp_hints_path p ++ str")" | PathSeq (p, p') -> pp_hints_path p ++ str" ; " ++ pp_hints_path p' | PathOr (p, p') -> str "(" ++ pp_hints_path p ++ spc () ++ str"|" ++ spc () ++ pp_hints_path p' ++ str ")" - | PathEmpty -> str"Ø" - | PathEpsilon -> str"ε" + | PathEmpty -> str"emp" + | PathEpsilon -> str"eps" let subst_path_atom subst p = match p with @@ -429,7 +462,9 @@ module Hint_db = struct else List.exists (matches_mode args) modes let merge_entry db nopat pat = - let h = Sort.merge pri_order (List.map snd db.hintdb_nopat @ nopat) pat in + let h = List.sort pri_order_int (List.map snd db.hintdb_nopat) in + let h = List.merge pri_order_int h nopat in + let h = List.merge pri_order_int h pat in List.map realize_tac h let map_none db = @@ -473,15 +508,14 @@ module Hint_db = struct let idv = id, v in let k = match gr with | Some gr -> if db.use_dn && is_transparent_gr db.hintdb_state gr && - is_unfold v.code then None else Some gr + is_unfold v.code.obj then None else Some gr | None -> None in let dnst = if db.use_dn then Some db.hintdb_state else None in - let pat = if not db.use_dn && is_exact v.code then None else v.pat in + let pat = if not db.use_dn && is_exact v.code.obj then None else v.pat in match k with | None -> - (** ppedrot: this equality here is dubious. Maybe we can remove it? *) - let is_present (_, (_, v')) = eq_gen_auto_tactic v v' in + let is_present (_, (_, v')) = KerName.equal v.code.uid v'.code.uid in if not (List.exists is_present db.hintdb_nopat) then (** FIXME *) { db with hintdb_nopat = (gr,idv) :: db.hintdb_nopat } @@ -497,10 +531,10 @@ module Hint_db = struct in List.fold_left (fun db (gr,(id,v)) -> addkv gr id v db) db' db.hintdb_nopat - let add_one (k, v) db = - let v = instantiate_hint v in + let add_one env sigma (k, v) db = + let v = instantiate_hint env sigma v in let st',db,rebuild = - match v.code with + match v.code.obj with | Unfold_nth egr -> let addunf (ids,csts) (ids',csts') = match egr with @@ -515,7 +549,7 @@ module Hint_db = struct let db, id = next_hint_id db in addkv k id v db - let add_list l db = List.fold_left (fun db k -> add_one k db) db l + let add_list env sigma l db = List.fold_left (fun db k -> add_one env sigma k db) db l let remove_sdl p sdl = List.smartfilter p sdl @@ -534,7 +568,9 @@ module Hint_db = struct let remove_one gr db = remove_list [gr] db - let get_entry se = List.map realize_tac (se.sentry_nopat @ se.sentry_pat) + let get_entry se = + let h = List.merge pri_order_int se.sentry_nopat se.sentry_pat in + List.map realize_tac h let iter f db = let iter_se k se = f (Some k) se.sentry_mode (get_entry se) in @@ -586,6 +622,7 @@ let auto_init_db = Hintdbmap.empty) let searchtable : hint_db_table = ref auto_init_db +let statustable = ref KNmap.empty let searchtable_map name = Hintdbmap.find name !searchtable @@ -598,7 +635,7 @@ let current_pure_db () = List.map snd (Hintdbmap.bindings (Hintdbmap.remove "v62" !searchtable)) let error_no_such_hint_database x = - error ("No such Hint database: "^x^".") + errorlabstrm "Hints" (str "No such Hint database: " ++ str x ++ str ".") (**************************************************************************) (* Definition of the summary *) @@ -609,9 +646,10 @@ let add_hints_init f = let init = !hints_init in hints_init := (fun () -> init (); f ()) -let init () = searchtable := auto_init_db; !hints_init () -let freeze _ = !searchtable -let unfreeze fs = searchtable := fs +let init () = + searchtable := auto_init_db; statustable := KNmap.empty; !hints_init () +let freeze _ = (!searchtable, !statustable) +let unfreeze (fs, st) = searchtable := fs; statustable := st let _ = Summary.declare_summary "search" { Summary.freeze_function = freeze; @@ -632,6 +670,8 @@ let try_head_pattern c = try head_pattern_bound c with BoundPattern -> error "Bound head variable." +let with_uid c = { obj = c; uid = fresh_key () } + let make_exact_entry env sigma pri poly ?(name=PathAny) (c, cty, ctx) = let cty = strip_outer_cast cty in match kind_of_term cty with @@ -647,7 +687,7 @@ let make_exact_entry env sigma pri poly ?(name=PathAny) (c, cty, ctx) = poly = poly; pat = Some pat; name = name; - code = Give_exact (c, cty, ctx) }) + code = with_uid (Give_exact (c, cty, ctx)); }) let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, cty, ctx) = let cty = if hnf then hnf_constr env sigma cty else cty in @@ -667,7 +707,7 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, poly = poly; pat = Some pat; name = name; - code = Res_pf(c,cty,ctx) }) + code = with_uid (Res_pf(c,cty,ctx)); }) else begin if not eapply then failwith "make_apply_entry"; if verbose then @@ -678,7 +718,7 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, poly = poly; pat = Some pat; name = name; - code = ERes_pf(c,cty,ctx) }) + code = with_uid (ERes_pf(c,cty,ctx)); }) end | _ -> failwith "make_apply_entry" @@ -724,7 +764,7 @@ let make_unfold eref = poly = false; pat = None; name = PathHints [g]; - code = Unfold_nth eref }) + code = with_uid (Unfold_nth eref) }) let make_extern pri pat tacast = let hdconstr = Option.map try_head_pattern pat in @@ -733,7 +773,7 @@ let make_extern pri pat tacast = poly = false; pat = pat; name = PathAny; - code = Extern tacast }) + code = with_uid (Extern tacast) }) let make_mode ref m = let ty = Global.type_of_global_unsafe ref in @@ -749,14 +789,14 @@ let make_mode ref m = let make_trivial env sigma poly ?(name=PathAny) r = let c,ctx = fresh_global_or_constr env sigma poly r in let sigma = Evd.merge_context_set univ_flexible sigma ctx in - let t = hnf_constr env sigma (type_of env sigma c) in + let t = hnf_constr env sigma (unsafe_type_of env sigma c) in let hd = head_of_constr_reference (head_constr t) in let ce = mk_clenv_from_env env sigma None (c,t) in (Some hd, { pri=1; poly = poly; pat = Some (pi3 (Patternops.pattern_of_constr env ce.evd (clenv_type ce))); name = name; - code=Res_pf_THEN_trivial_fail(c,t,ctx) }) + code= with_uid (Res_pf_THEN_trivial_fail(c,t,ctx)) }) @@ -771,9 +811,19 @@ let get_db dbname = try searchtable_map dbname with Not_found -> Hint_db.empty empty_transparent_state false -let add_hint dbname hintlist = +let add_hint dbname hintlist = + let check (_, h) = + let () = if KNmap.mem h.code.uid !statustable then + error "Conflicting hint keys. This can happen when including \ + twice the same module." + in + statustable := KNmap.add h.code.uid false !statustable + in + let () = List.iter check hintlist in let db = get_db dbname in - let db' = Hint_db.add_list hintlist db in + let env = Global.env () in + let sigma = Evd.from_env env in + let db' = Hint_db.add_list env sigma hintlist db in searchtable_add (dbname,db') let add_transparency dbname grs b = @@ -816,7 +866,7 @@ type hint_obj = { hint_action : hint_action; } -let cache_autohint (_, h) = +let load_autohint _ (kn, h) = let name = h.hint_name in match h.hint_action with | CreateDB (b, st) -> searchtable_add (name, Hint_db.empty st b) @@ -826,6 +876,16 @@ let cache_autohint (_, h) = | AddCut path -> add_cut name path | AddMode (l, m) -> add_mode name l m +let open_autohint i (kn, h) = + if Int.equal i 1 then match h.hint_action with + | AddHints hints -> + let add (_, hint) = statustable := KNmap.add hint.code.uid true !statustable in + List.iter add hints + | _ -> () + +let cache_autohint (kn, obj) = + load_autohint 1 (kn, obj); open_autohint 1 (kn, obj) + let subst_autohint (subst, obj) = let subst_key gr = let (lab'', elab') = subst_global subst gr in @@ -837,34 +897,36 @@ let subst_autohint (subst, obj) = let subst_hint (k,data as hint) = let k' = Option.smartmap subst_key k in let pat' = Option.smartmap (subst_pattern subst) data.pat in - let code' = match data.code with + let code' = match data.code.obj with | Res_pf (c,t,ctx) -> let c' = subst_mps subst c in let t' = subst_mps subst t in - if c==c' && t'==t then data.code else Res_pf (c', t',ctx) + if c==c' && t'==t then data.code.obj else Res_pf (c', t',ctx) | ERes_pf (c,t,ctx) -> let c' = subst_mps subst c in let t' = subst_mps subst t in - if c==c' && t'==t then data.code else ERes_pf (c',t',ctx) + if c==c' && t'==t then data.code.obj else ERes_pf (c',t',ctx) | Give_exact (c,t,ctx) -> let c' = subst_mps subst c in let t' = subst_mps subst t in - if c==c' && t'== t then data.code else Give_exact (c',t',ctx) + if c==c' && t'== t then data.code.obj else Give_exact (c',t',ctx) | Res_pf_THEN_trivial_fail (c,t,ctx) -> let c' = subst_mps subst c in let t' = subst_mps subst t in - if c==c' && t==t' then data.code else Res_pf_THEN_trivial_fail (c',t',ctx) + if c==c' && t==t' then data.code.obj else Res_pf_THEN_trivial_fail (c',t',ctx) | Unfold_nth ref -> let ref' = subst_evaluable_reference subst ref in - if ref==ref' then data.code else Unfold_nth ref' + if ref==ref' then data.code.obj else Unfold_nth ref' | Extern tac -> let tac' = Tacsubst.subst_tactic subst tac in - if tac==tac' then data.code else Extern tac' + if tac==tac' then data.code.obj else Extern tac' in let name' = subst_path_atom subst data.name in + let uid' = subst_kn subst data.code.uid in let data' = - if data.pat==pat' && data.name == name' && data.code==code' then data - else { data with pat = pat'; name = name'; code = code' } + if data.code.uid == uid' && data.pat == pat' && + data.name == name' && data.code.obj == code' then data + else { data with pat = pat'; name = name'; code = { obj = code'; uid = uid' } } in if k' == k && data' == data then hint else (k',data') in @@ -896,7 +958,8 @@ let classify_autohint obj = let inAutoHint : hint_obj -> obj = declare_object {(default_object "AUTOHINT") with cache_function = cache_autohint; - load_function = (fun _ -> cache_autohint); + load_function = load_autohint; + open_function = open_autohint; subst_function = subst_autohint; classify_function = classify_autohint; } @@ -999,7 +1062,7 @@ let default_prepare_hint_ident = Id.of_string "H" exception Found of constr * types -let prepare_hint check env init (sigma,c) = +let prepare_hint check (poly,local) env init (sigma,c) = let sigma = Typeclasses.resolve_typeclasses ~fail:false env sigma in (* We re-abstract over uninstantiated evars. It is actually a bit stupid to generalize over evars since the first @@ -1012,7 +1075,7 @@ let prepare_hint check env init (sigma,c) = (* We skip the test whether args is the identity or not *) let t = Evarutil.nf_evar sigma (existential_type sigma ev) in let t = List.fold_right (fun (e,id) c -> replace_term e id c) !subst t in - if not (Int.Set.is_empty (free_rels t)) then + if not (closed0 c) then error "Hints with holes dependent on a bound variable not supported."; if occur_existential t then (* Not clever enough to construct dependency graph of evars *) @@ -1029,13 +1092,18 @@ let prepare_hint check env init (sigma,c) = let c' = iter c in if check then Evarutil.check_evars (Global.env()) Evd.empty sigma c'; let diff = Univ.ContextSet.diff (Evd.universe_context_set sigma) (Evd.universe_context_set init) in - IsConstr (c', diff) + if poly then IsConstr (c', diff) + else if local then IsConstr (c', diff) + else (Global.push_context_set false diff; + IsConstr (c', Univ.ContextSet.empty)) let interp_hints poly = fun h -> - let f c = - let evd,c = Constrintern.interp_open_constr (Global.env()) Evd.empty c in - prepare_hint true (Global.env()) Evd.empty (evd,c) in + let env = (Global.env()) in + let sigma = Evd.from_env env in + let f poly c = + let evd,c = Constrintern.interp_open_constr env sigma c in + prepare_hint true (poly,false) (Global.env()) Evd.empty (evd,c) in let fref r = let gr = global_with_alias r in Dumpglob.add_glob (loc_of_reference r) gr; @@ -1048,7 +1116,7 @@ let interp_hints poly = | HintsReference c -> let gr = global_with_alias c in (PathHints [gr], poly, IsGlobRef gr) - | HintsConstr c -> (PathAny, poly, f c) + | HintsConstr c -> (PathAny, poly, f poly c) in let fres (pri, b, r) = let path, poly, gr = fi r in @@ -1083,7 +1151,8 @@ let add_hints local dbnames0 h = if String.List.mem "nocore" dbnames0 then error "The hint database \"nocore\" is meant to stay empty."; let dbnames = if List.is_empty dbnames0 then ["core"] else dbnames0 in - let env = Global.env() and sigma = Evd.empty in + let env = Global.env() in + let sigma = Evd.from_env env in match h with | HintsResolveEntry lhints -> add_resolves env sigma lhints local dbnames | HintsImmediateEntry lhints -> add_trivials env sigma lhints local dbnames @@ -1103,7 +1172,7 @@ let expand_constructor_hints env sigma lems = (fun i -> IsConstr (mkConstructU ((ind,i+1),u), Univ.ContextSet.empty)) | _ -> - [prepare_hint false env sigma (evd,lem)]) lems + [prepare_hint false (false,true) env sigma (evd,lem)]) lems (* builds a hint database from a constr signature *) (* typically used with (lid, ltyp) = pf_hyps_types <some goal> *) @@ -1111,8 +1180,8 @@ let expand_constructor_hints env sigma lems = let add_hint_lemmas env sigma eapply lems hint_db = let lems = expand_constructor_hints env sigma lems in let hintlist' = - List.map_append (make_resolves env sigma (eapply,true,false) None true) lems in - Hint_db.add_list hintlist' hint_db + List.map_append (make_resolves env sigma (eapply,true,false) None false) lems in + Hint_db.add_list env sigma hintlist' hint_db let make_local_hint_db env sigma ts eapply lems = let sign = Environ.named_context env in @@ -1122,7 +1191,7 @@ let make_local_hint_db env sigma ts eapply lems = in let hintlist = List.map_append (make_resolve_hyp env sigma) sign in add_hint_lemmas env sigma eapply lems - (Hint_db.add_list hintlist (Hint_db.empty ts false)) + (Hint_db.add_list env sigma hintlist (Hint_db.empty ts false)) let make_local_hint_db = if Flags.profile then @@ -1146,13 +1215,14 @@ let make_db_list dbnames = (* Functions for printing the hints *) (**************************************************************************) -let pr_autotactic = - function - | Res_pf (c,clenv) -> (str"apply " ++ pr_constr c) - | ERes_pf (c,clenv) -> (str"eapply " ++ pr_constr c) - | Give_exact (c,clenv) -> (str"exact " ++ pr_constr c) - | Res_pf_THEN_trivial_fail (c,clenv) -> - (str"apply " ++ pr_constr c ++ str" ; trivial") +let pr_hint_elt (c, _, _) = pr_constr c + +let pr_hint h = match h.obj with + | Res_pf (c, _) -> (str"apply " ++ pr_hint_elt c) + | ERes_pf (c, _) -> (str"eapply " ++ pr_hint_elt c) + | Give_exact (c, _) -> (str"exact " ++ pr_hint_elt c) + | Res_pf_THEN_trivial_fail (c, _) -> + (str"apply " ++ pr_hint_elt c ++ str" ; trivial") | Unfold_nth c -> (str"unfold " ++ pr_evaluable_reference c) | Extern tac -> let env = @@ -1163,11 +1233,11 @@ let pr_autotactic = in (str "(*external*) " ++ Pptactic.pr_glob_tactic env tac) -let pr_hint (id, v) = - (pr_autotactic v.code ++ str"(level " ++ int v.pri ++ str", id " ++ int id ++ str ")" ++ spc ()) +let pr_id_hint (id, v) = + (pr_hint v.code ++ str"(level " ++ int v.pri ++ str", id " ++ int id ++ str ")" ++ spc ()) let pr_hint_list hintlist = - (str " " ++ hov 0 (prlist pr_hint hintlist) ++ fnl ()) + (str " " ++ hov 0 (prlist pr_id_hint hintlist) ++ fnl ()) let pr_hints_db (name,db,hintlist) = (str "In the database " ++ str name ++ str ":" ++ @@ -1266,3 +1336,27 @@ let pr_searchtable () = in Hintdbmap.fold fold !searchtable (mt ()) +let print_mp mp = + try + let qid = Nametab.shortest_qualid_of_module mp in + str " from " ++ pr_qualid qid + with Not_found -> mt () + +let is_imported h = try KNmap.find h.uid !statustable with Not_found -> true + +let warn h x = + let hint = pr_hint h in + let (mp, _, _) = KerName.repr h.uid in + let () = msg_warning (str "Hint used but not imported: " ++ hint ++ print_mp mp) in + Proofview.tclUNIT x + +let run_hint tac k = match !warn_hint with +| `LAX -> k tac.obj +| `WARN -> + if is_imported tac then k tac.obj + else Proofview.tclBIND (k tac.obj) (fun x -> warn tac x) +| `STRICT -> + if is_imported tac then k tac.obj + else Proofview.tclZERO (UserError ("", (str "Tactic failure."))) + +let repr_hint h = h.obj diff --git a/tactics/hints.mli b/tactics/hints.mli index 958cca1c..3a0521f6 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -28,7 +28,7 @@ val decompose_app_bound : constr -> global_reference * constr array (** Pre-created hint databases *) -type 'a auto_tactic_ast = +type 'a hint_ast = | Res_pf of 'a (* Hint Apply *) | ERes_pf of 'a (* Hint EApply *) | Give_exact of 'a @@ -36,13 +36,14 @@ type 'a auto_tactic_ast = | Unfold_nth of evaluable_global_reference (* Hint Unfold *) | Extern of Tacexpr.glob_tactic_expr (* Hint Extern *) -type 'a auto_tactic +type hint +type raw_hint = constr * types * Univ.universe_context_set type hints_path_atom = | PathHints of global_reference list | PathAny -type 'a gen_auto_tactic = private { +type 'a with_metadata = private { pri : int; (** A number between 0 and 4, 4 = lower priority *) poly : polymorphic; (** Is the hint polymorpic and hence should be refreshed at each application *) pat : constr_pattern option; (** A pattern for the concl of the Goal *) @@ -50,7 +51,7 @@ type 'a gen_auto_tactic = private { code : 'a; (** the tactic to apply when the concl matches pat *) } -type pri_auto_tactic = (constr * clausenv) auto_tactic gen_auto_tactic +type full_hint = hint with_metadata type search_entry @@ -69,6 +70,7 @@ type hints_path = val normalize_path : hints_path -> hints_path val path_matches : hints_path -> hints_path_atom list -> bool val path_derivate : hints_path -> hints_path_atom -> hints_path +val pp_hints_path_atom : hints_path_atom -> Pp.std_ppcmds val pp_hints_path : hints_path -> Pp.std_ppcmds module Hint_db : @@ -76,28 +78,28 @@ module Hint_db : type t val empty : transparent_state -> bool -> t val find : global_reference -> t -> search_entry - val map_none : t -> pri_auto_tactic list + val map_none : t -> full_hint list (** All hints associated to the reference *) - val map_all : global_reference -> t -> pri_auto_tactic list + val map_all : global_reference -> t -> full_hint list (** All hints associated to the reference, respecting modes if evars appear in the arguments, _not_ using the discrimination net. *) - val map_existential : (global_reference * constr array) -> constr -> t -> pri_auto_tactic list + val map_existential : (global_reference * constr array) -> constr -> t -> full_hint list (** All hints associated to the reference, respecting modes if evars appear in the arguments and using the discrimination net. *) - val map_eauto : (global_reference * constr array) -> constr -> t -> pri_auto_tactic list + val map_eauto : (global_reference * constr array) -> constr -> t -> full_hint list (** All hints associated to the reference, respecting modes if evars appear in the arguments. *) - val map_auto : (global_reference * constr array) -> constr -> t -> pri_auto_tactic list + val map_auto : (global_reference * constr array) -> constr -> t -> full_hint list - val add_one : hint_entry -> t -> t - val add_list : (hint_entry) list -> t -> t + val add_one : env -> evar_map -> hint_entry -> t -> t + val add_list : env -> evar_map -> hint_entry list -> t -> t val remove_one : global_reference -> t -> t val remove_list : global_reference list -> t -> t - val iter : (global_reference option -> bool array list -> pri_auto_tactic list -> unit) -> t -> unit + val iter : (global_reference option -> bool array list -> full_hint list -> unit) -> t -> unit val use_dn : t -> bool val transparent_state : t -> transparent_state @@ -151,8 +153,9 @@ val interp_hints : polymorphic -> hints_expr -> hints_entry val add_hints : locality_flag -> hint_db_name list -> hints_entry -> unit -val prepare_hint : bool (* Check no remaining evars *) -> env -> evar_map -> - open_constr -> hint_term +val prepare_hint : bool (* Check no remaining evars *) -> + (bool * bool) (* polymorphic or monomorphic, local or global *) -> + env -> evar_map -> open_constr -> hint_term (** [make_exact_entry pri (c, ctyp)]. [c] is the term given as an exact proof to solve the goal; @@ -197,12 +200,12 @@ val make_extern : int -> constr_pattern option -> Tacexpr.glob_tactic_expr -> hint_entry -val run_auto_tactic : 'a auto_tactic -> - ('a auto_tactic_ast -> 'r Proofview.tactic) -> 'r Proofview.tactic +val run_hint : hint -> + ((raw_hint * clausenv) hint_ast -> 'r Proofview.tactic) -> 'r Proofview.tactic (** This function is for backward compatibility only, not to use in newly written code. *) -val repr_auto_tactic : 'a auto_tactic -> 'a auto_tactic_ast +val repr_hint : hint -> (raw_hint * clausenv) hint_ast val extern_intern_tac : (patvar list -> Tacexpr.raw_tactic_expr -> Tacexpr.glob_tactic_expr) Hook.t @@ -227,7 +230,7 @@ val pr_applicable_hint : unit -> std_ppcmds val pr_hint_ref : global_reference -> std_ppcmds val pr_hint_db_by_name : hint_db_name -> std_ppcmds val pr_hint_db : Hint_db.t -> std_ppcmds -val pr_autotactic : (constr * 'a) auto_tactic -> Pp.std_ppcmds +val pr_hint : hint -> Pp.std_ppcmds (** Hook for changing the initialization of auto *) diff --git a/tactics/hipattern.ml4 b/tactics/hipattern.ml4 index 4b94f420..95f3af57 100644 --- a/tactics/hipattern.ml4 +++ b/tactics/hipattern.ml4 @@ -411,7 +411,7 @@ let find_eq_data eqn = (* fails with PatternMatchingFailure *) let extract_eq_args gl = function | MonomorphicLeibnizEq (e1,e2) -> - let t = pf_type_of gl e1 in (t,e1,e2) + let t = pf_unsafe_type_of gl e1 in (t,e1,e2) | PolymorphicLeibnizEq (t,e1,e2) -> (t,e1,e2) | HeterogenousEq (t1,e1,t2,e2) -> if pf_conv_x gl t1 t2 then (t1,e1,e2) diff --git a/tactics/inv.ml b/tactics/inv.ml index 5502356f..ef115aea 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -123,13 +123,13 @@ let make_inv_predicate env evd indf realargs id status concl = let refl_term = eqdata.Coqlib.refl in let refl_term = Evarutil.evd_comb1 (Evd.fresh_global env) evd refl_term in let refl = mkApp (refl_term, [|eqnty; rhs|]) in - let _ = Evarutil.evd_comb1 (Typing.e_type_of env) evd refl in + let _ = Evarutil.evd_comb1 (Typing.type_of env) evd refl in let args = refl :: args in build_concl eqns args (succ n) restlist in let (newconcl, args) = build_concl [] [] 0 realargs in let predicate = it_mkLambda_or_LetIn_name env newconcl hyps in - let _ = Evarutil.evd_comb1 (Typing.e_type_of env) evd predicate in + let _ = Evarutil.evd_comb1 (Typing.type_of env) evd predicate in (* OK - this predicate should now be usable by res_elimination_then to do elimination on the conclusion. *) predicate, args @@ -437,7 +437,7 @@ let raw_inversion inv_kind id status names = let concl = Proofview.Goal.concl gl in let c = mkVar id in let (ind, t) = - try pf_apply Tacred.reduce_to_atomic_ind gl (pf_type_of gl c) + try pf_apply Tacred.reduce_to_atomic_ind gl (pf_unsafe_type_of gl c) with UserError _ -> let msg = str "The type of " ++ pr_id id ++ str " is not inductive." in Errors.errorlabstrm "" msg diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 9a64b03f..8ca62217 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -124,7 +124,7 @@ let rec add_prods_sign env sigma t = add_prods_sign (push_named (id,Some c1,t1) env) sigma b' | _ -> (env,t) -(* [dep_option] indicates wether the inversion lemma is dependent or not. +(* [dep_option] indicates whether the inversion lemma is dependent or not. If it is dependent and I is of the form (x_bar:T_bar)(I t_bar) then the stated goal will be (x_bar:T_bar)(H:(I t_bar))(P t_bar H) where P:(x_bar:T_bar)(H:(I x_bar))[sort]. @@ -194,7 +194,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = errorlabstrm "lemma_inversion" (str"Computed inversion goal was not closed in initial signature."); *) - let pf = Proof.start (Evd.from_env ~ctx:(evar_universe_context sigma) invEnv) [invEnv,invGoal] in + let pf = Proof.start (Evd.from_ctx (evar_universe_context sigma)) [invEnv,invGoal] in let pf = fst (Proof.run_tactic env ( tclTHEN intro (onLastHypId inv_op)) pf) @@ -229,7 +229,8 @@ let inversion_scheme env sigma t sort dep_option inv_op = let add_inversion_lemma name env sigma t sort dep inv_op = let invProof, ctx = inversion_scheme env sigma t sort dep inv_op in - let entry = definition_entry ~poly:(Flags.use_polymorphic_flag ()) ~univs:ctx invProof in + let entry = definition_entry ~poly:(Flags.use_polymorphic_flag ()) + ~univs:(snd ctx) invProof in let _ = declare_constant name (DefinitionEntry entry, IsProof Lemma) in () diff --git a/tactics/rewrite.ml b/tactics/rewrite.ml index ac8b4923..e8a7c0f6 100644 --- a/tactics/rewrite.ml +++ b/tactics/rewrite.ml @@ -52,7 +52,7 @@ let try_find_global_reference dir s = let sp = Libnames.make_path (make_dir ("Coq"::dir)) (Id.of_string s) in try Nametab.global_of_path sp with Not_found -> - anomaly (str ("Global reference " ^ s ^ " not found in generalized rewriting")) + anomaly (str "Global reference " ++ str s ++ str " not found in generalized rewriting") let find_reference dir s = let gr = lazy (try_find_global_reference dir s) in @@ -76,25 +76,6 @@ let coq_f_equal = find_global ["Init"; "Logic"] "f_equal" let coq_all = find_global ["Init"; "Logic"] "all" let impl = find_global ["Program"; "Basics"] "impl" -(* let coq_inverse = lazy (gen_constant ["Program"; "Basics"] "flip") *) - -(* let inverse car rel = mkApp (Lazy.force coq_inverse, [| car ; car; mkProp; rel |]) *) - -(* let forall_relation = lazy (gen_constant ["Classes"; "Morphisms"] "forall_relation") *) -(* let pointwise_relation = lazy (gen_constant ["Classes"; "Morphisms"] "pointwise_relation") *) -(* let respectful = lazy (gen_constant ["Classes"; "Morphisms"] "respectful") *) -(* let default_relation = lazy (gen_constant ["Classes"; "SetoidTactics"] "DefaultRelation") *) -(* let subrelation = lazy (gen_constant ["Classes"; "RelationClasses"] "subrelation") *) -(* let do_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "do_subrelation") *) -(* let apply_subrelation = lazy (gen_constant ["Classes"; "Morphisms"] "apply_subrelation") *) -(* let coq_relation = lazy (gen_constant ["Relations";"Relation_Definitions"] "relation") *) -(* let mk_relation a = mkApp (Lazy.force coq_relation, [| a |]) *) - -(* let proper_type = lazy (Universes.constr_of_global (Lazy.force proper_class).cl_impl) *) -(* let proper_proxy_type = lazy (Universes.constr_of_global (Lazy.force proper_proxy_class).cl_impl) *) - - - (** Bookkeeping which evars are constraints so that we can remove them at the end of the tactic. *) @@ -226,6 +207,7 @@ end) = struct let t = Reductionops.whd_betadeltaiota env (goalevars evars) ty in match kind_of_term t, l with | Prod (na, ty, b), obj :: cstrs -> + let b = Reductionops.nf_betaiota (goalevars evars) b in if noccurn 1 b (* non-dependent product *) then let ty = Reductionops.nf_betaiota (goalevars evars) ty in let (evars, b', arg, cstrs) = aux env evars (subst1 mkProp b) cstrs in @@ -380,7 +362,7 @@ end let type_app_poly env env evd f args = let evars, c = app_poly_nocheck env evd f args in - let evd', t = Typing.e_type_of env (goalevars evars) c in + let evd', t = Typing.type_of env (goalevars evars) c in (evd', cstrevars evars), c module PropGlobal = struct @@ -452,7 +434,6 @@ let convertible env evd x y = Reductionops.is_conv_leq env evd x y type hypinfo = { - env : env; prf : constr; car : constr; rel : constr; @@ -472,7 +453,7 @@ let rec decompose_app_rel env evd t = | App (f, [||]) -> assert false | App (f, [|arg|]) -> let (f', argl, argr) = decompose_app_rel env evd arg in - let ty = Typing.type_of env evd argl in + let ty = Typing.unsafe_type_of env evd argl in let f'' = mkLambda (Name default_dependent_ident, ty, mkLambda (Name (Id.of_string "y"), lift 1 ty, mkApp (lift 2 f, [| mkApp (lift 2 f', [| mkRel 2; mkRel 1 |]) |]))) @@ -498,7 +479,7 @@ let decompose_applied_relation env sigma (c,l) = let sort = sort_of_rel env sigma equiv in let args = Array.map_of_list (fun h -> h.Clenv.hole_evar) holes in let value = mkApp (c, args) in - Some (sigma, { env=env; prf=value; + Some (sigma, { prf=value; car=ty1; rel = equiv; sort = Sorts.is_prop sort; c1=c1; c2=c2; holes }) in @@ -510,10 +491,6 @@ let decompose_applied_relation env sigma (c,l) = | Some c -> c | None -> error "Cannot find an homogeneous relation to rewrite." -let decompose_applied_relation_expr env sigma (is, (c,l)) = - let sigma, cbl = Tacinterp.interp_open_constr_with_bindings is env sigma (c,l) in - decompose_applied_relation env sigma cbl - let rewrite_db = "rewrite" let conv_transparent_state = (Id.Pred.empty, Cpred.full) @@ -588,24 +565,12 @@ let general_rewrite_unif_flags () = Unification.resolve_evars = true } -let refresh_hypinfo env sigma hypinfo c = - let sigma, hypinfo = match hypinfo with - | None -> - decompose_applied_relation_expr env sigma c - | Some hypinfo -> - if hypinfo.env != env then - (* If the lemma actually generates existential variables, we cannot - use it here as it will polute the evar map with existential variables - that might not ever get instantiated (e.g. if we rewrite under a - binder and need to refresh [c] again) *) - (* TODO: remove bindings in sigma corresponding to c *) - decompose_applied_relation_expr env sigma c - else sigma, hypinfo - in +let refresh_hypinfo env sigma (is, cb) = + let sigma, cbl = Tacinterp.interp_open_constr_with_bindings is env sigma cb in + let sigma, hypinfo = decompose_applied_relation env sigma cbl in let { c1; c2; car; rel; prf; sort; holes } = hypinfo in sigma, (car, rel, prf, c1, c2, holes, sort) - (** FIXME: write this in the new monad interface *) let solve_remaining_by env sigma holes by = match by with @@ -647,13 +612,19 @@ let poly_inverse sort = type rewrite_proof = | RewPrf of constr * constr + (** A Relation (R : rew_car -> rew_car -> Prop) and a proof of R rew_from rew_to *) | RewCast of cast_kind + (** A proof of convertibility (with casts) *) type rewrite_result_info = { - rew_car : constr; - rew_from : constr; - rew_to : constr; - rew_prf : rewrite_proof; + rew_car : constr ; + (** A type *) + rew_from : constr ; + (** A term of type rew_car *) + rew_to : constr ; + (** A term of type rew_car *) + rew_prf : rewrite_proof ; + (** A proof of rew_from == rew_to *) rew_evars : evars; } @@ -662,9 +633,17 @@ type rewrite_result = | Identity | Success of rewrite_result_info -type 'a pure_strategy = 'a -> Environ.env -> Id.t list -> constr -> types -> - (bool (* prop *) * constr option) -> evars -> - 'a * rewrite_result +type 'a strategy_input = { state : 'a ; (* a parameter: for instance, a state *) + env : Environ.env ; + unfresh : Id.t list ; (* Unfresh names *) + term1 : constr ; + ty1 : types ; (* first term and its type (convertible to rew_from) *) + cstr : (bool (* prop *) * constr option) ; + evars : evars } + +type 'a pure_strategy = { strategy : + 'a strategy_input -> + 'a * rewrite_result (* the updated state and the "result" *) } type strategy = unit pure_strategy @@ -719,7 +698,7 @@ let unify_abs (car, rel, prf, c1, c2) l2r sort env (sigma, cstrs) t = let rew_prf = RewPrf (rel, prf) in let rew = { rew_car = car; rew_from = c1; rew_to = c2; rew_prf; rew_evars; } in let rew = if l2r then rew else symmetry env sort rew in - Some ((), rew) + Some rew with | e when Class_tactics.catchable e -> None | Reduction.NotConvertible -> None @@ -763,7 +742,7 @@ let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' (b,cstr) ev let morphargs, morphobjs = Array.chop first args in let morphargs', morphobjs' = Array.chop first args' in let appm = mkApp(m, morphargs) in - let appmtype = Typing.type_of env (goalevars evars) appm in + let appmtype = Typing.unsafe_type_of env (goalevars evars) appm in let cstrs = List.map (Option.map (fun r -> r.rew_car, get_opt_rew_rel r.rew_prf)) (Array.to_list morphobjs') @@ -829,42 +808,47 @@ let coerce env avoid cstr res = let rel, prf = get_rew_prf res in apply_constraint env avoid res.rew_car rel prf cstr res -let apply_rule unify loccs : ('a * int) pure_strategy = +let apply_rule unify loccs : int pure_strategy = let (nowhere_except_in,occs) = convert_occs loccs in let is_occ occ = if nowhere_except_in then List.mem occ occs else not (List.mem occ occs) in - fun (hypinfo, occ) env avoid t ty cstr evars -> - let unif = if isEvar t then None else unify hypinfo env evars t in + { strategy = fun { state = occ ; env ; unfresh ; + term1 = t ; ty1 = ty ; cstr ; evars } -> + let unif = if isEvar t then None else unify env evars t in match unif with - | None -> ((hypinfo, occ), Fail) - | Some (hypinfo', rew) -> + | None -> (occ, Fail) + | Some rew -> let occ = succ occ in - if not (is_occ occ) then ((hypinfo, occ), Fail) - else if eq_constr t rew.rew_to then ((hypinfo, occ), Identity) + if not (is_occ occ) then (occ, Fail) + else if eq_constr t rew.rew_to then (occ, Identity) else let res = { rew with rew_car = ty } in let rel, prf = get_rew_prf res in - let res = Success (apply_constraint env avoid rew.rew_car rel prf cstr res) in - ((hypinfo', occ), res) - -let apply_lemma l2r flags oc by loccs : strategy = - fun () env avoid t ty cstr (sigma, cstrs) -> + let res = Success (apply_constraint env unfresh rew.rew_car rel prf cstr res) in + (occ, res) + } + +let apply_lemma l2r flags oc by loccs : strategy = { strategy = + fun ({ state = () ; env ; term1 = t ; evars = (sigma, cstrs) } as input) -> let sigma, c = oc sigma in let sigma, hypinfo = decompose_applied_relation env sigma c in let { c1; c2; car; rel; prf; sort; holes } = hypinfo in let rew = (car, rel, prf, c1, c2, holes, sort) in let evars = (sigma, cstrs) in - let unify () env evars t = + let unify env evars t = let rew = unify_eqn rew l2r flags env evars by t in match rew with | None -> None - | Some rew -> Some ((), rew) + | Some rew -> Some rew in - let _, res = apply_rule unify loccs ((), 0) env avoid t ty cstr evars in + let _, res = (apply_rule unify loccs).strategy { input with + state = 0 ; + evars } in (), res + } let e_app_poly env evars f args = let evars', c = app_poly_nocheck env !evars f args in @@ -944,7 +928,8 @@ let unfold_match env sigma sk app = let is_rew_cast = function RewCast _ -> true | _ -> false let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = - let rec aux state env avoid t ty (prop, cstr) evars = + let rec aux { state ; env ; unfresh ; + term1 = t ; ty1 = ty ; cstr = (prop, cstr) ; evars } = let cstr' = Option.map (fun c -> (ty, Some c)) cstr in match kind_of_term t with | App (m, args) -> @@ -956,7 +941,11 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = state, (None :: acc, evars, progress) else let argty = Retyping.get_type_of env (goalevars evars) arg in - let state, res = s state env avoid arg argty (prop,None) evars in + let state, res = s.strategy { state ; env ; + unfresh ; + term1 = arg ; ty1 = argty ; + cstr = (prop,None) ; + evars } in let res' = match res with | Identity -> @@ -980,7 +969,7 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = | Some r -> not (is_rew_cast r.rew_prf)) args' then let evars', prf, car, rel, c1, c2 = - resolve_morphism env avoid t m args args' (prop, cstr') evars' + resolve_morphism env unfresh t m args args' (prop, cstr') evars' in let res = { rew_car = ty; rew_from = c1; rew_to = c2; rew_prf = RewPrf (rel, prf); @@ -1008,7 +997,9 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = evars, Some cstr', m, mty, args, Array.of_list args | None -> evars, None, m, mty, argsl, args in - let state, m' = s state env avoid m mty (prop, cstr') evars in + let state, m' = s.strategy { state ; env ; unfresh ; + term1 = m ; ty1 = mty ; + cstr = (prop, cstr') ; evars } in match m' with | Fail -> rewrite_args state None (* Standard path, try rewrite on arguments *) | Identity -> rewrite_args state (Some false) @@ -1031,7 +1022,7 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = let res = match prf with | RewPrf (rel, prf) -> - Success (apply_constraint env avoid res.rew_car + Success (apply_constraint env unfresh res.rew_car rel prf (prop,cstr) res) | _ -> Success res in state, res @@ -1045,7 +1036,9 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = else TypeGlobal.arrow_morphism in let (evars', mor), unfold = arr env evars tx tb x b in - let state, res = aux state env avoid mor ty (prop,cstr) evars' in + let state, res = aux { state ; env ; unfresh ; + term1 = mor ; ty1 = ty ; + cstr = (prop,cstr) ; evars = evars' } in let res = match res with | Success r -> Success { r with rew_to = unfold r.rew_to } @@ -1075,7 +1068,9 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = let forall = if prop then PropGlobal.coq_forall else TypeGlobal.coq_forall in (app_poly_sort prop env evars forall [| dom; lam |]), TypeGlobal.unfold_forall in - let state, res = aux state env avoid app ty (prop,cstr) evars' in + let state, res = aux { state ; env ; unfresh ; + term1 = app ; ty1 = ty ; + cstr = (prop,cstr) ; evars = evars' } in let res = match res with | Success r -> Success { r with rew_to = unfold r.rew_to } @@ -1111,11 +1106,14 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = (* | _ -> b') *) | Lambda (n, t, b) when flags.under_lambdas -> - let n' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n in + let n' = name_app (fun id -> Tactics.fresh_id_in_env unfresh id env) n in let env' = Environ.push_rel (n', None, t) env in let bty = Retyping.get_type_of env' (goalevars evars) b in let unlift = if prop then PropGlobal.unlift_cstr else TypeGlobal.unlift_cstr in - let state, b' = s state env' avoid b bty (prop, unlift env evars cstr) evars in + let state, b' = s.strategy { state ; env = env' ; unfresh ; + term1 = b ; ty1 = bty ; + cstr = (prop, unlift env evars cstr) ; + evars } in let res = match b' with | Success r -> @@ -1140,13 +1138,15 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = let cty = Retyping.get_type_of env (goalevars evars) c in let evars', eqty = app_poly_sort prop env evars coq_eq [| cty |] in let cstr' = Some eqty in - let state, c' = s state env avoid c cty (prop, cstr') evars' in + let state, c' = s.strategy { state ; env ; unfresh ; + term1 = c ; ty1 = cty ; + cstr = (prop, cstr') ; evars = evars' } in let state, res = match c' with | Success r -> let case = mkCase (ci, lift 1 p, mkRel 1, Array.map (lift 1) brs) in let res = make_leibniz_proof env case ty r in - state, Success (coerce env avoid (prop,cstr) res) + state, Success (coerce env unfresh (prop,cstr) res) | Fail | Identity -> if Array.for_all (Int.equal 0) ci.ci_cstr_ndecls then let evars', eqty = app_poly_sort prop env evars coq_eq [| ty |] in @@ -1156,7 +1156,9 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = if not (Option.is_empty found) then (state, found, fun x -> lift 1 br :: acc x) else - let state, res = s state env avoid br ty (prop,cstr) evars in + let state, res = s.strategy { state ; env ; unfresh ; + term1 = br ; ty1 = ty ; + cstr = (prop,cstr) ; evars } in match res with | Success r -> (state, Some r, fun x -> mkRel 1 :: acc x) | Fail | Identity -> (state, None, fun x -> lift 1 br :: acc x)) @@ -1171,7 +1173,9 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = match try Some (fold_match env (goalevars evars) t) with Not_found -> None with | None -> state, c' | Some (cst, _, t', eff (*FIXME*)) -> - let state, res = aux state env avoid t' ty (prop,cstr) evars in + let state, res = aux { state ; env ; unfresh ; + term1 = t' ; ty1 = ty ; + cstr = (prop,cstr) ; evars } in let res = match res with | Success prf -> @@ -1185,11 +1189,11 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = match res with | Success r -> let rel, prf = get_rew_prf r in - Success (apply_constraint env avoid r.rew_car rel prf (prop,cstr) r) + Success (apply_constraint env unfresh r.rew_car rel prf (prop,cstr) r) | Fail | Identity -> res in state, res | _ -> state, Fail - in aux + in { strategy = aux } let all_subterms = subterm true default_flags let one_subterm = subterm false default_flags @@ -1197,11 +1201,13 @@ let one_subterm = subterm false default_flags (** Requires transitivity of the rewrite step, if not a reduction. Not tail-recursive. *) -let transitivity state env avoid prop (res : rewrite_result_info) (next : 'a pure_strategy) : +let transitivity state env unfresh prop (res : rewrite_result_info) (next : 'a pure_strategy) : 'a * rewrite_result = let state, nextres = - next state env avoid res.rew_to res.rew_car - (prop, get_opt_rew_rel res.rew_prf) res.rew_evars + next.strategy { state ; env ; unfresh ; + term1 = res.rew_to ; ty1 = res.rew_car ; + cstr = (prop, get_opt_rew_rel res.rew_prf) ; + evars = res.rew_evars } in let res = match nextres with @@ -1238,15 +1244,16 @@ module Strategies = struct let fail : 'a pure_strategy = - fun state env avoid t ty cstr evars -> - state, Fail + { strategy = fun { state } -> state, Fail } let id : 'a pure_strategy = - fun state env avoid t ty cstr evars -> - state, Identity + { strategy = fun { state } -> state, Identity } let refl : 'a pure_strategy = - fun state env avoid t ty (prop,cstr) evars -> + { strategy = + fun { state ; env ; + term1 = t ; ty1 = ty ; + cstr = (prop,cstr) ; evars } -> let evars, rel = match cstr with | None -> let mkr = if prop then PropGlobal.mk_relation else TypeGlobal.mk_relation in @@ -1265,38 +1272,43 @@ module Strategies = let res = Success { rew_car = ty; rew_from = t; rew_to = t; rew_prf = RewPrf (rel, proof); rew_evars = evars } in state, res + } - let progress (s : 'a pure_strategy) : 'a pure_strategy = - fun state env avoid t ty cstr evars -> - let state, res = s state env avoid t ty cstr evars in + let progress (s : 'a pure_strategy) : 'a pure_strategy = { strategy = + fun input -> + let state, res = s.strategy input in match res with | Fail -> state, Fail | Identity -> state, Fail | Success r -> state, Success r + } - let seq first snd : 'a pure_strategy = - fun state env avoid t ty cstr evars -> - let state, res = first state env avoid t ty cstr evars in + let seq first snd : 'a pure_strategy = { strategy = + fun ({ env ; unfresh ; cstr } as input) -> + let state, res = first.strategy input in match res with | Fail -> state, Fail - | Identity -> snd state env avoid t ty cstr evars - | Success res -> transitivity state env avoid (fst cstr) res snd + | Identity -> snd.strategy { input with state } + | Success res -> transitivity state env unfresh (fst cstr) res snd + } - let choice fst snd : 'a pure_strategy = - fun state env avoid t ty cstr evars -> - let state, res = fst state env avoid t ty cstr evars in + let choice fst snd : 'a pure_strategy = { strategy = + fun input -> + let state, res = fst.strategy input in match res with - | Fail -> snd state env avoid t ty cstr evars + | Fail -> snd.strategy { input with state } | Identity | Success _ -> state, res + } let try_ str : 'a pure_strategy = choice str id - let check_interrupt str s e l c t r ev = + let check_interrupt str input = Control.check_for_interrupt (); - str s e l c t r ev - + str input + let fix (f : 'a pure_strategy -> 'a pure_strategy) : 'a pure_strategy = - let rec aux state = f (fun state -> check_interrupt aux state) state in aux + let rec aux input = (f { strategy = fun input -> check_interrupt aux input }).strategy input in + { strategy = aux } let any (s : 'a pure_strategy) : 'a pure_strategy = fix (fun any -> try_ (seq s any)) @@ -1332,16 +1344,17 @@ module Strategies = (List.map (fun hint -> (inj_open hint, hint.Autorewrite.rew_l2r, hint.Autorewrite.rew_tac)) rules) - let hints (db : string) : 'a pure_strategy = - fun state env avoid t ty cstr evars -> + let hints (db : string) : 'a pure_strategy = { strategy = + fun ({ term1 = t } as input) -> let rules = Autorewrite.find_matches db t in let lemma hint = (inj_open hint, hint.Autorewrite.rew_l2r, hint.Autorewrite.rew_tac) in let lems = List.map lemma rules in - lemmas lems state env avoid t ty cstr evars + (lemmas lems).strategy input + } - let reduce (r : Redexpr.red_expr) : 'a pure_strategy = - fun state env avoid t ty cstr evars -> + let reduce (r : Redexpr.red_expr) : 'a pure_strategy = { strategy = + fun { state = state ; env = env ; term1 = t ; ty1 = ty ; cstr = cstr ; evars = evars } -> let rfn, ckind = Redexpr.reduction_of_red_expr env r in let evars', t' = rfn env (goalevars evars) t in if eq_constr t' t then @@ -1350,9 +1363,10 @@ module Strategies = state, Success { rew_car = ty; rew_from = t; rew_to = t'; rew_prf = RewCast ckind; rew_evars = evars', cstrevars evars } + } - let fold_glob c : 'a pure_strategy = - fun state env avoid t ty cstr evars -> + let fold_glob c : 'a pure_strategy = { strategy = + fun { state ; env ; term1 = t ; ty1 = ty ; cstr ; evars } -> (* let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *) let sigma, c = Pretyping.understand_tcc env (goalevars evars) c in let unfolded = @@ -1367,23 +1381,23 @@ module Strategies = rew_prf = RewCast DEFAULTcast; rew_evars = (sigma, snd evars) } with e when Errors.noncritical e -> state, Fail + } end -(** The strategy for a single rewrite, dealing with occurences. *) +(** The strategy for a single rewrite, dealing with occurrences. *) (** A dummy initial clauseenv to avoid generating initial evars before even finding a first application of the rewriting lemma, in setoid_rewrite mode *) -let rewrite_with l2r flags c occs : strategy = - fun () env avoid t ty cstr (sigma, cstrs) -> - let hypinfo = None in - let unify hypinfo env evars t = +let rewrite_with l2r flags c occs : strategy = { strategy = + fun ({ state = () } as input) -> + let unify env evars t = let (sigma, cstrs) = evars in let ans = - try Some (refresh_hypinfo env sigma hypinfo c) + try Some (refresh_hypinfo env sigma c) with e when Class_tactics.catchable e -> None in match ans with @@ -1392,19 +1406,22 @@ let rewrite_with l2r flags c occs : strategy = let rew = unify_eqn rew l2r flags env (sigma, cstrs) None t in match rew with | None -> None - | Some rew -> Some (None, rew) (** reset the hypinfo cache *) + | Some rew -> Some rew in let app = apply_rule unify occs in let strat = Strategies.fix (fun aux -> Strategies.choice app (subterm true default_flags aux)) in - let _, res = strat (hypinfo, 0) env avoid t ty cstr (sigma, cstrs) in - ((), res) + let _, res = strat.strategy { input with state = 0 } in + ((), res) + } -let apply_strategy (s : strategy) env avoid concl (prop, cstr) evars = +let apply_strategy (s : strategy) env unfresh concl (prop, cstr) evars = let ty = Retyping.get_type_of env (goalevars evars) concl in - let _, res = s () env avoid concl ty (prop, Some cstr) evars in + let _, res = s.strategy { state = () ; env ; unfresh ; + term1 = concl ; ty1 = ty ; + cstr = (prop, Some cstr) ; evars } in res let solve_constraints env (evars,cstrs) = @@ -1506,7 +1523,7 @@ let newfail n s = let cl_rewrite_clause_newtac ?abs ?origsigma strat clause = let open Proofview.Notations in - let treat sigma (res, is_hyp) = + let treat sigma res = match res with | None -> newfail 0 (str "Nothing to rewrite") | Some None -> Proofview.tclUNIT () @@ -1514,7 +1531,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma strat clause = let (undef, prf, newt) = res in let fold ev _ accu = if Evd.mem sigma ev then accu else ev :: accu in let gls = List.rev (Evd.fold_undefined fold undef []) in - match is_hyp, prf with + match clause, prf with | Some id, Some p -> let tac = Proofview.Refine.refine ~unsafe:false (fun h -> (h, p)) <*> Proofview.Unsafe.tclNEWGOALS gls in Proofview.Unsafe.tclEVARS undef <*> @@ -1546,17 +1563,25 @@ let cl_rewrite_clause_newtac ?abs ?origsigma strat clause = let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in - let ty, is_hyp = - match clause with - | Some id -> Environ.named_type id env, Some id - | None -> concl, None + let ty = match clause with + | None -> concl + | Some id -> Environ.named_type id env + in + let env = match clause with + | None -> env + | Some id -> + (** Only consider variables not depending on [id] *) + let ctx = Environ.named_context env in + let filter decl = not (occur_var_in_decl env id decl) in + let nctx = List.filter filter ctx in + Environ.reset_with_named_context (Environ.val_of_named_context nctx) env in try let res = - cl_rewrite_clause_aux ?abs strat env [] sigma ty is_hyp + cl_rewrite_clause_aux ?abs strat env [] sigma ty clause in let sigma = match origsigma with None -> sigma | Some sigma -> sigma in - treat sigma (res, is_hyp) <*> + treat sigma res <*> (** For compatibility *) beta <*> opt_beta <*> Proofview.shelve_unifiable with @@ -1583,13 +1608,13 @@ let cl_rewrite_clause l left2right occs clause gl = let strat = rewrite_with left2right (general_rewrite_unif_flags ()) l occs in cl_rewrite_clause_strat strat clause gl -let apply_glob_constr c l2r occs = (); fun () env avoid t ty cstr evars -> +let apply_glob_constr c l2r occs = (); fun ({ state = () ; env = env } as input) -> let c sigma = let (sigma, c) = Pretyping.understand_tcc env sigma c in (sigma, (c, NoBindings)) in let flags = general_rewrite_unif_flags () in - apply_lemma l2r flags c None occs () env avoid t ty cstr evars + (apply_lemma l2r flags c None occs).strategy input let interp_glob_constr_list env = let make c = (); fun sigma -> @@ -1653,16 +1678,18 @@ let rec strategy_of_ast = function | Compose -> Strategies.seq | Choice -> Strategies.choice in f' s' t' - | StratConstr (c, b) -> apply_glob_constr (fst c) b AllOccurrences + | StratConstr (c, b) -> { strategy = apply_glob_constr (fst c) b AllOccurrences } | StratHints (old, id) -> if old then Strategies.old_hints id else Strategies.hints id - | StratTerms l -> - (fun () env avoid t ty cstr evars -> + | StratTerms l -> { strategy = + (fun ({ state = () ; env } as input) -> let l' = interp_glob_constr_list env (List.map fst l) in - Strategies.lemmas l' () env avoid t ty cstr evars) - | StratEval r -> - (fun () env avoid t ty cstr evars -> + (Strategies.lemmas l').strategy input) + } + | StratEval r -> { strategy = + (fun ({ state = () ; env ; evars } as input) -> let (sigma,r_interp) = Tacinterp.interp_redexp env (goalevars evars) r in - Strategies.reduce r_interp () env avoid t ty cstr (sigma,cstrevars evars)) + (Strategies.reduce r_interp).strategy { input with + evars = (sigma,cstrevars evars) }) } | StratFold c -> Strategies.fold_glob (fst c) @@ -1751,11 +1778,13 @@ let proper_projection r ty = it_mkLambda_or_LetIn app ctx let declare_projection n instance_id r = - let c,uctx = Universes.fresh_global_instance (Global.env()) r in let poly = Global.is_polymorphic r in - let ty = Retyping.get_type_of (Global.env ()) Evd.empty c in + let env = Global.env () in + let sigma = Evd.from_env env in + let evd,c = Evd.fresh_global env sigma r in + let ty = Retyping.get_type_of env sigma c in let term = proper_projection c ty in - let typ = Typing.type_of (Global.env ()) Evd.empty term in + let typ = Typing.unsafe_type_of env sigma term in let ctx, typ = decompose_prod_assum typ in let typ = let n = @@ -1777,18 +1806,19 @@ let declare_projection n instance_id r = in it_mkProd_or_LetIn ccl ctx in let typ = it_mkProd_or_LetIn typ ctx in + let pl, ctx = Evd.universe_context sigma in let cst = - Declare.definition_entry ~types:typ ~poly ~univs:(Univ.ContextSet.to_context uctx) - term + Declare.definition_entry ~types:typ ~poly ~univs:ctx term in ignore(Declare.declare_constant n (Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition)) let build_morphism_signature m = let env = Global.env () in - let m,ctx = Constrintern.interp_constr env Evd.empty m in - let sigma = Evd.from_env ~ctx env in - let t = Typing.type_of env sigma m in + let sigma = Evd.from_env env in + let m,ctx = Constrintern.interp_constr env sigma m in + let sigma = Evd.from_ctx ctx in + let t = Typing.unsafe_type_of env sigma m in let cstrs = let rec aux t = match kind_of_term t with @@ -1798,7 +1828,7 @@ let build_morphism_signature m = in aux t in let evars, t', sig_, cstrs = - PropGlobal.build_signature (Evd.empty, Evar.Set.empty) env t cstrs None in + PropGlobal.build_signature (sigma, Evar.Set.empty) env t cstrs None in let evd = ref evars in let _ = List.iter (fun (ty, rel) -> @@ -1815,9 +1845,10 @@ let build_morphism_signature m = let default_morphism sign m = let env = Global.env () in - let t = Typing.type_of env Evd.empty m in + let sigma = Evd.from_env env in + let t = Typing.unsafe_type_of env sigma m in let evars, _, sign, cstrs = - PropGlobal.build_signature (Evd.empty, Evar.Set.empty) env t (fst sign) (snd sign) + PropGlobal.build_signature (sigma, Evar.Set.empty) env t (fst sign) (snd sign) in let evars, morph = app_poly_check env evars PropGlobal.proper_type [| t; sign; m |] in let evars, mor = resolve_one_typeclass env (goalevars evars) morph in @@ -1848,9 +1879,9 @@ let add_morphism_infer glob m n = let poly = Flags.is_universe_polymorphism () in let instance_id = add_suffix n "_Proper" in let instance = build_morphism_signature m in - let evd = Evd.empty (*FIXME *) in + let evd = Evd.from_env (Global.env ()) in if Lib.is_modtype () then - let cst = Declare.declare_constant ~internal:Declare.KernelSilent instance_id + let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest instance_id (Entries.ParameterEntry (None,poly,(instance,Univ.UContext.empty),None), Decl_kinds.IsAssumption Decl_kinds.Logical) @@ -1967,13 +1998,14 @@ let general_rewrite_flags = { under_lambdas = false; on_morphisms = true } (** Setoid rewriting when called with "rewrite" *) let general_s_rewrite cl l2r occs (c,l) ~new_goals gl = let abs, evd, res, sort = get_hyp gl (c,l) cl l2r in - let unify () env evars t = unify_abs res l2r sort env evars t in + let unify env evars t = unify_abs res l2r sort env evars t in let app = apply_rule unify occs in let recstrat aux = Strategies.choice app (subterm true general_rewrite_flags aux) in let substrat = Strategies.fix recstrat in - let strat () env avoid t ty cstr evars = - let _, res = substrat ((), 0) env avoid t ty cstr evars in + let strat = { strategy = fun ({ state = () } as input) -> + let _, res = substrat.strategy { input with state = 0 } in (), res + } in let origsigma = project gl in init_setoid (); @@ -2011,7 +2043,7 @@ let setoid_proof ty fn fallback = try let rel, _, _ = decompose_app_rel env sigma concl in let evm = sigma in - let car = pi3 (List.hd (fst (Reduction.dest_prod env (Typing.type_of env evm rel)))) in + let car = pi3 (List.hd (fst (Reduction.dest_prod env (Typing.unsafe_type_of env evm rel)))) in (try init_setoid () with _ -> raise Not_found); fn env sigma car rel with e -> Proofview.tclZERO e @@ -2070,7 +2102,7 @@ let setoid_transitivity c = let setoid_symmetry_in id = Proofview.V82.tactic (fun gl -> - let ctype = pf_type_of gl (mkVar id) in + let ctype = pf_unsafe_type_of gl (mkVar id) in let binders,concl = decompose_prod_assum ctype in let (equiv, args) = decompose_app concl in let rec split_last_two = function diff --git a/tactics/rewrite.mli b/tactics/rewrite.mli index cae00f5a..40a18ac4 100644 --- a/tactics/rewrite.mli +++ b/tactics/rewrite.mli @@ -55,10 +55,7 @@ type rewrite_result = | Identity | Success of rewrite_result_info -type 'a pure_strategy = 'a -> Environ.env -> Id.t list -> constr -> types -> - (bool (* prop *) * constr option) -> evars -> 'a * rewrite_result - -type strategy = unit pure_strategy +type strategy val strategy_of_ast : (glob_constr_and_expr, raw_red_expr) strategy_ast -> strategy diff --git a/tactics/tacenv.ml b/tactics/tacenv.ml index 84c0a99b..09a98bc8 100644 --- a/tactics/tacenv.ml +++ b/tactics/tacenv.ml @@ -26,6 +26,8 @@ let interp_alias key = try KNmap.find key !alias_map with Not_found -> Errors.anomaly (str "Unknown tactic alias: " ++ KerName.print key) +let check_alias key = KNmap.mem key !alias_map + (** ML tactic extensions (TacML) *) type ml_tactic = @@ -43,7 +45,7 @@ end module MLTacMap = Map.Make(MLName) let pr_tacname t = - t.mltac_plugin ^ "::" ^ t.mltac_tactic + str t.mltac_plugin ++ str "::" ++ str t.mltac_tactic let tac_tab = ref MLTacMap.empty @@ -52,9 +54,9 @@ let register_ml_tactic ?(overwrite = false) s (t : ml_tactic) = if MLTacMap.mem s !tac_tab then if overwrite then let () = tac_tab := MLTacMap.remove s !tac_tab in - msg_warning (str ("Overwriting definition of tactic " ^ pr_tacname s)) + msg_warning (str "Overwriting definition of tactic " ++ pr_tacname s) else - Errors.anomaly (str ("Cannot redeclare tactic " ^ pr_tacname s ^ ".")) + Errors.anomaly (str "Cannot redeclare tactic " ++ pr_tacname s ++ str ".") in tac_tab := MLTacMap.add s t !tac_tab @@ -63,7 +65,7 @@ let interp_ml_tactic s = MLTacMap.find s !tac_tab with Not_found -> Errors.errorlabstrm "" - (str "The tactic " ++ str (pr_tacname s) ++ str " is not installed.") + (str "The tactic " ++ pr_tacname s ++ str " is not installed.") (***************************************************************************) (* Tactic registration *) @@ -73,34 +75,48 @@ let interp_ml_tactic s = open Nametab open Libobject +type ltac_entry = { + tac_for_ml : bool; + tac_body : glob_tactic_expr; + tac_redef : ModPath.t list; +} + let mactab = - Summary.ref (KNmap.empty : (bool * glob_tactic_expr) KNmap.t) + Summary.ref (KNmap.empty : ltac_entry KNmap.t) ~name:"tactic-definition" -let interp_ltac r = snd (KNmap.find r !mactab) +let ltac_entries () = !mactab + +let interp_ltac r = (KNmap.find r !mactab).tac_body + +let is_ltac_for_ml_tactic r = (KNmap.find r !mactab).tac_for_ml -let is_ltac_for_ml_tactic r = fst (KNmap.find r !mactab) +let add kn b t = + let entry = { tac_for_ml = b; tac_body = t; tac_redef = [] } in + mactab := KNmap.add kn entry !mactab -(* Declaration of the TAC-DEFINITION object *) -let add (kn,td) = mactab := KNmap.add kn td !mactab +let replace kn path t = + let (path, _, _) = KerName.repr path in + let entry _ e = { e with tac_body = t; tac_redef = path :: e.tac_redef } in + mactab := KNmap.modify kn entry !mactab let load_md i ((sp, kn), (local, id, b, t)) = match id with | None -> let () = if not local then Nametab.push_tactic (Until i) sp kn in - add (kn, (b,t)) -| Some kn -> add (kn, (b,t)) + add kn b t +| Some kn0 -> replace kn0 kn t let open_md i ((sp, kn), (local, id, b, t)) = match id with | None -> let () = if not local then Nametab.push_tactic (Exactly i) sp kn in - add (kn, (b,t)) -| Some kn -> add (kn, (b,t)) + add kn b t +| Some kn0 -> replace kn0 kn t let cache_md ((sp, kn), (local, id ,b, t)) = match id with | None -> let () = Nametab.push_tactic (Until 1) sp kn in - add (kn, (b,t)) -| Some kn -> add (kn, (b,t)) + add kn b t +| Some kn0 -> replace kn0 kn t let subst_kind subst id = match id with | None -> None diff --git a/tactics/tacenv.mli b/tactics/tacenv.mli index 29677fd4..2df6bb04 100644 --- a/tactics/tacenv.mli +++ b/tactics/tacenv.mli @@ -23,6 +23,9 @@ val register_alias : alias -> glob_tactic_expr -> unit val interp_alias : alias -> glob_tactic_expr (** Recover the the body of an alias. Raises an anomaly if it does not exist. *) +val check_alias : alias -> bool +(** Returns [true] if an alias is defined, false otherwise. *) + (** {5 Coq tactic definitions} *) val register_ltac : bool -> bool -> Id.t -> glob_tactic_expr -> unit @@ -41,6 +44,19 @@ val interp_ltac : KerName.t -> glob_tactic_expr (** Find a user-defined tactic by name. Raise [Not_found] if it is absent. *) val is_ltac_for_ml_tactic : KerName.t -> bool +(** Whether the tactic is defined from ML-side *) + +type ltac_entry = { + tac_for_ml : bool; + (** Whether the tactic is defined from ML-side *) + tac_body : glob_tactic_expr; + (** The current body of the tactic *) + tac_redef : ModPath.t list; + (** List of modules redefining the tactic in reverse chronological order *) +} + +val ltac_entries : unit -> ltac_entry KNmap.t +(** Low-level access to all Ltac entries currently defined. *) (** {5 ML tactic extensions} *) diff --git a/tactics/tacintern.ml b/tactics/tacintern.ml index 5cc4c835..fb22da83 100644 --- a/tactics/tacintern.ml +++ b/tactics/tacintern.ml @@ -341,7 +341,7 @@ let intern_typed_pattern ist p = let rec intern_typed_pattern_or_ref_with_occurrences ist (l,p) = let interp_ref r = - try l, Inl (intern_evaluable ist r) + try Inl (intern_evaluable ist r) with e when Logic.catchable_exception e -> (* Compatibility. In practice, this means that the code above is useless. Still the idea of having either an evaluable @@ -356,19 +356,19 @@ let rec intern_typed_pattern_or_ref_with_occurrences ist (l,p) = let c = Constrintern.interp_reference sign r in match c with | GRef (_,r,None) -> - l, Inl (ArgArg (evaluable_of_global_reference ist.genv r,None)) + Inl (ArgArg (evaluable_of_global_reference ist.genv r,None)) | GVar (_,id) -> let r = evaluable_of_global_reference ist.genv (VarRef id) in - l, Inl (ArgArg (r,None)) + Inl (ArgArg (r,None)) | _ -> - l, Inr ((c,None),dummy_pat) in - match p with + Inr ((c,None),dummy_pat) in + (l, match p with | Inl r -> interp_ref r | Inr (CAppExpl(_,(None,r,None),[])) -> (* We interpret similarly @ref and ref *) interp_ref (AN r) | Inr c -> - l, Inr (intern_typed_pattern ist c) + Inr (intern_typed_pattern ist c)) (* This seems fairly hacky, but it's the first way I've found to get proper globalization of [unfold]. --adamc *) @@ -809,11 +809,24 @@ let pr_ltac_fun_arg = function let print_ltac id = try let kn = Nametab.locate_tactic id in - let l,t = split_ltac_fun (Tacenv.interp_ltac kn) in + let entries = Tacenv.ltac_entries () in + let tac = KNmap.find kn entries in + let filter mp = + try Some (Nametab.shortest_qualid_of_module mp) + with Not_found -> None + in + let mods = List.map_filter filter tac.Tacenv.tac_redef in + let redefined = match mods with + | [] -> mt () + | mods -> + let redef = prlist_with_sep fnl pr_qualid mods in + fnl () ++ str "Redefined by:" ++ fnl () ++ redef + in + let l,t = split_ltac_fun tac.Tacenv.tac_body in hv 2 ( hov 2 (str "Ltac" ++ spc() ++ pr_qualid id ++ prlist pr_ltac_fun_arg l ++ spc () ++ str ":=") - ++ spc() ++ Pptactic.pr_glob_tactic (Global.env ()) t) + ++ spc() ++ Pptactic.pr_glob_tactic (Global.env ()) t) ++ redefined with Not_found -> errorlabstrm "print_ltac" diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml index f29680e1..355745d9 100644 --- a/tactics/tacinterp.ml +++ b/tactics/tacinterp.ml @@ -44,8 +44,8 @@ open Proofview.Notations let safe_msgnl s = Proofview.NonLogical.catch - (Proofview.NonLogical.print (s++fnl())) - (fun _ -> Proofview.NonLogical.print (str "bug in the debugger: an exception is raised while printing debug information"++fnl())) + (Proofview.NonLogical.print_debug (s++fnl())) + (fun _ -> Proofview.NonLogical.print_warning (str "bug in the debugger: an exception is raised while printing debug information"++fnl())) type value = tlevel generic_argument @@ -557,7 +557,9 @@ let interp_gen kind ist allow_patvar flags env sigma (c,ce) = ltac_vars = constr_context; ltac_bound = Id.Map.domain ist.lfun; } in - intern_gen kind ~allow_patvar ~ltacvars env c + let kind_for_intern = + 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 @@ -678,7 +680,19 @@ let interp_constr_with_occurrences ist env sigma (occs,c) = let interp_closed_typed_pattern_with_occurrences ist env sigma (occs, a) = let p = match a with - | Inl b -> Inl (interp_evaluable ist env sigma b) + | Inl (ArgVar (loc,id)) -> + (* This is the encoding of an ltac var supposed to be bound + prioritary to an evaluable reference and otherwise to a constr + (it is an encoding to satisfy the "union" type given to Simpl) *) + let coerce_eval_ref_or_constr x = + try Inl (coerce_to_evaluable_ref env x) + with CannotCoerceTo _ -> + let c = coerce_to_closed_constr env x in + Inr (pi3 (pattern_of_constr env sigma c)) in + (try try_interp_ltac_var coerce_eval_ref_or_constr ist (Some (env,sigma)) (loc,id) + with Not_found -> + error_global_not_found_loc loc (qualid_of_ident id)) + | Inl (ArgArg _ as b) -> Inl (interp_evaluable ist env sigma b) | Inr c -> Inr (pi3 (interp_typed_pattern ist env sigma c)) in interp_occurrences ist occs, p @@ -734,7 +748,7 @@ let interp_may_eval f ist env sigma = function str "Unbound context identifier" ++ pr_id s ++ str".")) | ConstrTypeOf c -> let (sigma,c_interp) = f ist env sigma c in - Typing.e_type_of ~refresh:true env sigma c_interp + Typing.type_of ~refresh:true env sigma c_interp | ConstrTerm c -> try f ist env sigma c @@ -971,10 +985,10 @@ let interp_induction_arg ist gl arg = let try_cast_id id' = if Tactics.is_quantified_hypothesis id' gl then keep,ElimOnIdent (loc,id') - else - (try keep,ElimOnConstr (fun env sigma -> sigma,(constr_of_id env id',NoBindings)) + else keep, ElimOnConstr (fun env sigma -> + try sigma, (constr_of_id env id', NoBindings) with Not_found -> - user_err_loc (loc,"", + user_err_loc (loc, "interp_induction_arg", pr_id id ++ strbrk " binds to " ++ pr_id id' ++ strbrk " which is neither a declared or a quantified hypothesis.")) in try @@ -1026,11 +1040,12 @@ let interp_context ctxt = in_gen (topwit wit_constr_context) ctxt (* Reads a pattern by substituting vars of lfun *) let use_types = false -let eval_pattern lfun ist env sigma (_,pat as c) = +let eval_pattern lfun ist env sigma ((glob,_),pat as c) = + let bound_names = bound_glob_vars glob in if use_types then - pi3 (interp_typed_pattern ist env sigma c) + (bound_names,pi3 (interp_typed_pattern ist env sigma c)) else - instantiate_pattern env sigma lfun pat + (bound_names,instantiate_pattern env sigma lfun pat) let read_pattern lfun ist env sigma = function | Subterm (b,ido,c) -> Subterm (b,ido,eval_pattern lfun ist env sigma c) @@ -1040,8 +1055,8 @@ let read_pattern lfun ist env sigma = function let cons_and_check_name id l = if Id.List.mem id l then user_err_loc (dloc,"read_match_goal_hyps", - strbrk ("Hypothesis pattern-matching variable "^(Id.to_string id)^ - " used twice in the same pattern.")) + str "Hypothesis pattern-matching variable " ++ pr_id id ++ + str " used twice in the same pattern.") else id::l let rec read_match_goal_hyps lfun ist env sigma lidh = function @@ -1123,7 +1138,7 @@ and eval_tactic ist tac : unit Proofview.tactic = match tac with interp_message ist s >>= fun msg -> return (hov 0 msg , hov 0 msg) in - let print (_,msgnl) = Proofview.(tclLIFT (NonLogical.print msgnl)) in + let print (_,msgnl) = Proofview.(tclLIFT (NonLogical.print_info msgnl)) in let log (msg,_) = Proofview.Trace.log (fun () -> msg) in let break = Proofview.tclLIFT (db_breakpoint (curr_debug ist) s) in Ftactic.run msgnl begin fun msgnl -> @@ -1492,11 +1507,11 @@ and tactic_of_value ist vle = extra = TacStore.set ist.extra f_trace []; } in let tac = name_if_glob appl (eval_tactic ist t) in catch_error_tac trace tac - | (VFun _|VRec _) -> Proofview.tclZERO (UserError ("" , str "A fully applied tactic is expected.")) + | (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 eval_tactic ist tac - else Proofview.tclZERO (UserError ("" , str"Expression does not evaluate to a tactic.")) + else Tacticals.New.tclZEROMSG (str "Expression does not evaluate to a tactic.") (* Interprets the clauses of a recursive LetIn *) and interp_letrec ist llc u = @@ -1752,10 +1767,8 @@ and interp_ltac_constr ist e : constr Ftactic.t = Ftactic.return cresult with CannotCoerceTo _ -> let env = Proofview.Goal.env gl in - Proofview.tclZERO (UserError ( "", - errorlabstrm "" - (str "Must evaluate to a closed term" ++ fnl() ++ - str "offending expression: " ++ fnl() ++ pr_inspect env e result))) + Tacticals.New.tclZEROMSG (str "Must evaluate to a closed term" ++ fnl() ++ + str "offending expression: " ++ fnl() ++ pr_inspect env e result) end diff --git a/tactics/tactic_matching.mli b/tactics/tactic_matching.mli index abeb47c3..d8e6dd0a 100644 --- a/tactics/tactic_matching.mli +++ b/tactics/tactic_matching.mli @@ -32,7 +32,7 @@ val match_term : Environ.env -> Evd.evar_map -> Term.constr -> - (Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list -> + (Tacexpr.binding_bound_vars * Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list -> Tacexpr.glob_tactic_expr t Proofview.tactic (** [match_goal env sigma hyps concl rules] matches the goal @@ -45,5 +45,5 @@ val match_goal: Evd.evar_map -> Context.named_context -> Term.constr -> - (Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list -> + (Tacexpr.binding_bound_vars * Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list -> Tacexpr.glob_tactic_expr t Proofview.tactic diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 9b16fe3f..bc82e9ef 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -420,7 +420,7 @@ module New = struct (* Try the first tactic that does not fail in a list of tactics *) let rec tclFIRST = function - | [] -> tclZERO (Errors.UserError ("Tacticals.New.tclFIRST",str"No applicable tactic.")) + | [] -> tclZEROMSG (str"No applicable tactic.") | t::rest -> tclORELSE0 t (tclFIRST rest) let rec tclFIRST_PROGRESS_ON tac = function @@ -430,10 +430,7 @@ module New = struct let rec tclDO n t = if n < 0 then - tclZERO (Errors.UserError ( - "Refiner.tclDO", - str"Wrong argument : Do needs a positive integer.") - ) + tclZEROMSG (str"Wrong argument : Do needs a positive integer.") else if n = 0 then tclUNIT () else if n = 1 then t else tclTHEN t (tclDO (n-1) t) @@ -456,7 +453,7 @@ module New = struct let tclCOMPLETE t = t >>= fun res -> (tclINDEPENDENT - (tclZERO (Errors.UserError ("",str"Proof is not complete."))) + (tclZEROMSG (str"Proof is not complete.")) ) <*> tclUNIT res @@ -596,12 +593,14 @@ module New = struct (* c should be of type A1->.. An->B with B an inductive definition *) let general_elim_then_using mk_elim isrec allnames tac predicate ind (c, t) = - Proofview.Goal.nf_enter begin fun gl -> - let indclause = Tacmach.New.of_old (fun gl -> mk_clenv_from gl (c, t)) gl in - (** FIXME: evar leak. *) + Proofview.Goal.nf_enter + begin fun gl -> let sigma, elim = Tacmach.New.of_old (mk_elim ind) gl in + Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) + (Proofview.Goal.nf_enter begin fun gl -> + let indclause = Tacmach.New.of_old (fun gl -> mk_clenv_from gl (c, t)) gl in (* applying elimination_scheme just a little modified *) - let elimclause = Tacmach.New.of_old (fun gls -> mk_clenv_from gls (elim,Tacmach.New.pf_type_of gl elim)) gl in + let elimclause = Tacmach.New.of_old (fun gls -> mk_clenv_from gls (elim,Tacmach.New.pf_unsafe_type_of gl elim)) gl in let indmv = match kind_of_term (last_arg elimclause.templval.Evd.rebus) with | Meta mv -> mv @@ -618,7 +617,8 @@ module New = struct | Var id -> string_of_id id | _ -> "\b" in - error ("The elimination combinator " ^ name_elim ^ " is unknown.") + errorlabstrm "Tacticals.general_elim_then_using" + (str "The elimination combinator " ++ str name_elim ++ str " is unknown.") in let elimclause' = clenv_fchain indmv elimclause indclause in let branchsigns = compute_construtor_signatures isrec ind in @@ -649,11 +649,11 @@ module New = struct Proofview.tclTHEN (Clenvtac.clenv_refine false clenv') (Proofview.tclEXTEND [] tclIDTAC branchtacs) - end + end) end let elimination_then tac c = Proofview.Goal.nf_enter begin fun gl -> - let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in + let (ind,t) = pf_reduce_to_quantified_ind gl (pf_unsafe_type_of gl c) in let isrec,mkelim = match (Global.lookup_mind (fst (fst ind))).mind_record with | None -> true,gl_make_elim diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 7484139c..2a46efd8 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -109,6 +109,44 @@ let _ = optread = (fun () -> !clear_hyp_by_default) ; optwrite = (fun b -> clear_hyp_by_default := b) } +(* Compatibility option useful in developments using apply intensively + in ltac code *) + +let universal_lemma_under_conjunctions = ref false + +let accept_universal_lemma_under_conjunctions () = + !universal_lemma_under_conjunctions + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "trivial unification in tactics applying under conjunctions"; + optkey = ["Universal";"Lemma";"Under";"Conjunction"]; + optread = (fun () -> !universal_lemma_under_conjunctions) ; + optwrite = (fun b -> universal_lemma_under_conjunctions := b) } + +(* The following boolean governs what "intros []" do on examples such + as "forall x:nat*nat, x=x"; if true, it behaves as "intros [? ?]"; + if false, it behaves as "intro H; case H; clear H" for fresh H. + Kept as false for compatibility. + *) + +let bracketing_last_or_and_intro_pattern = ref false + +let use_bracketing_last_or_and_intro_pattern () = + !bracketing_last_or_and_intro_pattern + && Flags.version_strictly_greater Flags.V8_4 + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "bracketing last or-and introduction pattern"; + optkey = ["Bracketing";"Last";"Introduction";"Pattern"]; + optread = (fun () -> !bracketing_last_or_and_intro_pattern) ; + optwrite = (fun b -> bracketing_last_or_and_intro_pattern := b) } + (*********************************************) (* Tactics *) (*********************************************) @@ -139,7 +177,8 @@ let introduction ?(check=true) id = let store = Proofview.Goal.extra gl in let env = Proofview.Goal.env gl in let () = if check && mem_named_context id hyps then - error ("Variable " ^ Id.to_string id ^ " is already declared.") + errorlabstrm "Tactics.introduction" + (str "Variable " ++ pr_id id ++ str " is already declared.") in match kind_of_term (whd_evar sigma concl) with | Prod (_, t, b) -> unsafe_intro env store (id, None, t) b @@ -157,7 +196,7 @@ let convert_concl ?(check=true) ty k = Proofview.Refine.refine ~unsafe:true begin fun sigma -> let sigma = if check then begin - ignore (Typing.type_of env sigma ty); + ignore (Typing.unsafe_type_of env sigma ty); let sigma,b = Reductionops.infer_conv env sigma ty conclty in if not b then error "Not convertible."; sigma @@ -184,8 +223,9 @@ let convert_hyp_no_check = convert_hyp ~check:false let convert_gen pb x y = Proofview.Goal.enter begin fun gl -> try - let sigma = Tacmach.New.pf_apply Evd.conversion gl pb x y in - Proofview.Unsafe.tclEVARS sigma + let sigma, b = Tacmach.New.pf_apply (Reductionops.infer_conv ~pb) gl x y in + if b then Proofview.Unsafe.tclEVARS sigma + else Tacticals.New.tclFAIL 0 (str "Not convertible") with (* Reduction.NotConvertible *) _ -> (** FIXME: Sometimes an anomaly is raised from conversion *) Tacticals.New.tclFAIL 0 (str "Not convertible") @@ -627,7 +667,7 @@ let change_on_subterm cv_pb deep t where env sigma c = env sigma c in if !mayneedglobalcheck then begin - try ignore (Typing.type_of env sigma c) + try ignore (Typing.unsafe_type_of env sigma c) with e when catchable_exception e -> error "Replacement would lead to an ill-typed term." end; @@ -687,12 +727,11 @@ let reduction_clause redexp cl = let reduce redexp cl goal = let cl = concrete_clause_of (fun () -> pf_ids_of_hyps goal) cl in let redexps = reduction_clause redexp cl in + let check = match redexp with Fold _ | Pattern _ -> true | _ -> false in let tac = tclMAP (fun (where,redexp) -> - e_reduct_option ~check:true + e_reduct_option ~check (Redexpr.reduction_of_red_expr (pf_env goal) redexp) where) redexps in - match redexp with - | Fold _ | Pattern _ -> with_check tac goal - | _ -> tac goal + if check then with_check tac goal else tac goal (* Unfolding occurrences of a constant *) @@ -751,8 +790,7 @@ let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = (intro_then_gen name_flag move_flag false dep_flag tac)) begin function (e, info) -> match e with | RefinerError IntroNeedsProduct -> - Proofview.tclZERO - (Errors.UserError("Intro",str "No product even after head-reduction.")) + Tacticals.New.tclZEROMSG (str "No product even after head-reduction.") | e -> Proofview.tclZERO ~info e end end @@ -800,16 +838,23 @@ let intro_forthcoming_then_gen name_flag move_flag dep_flag n bound tac = aux n [] let get_next_hyp_position id gl = - let rec get_next_hyp_position id = function + let rec aux = function | [] -> raise (RefinerError (NoSuchHyp id)) | (hyp,_,_) :: right -> if Id.equal hyp id then match right with (id,_,_)::_ -> MoveBefore id | [] -> MoveLast else - get_next_hyp_position id right + aux right + in + aux (Proofview.Goal.hyps (Proofview.Goal.assume gl)) + +let get_previous_hyp_position id gl = + let rec aux dest = function + | [] -> raise (RefinerError (NoSuchHyp id)) + | (hyp,_,_) :: right -> + if Id.equal hyp id then dest else aux (MoveAfter hyp) right in - let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in - get_next_hyp_position id hyps + aux MoveLast (Proofview.Goal.hyps (Proofview.Goal.assume gl)) let intro_replacing id = Proofview.Goal.enter begin fun gl -> @@ -979,7 +1024,7 @@ let cut c = let is_sort = try (** Backward compat: ensure that [c] is well-typed. *) - let typ = Typing.type_of env sigma c in + let typ = Typing.unsafe_type_of env sigma c in let typ = whd_betadeltaiota env sigma typ in match kind_of_term typ with | Sort _ -> true @@ -1224,7 +1269,7 @@ let find_ind_eliminator ind s gl = evd, c let find_eliminator c gl = - let ((ind,u),t) = Tacmach.New.pf_reduce_to_quantified_ind gl (Tacmach.New.pf_type_of gl c) in + let ((ind,u),t) = Tacmach.New.pf_reduce_to_quantified_ind gl (Tacmach.New.pf_unsafe_type_of gl c) in if is_nonrec ind then raise IsNonrec; let evd, c = find_ind_eliminator ind (Tacticals.New.elimination_sort_of_goal gl) gl in evd, {elimindex = None; elimbody = (c,NoBindings); @@ -1332,7 +1377,7 @@ let make_projection env sigma params cstr sign elim i n c u = (* to avoid surprising unifications, excludes flexible projection types or lambda which will be instantiated by Meta/Evar *) && not (isEvar (fst (whd_betaiota_stack sigma t))) - && not (isRel t && destRel t > n-i) + && (accept_universal_lemma_under_conjunctions () || not (isRel t)) then let t = lift (i+1-n) t in let abselim = beta_applist (elim,params@[t;branch]) in @@ -1358,7 +1403,7 @@ let make_projection env sigma params cstr sign elim i n c u = | None -> None in elim -let descend_in_conjunctions avoid tac exit c = +let descend_in_conjunctions avoid tac (err, info) c = Proofview.Goal.nf_enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in @@ -1392,9 +1437,8 @@ let descend_in_conjunctions avoid tac exit c = (* Might be ill-typed due to forbidden elimination. *) Tacticals.New.onLastHypId (tac (not isrec))] end)) - | None -> - raise Exit - with RefinerError _|UserError _|Exit -> exit () + | None -> Proofview.tclZERO ~info err + with RefinerError _|UserError _ -> Proofview.tclZERO ~info err end (****************************************************) @@ -1417,7 +1461,15 @@ let solve_remaining_apply_goals = with Not_found -> Proofview.tclUNIT () else Proofview.tclUNIT () end - + +let tclORELSEOPT t k = + Proofview.tclORELSE t + (fun e -> match k e with + | None -> + let (e, info) = e in + Proofview.tclZERO ~info e + | Some tac -> tac) + let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind)) = Proofview.Goal.nf_enter begin fun gl -> let concl = Proofview.Goal.concl gl in @@ -1442,50 +1494,46 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind)) with UserError _ as exn -> Proofview.tclZERO exn in - Proofview.tclORELSE + let rec try_red_apply thm_ty (exn0, info) = + try + (* Try to head-reduce the conclusion of the theorem *) + let red_thm = try_red_product env sigma thm_ty in + tclORELSEOPT + (try_apply red_thm concl_nprod) + (function (e, info) -> match e with + | PretypeError _|RefinerError _|UserError _|Failure _ -> + Some (try_red_apply red_thm (exn0, info)) + | _ -> None) + with Redelimination -> + (* Last chance: if the head is a variable, apply may try + second order unification *) + let info = Loc.add_loc info loc in + let tac = + if with_destruct then + descend_in_conjunctions [] + (fun b id -> + Tacticals.New.tclTHEN + (try_main_apply b (mkVar id)) + (Proofview.V82.tactic (thin [id]))) + (exn0, info) c + else + Proofview.tclZERO ~info exn0 in + if not (Int.equal concl_nprod 0) then + tclORELSEOPT + (try_apply thm_ty 0) + (function (e, info) -> match e with + | PretypeError _|RefinerError _|UserError _|Failure _-> + Some tac + | _ -> None) + else + tac + in + tclORELSEOPT (try_apply thm_ty0 concl_nprod) (function (e, info) -> match e with - | PretypeError _|RefinerError _|UserError _|Failure _ as exn0 -> - let rec try_red_apply thm_ty = - try - (* Try to head-reduce the conclusion of the theorem *) - let red_thm = try_red_product env sigma thm_ty in - Proofview.tclORELSE - (try_apply red_thm concl_nprod) - (function (e, info) -> match e with - | PretypeError _|RefinerError _|UserError _|Failure _ -> - try_red_apply red_thm - | exn -> iraise (exn, info)) - with Redelimination -> - (* Last chance: if the head is a variable, apply may try - second order unification *) - let tac = - if with_destruct then - descend_in_conjunctions [] - (fun b id -> - Tacticals.New.tclTHEN - (try_main_apply b (mkVar id)) - (Proofview.V82.tactic (thin [id]))) - (fun _ -> - let info = Loc.add_loc info loc in - Proofview.tclZERO ~info exn0) c - else - let info = Loc.add_loc info loc in - Proofview.tclZERO ~info exn0 in - if not (Int.equal concl_nprod 0) then - try - Proofview.tclORELSE - (try_apply thm_ty 0) - (function (e, info) -> match e with - | PretypeError _|RefinerError _|UserError _|Failure _-> - tac - | exn -> iraise (exn, info)) - with UserError _ | Exit -> - tac - else - tac - in try_red_apply thm_ty0 - | exn -> iraise (exn, info)) + | PretypeError _|RefinerError _|UserError _|Failure _ -> + Some (try_red_apply thm_ty0 (e, info)) + | _ -> None) end in Tacticals.New.tclTHENLIST [ @@ -1596,10 +1644,10 @@ let apply_in_once sidecond_first with_delta with_destruct with_evars naming tac id ]) with e when with_destruct && Errors.noncritical e -> - let e = Errors.push e in + let (e, info) = Errors.push e in (descend_in_conjunctions [targetid] (fun b id -> aux (id::idstoclear) b (mkVar id)) - (fun _ -> iraise e) c) + (e, info) c) end in aux [] with_destruct d @@ -1636,7 +1684,7 @@ let apply_in_delayed_once sidecond_first with_delta with_destruct with_evars nam let cut_and_apply c = Proofview.Goal.nf_enter begin fun gl -> - match kind_of_term (Tacmach.New.pf_hnf_constr gl (Tacmach.New.pf_type_of gl c)) with + match kind_of_term (Tacmach.New.pf_hnf_constr gl (Tacmach.New.pf_unsafe_type_of gl c)) with | Prod (_,c1,c2) when not (dependent (mkRel 1) c2) -> let concl = Proofview.Goal.concl gl in let env = Tacmach.New.pf_env gl in @@ -1669,7 +1717,7 @@ let exact_check c = let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in - let sigma, ct = Typing.e_type_of env sigma c in + let sigma, ct = Typing.type_of env sigma c in Proofview.Unsafe.tclEVARS sigma <*> Tacticals.New.tclTHEN (convert_leq ct concl) (new_exact_no_check c) end @@ -1818,7 +1866,7 @@ let specialize (c,lbind) g = let evd = Typeclasses.resolve_typeclasses (pf_env g) (project g) in tclEVARS evd, nf_evar evd c else - let clause = pf_apply make_clenv_binding g (c,pf_type_of g c) lbind in + let clause = pf_apply make_clenv_binding g (c,pf_unsafe_type_of g c) lbind in let flags = { (default_unify_flags ()) with resolve_evars = true } in let clause = clenv_unify_meta_types ~flags clause in let (thd,tstack) = whd_nored_stack clause.evd (clenv_value clause) in @@ -1838,11 +1886,11 @@ let specialize (c,lbind) g = | Var id when Id.List.mem id (pf_ids_of_hyps g) -> tclTHEN tac (tclTHENFIRST - (fun g -> Proofview.V82.of_tactic (assert_before_replacing id (pf_type_of g term)) g) + (fun g -> Proofview.V82.of_tactic (assert_before_replacing id (pf_unsafe_type_of g term)) g) (exact_no_check term)) g | _ -> tclTHEN tac (tclTHENLAST - (fun g -> Proofview.V82.of_tactic (cut (pf_type_of g term)) g) + (fun g -> Proofview.V82.of_tactic (cut (pf_unsafe_type_of g term)) g) (exact_no_check term)) g (* Keeping only a few hypotheses *) @@ -1871,8 +1919,8 @@ let check_number_of_constructors expctdnumopt i nconstr = if Int.equal i 0 then error "The constructors are numbered starting from 1."; begin match expctdnumopt with | Some n when not (Int.equal n nconstr) -> - error ("Not an inductive goal with "^ - string_of_int n ^ String.plural n " constructor"^".") + errorlabstrm "Tactics.check_number_of_constructors" + (str "Not an inductive goal with " ++ int n ++ str (String.plural n " constructor") ++ str ".") | _ -> () end; if i > nconstr then error "Not enough constructors." @@ -1977,7 +2025,7 @@ let my_find_eq_data_decompose gl t = let intro_decomp_eq loc l thin tac id = Proofview.Goal.nf_enter begin fun gl -> let c = mkVar id in - let t = Tacmach.New.pf_type_of gl c in + let t = Tacmach.New.pf_unsafe_type_of gl c in let _,t = Tacmach.New.pf_reduce_to_quantified_ind gl t in match my_find_eq_data_decompose gl t with | Some (eq,u,eq_args) -> @@ -1991,7 +2039,7 @@ let intro_decomp_eq loc l thin tac id = let intro_or_and_pattern loc bracketed ll thin tac id = Proofview.Goal.enter begin fun gl -> let c = mkVar id in - let t = Tacmach.New.pf_type_of gl c in + let t = Tacmach.New.pf_unsafe_type_of gl c in let ((ind,u),t) = Tacmach.New.pf_reduce_to_quantified_ind gl t in let nv = constructors_nrealargs ind in let ll = fix_empty_or_and_pattern (Array.length nv) ll in @@ -2010,7 +2058,7 @@ let rewrite_hyp assert_style l2r id = let clear_var_and_eq c = tclTHEN (clear [id]) (clear [destVar c]) in Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in - let type_of = Tacmach.New.pf_type_of gl in + let type_of = Tacmach.New.pf_unsafe_type_of gl in let whd_betadeltaiota = Tacmach.New.pf_apply whd_betadeltaiota gl in let t = whd_betadeltaiota (type_of (mkVar id)) in match match_with_equality_type t with @@ -2074,7 +2122,7 @@ let make_tmp_naming avoid l = function case of IntroFresh, we should use check_thin_clash_then anyway to prevent the case of an IntroFresh precisely using the wild_id *) | IntroWildcard -> NamingBasedOn (wild_id,avoid@explicit_intro_names l) - | _ -> NamingAvoid(avoid@explicit_intro_names l) + | pat -> NamingAvoid(avoid@explicit_intro_names ((dloc,IntroAction pat)::l)) let fit_bound n = function | None -> true @@ -2088,6 +2136,21 @@ let exceed_bound n = function to ensure that dependent hypotheses are cleared in the right dependency order (see bug #1000); we use fresh names, not used in the tactic, for the hyps to clear *) + (* In [intro_patterns_core b avoid ids thin destopt bound n tac patl]: + [b]: compatibility flag, if false at toplevel, do not complete incomplete + trailing toplevel or_and patterns (as in "intros []", see + [bracketing_last_or_and_intro_pattern]) + [avoid]: names to avoid when creating an internal name + [ids]: collect introduced names for possible use by the [tac] continuation + [thin]: collect names to erase at the end + [destopt]: position in the context where to introduce the hypotheses + [bound]: number of pending intros to do in the current or-and pattern, + with remembering of [b] flag if at toplevel + [n]: number of introduction done in the current or-and pattern + [tac]: continuation tactic + [patl]: introduction patterns to interpret + *) + let rec intro_patterns_core b avoid ids thin destopt bound n tac = function | [] when fit_bound n bound -> tac ids thin @@ -2105,31 +2168,33 @@ let rec intro_patterns_core b avoid ids thin destopt bound n tac = function (n+List.length ids) tac l) | IntroAction pat -> intro_then_gen (make_tmp_naming avoid l pat) - MoveLast true false + destopt true false (intro_pattern_action loc (b || not (List.is_empty l)) false pat thin + destopt (fun thin bound' -> intro_patterns_core b avoid ids thin destopt bound' 0 (fun ids thin -> intro_patterns_core b avoid ids thin destopt bound (n+1) tac l))) | IntroNaming pat -> - intro_pattern_naming loc b avoid ids pat thin destopt bound n tac l + intro_pattern_naming loc b avoid ids pat thin destopt bound (n+1) tac l + (* Pi-introduction rule, used backwards *) and intro_pattern_naming loc b avoid ids pat thin destopt bound n tac l = match pat with | IntroIdentifier id -> check_thin_clash_then id thin avoid (fun thin -> intro_then_gen (NamingMustBe (loc,id)) destopt true false - (fun id -> intro_patterns_core b avoid (id::ids) thin destopt bound (n+1) tac l)) + (fun id -> intro_patterns_core b avoid (id::ids) thin destopt bound n tac l)) | IntroAnonymous -> intro_then_gen (NamingAvoid (avoid@explicit_intro_names l)) destopt true false - (fun id -> intro_patterns_core b avoid (id::ids) thin destopt bound (n+1) tac l) + (fun id -> intro_patterns_core b avoid (id::ids) thin destopt bound n tac l) | IntroFresh id -> (* todo: avoid thinned names to interfere with generation of fresh name *) intro_then_gen (NamingBasedOn (id, avoid@explicit_intro_names l)) destopt true false - (fun id -> intro_patterns_core b avoid (id::ids) thin destopt bound (n+1) tac l) + (fun id -> intro_patterns_core b avoid (id::ids) thin destopt bound n tac l) -and intro_pattern_action loc b style pat thin tac id = match pat with +and intro_pattern_action loc b style pat thin destopt tac id = match pat with | IntroWildcard -> tac ((loc,id)::thin) None [] | IntroOrAndPattern ll -> @@ -2142,7 +2207,13 @@ and intro_pattern_action loc b style pat thin tac id = match pat with (rewrite_hyp style l2r id) (tac thin None []) | IntroApplyOn (f,(loc,pat)) -> - let naming,tac_ipat = prepare_intros_loc loc (IntroIdentifier id) pat in + let naming,tac_ipat = + prepare_intros_loc loc (IntroIdentifier id) destopt pat in + let doclear = + if naming = NamingMustBe (loc,id) then + Proofview.tclUNIT () (* apply_in_once do a replacement *) + else + Proofview.V82.tactic (clear [id]) in Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in @@ -2151,36 +2222,31 @@ and intro_pattern_action loc b style pat thin tac id = match pat with (Tacticals.New.tclTHENFIRST (* Skip the side conditions of the apply *) (apply_in_once false true true true naming id - (None,(sigma,(c,NoBindings))) tac_ipat) (tac thin None [])) + (None,(sigma,(c,NoBindings))) + (fun id -> Tacticals.New.tclTHEN doclear (tac_ipat id))) + (tac thin None [])) sigma end -and prepare_intros_loc loc dft = function +and prepare_intros_loc loc dft destopt = function | IntroNaming ipat -> prepare_naming loc ipat, - (fun _ -> Proofview.tclUNIT ()) + (fun id -> Proofview.V82.tactic (move_hyp id destopt)) | IntroAction ipat -> prepare_naming loc dft, (let tac thin bound = - intro_patterns_core true [] [] thin MoveLast bound 0 + intro_patterns_core true [] [] thin destopt bound 0 (fun _ l -> clear_wildcards l) in - fun id -> intro_pattern_action loc true true ipat [] tac id) + fun id -> intro_pattern_action loc true true ipat [] destopt tac id) | IntroForthcoming _ -> user_err_loc (loc,"",str "Introduction pattern for one hypothesis expected.") let intro_patterns_bound_to n destopt = intro_patterns_core true [] [] [] destopt - (Some (true,n)) 0 (fun _ -> clear_wildcards) - -(* The following boolean governs what "intros []" do on examples such - as "forall x:nat*nat, x=x"; if true, it behaves as "intros [? ?]"; - if false, it behaves as "intro H; case H; clear H" for fresh H. - Kept as false for compatibility. - *) -let bracketing_last_or_and_intro_pattern = false + (Some (true,n)) 0 (fun _ l -> clear_wildcards l) let intro_patterns_to destopt = - intro_patterns_core bracketing_last_or_and_intro_pattern + intro_patterns_core (use_bracketing_last_or_and_intro_pattern ()) [] [] [] destopt None 0 (fun _ l -> clear_wildcards l) let intro_pattern_to destopt pat = @@ -2197,23 +2263,24 @@ let intros_patterns = function (* Forward reasoning *) (**************************) -let prepare_intros dft = function +let prepare_intros dft destopt = function | None -> prepare_naming dloc dft, (fun _id -> Proofview.tclUNIT ()) - | Some (loc,ipat) -> prepare_intros_loc loc dft ipat + | Some (loc,ipat) -> prepare_intros_loc loc dft destopt ipat let ipat_of_name = function | Anonymous -> None | Name id -> Some (dloc, IntroNaming (IntroIdentifier id)) - let head_ident c = +let head_ident c = let c = fst (decompose_app ((strip_lam_assum c))) in if isVar c then Some (destVar c) else None -let assert_as first ipat c = - let naming,tac = prepare_intros IntroAnonymous ipat in - let repl = do_replace (head_ident c) naming in - if first then assert_before_then_gen repl naming c tac - else assert_after_then_gen repl naming c tac +let assert_as first hd ipat t = + let naming,tac = prepare_intros IntroAnonymous MoveLast ipat in + let repl = do_replace hd naming in + let tac = if repl then (fun id -> Proofview.tclUNIT ()) else tac in + if first then assert_before_then_gen repl naming t tac + else assert_after_then_gen repl naming t tac (* apply in as *) @@ -2222,13 +2289,18 @@ let general_apply_in sidecond_first with_delta with_destruct with_evars let tac (naming,lemma) tac id = apply_in_delayed_once sidecond_first with_delta with_destruct with_evars naming id lemma tac in - let naming,ipat_tac = prepare_intros (IntroIdentifier id) ipat in + Proofview.Goal.enter begin fun gl -> + let destopt = + if with_evars then MoveLast (* evars would depend on the whole context *) + else get_previous_hyp_position id gl in + let naming,ipat_tac = prepare_intros (IntroIdentifier id) destopt ipat in let lemmas_target, last_lemma_target = let last,first = List.sep_last lemmas in List.map (fun lem -> (NamingMustBe (dloc,id),lem)) first, (naming,last) in (* We chain apply_in_once, ending with an intro pattern *) List.fold_right tac lemmas_target (tac last_lemma_target ipat_tac) id + end (* if sidecond_first then @@ -2287,7 +2359,7 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = let eq = applist (eq,args) in let refl = applist (refl, [t;mkVar id]) in let term = mkNamedLetIn id c t (mkLetIn (Name heq, refl, eq, ccl)) in - let sigma, _ = Typing.e_type_of env sigma term in + let sigma, _ = Typing.type_of env sigma term in sigma, term, Tacticals.New.tclTHEN (intro_gen (NamingMustBe (loc,heq)) (decode_hyp lastlhyp) true false) @@ -2373,16 +2445,17 @@ let forward b usetac ipat c = match usetac with | None -> Proofview.Goal.enter begin fun gl -> - let t = Tacmach.New.pf_type_of gl c in - Tacticals.New.tclTHENFIRST (assert_as true ipat t) + let t = Tacmach.New.pf_unsafe_type_of gl c in + let hd = head_ident c in + Tacticals.New.tclTHENFIRST (assert_as true hd ipat t) (Proofview.V82.tactic (exact_no_check c)) end | Some tac -> if b then - Tacticals.New.tclTHENFIRST (assert_as b ipat c) tac + Tacticals.New.tclTHENFIRST (assert_as b None ipat c) tac else Tacticals.New.tclTHENS3PARTS - (assert_as b ipat c) [||] tac [|Tacticals.New.tclIDTAC|] + (assert_as b None ipat c) [||] tac [|Tacticals.New.tclIDTAC|] let pose_proof na c = forward true None (ipat_of_name na) c let assert_by na t tac = forward true (Some tac) (ipat_of_name na) t @@ -2408,11 +2481,13 @@ let bring_hyps hyps = else Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in + let store = Proofview.Goal.extra gl in let concl = Tacmach.New.pf_nf_concl gl in let newcl = List.fold_right mkNamedProd_or_LetIn hyps concl in let args = Array.of_list (instance_from_named_context hyps) in Proofview.Refine.refine begin fun sigma -> - let (sigma, ev) = Evarutil.new_evar env sigma newcl in + let (sigma, ev) = + Evarutil.new_evar env sigma ~principal:true ~store newcl in (sigma, (mkApp (ev, args))) end end @@ -2456,7 +2531,7 @@ let generalize_goal_gen env ids i ((occs,c,b),na) t (cl,evd) = mkProd_or_LetIn (na,b,t) cl', evd' let generalize_goal gl i ((occs,c,b),na as o) cl = - let t = pf_type_of gl c in + let t = pf_unsafe_type_of gl c in let env = pf_env gl in generalize_goal_gen env (pf_ids_of_hyps gl) i o t cl @@ -2517,7 +2592,7 @@ let new_generalize_gen_let lconstr = let (newcl, sigma), args = List.fold_right_i (fun i ((_,c,b),_ as o) (cl, args) -> - let t = Tacmach.New.pf_type_of gl c in + let t = Tacmach.New.pf_unsafe_type_of gl c in let args = if Option.is_empty b then c :: args else args in generalize_goal_gen env ids i o t cl, args) 0 lconstr ((concl, sigma), []) @@ -2794,7 +2869,7 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = let id = match kind_of_term c with | Var id -> id | _ -> - let type_of = Tacmach.New.pf_type_of gl in + let type_of = Tacmach.New.pf_unsafe_type_of gl in id_of_name_using_hdchar (Global.env()) (type_of c) Anonymous in let x = fresh_id_in_env avoid id env in Tacticals.New.tclTHEN @@ -3043,7 +3118,7 @@ let make_up_names n ind_opt cname = let error_ind_scheme s = let s = if not (String.is_empty s) then s^" " else s in - error ("Cannot recognize "^s^"an induction scheme.") + errorlabstrm "Tactics" (str "Cannot recognize " ++ str s ++ str "an induction scheme.") let glob = Universes.constr_of_global @@ -3178,7 +3253,7 @@ let is_defined_variable env id = match lookup_named id env with | (_, Some _, _) -> true let abstract_args gl generalize_vars dep id defined f args = - let sigma = project gl in + let sigma = ref (project gl) in let env = pf_env gl in let concl = pf_concl gl in let dep = dep || dependent (mkVar id) concl in @@ -3195,11 +3270,12 @@ let abstract_args gl generalize_vars dep id defined f args = *) let aux (prod, ctx, ctxenv, c, args, eqs, refls, nongenvars, vars, env) arg = let (name, _, ty), arity = - let rel, c = Reductionops.splay_prod_n env sigma 1 prod in + let rel, c = Reductionops.splay_prod_n env !sigma 1 prod in List.hd rel, c in - let argty = pf_type_of gl arg in - let ty = (* refresh_universes_strict *) ty in + let argty = pf_unsafe_type_of gl arg in + let sigma', ty = Evarsolve.refresh_universes (Some true) env !sigma ty in + let () = sigma := sigma' in let lenctx = List.length ctx in let liftargty = lift lenctx argty in let leq = constr_cmp Reduction.CUMUL liftargty ty in @@ -3238,8 +3314,9 @@ let abstract_args gl generalize_vars dep id defined f args = true, mkApp (f', before), after in if dogen then + let tyf' = pf_unsafe_type_of gl f' in let arity, ctx, ctxenv, c', args, eqs, refls, nogen, vars, env = - Array.fold_left aux (pf_type_of gl f',[],env,f',[],[],[],Id.Set.empty,Id.Set.empty,env) args' + Array.fold_left aux (tyf',[],env,f',[],[],[],Id.Set.empty,Id.Set.empty,env) args' in let args, refls = List.rev args, List.rev refls in let vars = @@ -3248,9 +3325,12 @@ let abstract_args gl generalize_vars dep id defined f args = hyps_of_vars (pf_env gl) (pf_hyps gl) nogen vars else [] in - let body, c' = if defined then Some c', typ_of ctxenv Evd.empty c' else None, c' in - Some (make_abstract_generalize gl id concl dep ctx body c' eqs args refls, - dep, succ (List.length ctx), vars) + let body, c' = + if defined then Some c', typ_of ctxenv !sigma c' + else None, c' + in + let term = make_abstract_generalize {gl with sigma = !sigma} id concl dep ctx body c' eqs args refls in + Some (term, !sigma, dep, succ (List.length ctx), vars) else None let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id = @@ -3272,20 +3352,26 @@ let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id = let newc = Tacmach.New.of_old (fun gl -> abstract_args gl generalize_vars force_dep id def f args) gl in match newc with | None -> Proofview.tclUNIT () - | Some (newc, dep, n, vars) -> + | Some (newc, sigma, dep, n, vars) -> let tac = if dep then - Tacticals.New.tclTHENLIST [Proofview.V82.tactic (refine newc); rename_hyp [(id, oldid)]; Tacticals.New.tclDO n intro; - Proofview.V82.tactic (generalize_dep ~with_let:true (mkVar oldid))] - else - Tacticals.New.tclTHENLIST [Proofview.V82.tactic (refine newc); Proofview.V82.tactic (clear [id]); Tacticals.New.tclDO n intro] + Tacticals.New.tclTHENLIST + [Proofview.Unsafe.tclEVARS sigma; + Proofview.V82.tactic (refine newc); + rename_hyp [(id, oldid)]; Tacticals.New.tclDO n intro; + Proofview.V82.tactic (generalize_dep ~with_let:true (mkVar oldid))] + else Tacticals.New.tclTHENLIST + [Proofview.Unsafe.tclEVARS sigma; + Proofview.V82.tactic (refine newc); + Proofview.V82.tactic (clear [id]); + Tacticals.New.tclDO n intro] in if List.is_empty vars then tac else Tacticals.New.tclTHEN tac (Tacticals.New.tclFIRST [revert vars ; Proofview.V82.tactic (fun gl -> tclMAP (fun id -> - tclTRY (generalize_dep ~with_let:true (mkVar id))) vars gl)]) + tclTRY (generalize_dep ~with_let:true (mkVar id))) vars gl)]) end let rec compare_upto_variables x y = @@ -3563,13 +3649,13 @@ let guess_elim isrec dep s hyp0 gl = Tacmach.New.pf_apply build_case_analysis_scheme gl mind true s else Tacmach.New.pf_apply build_case_analysis_scheme_default gl mind s in - let elimt = Tacmach.New.pf_type_of gl elimc in + let elimt = Tacmach.New.pf_unsafe_type_of gl elimc in evd, ((elimc, NoBindings), elimt), mkIndU mind let given_elim hyp0 (elimc,lbind as e) gl = let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 gl in let ind_type_guess,_ = decompose_app ((strip_prod tmptyp0)) in - Proofview.Goal.sigma gl, (e, Tacmach.New.pf_type_of gl elimc), ind_type_guess + Proofview.Goal.sigma gl, (e, Tacmach.New.pf_unsafe_type_of gl elimc), ind_type_guess type scheme_signature = (Id.t list * (elim_arg_kind * bool * Id.t) list) array @@ -3594,14 +3680,17 @@ let find_induction_type isrec elim hyp0 gl = if Option.is_empty scheme.indarg then error "Cannot find induction type"; let indsign = compute_scheme_signature scheme hyp0 ind_guess in let elim = ({elimindex = Some(-1); elimbody = elimc; elimrename = None},elimt) in - scheme, ElimUsing (elim,indsign) in - (Option.get scheme.indref,scheme.nparams, elim) + scheme, ElimUsing (elim,indsign) + in + match scheme.indref with + | None -> error_ind_scheme "" + | Some ref -> ref, scheme.nparams, elim let get_elim_signature elim hyp0 gl = compute_elim_signature (given_elim hyp0 elim gl) hyp0 let is_functional_induction elimc gl = - let scheme = compute_elim_sig ~elimc (Tacmach.New.pf_type_of gl (fst elimc)) in + let scheme = compute_elim_sig ~elimc (Tacmach.New.pf_unsafe_type_of gl (fst elimc)) in (* The test is not safe: with non-functional induction on non-standard induction scheme, this may fail *) Option.is_empty scheme.indarg @@ -3960,7 +4049,7 @@ let induction_gen_l isrec with_evars elim names lc = | _ -> Proofview.Goal.enter begin fun gl -> - let type_of = Tacmach.New.pf_type_of gl in + let type_of = Tacmach.New.pf_unsafe_type_of gl in let x = id_of_name_using_hdchar (Global.env()) (type_of c) Anonymous in @@ -4222,7 +4311,7 @@ let (forward_setoid_symmetry_in, setoid_symmetry_in) = Hook.make () let symmetry_in id = Proofview.Goal.enter begin fun gl -> - let ctype = Tacmach.New.pf_type_of gl (mkVar id) in + let ctype = Tacmach.New.pf_unsafe_type_of gl (mkVar id) in let sign,t = decompose_prod_assum ctype in Proofview.tclORELSE begin @@ -4273,7 +4362,7 @@ let prove_transitivity hdcncl eq_kind t = | HeterogenousEq (typ1,c1,typ2,c2) -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in - let type_of = Typing.type_of env sigma in + let type_of = Typing.unsafe_type_of env sigma in let typt = type_of t in (mkApp(hdcncl, [| typ1; c1; typt ;t |]), mkApp(hdcncl, [| typt; t; typ2; c2 |])) @@ -4374,13 +4463,13 @@ let abstract_subproof id gk tac = let cd = Entries.DefinitionEntry const in let decl = (cd, IsProof Lemma) in (** ppedrot: seems legit to have abstracted subproofs as local*) - let cst = Declare.declare_constant ~internal:Declare.KernelSilent ~local:true id decl in + let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest ~local:true id decl in (* let evd, lem = Evd.fresh_global (Global.env ()) evd (ConstRef cst) in *) let lem, ctx = Universes.unsafe_constr_of_global (ConstRef cst) in let evd = Evd.set_universe_context evd ectx in - let open Declareops in - let eff = Safe_typing.sideff_of_con (Global.safe_env ()) cst in - let effs = cons_side_effects eff + let open Safe_typing in + let eff = private_con_of_con (Global.safe_env ()) cst in + let effs = add_private eff Entries.(snd (Future.force const.const_entry_body)) in let args = List.rev (instance_from_named_context sign) in let solve = diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 0069d100..ade89fc9 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -348,6 +348,7 @@ val assert_before : Name.t -> types -> unit Proofview.tactic val assert_after : Name.t -> types -> unit Proofview.tactic val assert_as : (* true = before *) bool -> + (* optionally tell if a specialization of some hyp: *) identifier option -> intro_pattern option -> constr -> unit Proofview.tactic (** Implements the tactics assert, enough and pose proof; note that "by" diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4 index 4b03ff24..b4c7bffa 100644 --- a/tactics/tauto.ml4 +++ b/tactics/tauto.ml4 @@ -316,7 +316,7 @@ let tauto_intuitionistic flags = (intuition_gen (default_ist ()) flags <:tactic<fail>>) begin function (e, info) -> match e with | Refiner.FailError _ | UserError _ -> - Proofview.tclZERO (UserError ("tauto" , str "tauto failed.")) + Tacticals.New.tclZEROMSG (str "tauto failed.") | e -> Proofview.tclZERO ~info e end @@ -328,7 +328,7 @@ let tauto_classical flags nnpp = Proofview.tclORELSE (Tacticals.New.tclTHEN (apply nnpp) (tauto_intuitionistic flags)) begin function (e, info) -> match e with - | UserError _ -> Proofview.tclZERO (UserError ("tauto" , str "Classical tauto failed.")) + | UserError _ -> Tacticals.New.tclZEROMSG (str "Classical tauto failed.") | e -> Proofview.tclZERO ~info e end diff --git a/tactics/term_dnet.ml b/tactics/term_dnet.ml index e79fc6dc..65239a5f 100644 --- a/tactics/term_dnet.ml +++ b/tactics/term_dnet.ml @@ -98,8 +98,8 @@ struct | DSort, DSort -> 0 | DRef gr1, DRef gr2 -> RefOrdered.compare gr1 gr2 | DCtx (tl1, tr1), DCtx (tl2, tr2) - | DLambda (tl1, tr1), DCtx (tl2, tr2) - | DApp (tl1, tr1), DCtx (tl2, tr2) -> + | DLambda (tl1, tr1), DLambda (tl2, tr2) + | DApp (tl1, tr1), DApp (tl2, tr2) -> let c = cmp tl1 tl2 in if c = 0 then cmp tr1 tr2 else c diff --git a/test-suite/Makefile b/test-suite/Makefile index cffbe481..31b21290 100644 --- a/test-suite/Makefile +++ b/test-suite/Makefile @@ -28,9 +28,9 @@ # Default value when called from a freshly compiled Coq, but can be # easily overridden BIN := ../bin/ -LIB := .. +LIB := $(shell cd ..; pwd) -coqtop := $(BIN)coqtop -boot -q -batch -R prerequisite TestSuite +coqtop := $(BIN)coqtop -boot -q -batch -test-mode -R prerequisite TestSuite bincoqc := $(BIN)coqc -coqlib $(LIB) -R prerequisite TestSuite bincoqchk := $(BIN)coqchk -coqlib $(LIB) -R prerequisite TestSuite @@ -208,7 +208,7 @@ $(addsuffix .log,$(wildcard prerequisite/*.v)): %.v.log: %.v @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(coqc) "$*" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ + $(coqc) "$<" $(call get_coq_prog_args,"$<") 2>&1; R=$$?; times; \ if [ $$R != 0 ]; then \ echo $(log_failure); \ echo " $<...could not be prepared" ; \ @@ -238,7 +238,7 @@ $(addsuffix .log,$(wildcard stm/*.v)): %.v.log: %.v @echo "TEST $< $(call get_coq_prog_args_in_parens,"$<")" $(HIDE){ \ echo $(call log_intro,$<); \ - $(coqc) "$*" $(call get_coq_prog_args,"$<") -async-proofs on \ + $(coqc) "$<" $(call get_coq_prog_args,"$<") -async-proofs on \ -async-proofs-private-flags fallback-to-lazy-if-marshal-error=no,fallback-to-lazy-if-slave-dies=no \ $$opts 2>&1; R=$$?; times; \ if [ $$R = 0 ]; then \ @@ -352,7 +352,7 @@ $(addsuffix .log,$(wildcard ideal-features/*.v)): %.v.log: %.v # Additionnal dependencies for module tests $(addsuffix .log,$(wildcard modules/*.v)): %.v.log: modules/Nat.vo modules/plik.vo modules/%.vo: modules/%.v - $(HIDE)$(coqtop) -R modules Mods -compile $(<:.v=) + $(HIDE)$(coqtop) -R modules Mods -compile $< ####################################################################### # Miscellaneous tests @@ -388,7 +388,7 @@ misc/deps-order.log: } > "$@" # Sort universes for the whole standard library -EXPECTED_UNIVERSES := 3 +EXPECTED_UNIVERSES := 5 universes: misc/universes.log misc/universes.log: misc/universes/all_stdlib.v @echo "TEST misc/universes" diff --git a/test-suite/bugs/closed/2016.v b/test-suite/bugs/closed/2016.v new file mode 100644 index 00000000..13ec5bea --- /dev/null +++ b/test-suite/bugs/closed/2016.v @@ -0,0 +1,62 @@ +(* Coq 8.2beta4 *) +Require Import Classical_Prop. + +Record coreSemantics : Type := CoreSemantics { + core: Type; + corestep: core -> core -> Prop; + corestep_fun: forall q q1 q2, corestep q q1 -> corestep q q2 -> q1 = q2 +}. + +Definition state : Type := {sem: coreSemantics & sem.(core)}. + +Inductive step: state -> state -> Prop := + | step_core: forall sem st st' + (Hcs: sem.(corestep) st st'), + step (existT _ sem st) (existT _ sem st'). + +Lemma step_fun: forall st1 st2 st2', step st1 st2 -> step st1 st2' -> st2 = st2'. +Proof. +intros. +inversion H; clear H; subst. inversion H0; clear H0; subst; auto. +generalize (inj_pairT2 _ _ _ _ _ H2); clear H2; intro; subst. +rewrite (corestep_fun _ _ _ _ Hcs Hcs0); auto. +Qed. + +Record oe_core := oe_Core { + in_core: Type; + in_corestep: in_core -> in_core -> Prop; + in_corestep_fun: forall q q1 q2, in_corestep q q1 -> in_corestep q q2 -> q1 = q2; + in_q: in_core +}. + +Definition oe2coreSem (oec : oe_core) : coreSemantics := + CoreSemantics oec.(in_core) oec.(in_corestep) oec.(in_corestep_fun). + +Definition oe_corestep (q q': oe_core) := + step (existT _ (oe2coreSem q) q.(in_q)) (existT _ (oe2coreSem q') q'.(in_q)). + +Lemma inj_pairT1: forall (U: Type) (P: U -> Type) (p1 p2: U) x y, + existT P p1 x = existT P p2 y -> p1=p2. +Proof. intros; injection H; auto. +Qed. + +Definition f := CoreSemantics oe_core. + +Lemma oe_corestep_fun: forall q q1 q2, + oe_corestep q q1 -> oe_corestep q q2 -> q1 = q2. +Proof. +unfold oe_corestep; intros. +assert (HH:= step_fun _ _ _ H H0); clear H H0. +destruct q1; destruct q2; unfold oe2coreSem; simpl in *. +generalize (inj_pairT1 _ _ _ _ _ _ HH); clear HH; intros. +injection H; clear H; intros. +revert in_q1 in_corestep1 in_corestep_fun1 + H. +pattern in_core1. +apply eq_ind_r with (x := in_core0). +admit. +apply sym_eq. +(** good to here **) +Show Universes. +Print Universes. +Fail apply H0.
\ No newline at end of file diff --git a/test-suite/bugs/closed/2243.v b/test-suite/bugs/closed/2243.v new file mode 100644 index 00000000..6d45c9a0 --- /dev/null +++ b/test-suite/bugs/closed/2243.v @@ -0,0 +1,9 @@ +Inductive is_nul: nat -> Prop := X: is_nul 0. +Section O. +Variable u: nat. +Variable H: is_nul u. +Goal True. +Proof. +destruct H. +Undo. +revert H; intro H; destruct H. diff --git a/test-suite/bugs/closed/2584.v b/test-suite/bugs/closed/2584.v new file mode 100644 index 00000000..a5f4ae64 --- /dev/null +++ b/test-suite/bugs/closed/2584.v @@ -0,0 +1,89 @@ +Require Import List. + +Set Implicit Arguments. + +Definition err : Type := unit. + +Inductive res (A: Type) : Type := +| OK: A -> res A +| Error: err -> res A. + +Implicit Arguments Error [A]. + +Set Printing Universes. + +Section FOO. + +Inductive ftyp : Type := + | Funit : ftyp + | Ffun : list ftyp -> ftyp + | Fref : area -> ftyp +with area : Type := + | Stored : ftyp -> area +. + +Print ftyp. +(* yields: +Inductive ftyp : Type (* Top.27429 *) := + Funit : ftyp | Ffun : list ftyp -> ftyp | Fref : area -> ftyp + with area : Type (* Set *) := Stored : ftyp -> area +*) + +Fixpoint tc_wf_type (ftype: ftyp) {struct ftype}: res unit := + match ftype with + | Funit => OK tt + | Ffun args => + ((fix tc_wf_types (ftypes: list ftyp){struct ftypes}: res unit := + match ftypes with + | nil => OK tt + | t::ts => + match tc_wf_type t with + | OK tt => tc_wf_types ts + | Error m => Error m + end + end) args) + | Fref a => tc_wf_area a + end +with tc_wf_area (ar:area): res unit := + match ar with + | Stored c => tc_wf_type c + end. + +End FOO. + +Print ftyp. +(* yields: +Inductive ftyp : Type (* Top.27465 *) := + Funit : ftyp | Ffun : list ftyp -> ftyp | Fref : area -> ftyp + with area : Set := Stored : ftyp -> area +*) + +Fixpoint tc_wf_type' (ftype: ftyp) {struct ftype}: res unit := + match ftype with + | Funit => OK tt + | Ffun args => + ((fix tc_wf_types (ftypes: list ftyp){struct ftypes}: res unit := + match ftypes with + | nil => OK tt + | t::ts => + match tc_wf_type' t with + | OK tt => tc_wf_types ts + | Error m => Error m + end + end) args) + | Fref a => tc_wf_area' a + end +with tc_wf_area' (ar:area): res unit := + match ar with + | Stored c => tc_wf_type' c + end. + +(* yields: +Error: +Incorrect elimination of "ar" in the inductive type "area": +the return type has sort "Type (* max(Set, Top.27424) *)" while it +should be "Prop" or "Set". +Elimination of an inductive object of sort Set +is not allowed on a predicate in sort Type +because strong elimination on non-small inductive types leads to paradoxes. +*)
\ No newline at end of file diff --git a/test-suite/bugs/closed/3267.v b/test-suite/bugs/closed/3267.v index 5ce1ddf0..8175d66a 100644 --- a/test-suite/bugs/closed/3267.v +++ b/test-suite/bugs/closed/3267.v @@ -34,3 +34,14 @@ Module d. debug eauto. Defined. End d. + +(* An other variant which was still failing in 8.5 beta2 *) + +Parameter A B : Prop. +Axiom a:B. + +Hint Extern 1 => match goal with H:_ -> id _ |- _ => try (unfold id in H) end. +Goal (B -> id A) -> A. +intros. +eauto using a. +Abort. diff --git a/test-suite/bugs/closed/3309.v b/test-suite/bugs/closed/3309.v deleted file mode 100644 index 98043157..00000000 --- a/test-suite/bugs/closed/3309.v +++ /dev/null @@ -1,334 +0,0 @@ -Require Import TestSuite.admit. -(* -*- coq-prog-args: ("-emacs" "-impredicative-set") -*- *) -(* File reduced by coq-bug-finder from original input, then from 5968 lines to 11933 lines, then from 11239 lines to 11231 lines, then from 10365 lines to 446 lines, then from 456 lines to 379 lines, then from 391 lines to 373 lines, then from 369 lines to 351 lines, then from 350 lines to 340 lines, then from 348 lines to 320 lines, then from 328 lines to 302 lines *) -Set Universe Polymorphism. -Record sigT' {A} (P : A -> Type) := existT' { projT1' : A; projT2' : P projT1' }. -Notation "{ x : A &' P }" := (sigT' (A := A) (fun x => P)) : type_scope. -Arguments existT' {A} P _ _. -Axiom admit : forall {T}, T. -Notation paths := identity . - -Unset Automatic Introduction. - -Definition UU := Set. - -Definition dirprod ( X Y : UU ) := sigT' ( fun x : X => Y ) . -Definition dirprodpair { X Y : UU } := existT' ( fun x : X => Y ) . - -Definition ddualand { X Y P : UU } (xp : ( X -> P ) -> P ) ( yp : ( Y -> P ) -> P ) : ( dirprod X Y -> P ) -> P. -Proof. - intros X Y P xp yp X0 . - set ( int1 := fun ypp : ( ( Y -> P ) -> P ) => fun x : X => yp ( fun y : Y => X0 ( dirprodpair x y) ) ) . - apply ( xp ( int1 yp ) ) . -Defined . -Definition weq ( X Y : UU ) : UU . -intros; exact ( sigT' (fun f:X->Y => admit) ). -Defined. -Definition pr1weq ( X Y : UU):= @projT1' _ _ : weq X Y -> (X -> Y). -Coercion pr1weq : weq >-> Funclass. - -Definition invweq { X Y : UU } ( w : weq X Y ) : weq Y X . -admit. -Defined. - -Definition hProp := sigT' (fun X : Type => admit). - -Definition hProppair ( X : UU ) ( is : admit ) : hProp@{i j Set k}. -intros; exact (existT' (fun X : UU => admit ) X is ). -Defined. -Definition hProptoType := @projT1' _ _ : hProp -> Type . -Coercion hProptoType: hProp >-> Sortclass. - -Definition ishinh_UU ( X : UU ) : UU := forall P: Set, ( ( X -> P ) -> P ). - -Definition ishinh ( X : UU ) : hProp := hProppair ( ishinh_UU X ) admit. - -Definition hinhfun { X Y : UU } ( f : X -> Y ) : ishinh_UU X -> ishinh_UU Y. -intros X Y f; exact ( fun isx : ishinh X => fun P : _ => fun yp : Y -> P => isx P ( fun x : X => yp ( f x ) ) ). -Defined. - -Definition hinhuniv { X : UU } { P : hProp } ( f : X -> P ) ( wit : ishinh_UU X ) : P. -intros; exact ( wit P f ). -Defined. - -Definition hinhand { X Y : UU } ( inx1 : ishinh_UU X ) ( iny1 : ishinh_UU Y) : ishinh ( dirprod X Y ). -intros; exact ( fun P:_ => ddualand (inx1 P) (iny1 P)) . -Defined. - -Definition UU' := Type. -Definition hSet:= sigT' (fun X : UU' => admit) . -Definition hSetpair := existT' (fun X : UU' => admit). -Definition pr1hSet:= @projT1' UU (fun X : UU' => admit) : hSet -> Type. -Coercion pr1hSet: hSet >-> Sortclass. - -Definition hPropset : hSet := existT' _ hProp admit . - -Definition hsubtypes ( X : UU ) : Type. -intros; exact (X -> hProp ). -Defined. -Definition carrier { X : UU } ( A : hsubtypes X ) : Type. -intros; exact (sigT' A). -Defined. -Coercion carrier : hsubtypes >-> Sortclass. - -Definition subtypesdirprod { X Y : UU } ( A : hsubtypes X ) ( B : hsubtypes Y ) : hsubtypes ( dirprod X Y ). -admit. -Defined. - -Lemma weqsubtypesdirprod { X Y : UU } ( A : hsubtypes X ) ( B : hsubtypes Y ) : weq ( subtypesdirprod A B ) ( dirprod A B ) . - admit. -Defined. - -Lemma ishinhsubtypesdirprod { X Y : UU } ( A : hsubtypes X ) ( B : hsubtypes Y ) ( isa : ishinh A ) ( isb : ishinh B ) : ishinh ( subtypesdirprod A B ) . -Proof . - intros . - apply ( hinhfun ( invweq ( weqsubtypesdirprod A B ) ) ) . - apply hinhand . - apply isa . - apply isb . -Defined . - -Definition hrel ( X : UU ) : Type. -intros; exact ( X -> X -> hProp). -Defined. - -Definition iseqrel { X : UU } ( R : hrel X ) : Type. -admit. -Defined. - -Definition eqrel ( X : UU ) : Type. -intros; exact ( sigT' ( fun R : hrel X => iseqrel R ) ). -Defined. -Definition pr1eqrel ( X : UU ) : eqrel X -> ( X -> ( X -> hProp ) ) := @projT1' _ _ . -Coercion pr1eqrel : eqrel >-> Funclass . - -Definition hreldirprod { X Y : UU } ( RX : hrel X ) ( RY : hrel Y ) : hrel ( dirprod X Y ) . -admit. -Defined. -Set Printing Universes. -Print hProp. -Print ishinh_UU. -Print hProppair. -Definition iseqclass { X : UU } ( R : hrel X ) ( A : hsubtypes X ) : Type. -intros; exact ( dirprod ( ishinh ( carrier A ) ) ( dirprod ( forall x1 x2 : X , R x1 x2 -> A x1 -> A x2 ) ( forall x1 x2 : X, A x1 -> A x2 -> R x1 x2 ) )) . -Defined. -Definition iseqclassconstr { X : UU } ( R : hrel X ) { A : hsubtypes X } ( ax0 : ishinh ( carrier A ) ) ( ax1 : forall x1 x2 : X , R x1 x2 -> A x1 -> A x2 ) ( ax2 : forall x1 x2 : X, A x1 -> A x2 -> R x1 x2 ) : iseqclass R A. -intros. hnf. apply dirprodpair. exact ax0. apply dirprodpair. exact ax1. exact ax2. -Defined. - -Definition eqax0 { X : UU } { R : hrel X } { A : hsubtypes X } : iseqclass R A -> ishinh ( carrier A ) . -intros X R A; exact ( fun is : iseqclass R A => projT1' _ is ). -Defined. - -Lemma iseqclassdirprod { X Y : UU } { R : hrel X } { Q : hrel Y } { A : hsubtypes X } { B : hsubtypes Y } ( isa : iseqclass R A ) ( isb : iseqclass Q B ) : iseqclass ( hreldirprod R Q ) ( subtypesdirprod A B ) . -Proof . - intros . - set ( XY := dirprod X Y ) . - set ( AB := subtypesdirprod A B ) . - set ( RQ := hreldirprod R Q ) . - set ( ax0 := ishinhsubtypesdirprod A B ( eqax0 isa ) admit ) . - apply ( iseqclassconstr _ ax0 admit admit ) . -Defined . - -Definition image { X Y : UU } ( f : X -> Y ) : Type. -intros; exact ( sigT' ( fun y : Y => admit ) ). -Defined. -Definition pr1image { X Y : UU } ( f : X -> Y ) : image f -> Y. -intros X Y f; exact ( @projT1' _ ( fun y : Y => admit ) ). -Defined. - -Definition prtoimage { X Y : UU } (f : X -> Y) : X -> image f. - admit. -Defined. - -Definition setquot { X : UU } ( R : hrel X ) : Type. -intros; exact ( sigT' ( fun A : _ => iseqclass R A ) ). -Defined. -Definition setquotpair { X : UU } ( R : hrel X ) ( A : hsubtypes X ) ( is : iseqclass R A ) : setquot R. -intros; exact (existT' _ A is ). -Defined. -Definition pr1setquot { X : UU } ( R : hrel X ) : setquot R -> ( hsubtypes X ). -intros X R. -exact ( @projT1' _ ( fun A : _ => iseqclass R A ) ). -Defined. -Coercion pr1setquot : setquot >-> hsubtypes . - -Definition setquotinset { X : UU } ( R : hrel X ) : hSet. -intros; exact ( hSetpair (setquot R) admit) . -Defined. - -Definition dirprodtosetquot { X Y : UU } ( RX : hrel X ) ( RY : hrel Y ) (cd : dirprod ( setquot RX ) ( setquot RY ) ) : setquot ( hreldirprod RX RY ). -intros; exact ( setquotpair _ _ ( iseqclassdirprod ( projT2' _ ( projT1' _ cd ) ) ( projT2' _ ( projT2' _ cd ) ) ) ). -Defined. - -Definition iscomprelfun2 { X Y : UU } ( R : hrel X ) ( f : X -> X -> Y ) := forall x x' x0 x0' : X , R x x' -> R x0 x0' -> paths ( f x x0 ) ( f x' x0' ) . - -Definition binop ( X : UU ) : Type. -intros; exact ( X -> X -> X ). -Defined. - -Definition setwithbinop : Type. -exact (sigT' ( fun X : hSet => binop X ) ). -Defined. -Definition pr1setwithbinop : setwithbinop -> hSet@{j k Set l}. -unfold setwithbinop. -exact ( @projT1' _ ( fun X : hSet@{j k Set l} => binop@{Set} X ) ). -Defined. -Coercion pr1setwithbinop : setwithbinop >-> hSet . - -Definition op { X : setwithbinop } : binop X. -intros; exact ( projT2' _ X ). -Defined. - -Definition subsetswithbinop { X : setwithbinop } : Type. -admit. -Defined. - -Definition carrierofasubsetwithbinop { X : setwithbinop } ( A : @subsetswithbinop X ) : setwithbinop . -admit. -Defined. - -Coercion carrierofasubsetwithbinop : subsetswithbinop >-> setwithbinop . - -Definition binopeqrel { X : setwithbinop } : Type. -intros; exact (sigT' ( fun R : eqrel X => admit ) ). -Defined. -Definition binopeqrelpair { X : setwithbinop } := existT' ( fun R : eqrel X => admit ). -Definition pr1binopeqrel ( X : setwithbinop ) : @binopeqrel X -> eqrel X. -intros X; exact ( @projT1' _ ( fun R : eqrel X => admit ) ) . -Defined. -Coercion pr1binopeqrel : binopeqrel >-> eqrel . - -Definition setwithbinopdirprod ( X Y : setwithbinop ) : setwithbinop . -admit. -Defined. - -Definition monoid : Type. -exact ( sigT' ( fun X : setwithbinop => admit ) ). -Defined. -Definition monoidpair := existT' ( fun X : setwithbinop => admit ) . -Definition pr1monoid : monoid -> setwithbinop := @projT1' _ _ . -Coercion pr1monoid : monoid >-> setwithbinop . - -Notation "x + y" := ( op x y ) : addmonoid_scope . - -Definition submonoids { X : monoid } : Type. -admit. -Defined. - -Definition submonoidstosubsetswithbinop ( X : monoid ) : @submonoids X -> @subsetswithbinop X. -admit. -Defined. -Coercion submonoidstosubsetswithbinop : submonoids >-> subsetswithbinop . - -Definition abmonoid : Type. -exact (sigT' ( fun X : setwithbinop => admit ) ). -Defined. - -Definition abmonoidtomonoid : abmonoid -> monoid. -exact (fun X : _ => monoidpair ( projT1' _ X ) admit ). -Defined. -Coercion abmonoidtomonoid : abmonoid >-> monoid . - -Definition subabmonoids { X : abmonoid } := @submonoids X . - -Definition carrierofsubabmonoid { X : abmonoid } ( A : @subabmonoids X ) : abmonoid . -Proof . - intros . - unfold subabmonoids in A . - split with A . - admit. -Defined . - -Coercion carrierofsubabmonoid : subabmonoids >-> abmonoid . - -Definition abmonoiddirprod ( X Y : abmonoid ) : abmonoid . -Proof . - intros . - split with ( setwithbinopdirprod X Y ) . - admit. -Defined . - -Open Scope addmonoid_scope . - -Definition eqrelabmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) : eqrel ( setwithbinopdirprod X A ). -admit. -Defined. - -Definition binopeqrelabmonoidfrac ( X : abmonoid ) ( A : @subabmonoids X ) : @binopeqrel ( abmonoiddirprod X A ). -intros; exact ( @binopeqrelpair ( setwithbinopdirprod X A ) ( eqrelabmonoidfrac X A ) admit ). -Defined. - -Theorem setquotuniv { X : UU } ( R : hrel X ) ( Y : hSet ) ( f : X -> Y ) ( c : setquot R ) : Y . -Proof. - intros. - apply ( pr1image ( fun x : c => f ( projT1' _ x ) ) ) . - apply ( @hinhuniv ( projT1' _ c ) ( hProppair _ admit ) ( prtoimage ( fun x : c => f ( projT1' _ x ) ) ) ) . - pose ( eqax0 ( projT2' _ c ) ) as h. - simpl in *. - Set Printing Universes. - exact h. -Defined . - -Definition setquotuniv2 { X : UU } ( R : hrel X ) ( Y : hSet ) ( f : X -> X -> Y ) ( is : iscomprelfun2 R f ) ( c c0 : setquot R ) : Y . -Proof. - intros . - set ( RR := hreldirprod R R ) . - apply (setquotuniv RR Y admit). - apply dirprodtosetquot. - apply dirprodpair. - exact c. - exact c0. -Defined . - -Definition setquotfun2 { X Y : UU } ( RX : hrel X ) ( RY : eqrel Y ) ( f : X -> X -> Y ) ( cx cx0 : setquot RX ) : setquot RY . -Proof . - intros . - apply ( setquotuniv2 RX ( setquotinset RY ) admit admit admit admit ) . -Defined . - -Definition quotrel { X : UU } { R : hrel X } : hrel ( setquot R ). -intros; exact ( setquotuniv2 R hPropset admit admit ). -Defined. - -Definition setwithbinopquot { X : setwithbinop } ( R : @binopeqrel X ) : setwithbinop . -Proof . - intros . - split with ( setquotinset R ) . - set ( qtmlt := setquotfun2 R R op ) . - simpl . - unfold binop . - apply qtmlt . -Defined . - -Definition abmonoidquot { X : abmonoid } ( R : @binopeqrel X ) : abmonoid . -Proof . - intros . - split with ( setwithbinopquot R ) . - admit. -Defined . - -Definition abmonoidfrac ( X : abmonoid ) ( A : @submonoids X ) : abmonoid. -intros; exact ( @abmonoidquot (abmonoiddirprod X (@carrierofsubabmonoid X A)) ( binopeqrelabmonoidfrac X A ) ). -Defined. - -Definition abmonoidfracrel ( X : abmonoid ) ( A : @submonoids X ) : hrel (@setquot (setwithbinopdirprod X A) (eqrelabmonoidfrac X A)). -intros; exact (@quotrel _ _). -Defined. - -Fail Timeout 1 Axiom ispartlbinopabmonoidfracrel : forall ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( z : abmonoidfrac X A ) , @abmonoidfracrel X A ( ( admit + z ) )admit. - -Definition ispartlbinopabmonoidfracrel_type : Type := - forall ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( z : abmonoidfrac X A ), - @abmonoidfracrel X A ( ( admit + z ) )admit. - -Fail Timeout 1 Axiom ispartlbinopabmonoidfracrel' : $(let t:= eval unfold ispartlbinopabmonoidfracrel_type in - ispartlbinopabmonoidfracrel_type in exact t)$. - -Unset Kernel Term Sharing. - -Axiom ispartlbinopabmonoidfracrel : forall ( X : abmonoid ) ( A : @subabmonoids X ) { L : hrel X } ( z : abmonoidfrac X A ) , @abmonoidfracrel X A ( ( admit + z ) )admit. - -Axiom ispartlbinopabmonoidfracrel' : $(let t:= eval unfold ispartlbinopabmonoidfracrel_type in - ispartlbinopabmonoidfracrel_type in exact t)$. - diff --git a/test-suite/bugs/closed/3314.v b/test-suite/bugs/closed/3314.v index e63c46da..fb3791af 100644 --- a/test-suite/bugs/closed/3314.v +++ b/test-suite/bugs/closed/3314.v @@ -122,12 +122,12 @@ Definition depsort (T : Type) (x : bool) : informative x := end. (** This definition should fail *) -Definition Box (T : Type1) : Prop := Lift T. +Fail Definition Box (T : Type1) : Prop := Lift T. -Definition prop {T : Type1} (t : Box T) : T := t. -Definition wrap {T : Type1} (t : T) : Box T := t. +Fail Definition prop {T : Type1} (t : Box T) : T := t. +Fail Definition wrap {T : Type1} (t : T) : Box T := t. -Definition down (x : Type1) : Prop := Box x. +Fail Definition down (x : Type1) : Prop := Box x. Definition up (x : Prop) : Type1 := x. Fail Definition back A : up (down A) -> A := @prop A. diff --git a/test-suite/bugs/closed/3330.v b/test-suite/bugs/closed/3330.v index 4cd7c39e..e6a50449 100644 --- a/test-suite/bugs/closed/3330.v +++ b/test-suite/bugs/closed/3330.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 12106 lines to 1070 lines *) Set Universe Polymorphism. diff --git a/test-suite/bugs/closed/3352.v b/test-suite/bugs/closed/3352.v index b57b0a0f..f8113e4c 100644 --- a/test-suite/bugs/closed/3352.v +++ b/test-suite/bugs/closed/3352.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. (* I'm not sure what the general rule should be; intuitively, I want [IsHProp (* Set *) Foo] to mean [IsHProp (* U >= Set *) Foo]. (I think this worked in HoTT/coq, too.) Morally, [IsHProp] has no universe level associated with it distinct from that of its argument, you should never get a universe inconsistency from unifying [IsHProp A] with [IsHProp A]. (The issue is tricker when IsHProp uses [A] elsewhere, as in: diff --git a/test-suite/bugs/closed/3386.v b/test-suite/bugs/closed/3386.v index 0e236c21..b8bb8bce 100644 --- a/test-suite/bugs/closed/3386.v +++ b/test-suite/bugs/closed/3386.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Set Universe Polymorphism. Set Printing Universes. Record Cat := { Obj :> Type }. diff --git a/test-suite/bugs/closed/3387.v b/test-suite/bugs/closed/3387.v index ae212caa..cb435e78 100644 --- a/test-suite/bugs/closed/3387.v +++ b/test-suite/bugs/closed/3387.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Set Universe Polymorphism. Set Printing Universes. Record Cat := { Obj :> Type }. diff --git a/test-suite/bugs/closed/3446.v b/test-suite/bugs/closed/3446.v new file mode 100644 index 00000000..dce73e1a --- /dev/null +++ b/test-suite/bugs/closed/3446.v @@ -0,0 +1,51 @@ +(* File reduced by coq-bug-finder from original input, then from 7372 lines to 539 lines, then from 531 lines to 107 lines, then from 76 lines to 46 lines *) +Module First. +Set Asymmetric Patterns. +Reserved Notation "x -> y" (at level 99, right associativity, y at level 200). +Notation "A -> B" := (forall (_ : A), B). +Set Universe Polymorphism. + + +Notation "x → y" := (x -> y) + (at level 99, y at level 200, right associativity): type_scope. +Record sigT A (P : A -> Type) := + { projT1 : A ; projT2 : P projT1 }. +Arguments projT1 {A P} s. +Arguments projT2 {A P} s. +Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := fun x => g (f x). +Reserved Notation "x = y" (at level 70, no associativity). +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y). +Notation " x = y " := (paths x y) : type_scope. +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := match p with idpath => u end. +Reserved Notation "{ x : A & P }" (at level 0, x at level 99). +Notation "{ x : A & P }" := (sigT A (fun x => P)) : type_scope. + + +Axiom path_sigma_uncurried : forall {A : Type} (P : A -> Type) (u v : sigT A P) (pq : {p : projT1 u = projT1 v & transport _ p (projT2 u) = projT2 v}), u = v. +Axiom isequiv_pr1_contr : forall {A} {P : A -> Type}, (A -> {x : A & P x}). + +Definition path_sigma_hprop {A : Type} {P : A -> Type} (u v : sigT _ P) := + @compose _ _ _ (path_sigma_uncurried P u v) (@isequiv_pr1_contr _ _). +End First. + +Set Asymmetric Patterns. +Set Universe Polymorphism. +Arguments projT1 {_ _} _. +Notation "( x ; y )" := (existT _ x y). +Notation pr1 := projT1. +Notation "x .1" := (projT1 x) (at level 3). +Notation "x .2" := (projT2 x) (at level 3). +Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := fun x => g (f x). +Notation "g 'o' f" := (compose g f) (at level 40, left associativity). +Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. +Arguments idpath {A a} , [A] a. +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := match p with idpath => u end. +Notation "p # x" := (transport _ p x) (right associativity, at level 65, only parsing). +Class IsEquiv {A B : Type} (f : A -> B) := { equiv_inv : B -> A }. +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3). +Axiom path_sigma_uncurried : forall {A : Type} (P : A -> Type) (u v : sigT P) (pq : {p : u.1 = v.1 & p # u.2 = v.2}), u = v. +Instance isequiv_pr1_contr {A} {P : A -> Type} : IsEquiv (@pr1 A P) | 100. +Admitted. + +Definition path_sigma_hprop {A : Type} {P : A -> Type} (u v : sigT P) : u.1 = v.1 -> u = v := + path_sigma_uncurried P u v o pr1^-1.
\ No newline at end of file diff --git a/test-suite/bugs/opened/3461.v b/test-suite/bugs/closed/3461.v index 1b625e6a..1b625e6a 100644 --- a/test-suite/bugs/opened/3461.v +++ b/test-suite/bugs/closed/3461.v diff --git a/test-suite/bugs/closed/3509.v b/test-suite/bugs/closed/3509.v new file mode 100644 index 00000000..82266226 --- /dev/null +++ b/test-suite/bugs/closed/3509.v @@ -0,0 +1,6 @@ +Inductive T := Foo : T. +Axiom (b : T) (R : forall x : T, Prop) (f : forall x : T, R x). +Axiom a1 : match b with Foo => f end = f. +Axiom a2 : match b with Foo => f b end = f b. +Hint Rewrite a1 : bar. +Hint Rewrite a2 : bar. diff --git a/test-suite/bugs/closed/3510.v b/test-suite/bugs/closed/3510.v new file mode 100644 index 00000000..4cbae335 --- /dev/null +++ b/test-suite/bugs/closed/3510.v @@ -0,0 +1,5 @@ +Inductive T := Foo : T. +Axiom (b : T) (R : forall x : T, Prop) (f : forall x : T, R x). +Axiom a1 : match b with Foo => f end = f. +Axiom a2 : match b with Foo => f b end = f b. +Hint Rewrite a1 a2 : bar. diff --git a/test-suite/bugs/closed/3539.v b/test-suite/bugs/closed/3539.v index c862965d..d258bb31 100644 --- a/test-suite/bugs/closed/3539.v +++ b/test-suite/bugs/closed/3539.v @@ -1,4 +1,4 @@ -(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter" "-no-native-compiler") -*- *) +(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *) (* File reduced by coq-bug-finder from original input, then from 11678 lines to 11330 lines, then from 10721 lines to 9544 lines, then from 9549 lines to 794 lines, then from 810 lines to 785 lines, then from 628 lines to 246 lines, then from 220 lines to 89 lines, then from 80 lines to 47 lines *) (* coqc version trunk (August 2014) compiled on Aug 22 2014 4:17:28 with OCaml 4.01.0 coqtop version cagnode17:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (a67cc6941434124465f20b14a1256f2ede31a60e) *) @@ -63,4 +63,4 @@ x' : forall (_ : T1) (_ : T), T2 m : T3 (x' fst1 x2) (x' fst0 x2) Unable to unify "?25 (@pair ?23 ?24 (fst ?27) (snd ?27))" with "?25 ?27". - *)
\ No newline at end of file + *) diff --git a/test-suite/bugs/closed/3559.v b/test-suite/bugs/closed/3559.v index 50645090..da12b686 100644 --- a/test-suite/bugs/closed/3559.v +++ b/test-suite/bugs/closed/3559.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. (* File reduced by coq-bug-finder from original input, then from 8657 lines to 4731 lines, then from 4174 lines to 192 lines, then from 161 lines to 55 lines, then from 51 lines to 37 lines, then from 43 lines to 30 lines *) diff --git a/test-suite/bugs/closed/3566.v b/test-suite/bugs/closed/3566.v index b2aa8c3c..e2d79769 100644 --- a/test-suite/bugs/closed/3566.v +++ b/test-suite/bugs/closed/3566.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Notation idmap := (fun x => x). Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a. Arguments idpath {A a} , [A] a. diff --git a/test-suite/bugs/opened/3593.v b/test-suite/bugs/closed/3593.v index d83b9006..378db685 100644 --- a/test-suite/bugs/opened/3593.v +++ b/test-suite/bugs/closed/3593.v @@ -5,6 +5,6 @@ Record prod A B := pair { fst : A ; snd : B }. Goal forall x : prod Set Set, let f := @fst _ in f _ x = @fst _ _ x. simpl; intros. constr_eq (@fst Set Set x) (fst (A := Set) (B := Set) x). - Fail Fail progress change (@fst Set Set x) with (fst (A := Set) (B := Set) x). + Fail progress change (@fst Set Set x) with (fst (A := Set) (B := Set) x). reflexivity. Qed. diff --git a/test-suite/bugs/closed/3666.v b/test-suite/bugs/closed/3666.v index a5b0e934..e69ec109 100644 --- a/test-suite/bugs/closed/3666.v +++ b/test-suite/bugs/closed/3666.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. (* File reduced by coq-bug-finder from original input, then from 11542 lines to 325 lines, then from 347 lines to 56 lines, then from 58 lines to 15 lines *) (* coqc version trunk (September 2014) compiled on Sep 25 2014 2:53:46 with OCaml 4.01.0 coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (bec7e0914f4a7144cd4efa8ffaccc9f72dbdb790) *) diff --git a/test-suite/bugs/opened/3685.v b/test-suite/bugs/closed/3685.v index b2b5db6b..a5bea34a 100644 --- a/test-suite/bugs/opened/3685.v +++ b/test-suite/bugs/closed/3685.v @@ -63,7 +63,7 @@ Module Success. End Success. Module Bad. Include PointwiseCore. - Fail Definition functor_uncurried `{Funext} (P : PreCategory -> Type) + Definition functor_uncurried `{Funext} (P : PreCategory -> Type) (has_functor_categories : forall C D : sub_pre_cat P, P (C -> D)) : object (((sub_pre_cat P)^op * (sub_pre_cat P)) -> (sub_pre_cat P)) := Eval cbv zeta in diff --git a/test-suite/bugs/closed/3690.v b/test-suite/bugs/closed/3690.v index 4069e380..df9f5f47 100644 --- a/test-suite/bugs/closed/3690.v +++ b/test-suite/bugs/closed/3690.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Set Printing Universes. Set Universe Polymorphism. Definition foo (a := Type) (b := Type) (c := Type) := Type. diff --git a/test-suite/bugs/closed/3736.v b/test-suite/bugs/closed/3736.v new file mode 100644 index 00000000..637b77cc --- /dev/null +++ b/test-suite/bugs/closed/3736.v @@ -0,0 +1,8 @@ +(* Check non-error failure in case of unsupported decidability scheme *) +Local Set Decidable Equality Schemes. + +Inductive a := A with b := B. + +(* But fails with error if explicitly asked for the scheme *) + +Fail Scheme Equality for a. diff --git a/test-suite/bugs/closed/3743.v b/test-suite/bugs/closed/3743.v new file mode 100644 index 00000000..4dfb3380 --- /dev/null +++ b/test-suite/bugs/closed/3743.v @@ -0,0 +1,11 @@ +(* File reduced by coq-bug-finder from original input, then from 967 lines to 469 lines, then from 459 lines to 35 lines *) +(* coqc version trunk (October 2014) compiled on Oct 11 2014 1:13:41 with OCaml 4.01.0 + coqtop version cagnode16:/afs/csail.mit.edu/u/j/jgross/coq-trunk,trunk (d65496f09c4b68fa318783e53f9cd6d5c18e1eb7) *) +Require Export Coq.Setoids.Setoid. + +Fail Add Parametric Relation A +: A (@eq A) + transitivity proved by transitivity + as refine_rel. +(* Toplevel input, characters 20-118: +Anomaly: index to an anonymous variable. Please report. *)
\ No newline at end of file diff --git a/test-suite/bugs/closed/3777.v b/test-suite/bugs/closed/3777.v new file mode 100644 index 00000000..e203528f --- /dev/null +++ b/test-suite/bugs/closed/3777.v @@ -0,0 +1,17 @@ +Unset Strict Universe Declaration. +Module WithoutPoly. + Unset Universe Polymorphism. + Definition foo (A : Type@{i}) (B : Type@{i}) := A -> B. + Set Printing Universes. + Definition bla := ((@foo : Set -> _ -> _) : _ -> Type -> _). + (* ((fun A : Set => foo A):Set -> Type@{Top.55} -> Type@{Top.55}) +:Set -> Type@{Top.55} -> Type@{Top.55} + : Set -> Type@{Top.55} -> Type@{Top.55} +(* |= Set <= Top.55 + *) *) +End WithoutPoly. +Module WithPoly. + Set Universe Polymorphism. + Definition foo (A : Type@{i}) (B : Type@{i}) := A -> B. + Set Printing Universes. + Fail Check ((@foo : Set -> _ -> _) : _ -> Type -> _). diff --git a/test-suite/bugs/closed/3779.v b/test-suite/bugs/closed/3779.v new file mode 100644 index 00000000..2b44e225 --- /dev/null +++ b/test-suite/bugs/closed/3779.v @@ -0,0 +1,12 @@ +Unset Strict Universe Declaration. +Set Universe Polymorphism. +Record UnitSubuniverse := { a : Type@{sm} ; x : (Type@{sm} : Type@{lg}) ; inO_internal : Type@{lg} -> Type@{lg} }. +Class In (O : UnitSubuniverse@{sm lg}) (T : Type@{lg}) := in_inO_internal : inO_internal O T. +Section foo. + Universes sm lg. + Context (O : UnitSubuniverse@{sm lg}). + Context {A : Type@{sm}}. + Context (H' : forall (C : Type@{lg}) `{In@{sm lg} O C} (f : A -> C), In@{sm lg} O C). + Fail Check (H' : forall (C : Type@{lg}) `{In@{i j} O C} (f : A -> C), In@{j i} O C). + Fail Context (H'' : forall (C : Type@{lg}) `{In@{i j} O C} (f : A -> C), In@{j i} O C). +End foo. diff --git a/test-suite/bugs/closed/3808.v b/test-suite/bugs/closed/3808.v index 6e19ddf8..a5c84e68 100644 --- a/test-suite/bugs/closed/3808.v +++ b/test-suite/bugs/closed/3808.v @@ -1,2 +1,3 @@ +Unset Strict Universe Declaration. Inductive Foo : (let enforce := (fun x => x) : Type@{j} -> Type@{i} in Type@{i}) := foo : Foo.
\ No newline at end of file diff --git a/test-suite/bugs/opened/3819.v b/test-suite/bugs/closed/3819.v index 7105a658..355d23a5 100644 --- a/test-suite/bugs/opened/3819.v +++ b/test-suite/bugs/closed/3819.v @@ -1,5 +1,3 @@ -Set Universe Polymorphism. - Record Op := { t : Type ; op : t -> t }. Canonical Structure OpType : Op := Build_Op Type (fun X => X). @@ -7,5 +5,5 @@ Canonical Structure OpType : Op := Build_Op Type (fun X => X). Lemma test1 (X:Type) : eq (op OpType X) X. Proof eq_refl. -Lemma test2 (A:Type) : eq (op _ A) A. -Fail Proof eq_refl. +Definition test2 (A:Type) : eq (op _ A) A. +Proof eq_refl.
\ No newline at end of file diff --git a/test-suite/bugs/closed/3821.v b/test-suite/bugs/closed/3821.v index 8da4f736..30261ed2 100644 --- a/test-suite/bugs/closed/3821.v +++ b/test-suite/bugs/closed/3821.v @@ -1,2 +1,3 @@ +Unset Strict Universe Declaration. Inductive quotient {A : Type@{i}} {B : Type@{j}} : Type@{max(i, j)} := . diff --git a/test-suite/bugs/closed/3922.v b/test-suite/bugs/closed/3922.v index 93208489..5013bc6a 100644 --- a/test-suite/bugs/closed/3922.v +++ b/test-suite/bugs/closed/3922.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Require Import TestSuite.admit. Set Universe Polymorphism. Notation Type0 := Set. @@ -43,7 +44,7 @@ Notation IsHProp := (IsTrunc -1). Monomorphic Axiom dummy_funext_type : Type0. Monomorphic Class Funext := { dummy_funext_value : dummy_funext_type }. -Inductive Unit : Type1 := +Inductive Unit : Set := tt : Unit. Record TruncType (n : trunc_index) := BuildTruncType { diff --git a/test-suite/bugs/closed/3948.v b/test-suite/bugs/closed/3948.v new file mode 100644 index 00000000..56b1e3ff --- /dev/null +++ b/test-suite/bugs/closed/3948.v @@ -0,0 +1,24 @@ +Module Type S. +Parameter t : Type. +End S. + +Module Bar(X : S). +Definition elt := X.t. +Axiom fold : elt. +End Bar. + +Module Make (Z: S) := Bar(Z). + +Declare Module Y : S. + +Module Type Interface. +Parameter constant : unit. +End Interface. + +Module DepMap : Interface. +Module Dom := Make(Y). +Definition constant : unit := + let _ := @Dom.fold in tt. +End DepMap. + +Print Assumptions DepMap.constant. diff --git a/test-suite/bugs/closed/3956.v b/test-suite/bugs/closed/3956.v new file mode 100644 index 00000000..c19a2d4a --- /dev/null +++ b/test-suite/bugs/closed/3956.v @@ -0,0 +1,143 @@ +(* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter"); mode: visual-line -*- *) +Set Universe Polymorphism. +Set Primitive Projections. +Close Scope nat_scope. + +Record prod (A B : Type) := pair { fst : A ; snd : B }. +Arguments pair {A B} _ _. +Arguments fst {A B} _ / . +Arguments snd {A B} _ / . +Notation "x * y" := (prod x y) : type_scope. +Notation "( x , y , .. , z )" := (pair .. (pair x y) .. z) : core_scope. + +Unset Strict Universe Declaration. + +Definition Type1 := Eval hnf in let gt := (Set : Type@{i}) in Type@{i}. +Definition Type2 := Eval hnf in let gt := (Type1 : Type@{i}) in Type@{i}. + +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. +Arguments idpath {A a} , [A] a. +Notation "x = y" := (@paths _ x y) : type_scope. +Definition concat {A} {x y z : A} (p : x = y) (q : y = z) : x = z + := match p, q with idpath, idpath => idpath end. + +Definition path_prod {A B : Type} (z z' : A * B) +: (fst z = fst z') -> (snd z = snd z') -> (z = z'). +Proof. + destruct z, z'; simpl; intros [] []; reflexivity. +Defined. + +Module Type TypeM. + Parameter m : Type2. +End TypeM. + +Module ProdM (XM : TypeM) (YM : TypeM) <: TypeM. + Definition m := XM.m * YM.m. +End ProdM. + +Module Type FunctionM (XM YM : TypeM). + Parameter m : XM.m -> YM.m. +End FunctionM. + +Module IdmapM (XM : TypeM) <: FunctionM XM XM. + Definition m := (fun x => x) : XM.m -> XM.m. +End IdmapM. + +Module Type HomotopyM (XM YM : TypeM) (fM gM : FunctionM XM YM). + Parameter m : forall x, fM.m x = gM.m x. +End HomotopyM. + +Module ComposeM (XM YM ZM : TypeM) + (gM : FunctionM YM ZM) (fM : FunctionM XM YM) + <: FunctionM XM ZM. + Definition m := (fun x => gM.m (fM.m x)). +End ComposeM. + +Module Type CorecM (YM ZM : TypeM) (fM : FunctionM YM ZM) + (XM : TypeM) (gM : FunctionM XM ZM). + Parameter m : XM.m -> YM.m. + Parameter m_beta : forall x, fM.m (m x) = gM.m x. +End CorecM. + +Module Type CoindpathsM (YM ZM : TypeM) (fM : FunctionM YM ZM) + (XM : TypeM) (hM kM : FunctionM XM YM). + Module fhM := ComposeM XM YM ZM fM hM. + Module fkM := ComposeM XM YM ZM fM kM. + Declare Module mM (pM : HomotopyM XM ZM fhM fkM) + : HomotopyM XM YM hM kM. +End CoindpathsM. + +Module Type Comodality (XM : TypeM). + Parameter m : Type2. + Module mM <: TypeM. + Definition m := m. + End mM. + Parameter from : m -> XM.m. + Module fromM <: FunctionM mM XM. + Definition m := from. + End fromM. + Declare Module corecM : CorecM mM XM fromM. + Declare Module coindpathsM : CoindpathsM mM XM fromM. +End Comodality. + +Module Comodality_Theory (F : Comodality). + + Module F_functor_M (XM YM : TypeM) (fM : FunctionM XM YM) + (FXM : Comodality XM) (FYM : Comodality YM). + Module f_o_from_M <: FunctionM FXM.mM YM. + Definition m := fun x => fM.m (FXM.from x). + End f_o_from_M. + Module mM := FYM.corecM FXM.mM f_o_from_M. + Definition m := mM.m. + End F_functor_M. + + Module F_prod_cmp_M (XM YM : TypeM) + (FXM : Comodality XM) (FYM : Comodality YM). + Module PM := ProdM XM YM. + Module PFM := ProdM FXM FYM. + Module fstM <: FunctionM PM XM. + Definition m := @fst XM.m YM.m. + End fstM. + Module sndM <: FunctionM PM YM. + Definition m := @snd XM.m YM.m. + End sndM. + Module FPM := F PM. + Module FfstM := F_functor_M PM XM fstM FPM FXM. + Module FsndM := F_functor_M PM YM sndM FPM FYM. + Definition m : FPM.m -> PFM.m + := fun z => (FfstM.m z , FsndM.m z). + End F_prod_cmp_M. + + Module isequiv_F_prod_cmp_M + (XM YM : TypeM) + (FXM : Comodality XM) (FYM : Comodality YM). + (** The comparison map *) + Module cmpM := F_prod_cmp_M XM YM FXM FYM. + Module FPM := cmpM.FPM. + (** We construct an inverse to it using corecursion. *) + Module prod_from_M <: FunctionM cmpM.PFM cmpM.PM. + Definition m : cmpM.PFM.m -> cmpM.PM.m + := fun z => ( FXM.from (fst z) , FYM.from (snd z) ). + End prod_from_M. + Module cmpinvM <: FunctionM cmpM.PFM FPM + := FPM.corecM cmpM.PFM prod_from_M. + (** We prove the first homotopy *) + Module cmpinv_o_cmp_M <: FunctionM FPM FPM + := ComposeM FPM cmpM.PFM FPM cmpinvM cmpM. + Module idmap_FPM <: FunctionM FPM FPM + := IdmapM FPM. + Module cip_FPM := FPM.coindpathsM FPM cmpinv_o_cmp_M idmap_FPM. + Module cip_FPHM <: HomotopyM FPM cmpM.PM cip_FPM.fhM cip_FPM.fkM. + Definition m : forall x, cip_FPM.fhM.m@{i j} x = cip_FPM.fkM.m@{i j} x. + Proof. + intros x. + refine (concat (cmpinvM.m_beta@{i j} (cmpM.m@{i j} x)) _). + apply path_prod@{i i i}; simpl. + - exact (cmpM.FfstM.mM.m_beta@{i j} x). + - exact (cmpM.FsndM.mM.m_beta@{i j} x). + Defined. + End cip_FPHM. + End isequiv_F_prod_cmp_M. + +End Comodality_Theory.
\ No newline at end of file diff --git a/test-suite/bugs/closed/3974.v b/test-suite/bugs/closed/3974.v new file mode 100644 index 00000000..b6be1595 --- /dev/null +++ b/test-suite/bugs/closed/3974.v @@ -0,0 +1,7 @@ +Module Type S. +End S. + +Module Type M (X : S). + Fail Module P (X : S). + (* Used to say: Anomaly: X already exists. Please report. *) + (* Should rather say now: Error: X already exists. *)
\ No newline at end of file diff --git a/test-suite/bugs/closed/3975.v b/test-suite/bugs/closed/3975.v new file mode 100644 index 00000000..95851c81 --- /dev/null +++ b/test-suite/bugs/closed/3975.v @@ -0,0 +1,8 @@ +Module Type S. End S. + +Module M (X:S). End M. + +Module Type P (X : S). + Print M. + (* Used to say: Anomaly: X already exists. Please report. *) + (* Should rather : print something :-) *)
\ No newline at end of file diff --git a/test-suite/bugs/closed/4034.v b/test-suite/bugs/closed/4034.v new file mode 100644 index 00000000..3f7be4d1 --- /dev/null +++ b/test-suite/bugs/closed/4034.v @@ -0,0 +1,25 @@ +(* This checks compatibility of interpretation scope used for exact + between 8.4 and 8.5. See discussion at + https://coq.inria.fr/bugs/show_bug.cgi?id=4034. It is not clear + what we would like exactly, but certainly, if exact is interpreted + in a special scope, it should be interpreted consistently so also + in ltac code. *) + +Record Foo := {}. +Bind Scope foo_scope with Foo. +Notation "!" := Build_Foo : foo_scope. +Notation "!" := 1 : core_scope. +Open Scope foo_scope. +Open Scope core_scope. + +Goal Foo. + Fail exact !. +(* ... but maybe will we want it to succeed eventually if we ever + would be able to make it working the same in + +Ltac myexact e := exact e. + +Goal Foo. + myexact !. +Defined. +*) diff --git a/test-suite/bugs/closed/4057.v b/test-suite/bugs/closed/4057.v new file mode 100644 index 00000000..4f0e696c --- /dev/null +++ b/test-suite/bugs/closed/4057.v @@ -0,0 +1,210 @@ +Require Coq.Strings.String. + +Set Implicit Arguments. + +Axiom falso : False. +Ltac admit := destruct falso. + +Reserved Notation "[ x ]". + +Record string_like (CharType : Type) := + { + String :> Type; + Singleton : CharType -> String where "[ x ]" := (Singleton x); + Empty : String; + Concat : String -> String -> String where "x ++ y" := (Concat x y); + bool_eq : String -> String -> bool; + bool_eq_correct : forall x y : String, bool_eq x y = true <-> x = y; + Length : String -> nat + }. + +Delimit Scope string_like_scope with string_like. +Bind Scope string_like_scope with String. +Arguments Length {_%type_scope _} _%string_like. +Infix "++" := (@Concat _ _) : string_like_scope. + +Definition str_le {CharType} {String : string_like CharType} (s1 s2 : String) + := Length s1 < Length s2 \/ s1 = s2. +Infix "≤s" := str_le (at level 70, right associativity). + +Module Export ContextFreeGrammar. + Import Coq.Strings.String. + Import Coq.Lists.List. + + Section cfg. + Variable CharType : Type. + + Section definitions. + + Inductive item := + | NonTerminal (name : string). + + Definition production := list item. + Definition productions := list production. + + Record grammar := + { + Start_symbol :> string; + Lookup :> string -> productions + }. + End definitions. + + Section parse. + Variable String : string_like CharType. + Variable G : grammar. + + Inductive parse_of : String -> productions -> Type := + | ParseHead : forall str pat pats, parse_of_production str pat + -> parse_of str (pat::pats) + | ParseTail : forall str pat pats, parse_of str pats + -> parse_of str (pat::pats) + with parse_of_production : String -> production -> Type := + | ParseProductionCons : forall str pat strs pats, + parse_of_item str pat + -> parse_of_production strs pats + -> parse_of_production (str ++ strs) (pat::pats) + with parse_of_item : String -> item -> Type := + | ParseNonTerminal : forall name str, parse_of str (Lookup G name) + -> parse_of_item str (NonTerminal +name). + End parse. + End cfg. + +End ContextFreeGrammar. +Module Export ContextFreeGrammarProperties. + + Section cfg. + Context CharType (String : string_like CharType) (G : grammar) + (P : String.string -> Type). + + Fixpoint Forall_parse_of {str pats} (p : parse_of String G str pats) + := match p with + | @ParseHead _ _ _ str pat pats p' + => Forall_parse_of_production p' + | @ParseTail _ _ _ _ _ _ p' + => Forall_parse_of p' + end + with Forall_parse_of_production {str pat} (p : parse_of_production String G +str pat) + := let Forall_parse_of_item {str it} (p : parse_of_item String G str +it) + := match p return Type with + | @ParseNonTerminal _ _ _ name str p' + => (P name * Forall_parse_of p')%type + end in + match p return Type with + | @ParseProductionCons _ _ _ str pat strs pats p' p'' + => (Forall_parse_of_item p' * Forall_parse_of_production +p'')%type + end. + + Definition Forall_parse_of_item {str it} (p : parse_of_item String G str it) + := match p return Type with + | @ParseNonTerminal _ _ _ name str p' + => (P name * Forall_parse_of p')%type + end. + End cfg. + +End ContextFreeGrammarProperties. + +Module Export DependentlyTyped. + Import Coq.Strings.String. + + Section recursive_descent_parser. + + Class parser_computational_predataT := + { nonterminal_names_listT : Type; + initial_nonterminal_names_data : nonterminal_names_listT; + is_valid_nonterminal_name : nonterminal_names_listT -> string -> bool; + remove_nonterminal_name : nonterminal_names_listT -> string -> +nonterminal_names_listT }. + + End recursive_descent_parser. + +End DependentlyTyped. +Import Coq.Strings.String. +Import Coq.Lists.List. + +Section cfg. + Context CharType (String : string_like CharType) (G : grammar). + Context (names_listT : Type) + (initial_names_data : names_listT) + (is_valid_name : names_listT -> string -> bool) + (remove_name : names_listT -> string -> names_listT). + + Inductive minimal_parse_of + : forall (str0 : String) (valid : names_listT) + (str : String), + productions -> Type := + | MinParseHead : forall str0 valid str pat pats, + @minimal_parse_of_production str0 valid str pat + -> @minimal_parse_of str0 valid str (pat::pats) + | MinParseTail : forall str0 valid str pat pats, + @minimal_parse_of str0 valid str pats + -> @minimal_parse_of str0 valid str (pat::pats) + with minimal_parse_of_production + : forall (str0 : String) (valid : names_listT) + (str : String), + production -> Type := + | MinParseProductionNil : forall str0 valid, + @minimal_parse_of_production str0 valid (Empty _) +nil + | MinParseProductionCons : forall str0 valid str strs pat pats, + str ++ strs ≤s str0 + -> @minimal_parse_of_item str0 valid str pat + -> @minimal_parse_of_production str0 valid strs +pats + -> @minimal_parse_of_production str0 valid (str +++ strs) (pat::pats) + with minimal_parse_of_item + : forall (str0 : String) (valid : names_listT) + (str : String), + item -> Type := + | MinParseNonTerminal + : forall str0 valid str name, + @minimal_parse_of_name str0 valid str name + -> @minimal_parse_of_item str0 valid str (NonTerminal name) + with minimal_parse_of_name + : forall (str0 : String) (valid : names_listT) + (str : String), + string -> Type := + | MinParseNonTerminalStrLt + : forall str0 valid name str, + @minimal_parse_of str initial_names_data str (Lookup G name) + -> @minimal_parse_of_name str0 valid str name + | MinParseNonTerminalStrEq + : forall str valid name, + @minimal_parse_of str (remove_name valid name) str (Lookup G name) + -> @minimal_parse_of_name str valid str name. + Definition parse_of_item_name__of__minimal_parse_of_name + : forall {str0 valid str name} (p : @minimal_parse_of_name str0 valid str +name), + parse_of_item String G str (NonTerminal name). + Proof. + admit. + Defined. + +End cfg. + +Section recursive_descent_parser. + Context (CharType : Type) + (String : string_like CharType) + (G : grammar). + Context {premethods : parser_computational_predataT}. + Let P : string -> Prop. + Proof. + admit. + Defined. + + Let mp_parse_nonterminal_name str0 valid str nonterminal_name + := { p' : minimal_parse_of_name String G initial_nonterminal_names_data +remove_nonterminal_name str0 valid str nonterminal_name & Forall_parse_of_item +P (parse_of_item_name__of__minimal_parse_of_name p') }. + + Goal False. + Proof. + clear -mp_parse_nonterminal_name. + subst P. + simpl in *. + admit. + Qed. diff --git a/test-suite/bugs/closed/4069.v b/test-suite/bugs/closed/4069.v new file mode 100644 index 00000000..21b03ce5 --- /dev/null +++ b/test-suite/bugs/closed/4069.v @@ -0,0 +1,51 @@ + +Lemma test1 : +forall (v : nat) (f g : nat -> nat), +f v = g v. +intros. f_equal. +(* +Goal in v8.5: f v = g v +Goal in v8.4: v = v -> f v = g v +Expected: f = g +*) +Admitted. + +Lemma test2 : +forall (v u : nat) (f g : nat -> nat), +f v = g u. +intros. f_equal. +(* +In both v8.4 And v8.5 +Goal 1: v = u -> f v = g u +Goal 2: v = u + +Expected Goal 1: f = g +Expected Goal 2: v = u +*) +Admitted. + +Lemma test3 : +forall (v : nat) (u : list nat) (f : nat -> nat) (g : list nat -> nat), +f v = g u. +intros. f_equal. +(* +In both v8.4 And v8.5, the goal is unchanged. +*) +Admitted. + +Require Import List. +Lemma foo n (l k : list nat) : k ++ skipn n l = skipn n l. +Proof. f_equal. +(* + 8.4: leaves the goal unchanged, i.e. k ++ skipn n l = skipn n l + 8.5: 2 goals, skipn n l = l -> k ++ skipn n l = skipn n l + and skipn n l = l +*) +Require Import List. +Fixpoint replicate {A} (n : nat) (x : A) : list A := + match n with 0 => nil | S n => x :: replicate n x end. +Lemma bar {A} n m (x : A) : + skipn n (replicate m x) = replicate (m - n) x -> + skipn n (replicate m x) = replicate (m - n) x. +Proof. intros. f_equal. +(* 8.5: one goal, n = m - n *) diff --git a/test-suite/bugs/closed/4089.v b/test-suite/bugs/closed/4089.v index 1449f242..e4d76732 100644 --- a/test-suite/bugs/closed/4089.v +++ b/test-suite/bugs/closed/4089.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Require Import TestSuite.admit. (* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *) (* File reduced by coq-bug-finder from original input, then from 6522 lines to 318 lines, then from 1139 lines to 361 lines *) @@ -163,7 +164,7 @@ Notation "A <~> B" := (Equiv A B) (at level 85) : type_scope. Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : function_scope. -Inductive Unit : Type1 := +Inductive Unit : Set := tt : Unit. Ltac done := diff --git a/test-suite/bugs/closed/4116.v b/test-suite/bugs/closed/4116.v new file mode 100644 index 00000000..f808cb45 --- /dev/null +++ b/test-suite/bugs/closed/4116.v @@ -0,0 +1,383 @@ +(* File reduced by coq-bug-finder from original input, then from 13191 lines to 1315 lines, then from 1601 lines to 595 lines, then from 585 lines to 379 lines *) +(* coqc version 8.5beta1 (March 2015) compiled on Mar 3 2015 3:50:31 with OCaml 4.01.0 + coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-8.5,v8.5 (ac62cda8a4f488b94033b108c37556877232137a) *) + +Axiom admit : False. +Ltac admit := exfalso; exact admit. + +Global Set Primitive Projections. + +Notation projT1 := proj1_sig (only parsing). +Notation projT2 := proj2_sig (only parsing). + +Definition relation (A : Type) := A -> A -> Type. + +Class Reflexive {A} (R : relation A) := + reflexivity : forall x : A, R x x. + +Class Symmetric {A} (R : relation A) := + symmetry : forall x y, R x y -> R y x. + +Notation idmap := (fun x => x). +Delimit Scope function_scope with function. +Delimit Scope path_scope with path. +Delimit Scope fibration_scope with fibration. +Open Scope path_scope. +Open Scope fibration_scope. +Open Scope function_scope. + +Notation pr1 := projT1. +Notation pr2 := projT2. + +Notation "x .1" := (pr1 x) (at level 3, format "x '.1'") : fibration_scope. +Notation "x .2" := (pr2 x) (at level 3, format "x '.2'") : fibration_scope. + +Notation compose := (fun g f x => g (f x)). + +Notation "g 'o' f" := (compose g%function f%function) (at level 40, left associativity) : function_scope. + +Inductive paths {A : Type} (a : A) : A -> Type := + idpath : paths a a. + +Arguments idpath {A a} , [A] a. + +Notation "x = y :> A" := (@paths A x y) : type_scope. +Notation "x = y" := (x = y :>_) : type_scope. + +Definition inverse {A : Type} {x y : A} (p : x = y) : y = x + := match p with idpath => idpath end. + +Global Instance symmetric_paths {A} : Symmetric (@paths A) | 0 := @inverse A. + +Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := + match p, q with idpath, idpath => idpath end. + +Notation "1" := idpath : path_scope. + +Notation "p @ q" := (concat p%path q%path) (at level 20) : path_scope. + +Notation "p ^" := (inverse p%path) (at level 3, format "p '^'") : path_scope. + +Definition transport {A : Type} (P : A -> Type) {x y : A} (p : x = y) (u : P x) : P y := + match p with idpath => u end. + +Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y + := match p with idpath => idpath end. + +Definition pointwise_paths {A} {P:A->Type} (f g:forall x:A, P x) + := forall x:A, f x = g x. + +Notation "f == g" := (pointwise_paths f g) (at level 70, no associativity) : type_scope. + +Definition apD10 {A} {B:A->Type} {f g : forall x, B x} (h:f=g) +: f == g + := fun x => match h with idpath => 1 end. + +Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := + forall x : A, r (s x) = x. + +Class IsEquiv {A B : Type} (f : A -> B) := BuildIsEquiv { + equiv_inv : B -> A ; + eisretr : Sect equiv_inv f; + eissect : Sect f equiv_inv; + eisadj : forall x : A, eisretr (f x) = ap f (eissect x) + }. + +Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : function_scope. + +Class Contr_internal (A : Type) := BuildContr { + center : A ; + contr : (forall y : A, center = y) + }. + +Inductive trunc_index : Type := +| minus_two : trunc_index +| trunc_S : trunc_index -> trunc_index. + +Notation "n .+1" := (trunc_S n) (at level 2, left associativity, format "n .+1") : trunc_scope. +Local Open Scope trunc_scope. +Notation "-2" := minus_two (at level 0) : trunc_scope. +Notation "-1" := (-2.+1) (at level 0) : trunc_scope. +Notation "0" := (-1.+1) : trunc_scope. + +Fixpoint IsTrunc_internal (n : trunc_index) (A : Type) : Type := + match n with + | -2 => Contr_internal A + | n'.+1 => forall (x y : A), IsTrunc_internal n' (x = y) + end. + +Class IsTrunc (n : trunc_index) (A : Type) : Type := + Trunc_is_trunc : IsTrunc_internal n A. + +Tactic Notation "transparent" "assert" "(" ident(name) ":" constr(type) ")" := + refine (let __transparent_assert_hypothesis := (_ : type) in _); + [ + | ( + let H := match goal with H := _ |- _ => constr:(H) end in + rename H into name) ]. + +Definition transport_idmap_ap A (P : A -> Type) x y (p : x = y) (u : P x) +: transport P p u = transport idmap (ap P p) u + := match p with idpath => idpath end. + +Section Adjointify. + + Context {A B : Type} (f : A -> B) (g : B -> A). + Context (isretr : Sect g f) (issect : Sect f g). + + Let issect' := fun x => + ap g (ap f (issect x)^) @ ap g (isretr (f x)) @ issect x. + + Let is_adjoint' (a : A) : isretr (f a) = ap f (issect' a). + admit. + Defined. + + Definition isequiv_adjointify : IsEquiv f + := BuildIsEquiv A B f g isretr issect' is_adjoint'. + +End Adjointify. + +Record TruncType (n : trunc_index) := BuildTruncType { + trunctype_type : Type ; + istrunc_trunctype_type : IsTrunc n trunctype_type + }. +Arguments trunctype_type {_} _. + +Coercion trunctype_type : TruncType >-> Sortclass. + +Notation "n -Type" := (TruncType n) (at level 1) : type_scope. +Notation hSet := 0-Type. + +Module Export Category. + Module Export Core. + Set Implicit Arguments. + + Delimit Scope morphism_scope with morphism. + Delimit Scope category_scope with category. + Delimit Scope object_scope with object. + + Record PreCategory := + Build_PreCategory' { + object :> Type; + morphism : object -> object -> Type; + + identity : forall x, morphism x x; + compose : forall s d d', + morphism d d' + -> morphism s d + -> morphism s d' + where "f 'o' g" := (compose f g); + + associativity : forall x1 x2 x3 x4 + (m1 : morphism x1 x2) + (m2 : morphism x2 x3) + (m3 : morphism x3 x4), + (m3 o m2) o m1 = m3 o (m2 o m1); + + associativity_sym : forall x1 x2 x3 x4 + (m1 : morphism x1 x2) + (m2 : morphism x2 x3) + (m3 : morphism x3 x4), + m3 o (m2 o m1) = (m3 o m2) o m1; + + left_identity : forall a b (f : morphism a b), identity b o f = f; + right_identity : forall a b (f : morphism a b), f o identity a = f; + + identity_identity : forall x, identity x o identity x = identity x + }. + Arguments identity {!C%category} / x%object : rename. + Arguments compose {!C%category} / {s d d'}%object (m1 m2)%morphism : rename. + + Definition Build_PreCategory + object morphism compose identity + associativity left_identity right_identity + := @Build_PreCategory' + object + morphism + compose + identity + associativity + (fun _ _ _ _ _ _ _ => symmetry _ _ (associativity _ _ _ _ _ _ _)) + left_identity + right_identity + (fun _ => left_identity _ _ _). + + Module Export CategoryCoreNotations. + Infix "o" := compose : morphism_scope. + Notation "1" := (identity _) : morphism_scope. + End CategoryCoreNotations. + + End Core. + +End Category. +Module Export Core. + Set Implicit Arguments. + + Delimit Scope functor_scope with functor. + + Local Open Scope morphism_scope. + + Section Functor. + Variables C D : PreCategory. + + Record Functor := + { + object_of :> C -> D; + morphism_of : forall s d, morphism C s d + -> morphism D (object_of s) (object_of d); + composition_of : forall s d d' + (m1 : morphism C s d) (m2: morphism C d d'), + morphism_of _ _ (m2 o m1) + = (morphism_of _ _ m2) o (morphism_of _ _ m1); + identity_of : forall x, morphism_of _ _ (identity x) + = identity (object_of x) + }. + End Functor. + Arguments morphism_of [C%category] [D%category] F%functor [s%object d%object] m%morphism : rename, simpl nomatch. + +End Core. +Module Export Morphisms. + Set Implicit Arguments. + + Local Open Scope category_scope. + Local Open Scope morphism_scope. + + Class IsIsomorphism {C : PreCategory} {s d} (m : morphism C s d) := + { + morphism_inverse : morphism C d s; + left_inverse : morphism_inverse o m = identity _; + right_inverse : m o morphism_inverse = identity _ + }. + + Class Isomorphic {C : PreCategory} s d := + { + morphism_isomorphic :> morphism C s d; + isisomorphism_isomorphic :> IsIsomorphism morphism_isomorphic + }. + + Coercion morphism_isomorphic : Isomorphic >-> morphism. + + Local Infix "<~=~>" := Isomorphic (at level 70, no associativity) : category_scope. + + Section iso_equiv_relation. + Variable C : PreCategory. + + Global Instance isisomorphism_identity (x : C) : IsIsomorphism (identity x) + := {| morphism_inverse := identity x; + left_inverse := left_identity C x x (identity x); + right_inverse := right_identity C x x (identity x) |}. + + Global Instance isomorphic_refl : Reflexive (@Isomorphic C) + := fun x : C => {| morphism_isomorphic := identity x |}. + + Definition idtoiso (x y : C) (H : x = y) : Isomorphic x y + := match H in (_ = y0) return (x <~=~> y0) with + | 1%path => reflexivity x + end. + End iso_equiv_relation. + +End Morphisms. + +Notation IsCategory C := (forall s d : object C, IsEquiv (@idtoiso C s d)). + +Notation isotoid C s d := (@equiv_inv _ _ (@idtoiso C s d) _). + +Notation cat_of obj := + (@Build_PreCategory obj + (fun x y => x -> y) + (fun _ x => x) + (fun _ _ _ f g => f o g)%core + (fun _ _ _ _ _ _ _ => idpath) + (fun _ _ _ => idpath) + (fun _ _ _ => idpath) + ). +Definition set_cat : PreCategory := cat_of hSet. +Set Implicit Arguments. + +Local Open Scope morphism_scope. + +Section Grothendieck. + Variable C : PreCategory. + Variable F : Functor C set_cat. + + Record Pair := + { + c : C; + x : F c + }. + + Local Notation Gmorphism s d := + { f : morphism C s.(c) d.(c) + | morphism_of F f s.(x) = d.(x) }. + + Definition identity_H s + := apD10 (identity_of F s.(c)) s.(x). + + Definition Gidentity s : Gmorphism s s. + Proof. + exists 1. + apply identity_H. + Defined. + + Definition Gcategory : PreCategory. + Proof. + refine (@Build_PreCategory + Pair + (fun s d => Gmorphism s d) + Gidentity + _ + _ + _ + _); admit. + Defined. +End Grothendieck. + +Lemma isotoid_1 {C} `{IsCategory C} {x : C} {H : IsIsomorphism (identity x)} +: isotoid C x x {| morphism_isomorphic := (identity x) ; isisomorphism_isomorphic := H |} + = idpath. + admit. +Defined. +Generalizable All Variables. + +Section Grothendieck2. + Context `{IsCategory C}. + Variable F : Functor C set_cat. + + Instance iscategory_grothendieck_toset : IsCategory (Gcategory F). + Proof. + intros s d. + refine (isequiv_adjointify _ _ _ _). + { + intro m. + transparent assert (H' : (s.(c) = d.(c))). + { + apply (idtoiso C (x := s.(c)) (y := d.(c)))^-1%function. + exists (m : morphism _ _ _).1. + admit. + + } + { + transitivity {| x := transport (fun x => F x) H' s.(x) |}. + admit. + + { + change d with {| c := d.(c) ; x := d.(x) |}; simpl. + apply ap. + subst H'. + simpl. + refine (transport_idmap_ap _ (fun x => F x : Type) _ _ _ _ @ _ @ (m : morphism _ _ _).2). + change (fun x => F x : Type) with (trunctype_type o object_of F)%function. + admit. + } + } + } + { + admit. + } + + { + intro x. + hnf in s, d. + destruct x. + simpl. + erewrite @isotoid_1. diff --git a/test-suite/bugs/closed/4121.v b/test-suite/bugs/closed/4121.v index 5f8c411c..d34a2b8b 100644 --- a/test-suite/bugs/closed/4121.v +++ b/test-suite/bugs/closed/4121.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. (* -*- coq-prog-args: ("-emacs" "-nois") -*- *) (* File reduced by coq-bug-finder from original input, then from 830 lines to 47 lines, then from 25 lines to 11 lines *) (* coqc version 8.5beta1 (March 2015) compiled on Mar 11 2015 18:51:36 with OCaml 4.01.0 diff --git a/test-suite/bugs/closed/4151.v b/test-suite/bugs/closed/4151.v new file mode 100644 index 00000000..fec64555 --- /dev/null +++ b/test-suite/bugs/closed/4151.v @@ -0,0 +1,403 @@ +Lemma foo (H : forall A, A) : forall A, A. + Show Universes. + eexact H. +Qed. + +(* File reduced by coq-bug-finder from original input, then from 6390 lines to 397 lines *) +(* coqc version 8.5beta1 (March 2015) compiled on Mar 17 2015 12:34:25 with OCaml 4.01.0 + coqtop version cagnode15:/afs/csail.mit.edu/u/j/jgross/coq-8.5,v8.5 (1b3759e78f227eb85a128c58b8ce8c11509dd8c3) *) +Axiom proof_admitted : False. +Tactic Notation "admit" := case proof_admitted. +Require Import Coq.Lists.SetoidList. +Require Export Coq.Program.Program. + +Global Set Implicit Arguments. +Global Set Asymmetric Patterns. + +Fixpoint combine_sig_helper {T} {P : T -> Prop} (ls : list T) : (forall x, In x ls -> P x) -> list (sig P). + admit. +Defined. + +Lemma Forall_forall1_transparent_helper_1 {A P} {x : A} {xs : list A} {l : list A} + (H : Forall P l) (H' : x::xs = l) +: P x. + admit. +Defined. +Lemma Forall_forall1_transparent_helper_2 {A P} {x : A} {xs : list A} {l : list A} + (H : Forall P l) (H' : x::xs = l) +: Forall P xs. + admit. +Defined. + +Fixpoint Forall_forall1_transparent {A} (P : A -> Prop) (l : list A) {struct l} +: Forall P l -> forall x, In x l -> P x + := match l as l return Forall P l -> forall x, In x l -> P x with + | nil => fun _ _ f => match f : False with end + | x::xs => fun H x' H' => + match H' with + | or_introl H'' => eq_rect x + P + (Forall_forall1_transparent_helper_1 H eq_refl) + _ + H'' + | or_intror H'' => @Forall_forall1_transparent A P xs (Forall_forall1_transparent_helper_2 H eq_refl) _ H'' + end + end. + +Definition combine_sig {T P ls} (H : List.Forall P ls) : list (@sig T P) + := combine_sig_helper ls (@Forall_forall1_transparent T P ls H). +Fixpoint Forall_tails {T} (P : list T -> Type) (ls : list T) : Type + := match ls with + | nil => P nil + | x::xs => (P (x::xs) * Forall_tails P xs)%type + end. + +Record string_like (CharType : Type) := + { + String :> Type; + Singleton : CharType -> String where "[ x ]" := (Singleton x); + Empty : String; + Concat : String -> String -> String where "x ++ y" := (Concat x y); + bool_eq : String -> String -> bool; + bool_eq_correct : forall x y : String, bool_eq x y = true <-> x = y; + Length : String -> nat; + Associativity : forall x y z, (x ++ y) ++ z = x ++ (y ++ z); + LeftId : forall x, Empty ++ x = x; + RightId : forall x, x ++ Empty = x; + Singleton_Length : forall x, Length (Singleton x) = 1; + Length_correct : forall s1 s2, Length s1 + Length s2 = Length (s1 ++ s2); + Length_Empty : Length Empty = 0; + Empty_Length : forall s1, Length s1 = 0 -> s1 = Empty; + Not_Singleton_Empty : forall x, Singleton x <> Empty; + SplitAt : nat -> String -> String * String; + SplitAt_correct : forall n s, fst (SplitAt n s) ++ snd (SplitAt n s) = s; + SplitAt_concat_correct : forall s1 s2, SplitAt (Length s1) (s1 ++ s2) = (s1, s2); + SplitAtLength_correct : forall n s, Length (fst (SplitAt n s)) = min (Length s) n + }. + +Delimit Scope string_like_scope with string_like. +Bind Scope string_like_scope with String. +Arguments Length {_%type_scope _} _%string_like. +Notation "[[ x ]]" := (@Singleton _ _ x) : string_like_scope. +Infix "++" := (@Concat _ _) : string_like_scope. +Infix "=s" := (@bool_eq _ _) (at level 70, right associativity) : string_like_scope. + +Definition str_le {CharType} {String : string_like CharType} (s1 s2 : String) + := Length s1 < Length s2 \/ s1 = s2. +Infix "≤s" := str_le (at level 70, right associativity). + +Record StringWithSplitState {CharType} (String : string_like CharType) (split_stateT : String -> Type) := + { string_val :> String; + state_val : split_stateT string_val }. + +Module Export ContextFreeGrammar. + Require Import Coq.Strings.String. + + Section cfg. + Variable CharType : Type. + + Section definitions. + + Inductive item := + | Terminal (_ : CharType) + | NonTerminal (_ : string). + + Definition production := list item. + Definition productions := list production. + + Record grammar := + { + Start_symbol :> string; + Lookup :> string -> productions; + Start_productions :> productions := Lookup Start_symbol; + Valid_nonterminals : list string; + Valid_productions : list productions := map Lookup Valid_nonterminals + }. + End definitions. + + End cfg. + +End ContextFreeGrammar. +Module Export BaseTypes. + Import Coq.Strings.String. + + Local Open Scope string_like_scope. + + Inductive any_grammar CharType := + | include_item (_ : item CharType) + | include_production (_ : production CharType) + | include_productions (_ : productions CharType) + | include_nonterminal (_ : string). + Global Coercion include_item : item >-> any_grammar. + Global Coercion include_production : production >-> any_grammar. + + Section recursive_descent_parser. + Context {CharType : Type} + {String : string_like CharType} + {G : grammar CharType}. + + Class parser_computational_predataT := + { nonterminals_listT : Type; + initial_nonterminals_data : nonterminals_listT; + is_valid_nonterminal : nonterminals_listT -> string -> bool; + remove_nonterminal : nonterminals_listT -> string -> nonterminals_listT; + nonterminals_listT_R : nonterminals_listT -> nonterminals_listT -> Prop; + remove_nonterminal_dec : forall ls nonterminal, + is_valid_nonterminal ls nonterminal = true + -> nonterminals_listT_R (remove_nonterminal ls nonterminal) ls; + ntl_wf : well_founded nonterminals_listT_R }. + + Class parser_computational_types_dataT := + { predata :> parser_computational_predataT; + split_stateT : String -> nonterminals_listT -> any_grammar CharType -> String -> Type }. + + Class parser_computational_dataT' `{parser_computational_types_dataT} := + { split_string_for_production + : forall (str0 : String) (valid : nonterminals_listT) (it : item CharType) (its : production CharType) (str : StringWithSplitState String (split_stateT str0 valid (it::its : production CharType))), + list (StringWithSplitState String (split_stateT str0 valid it) + * StringWithSplitState String (split_stateT str0 valid its)); + split_string_for_production_correct + : forall str0 valid it its str, + let P f := List.Forall f (@split_string_for_production str0 valid it its str) in + P (fun s1s2 => (fst s1s2 ++ snd s1s2 =s str) = true) }. + End recursive_descent_parser. + +End BaseTypes. +Import Coq.Strings.String. + +Section cfg. + Context CharType (String : string_like CharType) (G : grammar CharType). + Context (names_listT : Type) + (initial_names_data : names_listT) + (is_valid_name : names_listT -> string -> bool) + (remove_name : names_listT -> string -> names_listT) + (names_listT_R : names_listT -> names_listT -> Prop) + (remove_name_dec : forall ls name, + is_valid_name ls name = true + -> names_listT_R (remove_name ls name) ls) + (remove_name_1 + : forall ls ps ps', + is_valid_name (remove_name ls ps) ps' = true + -> is_valid_name ls ps' = true) + (remove_name_2 + : forall ls ps ps', + is_valid_name (remove_name ls ps) ps' = false + <-> is_valid_name ls ps' = false \/ ps = ps') + (ntl_wf : well_founded names_listT_R). + + Inductive minimal_parse_of + : forall (str0 : String) (valid : names_listT) + (str : String), + productions CharType -> Type := + | MinParseHead : forall str0 valid str pat pats, + @minimal_parse_of_production str0 valid str pat + -> @minimal_parse_of str0 valid str (pat::pats) + | MinParseTail : forall str0 valid str pat pats, + @minimal_parse_of str0 valid str pats + -> @minimal_parse_of str0 valid str (pat::pats) + with minimal_parse_of_production + : forall (str0 : String) (valid : names_listT) + (str : String), + production CharType -> Type := + | MinParseProductionNil : forall str0 valid, + @minimal_parse_of_production str0 valid (Empty _) nil + | MinParseProductionCons : forall str0 valid str strs pat pats, + str ++ strs ≤s str0 + -> @minimal_parse_of_item str0 valid str pat + -> @minimal_parse_of_production str0 valid strs pats + -> @minimal_parse_of_production str0 valid (str ++ strs) (pat::pats) + with minimal_parse_of_item + : forall (str0 : String) (valid : names_listT) + (str : String), + item CharType -> Type := + | MinParseTerminal : forall str0 valid x, + @minimal_parse_of_item str0 valid [[ x ]]%string_like (Terminal x) + | MinParseNonTerminal + : forall str0 valid str name, + @minimal_parse_of_name str0 valid str name + -> @minimal_parse_of_item str0 valid str (NonTerminal CharType name) + with minimal_parse_of_name + : forall (str0 : String) (valid : names_listT) + (str : String), + string -> Type := + | MinParseNonTerminalStrLt + : forall str0 valid name str, + Length str < Length str0 + -> is_valid_name initial_names_data name = true + -> @minimal_parse_of str initial_names_data str (Lookup G name) + -> @minimal_parse_of_name str0 valid str name + | MinParseNonTerminalStrEq + : forall str valid name, + is_valid_name initial_names_data name = true + -> is_valid_name valid name = true + -> @minimal_parse_of str (remove_name valid name) str (Lookup G name) + -> @minimal_parse_of_name str valid str name. +End cfg. + +Local Coercion is_true : bool >-> Sortclass. + +Local Open Scope string_like_scope. + +Section general. + Context {CharType} {String : string_like CharType} {G : grammar CharType}. + + Class boolean_parser_dataT := + { predata :> parser_computational_predataT; + split_stateT : String -> Type; + data' :> _ := {| BaseTypes.predata := predata ; BaseTypes.split_stateT := fun _ _ _ => split_stateT |}; + split_string_for_production + : forall it its, + StringWithSplitState String split_stateT + -> list (StringWithSplitState String split_stateT * StringWithSplitState String split_stateT); + split_string_for_production_correct + : forall it its (str : StringWithSplitState String split_stateT), + let P f := List.Forall f (split_string_for_production it its str) in + P (fun s1s2 => + (fst s1s2 ++ snd s1s2 =s str) = true); + premethods :> parser_computational_dataT' + := @Build_parser_computational_dataT' + _ String data' + (fun _ _ => split_string_for_production) + (fun _ _ => split_string_for_production_correct) }. + + Definition split_list_completeT `{data : boolean_parser_dataT} + {str0 valid} + (str : StringWithSplitState String split_stateT) (pf : str ≤s str0) + (split_list : list (StringWithSplitState String split_stateT * StringWithSplitState String split_stateT)) + (it : item CharType) (its : production CharType) + := ({ s1s2 : String * String + & (fst s1s2 ++ snd s1s2 =s str) + * (minimal_parse_of_item _ G initial_nonterminals_data is_valid_nonterminal remove_nonterminal str0 valid (fst s1s2) it) + * (minimal_parse_of_production _ G initial_nonterminals_data is_valid_nonterminal remove_nonterminal str0 valid (snd s1s2) its) }%type) + -> ({ s1s2 : StringWithSplitState String split_stateT * StringWithSplitState String split_stateT + & (In s1s2 split_list) + * (minimal_parse_of_item _ G initial_nonterminals_data is_valid_nonterminal remove_nonterminal str0 valid (fst s1s2) it) + * (minimal_parse_of_production _ G initial_nonterminals_data is_valid_nonterminal remove_nonterminal str0 valid (snd s1s2) its) }%type). +End general. + +Section recursive_descent_parser. + Context {CharType} + {String : string_like CharType} + {G : grammar CharType}. + Context `{data : @boolean_parser_dataT _ String}. + + Section bool. + Section parts. + Definition parse_item + (str_matches_nonterminal : string -> bool) + (str : StringWithSplitState String split_stateT) + (it : item CharType) + : bool + := match it with + | Terminal ch => [[ ch ]] =s str + | NonTerminal nt => str_matches_nonterminal nt + end. + + Section production. + Context {str0} + (parse_nonterminal + : forall (str : StringWithSplitState String split_stateT), + str ≤s str0 + -> string + -> bool). + + Fixpoint parse_production + (str : StringWithSplitState String split_stateT) + (pf : str ≤s str0) + (prod : production CharType) + : bool. + Proof. + refine + match prod with + | nil => + + str =s Empty _ + | it::its + => let parse_production' := fun str pf => parse_production str pf its in + fold_right + orb + false + (let mapF f := map f (combine_sig (split_string_for_production_correct it its str)) in + mapF (fun s1s2p => + (parse_item + (parse_nonterminal (fst (proj1_sig s1s2p)) _) + (fst (proj1_sig s1s2p)) + it) + && parse_production' (snd (proj1_sig s1s2p)) _)%bool) + end; + revert pf; clear; intros; admit. + Defined. + End production. + + End parts. + End bool. +End recursive_descent_parser. + +Section sound. + Context CharType (String : string_like CharType) (G : grammar CharType). + Context `{data : @boolean_parser_dataT CharType String}. + + Section production. + Context (str0 : String) + (parse_nonterminal : forall (str : StringWithSplitState String split_stateT), + str ≤s str0 + -> string + -> bool). + + Definition parse_nonterminal_completeT P + := forall valid (str : StringWithSplitState String split_stateT) pf nonterminal (H_sub : P str0 valid nonterminal), + minimal_parse_of_name _ G initial_nonterminals_data is_valid_nonterminal remove_nonterminal str0 valid str nonterminal + -> @parse_nonterminal str pf nonterminal = true. + + Lemma parse_production_complete + valid Pv + (parse_nonterminal_complete : parse_nonterminal_completeT Pv) + (Hinit : forall str (pf : str ≤s str0) nonterminal, + minimal_parse_of_name String G initial_nonterminals_data is_valid_nonterminal remove_nonterminal str0 valid str nonterminal + -> Pv str0 valid nonterminal) + (str : StringWithSplitState String split_stateT) (pf : str ≤s str0) + (prod : production CharType) + (split_string_for_production_complete' + : forall str0 valid str pf, + Forall_tails + (fun prod' => + match prod' return Type with + | nil => True + | it::its => split_list_completeT (G := G) (valid := valid) (str0 := str0) str pf (split_string_for_production it its str) it its + end) + prod) + : minimal_parse_of_production _ G initial_nonterminals_data is_valid_nonterminal remove_nonterminal str0 valid str prod + -> parse_production parse_nonterminal str pf prod = true. + admit. + Defined. + End production. + Context (str0 : String) + (parse_nonterminal : forall (str : StringWithSplitState String split_stateT), + str ≤s str0 + -> string + -> bool). + + Goal forall (a : production CharType), + (forall (str1 : String) (valid : nonterminals_listT) + (str : StringWithSplitState String split_stateT) + (pf : str ≤s str1), + Forall_tails + (fun prod' : list (item CharType) => + match prod' with + | [] => True + | it :: its => + split_list_completeT (G := G) (valid := valid) str pf + (split_string_for_production it its str) it its + end) a) -> + forall (str : String) (pf : str ≤s str0) (st : split_stateT str), + parse_production parse_nonterminal + {| string_val := str; state_val := st |} pf a = true. + Proof. + intros a X **. + eapply parse_production_complete. + Focus 3. + exact X. + Undo. + assumption. + Undo. + eassumption. (* no applicable tactic *)
\ No newline at end of file diff --git a/test-suite/bugs/closed/4161.v b/test-suite/bugs/closed/4161.v new file mode 100644 index 00000000..aa2b189b --- /dev/null +++ b/test-suite/bugs/closed/4161.v @@ -0,0 +1,27 @@ + + (* Inductive t : Type -> Type := *) + (* | Just : forall (A : Type), t A -> t A. *) + + (* Fixpoint test {A : Type} (x : t A) : t (A + unit) := *) + (* match x in t A return t (A + unit) with *) + (* | Just T x => @test T x *) + (* end. *) + + + Definition Type1 := Type. +Definition Type2 := Type. +Definition cast (x:Type2) := x:Type1. +Axiom f: Type2 -> Prop. +Definition A := + let T := fun A:Type1 => _ in + fun A':Type2 => + eq_refl : T A' = f A' :> Prop. +(* Type2 <= Type1... f A -> Type1 <= Type2 *) + +Inductive t : Type -> Type := + | Just : forall (A : Type), t A -> t A. + +Fixpoint test {A : Type} (x : t A) : t (A + unit) := + match x in t A with + | Just B x => @test B x + end.
\ No newline at end of file diff --git a/test-suite/bugs/closed/4191.v b/test-suite/bugs/closed/4191.v new file mode 100644 index 00000000..290bb384 --- /dev/null +++ b/test-suite/bugs/closed/4191.v @@ -0,0 +1,5 @@ +(* Test maximal implicit arguments in the presence of let-ins *) +Definition foo (x := 1) {y : nat} (H : y = y) : True := I. +Definition bar {y : nat} (x := 1) (H : y = y) : True := I. +Check bar (eq_refl 1). +Check foo (eq_refl 1). diff --git a/test-suite/bugs/closed/4198.v b/test-suite/bugs/closed/4198.v new file mode 100644 index 00000000..f85a6026 --- /dev/null +++ b/test-suite/bugs/closed/4198.v @@ -0,0 +1,37 @@ +(* Check that the subterms of the predicate of a match are taken into account *) + +Require Import List. +Open Scope list_scope. +Goal forall A (x x' : A) (xs xs' : list A) (H : x::xs = x'::xs'), + let k := + (match H in (_ = y) return x = hd x y with + | eq_refl => eq_refl + end : x = x') + in k = k. + simpl. + intros. + match goal with + | [ |- appcontext G[@hd] ] => idtac + end. + +(* This second example comes from CFGV where inspecting subterms of a + match is expecting to inspect first the term to match (even though + it would certainly be better to provide a "match x with _ end" + construct for generically matching a "match") *) + +Ltac find_head_of_head_match T := + match T with context [?E] => + match T with + | E => fail 1 + | _ => constr:(E) + end + end. + +Ltac mydestruct := + match goal with + | |- ?T1 = _ => let E := find_head_of_head_match T1 in destruct E + end. + +Goal forall x, match x with 0 => 0 | _ => 0 end = 0. +intros. +mydestruct. diff --git a/test-suite/bugs/closed/4203.v b/test-suite/bugs/closed/4203.v new file mode 100644 index 00000000..076a3c3d --- /dev/null +++ b/test-suite/bugs/closed/4203.v @@ -0,0 +1,19 @@ +Set Primitive Projections. + +Record ops {T:Type} := { is_ok : T -> Prop; constant : T }. +Arguments ops : clear implicits. + +Record ops_ok {T} (Ops:ops T) := { constant_ok : is_ok Ops (constant Ops) }. + +Definition nat_ops : ops nat := {| is_ok := fun n => n = 1; constant := 1 |}. +Definition nat_ops_ok : ops_ok nat_ops. +Proof. + split. cbn. apply eq_refl. +Qed. + +Definition t := Eval lazy in constant_ok nat_ops nat_ops_ok. +Definition t' := Eval vm_compute in constant_ok nat_ops nat_ops_ok. +Definition t'' := Eval native_compute in constant_ok nat_ops nat_ops_ok. + +Check (eq_refl t : t = t'). +Check (eq_refl t : t = t'').
\ No newline at end of file diff --git a/test-suite/bugs/closed/4205.v b/test-suite/bugs/closed/4205.v new file mode 100644 index 00000000..c40dfcc1 --- /dev/null +++ b/test-suite/bugs/closed/4205.v @@ -0,0 +1,8 @@ +(* Testing a regression from 8.5beta1 to 8.5beta2 in evar-evar tactic unification problems *) + + +Inductive test : nat -> nat -> nat -> nat -> Prop := + | test1 : forall m n, test m n m n. + +Goal test 1 2 3 4. +erewrite f_equal2 with (f := fun k l => test _ _ k l). diff --git a/test-suite/bugs/closed/4216.v b/test-suite/bugs/closed/4216.v new file mode 100644 index 00000000..ae7f7467 --- /dev/null +++ b/test-suite/bugs/closed/4216.v @@ -0,0 +1,20 @@ +Generalizable Variables T A. + +Inductive path `(a: A): A -> Type := idpath: path a a. + +Class TMonad (T: Type -> Type) := { + bind: forall {A B: Type}, (T A) -> (A -> T B) -> T B; + ret: forall {A: Type}, A -> T A; + ret_unit_left: forall {A B: Type} (k: A -> T B) (a: A), + path (bind (ret a) k) (k a) + }. + +Let T_fzip `{TMonad T} := fun (A B: Type) (f: T (A -> B)) (t: T A) + => bind t (fun a => bind f (fun g => ret (g a) )). +Let T_pure `{TMonad T} := @ret _ _. + +Let T_pure_id `{TMonad T} {A: Type} (t: A -> A) (x: T A): + path (T_fzip A A (T_pure (A -> A) t) x) x. + unfold T_fzip, T_pure. + Fail rewrite (ret_unit_left (fun g a => ret (g a)) (fun x => x)). + diff --git a/test-suite/bugs/closed/4217.v b/test-suite/bugs/closed/4217.v new file mode 100644 index 00000000..19973f30 --- /dev/null +++ b/test-suite/bugs/closed/4217.v @@ -0,0 +1,6 @@ +(* Checking correct index of implicit by pos in fixpoints *) + +Fixpoint ith_default + {default_A : nat} + {As : list nat} + {struct As} : Set. diff --git a/test-suite/bugs/closed/4221.v b/test-suite/bugs/closed/4221.v new file mode 100644 index 00000000..bc120fb1 --- /dev/null +++ b/test-suite/bugs/closed/4221.v @@ -0,0 +1,9 @@ +(* Some test checking that interpreting binder names using ltac + context does not accidentally break the bindings *) + +Goal (forall x : nat, x = 1 -> False) -> 1 = 1 -> False. + intros H0 x. + lazymatch goal with + | [ x : forall k : nat, _ |- _ ] + => specialize (fun H0 => x 1 H0) + end. diff --git a/test-suite/bugs/closed/4232.v b/test-suite/bugs/closed/4232.v new file mode 100644 index 00000000..61e544a9 --- /dev/null +++ b/test-suite/bugs/closed/4232.v @@ -0,0 +1,20 @@ +Require Import Setoid Morphisms Vector. + +Class Equiv A := equiv : A -> A -> Prop. +Class Setoid A `{Equiv A} := setoid_equiv:> Equivalence (equiv). + +Global Declare Instance vec_equiv {A} `{Equiv A} {n}: Equiv (Vector.t A n). +Global Declare Instance vec_setoid A `{Setoid A} n : Setoid (Vector.t A n). + +Global Declare Instance tl_proper1 {A} `{Equiv A} n: + Proper ((equiv) ==> (equiv)) + (@tl A n). + +Lemma test: + forall {A} `{Setoid A} n (xa ya: Vector.t A (S n)), + (equiv xa ya) -> equiv (tl xa) (tl ya). +Proof. + intros A R HA n xa ya Heq. + setoid_rewrite Heq. + reflexivity. +Qed. diff --git a/test-suite/bugs/closed/4234.v b/test-suite/bugs/closed/4234.v new file mode 100644 index 00000000..348dd49d --- /dev/null +++ b/test-suite/bugs/closed/4234.v @@ -0,0 +1,7 @@ +Definition UU := Type. + +Definition dirprodpair {X Y : UU} := existT (fun x : X => Y). + +Definition funtoprodtoprod {X Y Z : UU} : { a : X -> Y & X -> Z }. +Proof. + refine (dirprodpair _ (fun x => _)). diff --git a/test-suite/bugs/closed/4240.v b/test-suite/bugs/closed/4240.v new file mode 100644 index 00000000..083c59fe --- /dev/null +++ b/test-suite/bugs/closed/4240.v @@ -0,0 +1,12 @@ +(* Check that closure of filter did not restrict the former evar filter *) + +Lemma foo (new : nat) : False. +evar (H1: nat). +set (H3 := 0). +assert (H3' := id H3). +evar (H5: nat). +clear H3. +assert (H5 = new). +unfold H5. +unfold H1. +exact (eq_refl new). diff --git a/test-suite/bugs/closed/4251.v b/test-suite/bugs/closed/4251.v new file mode 100644 index 00000000..66343d66 --- /dev/null +++ b/test-suite/bugs/closed/4251.v @@ -0,0 +1,17 @@ + +Inductive array : Type -> Type := +| carray : forall A, array A. + +Inductive Mtac : Type -> Prop := +| bind : forall {A B}, Mtac A -> (A -> Mtac B) -> Mtac B +| array_make : forall {A}, A -> Mtac (array A). + +Definition Ref := array. + +Definition ref : forall {A}, A -> Mtac (Ref A) := + fun A x=> array_make x. +Check array Type. +Check fun A : Type => Ref A. + +Definition abs_val (a : Type) := + bind (ref a) (fun r : array Type => array_make tt).
\ No newline at end of file diff --git a/test-suite/bugs/closed/4254.v b/test-suite/bugs/closed/4254.v new file mode 100644 index 00000000..ef219973 --- /dev/null +++ b/test-suite/bugs/closed/4254.v @@ -0,0 +1,13 @@ +Inductive foo (V:Type):Type := + | Foo : list (bar V) -> foo V +with bar (V:Type): Type := + | bar1: bar V + | bar2 : V -> bar V. + +Module WithPoly. +Polymorphic Inductive foo (V:Type):Type := + | Foo : list (bar V) -> foo V +with bar (V:Type): Type := + | bar1: bar V + | bar2 : V -> bar V. +End WithPoly. diff --git a/test-suite/bugs/closed/4272.v b/test-suite/bugs/closed/4272.v new file mode 100644 index 00000000..aeb4c9bb --- /dev/null +++ b/test-suite/bugs/closed/4272.v @@ -0,0 +1,12 @@ +Set Implicit Arguments. + +Record foo := Foo { p1 : Type; p2 : p1 }. + +Variable x : foo. + +Let p := match x with @Foo a b => a end. + +Notation "@ 'id'" := 3 (at level 10). +Notation "@ 'sval'" := 3 (at level 10). + +Let q := match x with @Foo a b => a end. diff --git a/test-suite/bugs/closed/4276.v b/test-suite/bugs/closed/4276.v new file mode 100644 index 00000000..ba82e6c3 --- /dev/null +++ b/test-suite/bugs/closed/4276.v @@ -0,0 +1,11 @@ +Set Primitive Projections. + +Record box (T U : Type) (x := T) := wrap { unwrap : T }. +Definition mybox : box True False := wrap _ _ I. +Definition unwrap' := @unwrap. + +Definition bad' : True := mybox.(unwrap _ _). + +Fail Definition bad : False := unwrap _ _ mybox. + +(* Closed under the global context *)
\ No newline at end of file diff --git a/test-suite/bugs/closed/4280.v b/test-suite/bugs/closed/4280.v new file mode 100644 index 00000000..fd789750 --- /dev/null +++ b/test-suite/bugs/closed/4280.v @@ -0,0 +1,24 @@ +Require Import ZArith. +Require Import Eqdep_dec. +Local Open Scope Z_scope. + +Definition t := { n: Z | n > 1 }. + +Program Definition two : t := 2. +Next Obligation. omega. Qed. + +Program Definition t_eq (x y: t) : {x=y} + {x<>y} := + if Z.eq_dec (proj1_sig x) (proj1_sig y) then left _ else right _. +Next Obligation. + destruct x as [x Px], y as [y Py]. simpl in H; subst y. + f_equal. apply UIP_dec. decide equality. +Qed. +Next Obligation. + congruence. +Qed. + +Definition t_list_eq: forall (x y: list t), {x=y} + {x<>y}. +Proof. decide equality. apply t_eq. Defined. + +Goal match t_list_eq (two::nil) (two::nil) with left _ => True | right _ => False end. +Proof. exact I. Qed. diff --git a/test-suite/bugs/closed/4283.v b/test-suite/bugs/closed/4283.v new file mode 100644 index 00000000..e06998b7 --- /dev/null +++ b/test-suite/bugs/closed/4283.v @@ -0,0 +1,8 @@ +Require Import Hurkens. + +Polymorphic Record box (X : Type) (T := Type) : Type := wrap { unwrap : T }. + +Definition unwrap' := fun (X : Type) (b : box X) => let (unwrap) := b in unwrap. + +Fail Definition bad : False := TypeNeqSmallType.paradox (unwrap' Type (wrap _ Type)) eq_refl. + diff --git a/test-suite/bugs/closed/4287.v b/test-suite/bugs/closed/4287.v new file mode 100644 index 00000000..0623cf5b --- /dev/null +++ b/test-suite/bugs/closed/4287.v @@ -0,0 +1,125 @@ +Unset Strict Universe Declaration. + +Universe b. + +Universe c. + +Definition U : Type@{b} := Type@{c}. + +Module Type MT. + +Definition T := Prop. +End MT. + +Module M : MT. + Definition T := Type@{b}. + +Print Universes. +Fail End M. + +Set Universe Polymorphism. + +(* This is a modified version of Hurkens with all universes floating *) +Section Hurkens. + +Variable down : Type -> Type. +Variable up : Type -> Type. + +Hypothesis back : forall A, up (down A) -> A. + +Hypothesis forth : forall A, A -> up (down A). + +Hypothesis backforth : forall (A:Type) (P:A->Type) (a:A), + P (back A (forth A a)) -> P a. + +Hypothesis backforth_r : forall (A:Type) (P:A->Type) (a:A), + P a -> P (back A (forth A a)). + +(** Proof *) +Definition V : Type := forall A:Type, ((up A -> Type) -> up A -> Type) -> up A -> Type. +Definition U : Type := V -> Type. + +Definition sb (z:V) : V := fun A r a => r (z A r) a. +Definition le (i:U -> Type) (x:U) : Type := x (fun A r a => i (fun v => sb v A r a)). +Definition le' (i:up (down U) -> Type) (x:up (down U)) : Type := le (fun a:U => i (forth _ a)) (back _ x). +Definition induct (i:U -> Type) : Type := forall x:U, up (le i x) -> up (i x). +Definition WF : U := fun z => down (induct (fun a => z (down U) le' (forth _ a))). +Definition I (x:U) : Type := + (forall i:U -> Type, up (le i x) -> up (i (fun v => sb v (down U) le' (forth _ x)))) -> False. + +Lemma Omega : forall i:U -> Type, induct i -> up (i WF). +Proof. +intros i y. +apply y. +unfold le, WF, induct. +apply forth. +intros x H0. +apply y. +unfold sb, le', le. +compute. +apply backforth_r. +exact H0. +Qed. + +Lemma lemma1 : induct (fun u => down (I u)). +Proof. +unfold induct. +intros x p. +apply forth. +intro q. +generalize (q (fun u => down (I u)) p). +intro r. +apply back in r. +apply r. +intros i j. +unfold le, sb, le', le in j |-. +apply backforth in j. +specialize q with (i := fun y => i (fun v:V => sb v (down U) le' (forth _ y))). +apply q. +exact j. +Qed. + +Lemma lemma2 : (forall i:U -> Type, induct i -> up (i WF)) -> False. +Proof. +intro x. +generalize (x (fun u => down (I u)) lemma1). +intro r; apply back in r. +apply r. +intros i H0. +apply (x (fun y => i (fun v => sb v (down U) le' (forth _ y)))). +unfold le, WF in H0. +apply back in H0. +exact H0. +Qed. + +Theorem paradox : False. +Proof. +exact (lemma2 Omega). +Qed. + +End Hurkens. + +Polymorphic Record box (T : Type) := wrap {unwrap : T}. + +(* Here we instantiate to Set *) + +Fail Definition down (x : Type) : Prop := box x. +Definition up (x : Prop) : Type := x. + +Fail Definition back A : up (down A) -> A := unwrap A. + +Fail Definition forth A : A -> up (down A) := wrap A. + +Definition id {A : Type} (a : A) := a. +Definition setlt (A : Type@{i}) := + let foo := Type@{i} : Type@{j} in True. + +Definition setle (B : Type@{i}) := + let foo (A : Type@{j}) := A in foo B. + +Fail Check @setlt@{j Prop}. +Check @setlt@{Prop j}. +Check @setle@{Prop j}. + +Fail Definition foo := @setle@{j Prop}. +Definition foo := @setle@{Prop j}. diff --git a/test-suite/bugs/closed/4294.v b/test-suite/bugs/closed/4294.v new file mode 100644 index 00000000..1d5e3c71 --- /dev/null +++ b/test-suite/bugs/closed/4294.v @@ -0,0 +1,31 @@ +Require Import Hurkens. + +Module NonPoly. +Module Type Foo. + Definition U := Type. + Parameter eq : Type = U. +End Foo. + +Module M : Foo with Definition U := Type. + Definition U := Type. + Definition eq : Type = U := eq_refl. +End M. + +Print Universes. +Fail Definition bad : False := TypeNeqSmallType.paradox M.U M.eq. +End NonPoly. + +Set Universe Polymorphism. + +Module Type Foo. + Definition U := Type. + Monomorphic Parameter eq : Type = U. +End Foo. + +Module M : Foo with Definition U := Type. + Definition U := Type. + Monomorphic Definition eq : Type = U := eq_refl. +End M. + +Fail Definition bad : False := TypeNeqSmallType.paradox Type M.eq. +(* Print Assumptions bad. *) diff --git a/test-suite/bugs/closed/4298.v b/test-suite/bugs/closed/4298.v new file mode 100644 index 00000000..875612dd --- /dev/null +++ b/test-suite/bugs/closed/4298.v @@ -0,0 +1,7 @@ +Set Universe Polymorphism. + +Module Type Foo. + Definition U := Type. +End Foo. + +Fail Module M : Foo with Definition U := Prop. diff --git a/test-suite/bugs/closed/4299.v b/test-suite/bugs/closed/4299.v new file mode 100644 index 00000000..955c3017 --- /dev/null +++ b/test-suite/bugs/closed/4299.v @@ -0,0 +1,12 @@ +Unset Strict Universe Declaration. +Set Universe Polymorphism. + +Module Type Foo. + Definition U := Type : Type. + Parameter eq : Type = U. +End Foo. + +Module M : Foo with Definition U := Type : Type. + Definition U := let X := Type in Type. + Definition eq : Type = U := eq_refl. +Fail End M.
\ No newline at end of file diff --git a/test-suite/bugs/closed/4301.v b/test-suite/bugs/closed/4301.v new file mode 100644 index 00000000..b4e17c22 --- /dev/null +++ b/test-suite/bugs/closed/4301.v @@ -0,0 +1,13 @@ +Unset Strict Universe Declaration. +Set Universe Polymorphism. + +Module Type Foo. + Parameter U : Type. +End Foo. + +Module Lower (X : Foo with Definition U := True : Type). +End Lower. + +Module M : Foo. + Definition U := nat : Type@{i}. +End M. diff --git a/test-suite/bugs/closed/4305.v b/test-suite/bugs/closed/4305.v new file mode 100644 index 00000000..39fc02d2 --- /dev/null +++ b/test-suite/bugs/closed/4305.v @@ -0,0 +1,17 @@ +(* Check fallback when an abbreviation is not interpretable as a pattern *) + +Notation foo := Type. + +Definition t := + match 0 with + | S foo => foo + | _ => 0 + end. + +Notation bar := (option Type). + +Definition u := + match 0 with + | S bar => bar + | _ => 0 + end. diff --git a/test-suite/bugs/closed/4316.v b/test-suite/bugs/closed/4316.v new file mode 100644 index 00000000..68dec133 --- /dev/null +++ b/test-suite/bugs/closed/4316.v @@ -0,0 +1,3 @@ +Ltac tac := idtac. +Reset tac. +Ltac tac := idtac. diff --git a/test-suite/bugs/closed/4318.v b/test-suite/bugs/closed/4318.v new file mode 100644 index 00000000..e3140ed5 --- /dev/null +++ b/test-suite/bugs/closed/4318.v @@ -0,0 +1,2 @@ +(* Check no anomaly is raised *) +Fail Definition foo p := match p with (x, y) z => tt end. diff --git a/test-suite/bugs/closed/4325.v b/test-suite/bugs/closed/4325.v new file mode 100644 index 00000000..af69ca04 --- /dev/null +++ b/test-suite/bugs/closed/4325.v @@ -0,0 +1,5 @@ +Goal (forall a b : nat, Set = (a = b)) -> Set. +Proof. + clear. + intro H. + erewrite (fun H' => H _ H'). diff --git a/test-suite/bugs/closed/4328.v b/test-suite/bugs/closed/4328.v new file mode 100644 index 00000000..8e1bb310 --- /dev/null +++ b/test-suite/bugs/closed/4328.v @@ -0,0 +1,6 @@ +Inductive M (A:Type) : Type := M'. +Axiom pi : forall (P : Prop) (p : P), Prop. +Definition test1 A (x : _) := pi A x. (* success *) +Fail Definition test2 A (x : A) := pi A x. (* failure ??? *) +Fail Definition test3 A (x : A) (_ : M A) := pi A x. (* failure *) +Fail Definition test4 A (_ : M A) (x : A) := pi A x. (* success ??? *)
\ No newline at end of file diff --git a/test-suite/bugs/closed/4346.v b/test-suite/bugs/closed/4346.v new file mode 100644 index 00000000..b50dff24 --- /dev/null +++ b/test-suite/bugs/closed/4346.v @@ -0,0 +1,2 @@ +Check (Set <: Type). +Check (Set <<: Type). diff --git a/test-suite/bugs/closed/4347.v b/test-suite/bugs/closed/4347.v new file mode 100644 index 00000000..29686a26 --- /dev/null +++ b/test-suite/bugs/closed/4347.v @@ -0,0 +1,17 @@ +Fixpoint demo_recursion(n:nat) := match n with + |0 => Type + |S k => (demo_recursion k) -> Type + end. + +Record Demonstration := mkDemo +{ + demo_law : forall n:nat, demo_recursion n; + demo_stuff : forall n:nat, forall q:(fix demo_recursion (n : nat) : Type := + match n with + | 0 => Type + | S k => demo_recursion k -> Type + end) n, (demo_law (S n)) q +}. + +Theorem DemoError : Demonstration. +Fail apply mkDemo. (*Anomaly: Uncaught exception Not_found. Please report.*) diff --git a/test-suite/bugs/closed/4354.v b/test-suite/bugs/closed/4354.v new file mode 100644 index 00000000..e71ddaf7 --- /dev/null +++ b/test-suite/bugs/closed/4354.v @@ -0,0 +1,11 @@ +Inductive True : Prop := I. +Class Lift (T : Type). +Axiom closed_increment : forall {T} {H : Lift T}, True. +Create HintDb core. +Lemma closed_monotonic T (H : Lift T) : True. +Proof. + Set Printing Universes. + auto using closed_increment. Show Universes. +Qed. +(* also fails with -nois, so the content of the hint database does not matter +*)
\ No newline at end of file diff --git a/test-suite/bugs/closed/4366.v b/test-suite/bugs/closed/4366.v new file mode 100644 index 00000000..6a5e9a40 --- /dev/null +++ b/test-suite/bugs/closed/4366.v @@ -0,0 +1,15 @@ +Fixpoint stupid (n : nat) : unit := +match n with +| 0 => tt +| S n => + let () := stupid n in + let () := stupid n in + tt +end. + +Goal True. +Proof. +pose (v := stupid 24). +Timeout 2 vm_compute in v. +exact I. +Qed. diff --git a/test-suite/bugs/closed/4372.v b/test-suite/bugs/closed/4372.v new file mode 100644 index 00000000..428192a3 --- /dev/null +++ b/test-suite/bugs/closed/4372.v @@ -0,0 +1,20 @@ +(* Tactic inversion was raising an anomaly because of a fake + dependency of TypeDenote into its argument *) + +Inductive expr := +| ETrue. + +Inductive IntermediateType : Set := ITbool. + +Definition TypeDenote (IT : IntermediateType) : Type := + match IT with + | _ => bool + end. + +Inductive ValueDenote : forall (e:expr) it, TypeDenote it -> Prop := +| VT : ValueDenote ETrue ITbool true. + +Goal forall it v, @ValueDenote ETrue it v -> True. + intros it v H. + inversion H. +Abort. diff --git a/test-suite/bugs/closed/4375.v b/test-suite/bugs/closed/4375.v new file mode 100644 index 00000000..03af1653 --- /dev/null +++ b/test-suite/bugs/closed/4375.v @@ -0,0 +1,106 @@ + + +Polymorphic Fixpoint g@{i} (t : Type@{i}) (n : nat) : Type@{i} := + t. + + +Module A. +Polymorphic Fixpoint foo@{i} (t : Type@{i}) (n : nat) : Type@{i} := + match n with + | 0 => t + | S n => bar t n + end + +with bar (t : Type@{i}) (n : nat) : Type@{i} := + match n with + | 0 => t + | S n => foo t n + end. +End A. + +Module B. +Polymorphic Fixpoint foo@{i} (t : Type@{i}) (n : nat) : Type@{i} := + match n with + | 0 => t + | S n => bar t n + end + +with bar@{i} (t : Type@{i}) (n : nat) : Type@{i} := + match n with + | 0 => t + | S n => foo t n + end. +End B. + +Module C. +Fail Polymorphic Fixpoint foo@{i} (t : Type@{i}) (n : nat) : Type@{i} := + match n with + | 0 => t + | S n => bar t n + end + +with bar@{j} (t : Type@{j}) (n : nat) : Type@{j} := + match n with + | 0 => t + | S n => foo t n + end. +End C. + +Module D. +Polymorphic Fixpoint foo@{i j} (t : Type@{i}) (n : nat) : Type@{i} := + match n with + | 0 => t + | S n => bar t n + end + +with bar@{i j} (t : Type@{j}) (n : nat) : Type@{j} := + match n with + | 0 => t + | S n => foo t n + end. +End D. + +Module E. +Fail Polymorphic Fixpoint foo@{i j} (t : Type@{i}) (n : nat) : Type@{i} := + match n with + | 0 => t + | S n => bar t n + end + +with bar@{j i} (t : Type@{j}) (n : nat) : Type@{j} := + match n with + | 0 => t + | S n => foo t n + end. +End E. + +(* +Polymorphic Fixpoint g@{i} (t : Type@{i}) (n : nat) : Type@{i} := + t. + +Print g. + +Polymorphic Fixpoint a@{i} (t : Type@{i}) (n : nat) : Type@{i} := + t +with b@{i} (t : Type@{i}) (n : nat) : Type@{i} := + t. + +Print a. +Print b. +*) + +Polymorphic CoInductive foo@{i} (T : Type@{i}) : Type@{i} := +| A : foo T -> foo T. + +Polymorphic CoFixpoint cg@{i} (t : Type@{i}) : foo@{i} t := + @A@{i} t (cg@{i} t). + +Print cg. + +Polymorphic CoFixpoint ca@{i} (t : Type@{i}) : foo@{i} t := + @A@{i} t (@cb@{i} t) +with cb@{i} (t : Type@{i}) : foo@{i} t := + @A@{i} t (@ca@{i} t). + +Print ca. +Print cb.
\ No newline at end of file diff --git a/test-suite/bugs/closed/4390.v b/test-suite/bugs/closed/4390.v new file mode 100644 index 00000000..a96a1370 --- /dev/null +++ b/test-suite/bugs/closed/4390.v @@ -0,0 +1,37 @@ +Module A. +Set Printing All. +Set Printing Universes. + +Module M. +Section foo. +Universe i. +End foo. +End M. + +Check Type@{i}. +(* Succeeds *) + +Fail Check Type@{j}. +(* Error: Undeclared universe: j *) + +Definition foo@{j} : Type@{i} := Type@{j}. +(* ok *) +End A. + +Set Universe Polymorphism. +Fail Universes j. +Monomorphic Universe j. +Section foo. + Universes i. + Constraint i < j. + Definition foo : Type@{j} := Type@{i}. + Definition foo' : Type@{j} := Type@{i}. +End foo. + +Check eq_refl : foo@{i} = foo'@{i}. + +Definition bar := foo. +Monomorphic Definition bar'@{k} := foo@{k}. + +Fail Constraint j = j. +Monomorphic Constraint i = i. diff --git a/test-suite/bugs/closed/4394.v b/test-suite/bugs/closed/4394.v new file mode 100644 index 00000000..60c93545 --- /dev/null +++ b/test-suite/bugs/closed/4394.v @@ -0,0 +1,19 @@ +(* -*- coq-prog-args: ("-emacs" "-compat" "8.4") -*- *) + +Require Import Equality List. +Inductive Foo (I : Type -> Type) (A : Type) : Type := +| foo (B : Type) : A -> I B -> Foo I A. +Definition Family := Type -> Type. +Definition FooToo : Family -> Family := Foo. +Definition optionize (I : Type -> Type) (A : Type) := option (I A). +Definition bar (I : Type -> Type) (A : Type) : A -> option (I A) -> Foo (optionize I) A := foo (optionize I) A A. +Record Rec (I : Type -> Type) := { rec : forall A : Type, A -> I A -> Foo I A }. +Definition barRec : Rec (optionize id) := {| rec := bar id |}. +Inductive Empty {T} : T -> Prop := . +Theorem empty (family : Family) (a : fold_right prod unit (map (Foo family) nil)) (b : unit) : + Empty (a, b) -> False. +Proof. + intro e. + dependent induction e. +Qed. + diff --git a/test-suite/bugs/closed/4397.v b/test-suite/bugs/closed/4397.v new file mode 100644 index 00000000..3566353d --- /dev/null +++ b/test-suite/bugs/closed/4397.v @@ -0,0 +1,3 @@ +Require Import Equality. +Theorem foo (u : unit) (H : u = u) : True. +dependent destruction H. diff --git a/test-suite/bugs/closed/HoTT_coq_007.v b/test-suite/bugs/closed/HoTT_coq_007.v index 0b8bb235..844ff875 100644 --- a/test-suite/bugs/closed/HoTT_coq_007.v +++ b/test-suite/bugs/closed/HoTT_coq_007.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Require Import TestSuite.admit. Module Comment1. Set Implicit Arguments. diff --git a/test-suite/bugs/closed/HoTT_coq_014.v b/test-suite/bugs/closed/HoTT_coq_014.v index ae3e50d7..223a98de 100644 --- a/test-suite/bugs/closed/HoTT_coq_014.v +++ b/test-suite/bugs/closed/HoTT_coq_014.v @@ -3,9 +3,9 @@ Set Implicit Arguments. Generalizable All Variables. Set Universe Polymorphism. -Polymorphic Record SpecializedCategory (obj : Type) := Build_SpecializedCategory' { - Object :> _ := obj; - Morphism' : obj -> obj -> Type; +Polymorphic Record SpecializedCategory@{l k} (obj : Type@{l}) := Build_SpecializedCategory' { + Object :> Type@{l} := obj; + Morphism' : obj -> obj -> Type@{k}; Identity' : forall o, Morphism' o o; Compose' : forall s d d', Morphism' d d' -> Morphism' s d -> Morphism' s d' diff --git a/test-suite/bugs/closed/HoTT_coq_036.v b/test-suite/bugs/closed/HoTT_coq_036.v index 4c3e078a..7a84531a 100644 --- a/test-suite/bugs/closed/HoTT_coq_036.v +++ b/test-suite/bugs/closed/HoTT_coq_036.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Module Version1. Set Implicit Arguments. Set Universe Polymorphism. diff --git a/test-suite/bugs/closed/HoTT_coq_053.v b/test-suite/bugs/closed/HoTT_coq_053.v index a14fb6aa..e2bf1dbe 100644 --- a/test-suite/bugs/closed/HoTT_coq_053.v +++ b/test-suite/bugs/closed/HoTT_coq_053.v @@ -39,7 +39,7 @@ Definition NatCategory (n : nat) := Definition NatCategory' (n : nat) := match n with | 0 => (fun X => @Build_PreCategory X - (fun _ _ => Unit : Prop)) Unit + (fun _ _ => Unit : Set)) Unit | _ => DiscreteCategory Bool end. diff --git a/test-suite/bugs/closed/HoTT_coq_062.v b/test-suite/bugs/closed/HoTT_coq_062.v index b7db22a6..90d1d183 100644 --- a/test-suite/bugs/closed/HoTT_coq_062.v +++ b/test-suite/bugs/closed/HoTT_coq_062.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Require Import TestSuite.admit. (* -*- mode: coq; coq-prog-args: ("-emacs" "-indices-matter") -*- *) (* File reduced by coq-bug-finder from 5012 lines to 4659 lines, then from 4220 lines to 501 lines, then from 513 lines to 495 lines, then from 513 lines to 495 lines, then from 412 lines to 79 lines, then from 412 lines to 79 lines. *) diff --git a/test-suite/bugs/closed/HoTT_coq_093.v b/test-suite/bugs/closed/HoTT_coq_093.v index 38943ab3..4f8868d5 100644 --- a/test-suite/bugs/closed/HoTT_coq_093.v +++ b/test-suite/bugs/closed/HoTT_coq_093.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. (** It would be nice if we had more lax constraint checking of inductive types, and had variance annotations on their universes *) Set Printing All. Set Printing Implicit. @@ -21,7 +22,7 @@ Section lift. Definition Lift (A : Type@{i}) : Type@{j} := A. End lift. -Goal forall (A : Type@{i}) (x y : A), @paths@{i} A x y -> @paths@{j} A x y. +Goal forall (A : Type@{i}) (x y : A), @paths@{i j} A x y -> @paths@{j k} A x y. intros A x y p. compute in *. destruct p. exact idpath. Defined. diff --git a/test-suite/bugs/closed/HoTT_coq_108.v b/test-suite/bugs/closed/HoTT_coq_108.v index 4f5ef997..b6c0da76 100644 --- a/test-suite/bugs/closed/HoTT_coq_108.v +++ b/test-suite/bugs/closed/HoTT_coq_108.v @@ -107,7 +107,7 @@ Section path_functor. Variable D : PreCategory. Local Notation path_functor'_T F G := { HO : object_of F = object_of G - | transport (fun GO => forall s d, morphism C s d -> morphism D (GO s) (GO d)) + & transport (fun GO => forall s d, morphism C s d -> morphism D (GO s) (GO d)) HO (morphism_of F) = morphism_of G } diff --git a/test-suite/bugs/opened/HoTT_coq_120.v b/test-suite/bugs/closed/HoTT_coq_120.v index 05ee6c7b..e46ea58b 100644 --- a/test-suite/bugs/opened/HoTT_coq_120.v +++ b/test-suite/bugs/closed/HoTT_coq_120.v @@ -116,7 +116,8 @@ Section fully_faithful_helpers. Variables x y : hSet. Variable m : x -> y. - Let isequiv_isepi_ismono_helper ua := (@isequiv_isepi_ismono ua fs0 x y m : isepi m -> ismono m -> IsEquiv m). + Fail Let isequiv_isepi_ismono_helper ua := + (@isequiv_isepi_ismono ua fs0 x y m : isepi m -> ismono m -> IsEquiv m). Goal True. Fail set (isequiv_isepimorphism_ismonomorphism @@ -126,7 +127,7 @@ Section fully_faithful_helpers. => (@isequiv_isepi_ismono_helper _ Hepi Hmono : @IsEquiv _ _ m)). admit. Undo. - Fail set (isequiv_isepimorphism_ismonomorphism' + Fail set (isequiv_isepimorphism_ismonomorphism := fun `{Univalence} (Hepi : IsEpimorphism (m : morphism set_cat x y)) (Hmono : IsMonomorphism (m : morphism set_cat x y)) diff --git a/test-suite/bugs/opened/3045.v b/test-suite/bugs/opened/3045.v deleted file mode 100644 index b7f40b4a..00000000 --- a/test-suite/bugs/opened/3045.v +++ /dev/null @@ -1,30 +0,0 @@ -Set Asymmetric Patterns. -Generalizable All Variables. -Set Implicit Arguments. -Set Universe Polymorphism. - -Record SpecializedCategory (obj : Type) := - { - Object :> _ := obj; - Morphism : obj -> obj -> Type; - - Compose : forall s d d', Morphism d d' -> Morphism s d -> Morphism s d' - }. - -Arguments Compose {obj} [C s d d'] m1 m2 : rename. - -Inductive ReifiedMorphism : forall objC (C : SpecializedCategory objC), C -> C -> Type := -| ReifiedComposedMorphism : forall objC C s d d', ReifiedMorphism C d d' -> ReifiedMorphism C s d -> @ReifiedMorphism objC C s d'. - -Fixpoint ReifiedMorphismDenote objC C s d (m : @ReifiedMorphism objC C s d) : Morphism C s d := - match m in @ReifiedMorphism objC C s d return Morphism C s d with - | ReifiedComposedMorphism _ _ _ _ _ m1 m2 => Compose (@ReifiedMorphismDenote _ _ _ _ m1) - (@ReifiedMorphismDenote _ _ _ _ m2) - end. - -Fixpoint ReifiedMorphismSimplifyWithProof objC C s d (m : @ReifiedMorphism objC C s d) -: { m' : ReifiedMorphism C s d | ReifiedMorphismDenote m = ReifiedMorphismDenote m' }. -refine match m with - | ReifiedComposedMorphism _ _ s0 d0 d0' m1 m2 => _ - end; clear m. -Fail destruct (@ReifiedMorphismSimplifyWithProof _ _ _ _ m1) as [ [] ? ]. diff --git a/test-suite/bugs/opened/3326.v b/test-suite/bugs/opened/3326.v deleted file mode 100644 index f73117a2..00000000 --- a/test-suite/bugs/opened/3326.v +++ /dev/null @@ -1,18 +0,0 @@ -Class ORDER A := Order { - LEQ : A -> A -> bool; - leqRefl: forall x, true = LEQ x x -}. - -Section XXX. - -Variable A:Type. -Variable (O:ORDER A). -Definition aLeqRefl := @leqRefl _ O. - -Lemma OK : forall x, true = LEQ x x. - intros. - unfold LEQ. - destruct O. - clear. - Fail apply aLeqRefl. (* Toplevel input, characters 15-30: -Anomaly: Uncaught exception Not_found(_). Please report. *) diff --git a/test-suite/bugs/opened/3509.v b/test-suite/bugs/opened/3509.v deleted file mode 100644 index 3913bbb4..00000000 --- a/test-suite/bugs/opened/3509.v +++ /dev/null @@ -1,19 +0,0 @@ -Require Import TestSuite.admit. -Lemma match_bool_fn b A B xT xF -: match b as b return forall x : A, B b x with - | true => xT - | false => xF - end - = fun x : A => match b as b return B b x with - | true => xT x - | false => xF x - end. -admit. -Defined. -Lemma match_bool_comm_1 (b : bool) A B (F : forall x : A, B x) t f -: (if b as b return B (if b then t else f) then F t else F f) - = F (if b then t else f). -admit. -Defined. -Hint Rewrite match_bool_fn : matchdb. -Fail Hint Rewrite match_bool_comm_1 : matchdb. diff --git a/test-suite/bugs/opened/3510.v b/test-suite/bugs/opened/3510.v deleted file mode 100644 index daf26507..00000000 --- a/test-suite/bugs/opened/3510.v +++ /dev/null @@ -1,35 +0,0 @@ -Require Import TestSuite.admit. -Lemma match_option_fn T (b : option T) A B s n -: match b as b return forall x : A, B b x with - | Some k => s k - | None => n - end - = fun x : A => match b as b return B b x with - | Some k => s k x - | None => n x - end. -admit. -Defined. -Lemma match_option_comm_2 T (p : option T) A B R (f : forall (x : A) (y : B x), R x y) (s1 : T -> A) (s2 : forall x : T, B (s1 x)) n1 n2 -: match p as p return R match p with - | Some k => s1 k - | None => n1 - end - match p as p return B match p with Some k => s1 k | None => n1 end with - | Some k => s2 k - | None => n2 - end with - | Some k => f (s1 k) (s2 k) - | None => f n1 n2 - end - = f match p return A with - | Some k => s1 k - | None => n1 - end - match p as p return B match p with Some k => s1 k | None => n1 end with - | Some k => s2 k - | None => n2 - end. -admit. -Defined. -Fail Hint Rewrite match_option_fn match_option_comm_2 : matchdb. diff --git a/test-suite/bugs/opened/3562.v b/test-suite/bugs/opened/3562.v deleted file mode 100644 index 04a1223b..00000000 --- a/test-suite/bugs/opened/3562.v +++ /dev/null @@ -1,2 +0,0 @@ -Theorem t: True. -Fail destruct 0 as x. diff --git a/test-suite/bugs/opened/3657.v b/test-suite/bugs/opened/3657.v deleted file mode 100644 index 6faec076..00000000 --- a/test-suite/bugs/opened/3657.v +++ /dev/null @@ -1,33 +0,0 @@ -(* Set Primitive Projections. *) -Class foo {A} {a : A} := { bar := a; baz : bar = bar }. -Arguments bar {_} _ {_}. -Instance: forall A a, @foo A a. -intros; constructor. -abstract reflexivity. -Defined. -Goal @bar _ Set _ = (@bar _ (fun _ : Set => Set) _) nat. -Proof. - Check (bar Set). - Check (bar (fun _ : Set => Set)). - Fail change (bar (fun _ : Set => Set)) with (bar Set). (* Error: Conversion test raised an anomaly *) - -Abort. - - -Module A. -Universes i j. -Constraint i < j. -Variable foo : Type@{i}. -Goal Type@{i}. - Fail let t := constr:(Type@{j}) in - change Type with t. -Abort. - -Goal Type@{j}. - Fail let t := constr:(Type@{i}) in - change Type with t. - let t := constr:(Type@{i}) in - change t. exact foo. -Defined. - -End A. diff --git a/test-suite/bugs/opened/3670.v b/test-suite/bugs/opened/3670.v deleted file mode 100644 index cf5e9b09..00000000 --- a/test-suite/bugs/opened/3670.v +++ /dev/null @@ -1,19 +0,0 @@ -Module Type FOO. - Parameters P Q : Type -> Type. -End FOO. - -Module Type BAR. - Declare Module Export foo : FOO. - Parameter f : forall A, P A -> Q A -> A. -End BAR. - -Module Type BAZ. - Declare Module Export foo : FOO. - Parameter g : forall A, P A -> Q A -> A. -End BAZ. - -Module BAR_FROM_BAZ (baz : BAZ) : BAR. - Import baz. - Module foo <: FOO := foo. - Definition f : forall A, P A -> Q A -> A := g. -End BAR_FROM_BAZ. diff --git a/test-suite/bugs/opened/3675.v b/test-suite/bugs/opened/3675.v deleted file mode 100644 index 93227ab8..00000000 --- a/test-suite/bugs/opened/3675.v +++ /dev/null @@ -1,20 +0,0 @@ -Set Primitive Projections. -Definition compose {A B C : Type} (g : B -> C) (f : A -> B) := fun x => g (f x). -Inductive paths {A : Type} (a : A) : A -> Type := idpath : paths a a where "x = y" := (@paths _ x y) : type_scope. -Arguments idpath {A a} , [A] a. -Definition concat {A : Type} {x y z : A} (p : x = y) (q : y = z) : x = z := match p, q with idpath, idpath => idpath end. -Notation "p @ q" := (concat p q) (at level 20) : path_scope. -Axiom ap : forall {A B:Type} (f:A -> B) {x y:A} (p:x = y), f x = f y. -Definition Sect {A B : Type} (s : A -> B) (r : B -> A) := forall x : A, r (s x) = x. -Class IsEquiv {A B : Type} (f : A -> B) := { equiv_inv : B -> A ; eisretr : forall x, f (equiv_inv x) = x }. -Notation "f ^-1" := (@equiv_inv _ _ f _) (at level 3, format "f '^-1'") : equiv_scope. -Local Open Scope path_scope. -Local Open Scope equiv_scope. -Generalizable Variables A B C f g. -Lemma isequiv_compose `{IsEquiv A B f} `{IsEquiv B C g} -: IsEquiv (compose g f). -Proof. - refine (Build_IsEquiv A C - (compose g f) - (compose f^-1 g^-1) _). - exact (fun c => ap g (@eisretr _ _ f _ (g^-1 c)) @ (@eisretr _ _ g _ c)). diff --git a/test-suite/bugs/opened/3754.v b/test-suite/bugs/opened/3754.v index 9b3f94d9..a717bbe7 100644 --- a/test-suite/bugs/opened/3754.v +++ b/test-suite/bugs/opened/3754.v @@ -1,3 +1,4 @@ +Unset Strict Universe Declaration. Require Import TestSuite.admit. (* File reduced by coq-bug-finder from original input, then from 9113 lines to 279 lines *) (* coqc version trunk (October 2014) compiled on Oct 19 2014 18:56:9 with OCaml 3.12.1 diff --git a/test-suite/bugs/opened/3788.v b/test-suite/bugs/opened/3788.v deleted file mode 100644 index 8e605a00..00000000 --- a/test-suite/bugs/opened/3788.v +++ /dev/null @@ -1,5 +0,0 @@ -Set Implicit Arguments. -Global Set Primitive Projections. -Record Functor (C D : Type) := { object_of :> forall _ : C, D }. -Axiom path_functor_uncurried : forall C D (F G : Functor C D) (_ : sigT (fun HO : object_of F = object_of G => Set)), F = G. -Fail Lemma path_functor_uncurried_snd C D F G HO HM : (@path_functor_uncurried C D F G (existT _ HO HM)) = HM. diff --git a/test-suite/bugs/opened/3808.v b/test-suite/bugs/opened/3808.v deleted file mode 100644 index df40ca19..00000000 --- a/test-suite/bugs/opened/3808.v +++ /dev/null @@ -1,2 +0,0 @@ -Inductive Foo : (let enforce := (fun x => x) : Type@{j} -> Type@{i} in Type@{i}) - := foo : Foo. diff --git a/test-suite/bugs/opened/4214.v b/test-suite/bugs/opened/4214.v new file mode 100644 index 00000000..3daf4521 --- /dev/null +++ b/test-suite/bugs/opened/4214.v @@ -0,0 +1,5 @@ +(* Check that subst uses all equations around *) +Goal forall A (a b c : A), b = a -> b = c -> a = c. +intros. +subst. +Fail reflexivity. diff --git a/test-suite/coqchk/primproj.v b/test-suite/coqchk/primproj.v new file mode 100644 index 00000000..04d0a2b6 --- /dev/null +++ b/test-suite/coqchk/primproj.v @@ -0,0 +1,2 @@ +Set Primitive Projections. +Record foo (T : Type) := { bar : T}. diff --git a/test-suite/failure/guard-cofix.v b/test-suite/failure/guard-cofix.v index 64faa0ce..eda4a186 100644 --- a/test-suite/failure/guard-cofix.v +++ b/test-suite/failure/guard-cofix.v @@ -25,7 +25,7 @@ Fail Definition ff : False := match loop with CF _ t => t end. (* Second example *) -Inductive omega := Omega : omega -> omega. +Inductive omega : Prop := Omega : omega -> omega. Lemma H : omega = CoFalse. Proof. diff --git a/test-suite/ide/bug4246.fake b/test-suite/ide/bug4246.fake new file mode 100644 index 00000000..16b552f6 --- /dev/null +++ b/test-suite/ide/bug4246.fake @@ -0,0 +1,14 @@ +# first proof +ADD { Lemma a : True. } +ADD { Proof using. } +ADD here { trivial. } # first error +ADD { fail. } +ADD { Qed. } +WAIT +EDIT_AT here +# Fixing the proof +ADD { Qed. } +WAIT +EDIT_AT here +ADD { Qed. } +JOIN diff --git a/test-suite/ide/bug4249.fake b/test-suite/ide/bug4249.fake new file mode 100644 index 00000000..20afe0fb --- /dev/null +++ b/test-suite/ide/bug4249.fake @@ -0,0 +1,16 @@ +ADD { Lemma a : True. } +ADD here { Proof using. } +ADD { fail. } +ADD { trivial. } # first error +ADD { Qed. } +WAIT +EDIT_AT here +# Fixing the proof +ADD fix { trivial. } +ADD { Qed. } +WAIT +EDIT_AT fix +ADD { Qed. } +EDIT_AT fix +ADD { Qed. } +JOIN diff --git a/test-suite/ide/reopen.fake b/test-suite/ide/reopen.fake new file mode 100644 index 00000000..8166d013 --- /dev/null +++ b/test-suite/ide/reopen.fake @@ -0,0 +1,21 @@ +# Script simulating a dialog between coqide and coqtop -ideslave +# Run it via fake_ide +# +# jumping between broken proofs + interp error while fixing. +# the error should note make the GUI unfocus the currently focused proof. + +# first proof +ADD { Lemma a : True. } +ADD here { Proof using. } +ADD { fail. } +ADD { trivial. } # first error +ADD { Qed. } +WAIT +EDIT_AT here +# Fixing the proof +ADD fix { trivial. } +ADD { Qed. } +WAIT +EDIT_AT fix +ADD { Qed. } +JOIN diff --git a/test-suite/ide/univ.fake b/test-suite/ide/univ.fake new file mode 100644 index 00000000..90af8785 --- /dev/null +++ b/test-suite/ide/univ.fake @@ -0,0 +1,14 @@ +# Script simulating a dialog between coqide and coqtop -ideslave +# Run it via fake_ide +# +# jumping between broken proofs + interp error while fixing. +# the error should note make the GUI unfocus the currently focused proof. + +# first proof +ADD { Set Implicit Arguments. } +ADD { Record dynamic := dyn { dyn_type : Type; dyn_value : dyn_type }. } +ADD { Lemma dyn_inj_type : forall A1 A2 (x1:A1) (x2:A2), dyn x1 = dyn x2 -> A1 = A2. } +ADD { Proof. } +ADD { now intros A1 A2 x1 x2 [= e1 e2]. } +ADD { Qed. } +JOIN diff --git a/test-suite/interactive/4289.v b/test-suite/interactive/4289.v new file mode 100644 index 00000000..610a509c --- /dev/null +++ b/test-suite/interactive/4289.v @@ -0,0 +1,14 @@ +(* Checking backtracking with modules which used to fail due to an + hash-consing bug *) + +Module Type A. + Axiom B : nat. +End A. +Module C (a : A). + Include a. + Definition c : nat := B. +End C. +Back 4. +Module C (a : A). + Include a. + Definition c : nat := B. diff --git a/test-suite/interactive/ParalITP_smallproofs.v b/test-suite/interactive/ParalITP_smallproofs.v index 0d75d52a..0d75d52a 100755..100644 --- a/test-suite/interactive/ParalITP_smallproofs.v +++ b/test-suite/interactive/ParalITP_smallproofs.v diff --git a/test-suite/kernel/vm-univ.v b/test-suite/kernel/vm-univ.v new file mode 100644 index 00000000..1bdba3c6 --- /dev/null +++ b/test-suite/kernel/vm-univ.v @@ -0,0 +1,145 @@ +(* Basic tests *) +Polymorphic Definition pid {T : Type} (x : T) : T := x. +(* +Definition _1 : pid true = true := + @eq_refl _ true <: pid true = true. + +Polymorphic Definition a_type := Type. + +Definition _2 : a_type@{i} = Type@{i} := + @eq_refl _ Type@{i} <: a_type@{i} = Type@{i}. + +Polymorphic Definition FORALL (T : Type) (P : T -> Prop) : Prop := + forall x : T, P x. + +Polymorphic Axiom todo : forall {T:Type}, T -> T. + +Polymorphic Definition todo' (T : Type) := @todo T. + +Definition _3 : @todo'@{Set} = @todo@{Set} := + @eq_refl _ (@todo@{Set}) <: @todo'@{Set} = @todo@{Set}. +*) + +(* Inductive Types *) +Inductive sumbool (A B : Prop) : Set := +| left : A -> sumbool A B +| right : B -> sumbool A B. + +Definition x : sumbool True False := left _ _ I. + +Definition sumbool_copy {A B : Prop} (H : sumbool A B) : sumbool A B := + match H with + | left _ _ x => left _ _ x + | right _ _ x => right _ _ x + end. + +Definition _4 : sumbool_copy x = x := + @eq_refl _ x <: sumbool_copy x = x. + +(* Polymorphic Inductive Types *) +Polymorphic Inductive poption (T : Type@{i}) : Type@{i} := +| PSome : T -> poption@{i} T +| PNone : poption@{i} T. + +Polymorphic Definition poption_default {T : Type@{i}} (p : poption@{i} T) (x : T) : T := + match p with + | @PSome _ y => y + | @PNone _ => x + end. + +Polymorphic Inductive plist (T : Type@{i}) : Type@{i} := +| pnil +| pcons : T -> plist@{i} T -> plist@{i} T. + +Arguments pnil {_}. +Arguments pcons {_} _ _. + +Section pmap. + Context {T : Type@{i}} {U : Type@{j}} (f : T -> U). + + Polymorphic Fixpoint pmap (ls : plist@{i} T) : plist@{j} U := + match ls with + | @pnil _ => @pnil _ + | @pcons _ l ls => @pcons@{j} U (f l) (pmap@{i j} ls) + end. +End pmap. + +Universe Ubool. +Inductive tbool : Type@{Ubool} := ttrue | tfalse. + + +Eval vm_compute in pmap pid (pcons true (pcons false pnil)). +Eval vm_compute in pmap (fun x => match x with + | pnil => true + | pcons _ _ => false + end) (pcons pnil (pcons (pcons false pnil) pnil)). +Eval vm_compute in pmap (fun x => x -> Type) (pcons tbool (pcons (plist tbool) pnil)). + +Polymorphic Inductive Tree (T : Type@{i}) : Type@{i} := +| Empty +| Branch : plist@{i} (Tree@{i} T) -> Tree@{i} T. + +Section pfold. + Context {T : Type@{i}} {U : Type@{u}} (f : T -> U -> U). + + Polymorphic Fixpoint pfold (acc : U) (ls : plist@{i} T) : U := + match ls with + | pnil => acc + | pcons a b => pfold (f a acc) b + end. +End pfold. + +Polymorphic Inductive nat : Type@{i} := +| O +| S : nat -> nat. + +Fixpoint nat_max (a b : nat) : nat := + match a , b with + | O , b => b + | a , O => a + | S a , S b => S (nat_max a b) + end. + +Polymorphic Fixpoint height {T : Type@{i}} (t : Tree@{i} T) : nat := + match t with + | Empty _ => O + | Branch _ ls => S (pfold nat_max O (pmap height ls)) + end. + +Polymorphic Fixpoint repeat {T : Type@{i}} (n : nat) (v : T) : plist@{i} T := + match n with + | O => pnil + | S n => pcons v (repeat n v) + end. + +Polymorphic Fixpoint big_tree (n : nat) : Tree@{i} nat := + match n with + | O => @Empty nat + | S n' => Branch _ (repeat n' (big_tree n')) + end. + +Eval compute in height (big_tree (S (S (S O)))). + +Let big := S (S (S (S (S O)))). +Polymorphic Definition really_big := (S@{i} (S (S (S (S (S (S (S (S (S O)))))))))). + +Time Definition _5 : height (@Empty nat) = O := + @eq_refl nat O <: height (@Empty nat) = O. + +Time Definition _6 : height@{Set} (@Branch nat pnil) = S O := + @eq_refl nat@{Set} (S@{Set} O@{Set}) <: height@{Set} (@Branch nat pnil) = S O. + +Time Definition _7 : height (big_tree big) = big := + @eq_refl nat big <: height (big_tree big) = big. + +Time Definition _8 : height (big_tree really_big) = really_big := + @eq_refl nat@{Set} (S@{Set} + (S@{Set} + (S@{Set} + (S@{Set} + (S@{Set} + (S@{Set} (S@{Set} (S@{Set} (S@{Set} (S@{Set} O@{Set})))))))))) + <: + @eq nat@{Set} + (@height nat@{Set} (big_tree really_big@{Set})) + really_big@{Set}. diff --git a/test-suite/output/Inductive.out b/test-suite/output/Inductive.out new file mode 100644 index 00000000..e912003f --- /dev/null +++ b/test-suite/output/Inductive.out @@ -0,0 +1,3 @@ +The command has indeed failed with message: +Last occurrence of "list'" must have "A" as 1st argument in + "A -> list' A -> list' (A * A)%type". diff --git a/test-suite/output/Inductive.v b/test-suite/output/Inductive.v new file mode 100644 index 00000000..8db8956e --- /dev/null +++ b/test-suite/output/Inductive.v @@ -0,0 +1,3 @@ +Fail Inductive list' (A:Set) : Set := +| nil' : list' A +| cons' : A -> list' A -> list' (A*A). diff --git a/test-suite/output/Notations.out b/test-suite/output/Notations.out index 6efd671a..b1558dab 100644 --- a/test-suite/output/Notations.out +++ b/test-suite/output/Notations.out @@ -70,7 +70,7 @@ FST (0; 1) : Z Nil : forall A : Type, list A -NIL:list nat +NIL : list nat : list nat (false && I 3)%bool /\ I 6 : Prop @@ -78,7 +78,7 @@ NIL:list nat : Z * Z * Z * (Z * Z * Z) [|0 * (1, 2, 3); (4, 5, 6) * false|] : Z * Z * (Z * Z) * (Z * Z) * (Z * bool * (Z * bool) * (Z * bool)) -fun f : Z -> Z -> Z -> Z => {|f; 0; 1; 2|}:Z +fun f : Z -> Z -> Z -> Z => {|f; 0; 1; 2|} : Z : (Z -> Z -> Z -> Z) -> Z Init.Nat.add : nat -> nat -> nat diff --git a/test-suite/output/PrintAssumptions.out b/test-suite/output/PrintAssumptions.out index 08df9150..66458543 100644 --- a/test-suite/output/PrintAssumptions.out +++ b/test-suite/output/PrintAssumptions.out @@ -2,11 +2,6 @@ Axioms: foo : nat Axioms: foo : nat -Fetching opaque proofs from disk for Coq.Numbers.NatInt.NZAdd -Fetching opaque proofs from disk for Coq.Arith.PeanoNat -Fetching opaque proofs from disk for Coq.Classes.Morphisms -Fetching opaque proofs from disk for Coq.Init.Logic -Fetching opaque proofs from disk for Coq.Numbers.NatInt.NZBase Axioms: extensionality : forall (P Q : Type) (f g : P -> Q), (forall x : P, f x = g x) -> f = g @@ -21,3 +16,5 @@ extensionality : forall (P Q : Type) (f g : P -> Q), (forall x : P, f x = g x) -> f = g Closed under the global context Closed under the global context +Axioms: +M.foo : False diff --git a/test-suite/output/PrintAssumptions.v b/test-suite/output/PrintAssumptions.v index f23bc498..c2003816 100644 --- a/test-suite/output/PrintAssumptions.v +++ b/test-suite/output/PrintAssumptions.v @@ -94,3 +94,19 @@ Proof (false_positive.add_comm 5). Print Assumptions comm_plus5. (* Should answer : Closed under the global context *) + +(** Print Assumption and Include *) + +Module INCLUDE. + +Module M. +Axiom foo : False. +End M. + +Module N. +Include M. +End N. + +Print Assumptions N.foo. + +End INCLUDE. diff --git a/test-suite/output/PrintModule.out b/test-suite/output/PrintModule.out new file mode 100644 index 00000000..db464fd0 --- /dev/null +++ b/test-suite/output/PrintModule.out @@ -0,0 +1,4 @@ +Module N : S with Definition T := nat := M + +Module N : S with Module T := K := M + diff --git a/test-suite/output/PrintModule.v b/test-suite/output/PrintModule.v new file mode 100644 index 00000000..999d9a98 --- /dev/null +++ b/test-suite/output/PrintModule.v @@ -0,0 +1,34 @@ +Module FOO. + +Module M. + Definition T := nat. +End M. + +Module Type S. + Parameter T : Set. +End S. + +Module N : S with Definition T := nat := M. + +Print Module N. + +End FOO. + +Module BAR. + +Module K. End K. +Module Type KS. End KS. + +Module M. + Module T := K. +End M. + +Module Type S. + Declare Module T : KS. +End S. + +Module N : S with Module T := K := M. + +Print Module N. + +End BAR. diff --git a/test-suite/output/inference.out b/test-suite/output/inference.out index b1952aec..f2d14477 100644 --- a/test-suite/output/inference.out +++ b/test-suite/output/inference.out @@ -6,12 +6,12 @@ fun e : option L => match e with : option L -> option L fun (m n p : nat) (H : S m <= S n + p) => le_S_n m (n + p) H : forall m n p : nat, S m <= S n + p -> m <= n + p -fun n : nat => let x := A n in ?y ?y0:T n +fun n : nat => let x := A n in ?y ?y0 : T n : forall n : nat, T n where ?y : [n : nat x := A n : T n |- ?T0 -> T n] ?y0 : [n : nat x := A n : T n |- ?T0] -fun n : nat => ?y ?y0:T n +fun n : nat => ?y ?y0 : T n : forall n : nat, T n where ?y : [n : nat |- ?T0 -> T n] diff --git a/test-suite/output/ltac.out b/test-suite/output/ltac.out new file mode 100644 index 00000000..d003c70d --- /dev/null +++ b/test-suite/output/ltac.out @@ -0,0 +1,2 @@ +The command has indeed failed with message: +Error: Ltac variable y depends on pattern variable name z which is not bound in current context. diff --git a/test-suite/output/ltac.v b/test-suite/output/ltac.v new file mode 100644 index 00000000..7e2610c7 --- /dev/null +++ b/test-suite/output/ltac.v @@ -0,0 +1,17 @@ +(* This used to refer to b instead of z sometimes between 8.4 and 8.5beta3 *) +Goal True. +Fail let T := constr:((fun a b : nat => a+b) 1 1) in + lazymatch T with + | (fun x z => ?y) 1 1 + => pose ((fun x _ => y) 1 1) + end. +Abort. + +(* This should not raise a warning (see #4317) *) +Goal True. +assert (H:= eq_refl ((fun x => x) 1)). +let HT := type of H in +lazymatch goal with +| H1 : HT |- _ => idtac +end. +Abort. diff --git a/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v b/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v index 0d75d52a..0d75d52a 100755..100644 --- a/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v +++ b/test-suite/stm/Nijmegen_QArithSternBrocot_Zaux.v diff --git a/test-suite/success/Hints.v b/test-suite/success/Hints.v index cc8cec47..f934a5c7 100644 --- a/test-suite/success/Hints.v +++ b/test-suite/success/Hints.v @@ -62,3 +62,47 @@ Axiom cast_coalesce : ((e :? pf1) :? pf2) = (e :? trans_eq pf1 pf2). Hint Rewrite cast_coalesce : ltamer. + +Require Import Program. +Module HintCut. +Class A (f : nat -> nat) := a : True. +Class B (f : nat -> nat) := b : True. +Class C (f : nat -> nat) := c : True. +Class D (f : nat -> nat) := d : True. +Class E (f : nat -> nat) := e : True. + +Instance a_is_b f : A f -> B f. +Proof. easy. Qed. +Instance b_is_c f : B f -> C f. +Proof. easy. Qed. +Instance c_is_d f : C f -> D f. +Proof. easy. Qed. +Instance d_is_e f : D f -> E f. +Proof. easy. Qed. + +Instance a_compose f g : A f -> A g -> A (compose f g). +Proof. easy. Qed. +Instance b_compose f g : B f -> B g -> B (compose f g). +Proof. easy. Qed. +Instance c_compose f g : C f -> C g -> C (compose f g). +Proof. easy. Qed. +Instance d_compose f g : D f -> D g -> D (compose f g). +Proof. easy. Qed. +Instance e_compose f g : E f -> E g -> E (compose f g). +Proof. easy. Qed. + +Instance a_id : A id. +Proof. easy. Qed. + +Instance foo f : + E (id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ + id ∘ id ∘ id ∘ id ∘ id ∘ f ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id ∘ id). +Proof. + Fail Timeout 1 apply _. (* 3.7s *) + +Hint Cut [!*; (a_is_b | b_is_c | c_is_d | d_is_e) ; + (a_compose | b_compose | c_compose | d_compose | e_compose)] : typeclass_instances. + + Timeout 1 Fail apply _. (* 0.06s *) +Abort. +End HintCut.
\ No newline at end of file diff --git a/test-suite/success/apply.v b/test-suite/success/apply.v index a4ed76c5..55b666b7 100644 --- a/test-suite/success/apply.v +++ b/test-suite/success/apply.v @@ -333,13 +333,10 @@ exact (refl_equal 3). exact (refl_equal 4). Qed. -(* From 12612, descent in conjunctions is more powerful *) +(* From 12612, Dec 2009, descent in conjunctions is more powerful *) (* The following, which was failing badly in bug 1980, is now properly rejected, as descend in conjunctions builds an - ill-formed elimination from Prop to Type. - - Added Aug 2014: why it fails is now that trivial unification ?x = goal is - rejected by the descent in conjunctions to avoid surprising results. *) + ill-formed elimination from Prop to the domain of ex which is in Type. *) Goal True. Fail eapply ex_intro. @@ -351,28 +348,32 @@ Fail eapply (ex_intro _). exact I. Qed. -(* Note: the following succeed directly (i.e. w/o "exact I") since - Aug 2014 since the descent in conjunction does not use a "cut" - anymore: the iota-redex is contracted and we get rid of the - uninstantiated evars - - Is it good or not? Maybe it does not matter so much. +(* No failure here, because the domain of ex is in Prop *) Goal True. -eapply (ex_intro (fun _ => True) I). -exact I. (* Not needed since Aug 2014 *) +eapply (ex_intro (fun _ => 0=0) I). +reflexivity. Qed. Goal True. -eapply (ex_intro (fun _ => True) I _). -exact I. (* Not needed since Aug 2014 *) +eapply (ex_intro (fun _ => 0=0) I _). +Unshelve. (* In 8.4: Grab Existential Variables. *) +reflexivity. Qed. Goal True. eapply (fun (A:Prop) (x:A) => conj I x). -exact I. (* Not needed since Aug 2014 *) +Unshelve. (* In 8.4: the goal ?A was there *) +exact I. Qed. -*) + +(* Testing compatibility mode with v8.4 *) + +Goal True. +Fail eapply existT. +Set Universal Lemma Under Conjunction. +eapply existT. +Abort. (* The following was not accepted from r12612 to r12657 *) @@ -463,6 +464,7 @@ Abort. Goal forall H:0=0, H = H. intros. Fail apply eq_sym in H. +Abort. (* Check that unresolved evars not originally present in goal prevent apply in to work*) @@ -546,3 +548,14 @@ apply (foo ?y). Grab Existential Variables. exact 0. Qed. + +(* Test position of new hypotheses when using "apply ... in ... as ..." *) +Goal (True -> 0=0 /\ True) -> True -> False -> True/\0=0. +intros H H0 H1. +apply H in H0 as (a,b). +(* clear H1:False *) match goal with H:_ |- _ => clear H end. +split. +- (* use b:True *) match goal with H:_ |- _ => exact H end. +- (* clear b:True *) match goal with H:_ |- _ => clear H end. + (* use a:0=0 *) match goal with H:_ |- _ => exact H end. +Qed. diff --git a/test-suite/success/auto.v b/test-suite/success/auto.v index db3b19af..aaa7b3a5 100644 --- a/test-suite/success/auto.v +++ b/test-suite/success/auto.v @@ -1,6 +1,6 @@ (* Wish #2154 by E. van der Weegen *) -(* auto was not using f_equal-style lemmas with metavariables occuring +(* auto was not using f_equal-style lemmas with metavariables occurring only in the type of an evar of the concl, but not directly in the concl itself *) diff --git a/test-suite/success/extraction_polyprop.v b/test-suite/success/extraction_polyprop.v new file mode 100644 index 00000000..7215bd99 --- /dev/null +++ b/test-suite/success/extraction_polyprop.v @@ -0,0 +1,11 @@ +(* The current extraction cannot handle this situation, + and shouldn't try, otherwise it might produce some Ocaml + code that segfaults. See Table.error_singleton_become_prop + or S. Glondu's thesis for more details. *) + +Definition f {X} (p : (nat -> X) * True) : X * nat := + (fst p 0, 0). + +Definition f_prop := f ((fun _ => I),I). + +Fail Extraction f_prop. diff --git a/test-suite/success/intros.v b/test-suite/success/intros.v index 9443d01e..35ba94fb 100644 --- a/test-suite/success/intros.v +++ b/test-suite/success/intros.v @@ -33,3 +33,39 @@ Goal True -> True -> True. intros _ ?. exact H. Qed. + +(* A short test about introduction pattern pat/c *) +Goal (True -> 0=0) -> True /\ False -> 0=0. +intros H (H1/H,_). +exact H1. +Qed. + +(* A test about bugs in 8.5beta2 *) +Goal (True -> 0=0) -> True /\ False -> False -> 0=0. +intros H H0 H1. +destruct H0 as (a/H,_). +(* Check that H0 is removed (was bugged in 8.5beta2) *) +Fail clear H0. +(* Check position of newly created hypotheses when using pat/c (was + left at top in 8.5beta2) *) +match goal with H:_ |- _ => clear H end. (* clear H1:False *) +match goal with H:_ |- _ => exact H end. (* check that next hyp shows 0=0 *) +Qed. + +Goal (True -> 0=0) -> True -> 0=0. +intros H H1/H. +exact H1. +Qed. + +Goal forall n, n = S n -> 0=0. +intros n H/n_Sn. +destruct H. +Qed. + +(* Another check about generated names and cleared hypotheses with + pat/c patterns *) +Goal (True -> 0=0 /\ 1=1) -> True -> 0=0. +intros H (H1,?)/H. +change (1=1) in H0. +exact H1. +Qed. diff --git a/test-suite/success/ltac.v b/test-suite/success/ltac.v index badce063..6c4d4ae9 100644 --- a/test-suite/success/ltac.v +++ b/test-suite/success/ltac.v @@ -298,3 +298,22 @@ evar(foo:nat). let evval := eval compute in foo in not_eq evval 1. let evval := eval compute in foo in not_eq 1 evval. Abort. + +(* Check instantiation of binders using ltac names *) + +Goal True. +let x := ipattern:y in assert (forall x y, x = y + 0). +intro. +destruct y. (* Check that the name is y here *) +Abort. + +(* An example suggested by Jason (see #4317) showing the intended semantics *) +(* Order of binders is reverted because y is just told to depend on x *) + +Goal 1=1. +let T := constr:(fun a b : nat => a) in + lazymatch T with + | (fun x z => ?y) => pose ((fun x x => y) 2 1) + end. +exact (eq_refl n). +Qed. diff --git a/test-suite/success/namedunivs.v b/test-suite/success/namedunivs.v index 059462fa..f9154ef5 100644 --- a/test-suite/success/namedunivs.v +++ b/test-suite/success/namedunivs.v @@ -4,6 +4,8 @@ (* Fail exact H. *) (* Section . *) +Unset Strict Universe Declaration. + Section lift_strict. Polymorphic Definition liftlt := let t := Type@{i} : Type@{k} in diff --git a/test-suite/success/polymorphism.v b/test-suite/success/polymorphism.v index 9167c9fc..d6bbfe29 100644 --- a/test-suite/success/polymorphism.v +++ b/test-suite/success/polymorphism.v @@ -1,3 +1,5 @@ +Unset Strict Universe Declaration. + Module withoutpoly. Inductive empty :=. @@ -292,3 +294,31 @@ Section foo2. Context `{forall A B, Funext A B}. Print Universes. End foo2. + +Module eta. +Set Universe Polymorphism. + +Set Printing Universes. + +Axiom admit : forall A, A. +Record R := {O : Type}. + +Definition RL (x : R@{i}) : $(let u := constr:(Type@{i}:Type@{j}) in exact (R@{j}) )$ := {|O := @O x|}. +Definition RLRL : forall x : R, RL x = RL (RL x) := fun x => eq_refl. +Definition RLRL' : forall x : R, RL x = RL (RL x). + intros. apply eq_refl. +Qed. + +End eta. + +Module Hurkens'. + Require Import Hurkens. + +Polymorphic Record box (X : Type) (T := Type) : Type := wrap { unwrap : T }. + +Definition unwrap' := fun (X : Type) (b : box X) => let (unw) := b in unw. + +Fail Definition bad : False := TypeNeqSmallType.paradox (unwrap' Type (wrap _ +Type)) eq_refl. + +End Hurkens'.
\ No newline at end of file diff --git a/test-suite/success/primitiveproj.v b/test-suite/success/primitiveproj.v index 068f8ac3..125615c5 100644 --- a/test-suite/success/primitiveproj.v +++ b/test-suite/success/primitiveproj.v @@ -188,3 +188,10 @@ Set Printing All. Check (@p' nat). Check p'. Unset Printing All. + +Record wrap (A : Type) := { unwrap : A; unwrap2 : A }. + +Definition term (x : wrap nat) := x.(unwrap). +Definition term' (x : wrap nat) := let f := (@unwrap2 nat) in f x. +Recursive Extraction term term'. +(*Unset Printing Primitive Projection Parameters.*)
\ No newline at end of file diff --git a/test-suite/success/proof_using.v b/test-suite/success/proof_using.v index 61e73f85..c83f45e2 100644 --- a/test-suite/success/proof_using.v +++ b/test-suite/success/proof_using.v @@ -117,5 +117,81 @@ End T1. Check (bla 7 : 2 = 8). +Section A. +Variable a : nat. +Variable b : nat. +Variable c : nat. +Variable H1 : a = 3. +Variable H2 : a = 3 -> b = 7. +Variable H3 : c = 3. + +Lemma foo : a = a. +Proof using Type*. +pose H1 as e1. +pose H2 as e2. +reflexivity. +Qed. + +Lemma bar : a = 3 -> b = 7. +Proof using b*. +exact H2. +Qed. + +Lemma baz : c=3. +Proof using c*. +exact H3. +Qed. + +Lemma baz2 : c=3. +Proof using c* a. +exact H3. +Qed. + +End A. + +Check (foo 3 7 (refl_equal 3) + (fun _ => refl_equal 7)). +Check (bar 3 7 (refl_equal 3) + (fun _ => refl_equal 7)). +Check (baz2 99 3 (refl_equal 3)). +Check (baz 3 (refl_equal 3)). + +Section Let. + +Variables a b : nat. +Let pa : a = a. Proof. reflexivity. Qed. +Unset Default Proof Using. +Set Suggest Proof Using. +Lemma test_let : a = a. +Proof using a. +exact pa. +Qed. + +Let ppa : pa = pa. Proof. reflexivity. Qed. + +Lemma test_let2 : pa = pa. +Proof using Type. +exact ppa. +Qed. + +End Let. + +Check (test_let 3). + +Section Clear. + +Variable a: nat. +Hypotheses H : a = 4. + +Set Proof Using Clear Unused. + +Lemma test_clear : a = a. +Proof using a. +Fail rewrite H. +trivial. +Qed. + +End Clear. + diff --git a/test-suite/success/record_syntax.v b/test-suite/success/record_syntax.v new file mode 100644 index 00000000..db2bbb0d --- /dev/null +++ b/test-suite/success/record_syntax.v @@ -0,0 +1,47 @@ +Module A. + +Record Foo := { foo : unit; bar : unit }. + +Definition foo_ := {| + foo := tt; + bar := tt +|}. + +Definition foo0 (p : Foo) := match p with {| |} => tt end. +Definition foo1 (p : Foo) := match p with {| foo := f |} => f end. +Definition foo2 (p : Foo) := match p with {| foo := f; |} => f end. +Definition foo3 (p : Foo) := match p with {| foo := f; bar := g |} => (f, g) end. +Definition foo4 (p : Foo) := match p with {| foo := f; bar := g; |} => (f, g) end. + +End A. + +Module B. + +Record Foo := { }. + +End B. + +Module C. + +Record Foo := { foo : unit; bar : unit; }. + +Definition foo_ := {| + foo := tt; + bar := tt; +|}. + +End C. + +Module D. + +Record Foo := { foo : unit }. +Definition foo_ := {| foo := tt |}. + +End D. + +Module E. + +Record Foo := { foo : unit; }. +Definition foo_ := {| foo := tt; |}. + +End E. diff --git a/test-suite/success/sideff.v b/test-suite/success/sideff.v new file mode 100644 index 00000000..3c0b8156 --- /dev/null +++ b/test-suite/success/sideff.v @@ -0,0 +1,12 @@ +Definition idw (A : Type) := A. +Lemma foobar : unit. +Proof. + Require Import Program. + apply (const tt tt). +Qed. + +Lemma foobar' : unit. + Lemma aux : forall A : Type, A -> unit. + Proof. intros. pose (foo := idw A). exact tt. Show Universes. Qed. + apply (@aux unit tt). +Qed. diff --git a/test-suite/success/simpl.v b/test-suite/success/simpl.v index e540ae5f..5b87e877 100644 --- a/test-suite/success/simpl.v +++ b/test-suite/success/simpl.v @@ -98,3 +98,10 @@ Fail simpl (unbox _ (unbox _ _)) at 3 4. (* Nested and even overlapping *) simpl (unbox _ (unbox _ _)) at 2 4. match goal with |- unbox _ (Box _ True) = unbox _ (Box _ True) => idtac end. Abort. + +(* Check interpretation of ltac variables (was broken in 8.5 beta 1 and 2 *) + +Goal 2=1+1. +match goal with |- (_ = ?c) => simpl c end. +match goal with |- 2 = 2 => idtac end. (* Check that it reduced *) +Abort. diff --git a/test-suite/success/specialize.v b/test-suite/success/specialize.v index c5f032be..3faa1ca4 100644 --- a/test-suite/success/specialize.v +++ b/test-suite/success/specialize.v @@ -45,4 +45,22 @@ specialize eq_trans with _ a b c. intros _. (* Anomaly: Evar ?88 was not declared. Please report. *) *) -Abort.
\ No newline at end of file +Abort. + +(* Test use of pose proof and assert as a specialize *) + +Goal True -> (True -> 0=0) -> False -> 0=0. +intros H0 H H1. +pose proof (H I) as H. +(* Check that the hypothesis is in 2nd position by removing the top one *) +match goal with H:_ |- _ => clear H end. +match goal with H:_ |- _ => exact H end. +Qed. + +Goal True -> (True -> 0=0) -> False -> 0=0. +intros H0 H H1. +assert (H:=H I). +(* Check that the hypothesis is in 2nd position by removing the top one *) +match goal with H:_ |- _ => clear H end. +match goal with H:_ |- _ => exact H end. +Qed. diff --git a/test-suite/success/univnames.v b/test-suite/success/univnames.v new file mode 100644 index 00000000..048b53d2 --- /dev/null +++ b/test-suite/success/univnames.v @@ -0,0 +1,26 @@ +Set Universe Polymorphism. + +Definition foo@{i j} (A : Type@{i}) (B : Type@{j}) := A. + +Set Printing Universes. + +Fail Definition bar@{i} (A : Type@{i}) (B : Type) := A. + +Definition baz@{i j} (A : Type@{i}) (B : Type@{j}) := (A * B)%type. + +Fail Definition bad@{i j} (A : Type@{i}) (B : Type@{j}) : Type := (A * B)%type. + +Fail Definition bad@{i} (A : Type@{i}) (B : Type@{j}) : Type := (A * B)%type. + +Definition shuffle@{i j} (A : Type@{j}) (B : Type@{i}) := (A * B)%type. + +Definition nothing (A : Type) := A. + +Inductive bla@{l k} : Type@{k} := blaI : Type@{l} -> bla. + +Inductive blacopy@{k l} : Type@{k} := blacopyI : Type@{l} -> blacopy. + + +Monomorphic Universe g. + +Inductive blacopy'@{l} : Type@{g} := blacopy'I : Type@{l} -> blacopy'.
\ No newline at end of file diff --git a/theories/Arith/intro.tex b/theories/Arith/intro.tex deleted file mode 100755 index 655de34c..00000000 --- a/theories/Arith/intro.tex +++ /dev/null @@ -1,55 +0,0 @@ -\section{Arith}\label{Arith} - -The {\tt Arith} library deals with various arithmetical notions and -their properties. - -\subsection*{Standard {\tt Arith} library} - -The following files are automatically loaded by {\tt Require Arith}. - -\begin{itemize} - -\item {\tt Le.v} states and proves properties of the large order {\tt le}. - -\item {\tt Lt.v} states and proves properties of the strict order {\tt -lt} (especially, the relationship with {\tt le}). - -\item {\tt Plus.v} states and proves properties on the addition. - -\item {\tt Gt.v} states and proves properties on the strict order {\tt gt}. - -\item {\tt Minus.v} defines the difference on -{\tt nat} and proves properties of it. On {\tt nat}, {\tt (minus n p)} is -{\tt O} if {\tt n} $<$ {\tt p}. - -\item {\tt Mult.v} states and proves properties on the multiplication. - -\item {\tt Between.v} defines modalities on {\tt nat} and proves properties -of them. - -\end{itemize} - -\subsection*{Additional {\tt Arith} library} - -\begin{itemize} - -\item {\tt Compare.v}, {\tt Compare\_dec.v} and {\tt Peano\_dec.v} state -and prove various decidability results on {\tt nat}. - -\item {\tt Wf\_nat.v} states and proves various induction and recursion -principles on {\tt nat}. Especially, recursion for objects measurable by -a natural number and recursion on {\tt nat * nat} are provided. - -\item {\tt Min.v} defines the minimum of two natural numbers and proves -properties of it. - -\item {\tt Eqnat.v} defines a specific equality on {\tt nat} and shows -the equivalence with Leibniz' equality. - -\item {\tt Euclid.v} proves that the euclidean -division specification is realisable. Conversely, {\tt Div.v} exhibits -two different algorithms and semi-automatically reconstruct the proof of -their correctness. These files emphasize the extraction of program vs -reconstruction of proofs paradigm. - -\end{itemize} diff --git a/theories/Bool/intro.tex b/theories/Bool/intro.tex deleted file mode 100644 index 22ee38aa..00000000 --- a/theories/Bool/intro.tex +++ /dev/null @@ -1,16 +0,0 @@ -\section{Bool}\label{Bool} - -The BOOL library includes the following files: - -\begin{itemize} - -\item {\tt Bool.v} defines standard operations on booleans and states - and proves simple facts on them. -\item {\tt IfProp.v} defines a disjunction which contains its proof - and states its properties. -\item {\tt Zerob.v} defines the test against 0 on natural numbers and - states and proves properties of it. -\item {\tt Orb.v} states and proves facts on the boolean or. -\item {\tt DecBool.v} defines a conditional from a proof of - decidability and states its properties. -\end{itemize} diff --git a/theories/Classes/CMorphisms.v b/theories/Classes/CMorphisms.v index 048faa91..fdedbf67 100644 --- a/theories/Classes/CMorphisms.v +++ b/theories/Classes/CMorphisms.v @@ -266,11 +266,12 @@ Section GenericInstances. transitivity (y x0)... Qed. - (** The complement of a crelation conserves its proper elements. *) + Unset Strict Universe Declaration. - Program Definition complement_proper + (** The complement of a crelation conserves its proper elements. *) + Program Definition complement_proper (A : Type@{k}) (RA : crelation A) `(mR : Proper (A -> A -> Prop) (RA ==> RA ==> iff) R) : - Proper (RA ==> RA ==> iff) (complement R) := _. + Proper (RA ==> RA ==> iff) (complement@{i j Prop} R) := _. Next Obligation. Proof. @@ -280,7 +281,6 @@ Section GenericInstances. Qed. (** The [flip] too, actually the [flip] instance is a bit more general. *) - Program Definition flip_proper `(mor : Proper (A -> B -> C) (RA ==> RB ==> RC) f) : Proper (RB ==> RA ==> RC) (flip f) := _. diff --git a/theories/Classes/RelationClasses.v b/theories/Classes/RelationClasses.v index 1a40e5d5..15cb02d3 100644 --- a/theories/Classes/RelationClasses.v +++ b/theories/Classes/RelationClasses.v @@ -89,6 +89,11 @@ Section Defs. Global Instance Equivalence_PER {R} `(E:Equivalence R) : PER R | 10 := { }. + (** An Equivalence is a PreOrder plus symmetry. *) + + Global Instance Equivalence_PreOrder {R} `(E:Equivalence R) : PreOrder R | 10 := + { }. + (** We can now define antisymmetry w.r.t. an equivalence relation on the carrier. *) Class Antisymmetric eqA `{equ : Equivalence eqA} (R : relation A) := diff --git a/theories/Compat/Coq84.v b/theories/Compat/Coq84.v new file mode 100644 index 00000000..b04d5168 --- /dev/null +++ b/theories/Compat/Coq84.v @@ -0,0 +1,77 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Compatibility file for making Coq act similar to Coq v8.4 *) +(** See https://coq.inria.fr/bugs/show_bug.cgi?id=4319 for updates *) +(** This is required in Coq 8.5 to use the [omega] tactic; in Coq 8.4, it's automatically available. But ZArith_base puts infix ~ at level 7, and we don't want that, so we don't [Import] it. *) +Require Coq.omega.Omega. +Ltac omega := Coq.omega.Omega.omega. + +(** The number of arguments given in [match] statements has changed from 8.4 to 8.5. *) +Global Set Asymmetric Patterns. + +(** See bug 3545 *) +Global Set Universal Lemma Under Conjunction. + +(** In 8.4, [admit] created a new axiom; in 8.5, it just shelves the goal. *) +Axiom proof_admitted : False. +Ltac admit := clear; abstract case proof_admitted. + +(** In 8.5, [refine] leaves over dependent subgoals. *) +Tactic Notation "refine" uconstr(term) := refine term; shelve_unifiable. + +(** In 8.4, [constructor (tac)] allowed backtracking across the use of [constructor]; it has been subsumed by [constructor; tac]. *) +Ltac constructor_84 := constructor. +Ltac constructor_84_n n := constructor n. +Ltac constructor_84_tac tac := once (constructor; tac). + +Tactic Notation "constructor" := constructor_84. +Tactic Notation "constructor" int_or_var(n) := constructor_84_n n. +Tactic Notation "constructor" "(" tactic(tac) ")" := constructor_84_tac tac. + +(** Some tactic notations do not factor well with tactics; we add global parsing entries for some tactics that would otherwise be overwritten by custom variants. See https://coq.inria.fr/bugs/show_bug.cgi?id=4392. *) +Tactic Notation "reflexivity" := reflexivity. +Tactic Notation "assumption" := assumption. +Tactic Notation "etransitivity" := etransitivity. +Tactic Notation "cut" constr(c) := cut c. +Tactic Notation "exact_no_check" constr(c) := exact_no_check c. +Tactic Notation "vm_cast_no_check" constr(c) := vm_cast_no_check c. +Tactic Notation "casetype" constr(c) := casetype c. +Tactic Notation "elimtype" constr(c) := elimtype c. +Tactic Notation "lapply" constr(c) := lapply c. +Tactic Notation "transitivity" constr(c) := transitivity c. +Tactic Notation "left" := left. +Tactic Notation "eleft" := eleft. +Tactic Notation "right" := right. +Tactic Notation "eright" := eright. +Tactic Notation "constructor" := constructor. +Tactic Notation "econstructor" := econstructor. +Tactic Notation "symmetry" := symmetry. +Tactic Notation "split" := split. +Tactic Notation "esplit" := esplit. + +Global Set Regular Subst Tactic. + +(** Some names have changed in the standard library, so we add aliases. *) +Require Coq.ZArith.Int. +Module Export Coq. + Module Export ZArith. + Module Int. + Module Z_as_Int. + Include Coq.ZArith.Int.Z_as_Int. + (* FIXME: Should these get a (compat "8.4")? Or be moved to Z_as_Int, probably? *) + Notation plus := Coq.ZArith.Int.Z_as_Int.add (only parsing). + Notation minus := Coq.ZArith.Int.Z_as_Int.sub (only parsing). + Notation mult := Coq.ZArith.Int.Z_as_Int.mul (only parsing). + End Z_as_Int. + End Int. + End ZArith. +End Coq. + +(** Many things now import [PeanoNat] rather than [NPeano], so we require it so that the old absolute names in [NPeano.Nat] are available. *) +Require Coq.Numbers.Natural.Peano.NPeano. diff --git a/theories/Compat/Coq85.v b/theories/Compat/Coq85.v new file mode 100644 index 00000000..1622f2ae --- /dev/null +++ b/theories/Compat/Coq85.v @@ -0,0 +1,9 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Compatibility file for making Coq act similar to Coq v8.5 *) diff --git a/theories/Compat/vo.itarget b/theories/Compat/vo.itarget new file mode 100644 index 00000000..c0c40ab1 --- /dev/null +++ b/theories/Compat/vo.itarget @@ -0,0 +1,2 @@ +Coq84.vo +Coq85.vo diff --git a/theories/Lists/List.v b/theories/Lists/List.v index ea07a849..fe18686e 100644 --- a/theories/Lists/List.v +++ b/theories/Lists/List.v @@ -45,8 +45,8 @@ Section Lists. Definition hd_error (l:list A) := match l with - | [] => error - | x :: _ => value x + | [] => None + | x :: _ => Some x end. Definition tl (l:list A) := @@ -69,7 +69,7 @@ Section Facts. Variable A : Type. - (** *** Genereric facts *) + (** *** Generic facts *) (** Discrimination *) Theorem nil_cons : forall (x:A) (l:list A), [] <> x :: l. @@ -393,11 +393,11 @@ Section Elts. simpl; auto. Qed. - Fixpoint nth_error (l:list A) (n:nat) {struct n} : Exc A := + Fixpoint nth_error (l:list A) (n:nat) {struct n} : option A := match n, l with - | O, x :: _ => value x + | O, x :: _ => Some x | S n, _ :: l => nth_error l n - | _, _ => error + | _, _ => None end. Definition nth_default (default:A) (l:list A) (n:nat) : A := @@ -622,9 +622,9 @@ Section Elts. Qed. - (****************************************) - (** ** Counting occurences of a element *) - (****************************************) + (******************************************) + (** ** Counting occurrences of an element *) + (******************************************) Fixpoint count_occ (l : list A) (x : A) : nat := match l with @@ -2202,7 +2202,7 @@ Section ForallPairs. Proof. induction 1. inversion 1. - simpl; destruct 1; destruct 1; repeat subst; auto. + simpl; destruct 1; destruct 1; subst; auto. right; left. apply -> Forall_forall; eauto. right; right. apply -> Forall_forall; eauto. Qed. diff --git a/theories/Lists/intro.tex b/theories/Lists/intro.tex deleted file mode 100755 index d372de8e..00000000 --- a/theories/Lists/intro.tex +++ /dev/null @@ -1,20 +0,0 @@ -\section{Lists}\label{Lists} - -This library includes the following files: - -\begin{itemize} - -\item {\tt List.v} contains definitions of (polymorphic) lists, - functions on lists such as head, tail, map, append and prove some - properties of these functions. Implicit arguments are used in this - library, so you should read the Reference Manual about implicit - arguments before using it. - -\item {\tt ListSet.v} contains definitions and properties of finite - sets, implemented as lists. - -\item {\tt Streams.v} defines the type of infinite lists (streams). It is a - co-inductive type. Basic facts are stated and proved. The streams are - also polymorphic. - -\end{itemize} diff --git a/theories/Logic/WeakFan.v b/theories/Logic/WeakFan.v index 49cc12b8..2f84ebe5 100644 --- a/theories/Logic/WeakFan.v +++ b/theories/Logic/WeakFan.v @@ -89,17 +89,14 @@ Qed. Theorem WeakFanTheorem : forall P, barred P -> inductively_barred P []. Proof. intros P Hbar. -destruct (Hbar (X P)) as (l,(Hd,HP)). +destruct Hbar with (X P) as (l,(Hd/Y_approx,HP)). assert (inductively_barred P l) by (apply (now P l), HP). clear Hbar HP. -induction l. +induction l as [|a l]. - assumption. - destruct Hd as (Hd,HX). apply (IHl Hd). clear IHl. destruct a; unfold X in HX; simpl in HX. - + apply propagate. - * apply H. - * destruct HX as (l',(Hl,(HY,Ht))); firstorder. - apply Y_approx in Hd. rewrite <- (Y_unique P l' l Hl); trivial. - + destruct HX. exists l. split; auto using Y_approx. + + apply propagate; assumption. + + exfalso; destruct (HX H). Qed. diff --git a/theories/Logic/intro.tex b/theories/Logic/intro.tex deleted file mode 100755 index 1fb294f2..00000000 --- a/theories/Logic/intro.tex +++ /dev/null @@ -1,8 +0,0 @@ -\section{Logic}\label{Logic} - -This library deals with classical logic and its properties. -The main file is {\tt Classical.v}. - -This library also provides some facts on equalities for dependent -types. See the files {\tt Eqdep.v} and {\tt JMeq.v}. - diff --git a/theories/NArith/intro.tex b/theories/NArith/intro.tex deleted file mode 100644 index bf39bc36..00000000 --- a/theories/NArith/intro.tex +++ /dev/null @@ -1,5 +0,0 @@ -\section{Binary natural numbers : NArith}\label{NArith} - -Here are defined various arithmetical notions and their properties, -similar to those of {\tt Arith}. - diff --git a/theories/Numbers/Cyclic/Int31/Int31.v b/theories/Numbers/Cyclic/Int31/Int31.v index 4e28b5b9..f5e936cf 100644 --- a/theories/Numbers/Cyclic/Int31/Int31.v +++ b/theories/Numbers/Cyclic/Int31/Int31.v @@ -19,7 +19,7 @@ Require Export DoubleType. arithmetic. In fact it is more general than that. The only reason for this use of 31 is the underlying mecanism for hardware-efficient computations by A. Spiwack. Apart from this, a switch to, say, - 63-bit integers is now just a matter of replacing every occurences + 63-bit integers is now just a matter of replacing every occurrences of 31 by 63. This is actually made possible by the use of dependently-typed n-ary constructions for the inductive type [int31], its constructor [I31] and any pattern matching on it. diff --git a/theories/Numbers/NaryFunctions.v b/theories/Numbers/NaryFunctions.v index 6fdf0a2a..376620dd 100644 --- a/theories/Numbers/NaryFunctions.v +++ b/theories/Numbers/NaryFunctions.v @@ -15,7 +15,7 @@ Require Import List. (** * Generic dependently-typed operators about [n]-ary functions *) (** The type of [n]-ary function: [nfun A n B] is - [A -> ... -> A -> B] with [n] occurences of [A] in this type. *) + [A -> ... -> A -> B] with [n] occurrences of [A] in this type. *) Fixpoint nfun A n B := match n with diff --git a/theories/PArith/intro.tex b/theories/PArith/intro.tex deleted file mode 100644 index ffce881e..00000000 --- a/theories/PArith/intro.tex +++ /dev/null @@ -1,4 +0,0 @@ -\section{Binary positive integers : PArith}\label{PArith} - -Here are defined various arithmetical notions and their properties, -similar to those of {\tt Arith}. diff --git a/theories/Program/Syntax.v b/theories/Program/Syntax.v index 67e9a20c..892305b4 100644 --- a/theories/Program/Syntax.v +++ b/theories/Program/Syntax.v @@ -32,10 +32,3 @@ Require List. Export List.ListNotations. Require Import Bvector. - -(** Treating n-ary exists *) - -Tactic Notation "exists" constr(x) := exists x. -Tactic Notation "exists" constr(x) constr(y) := exists x ; exists y. -Tactic Notation "exists" constr(x) constr(y) constr(z) := exists x ; exists y ; exists z. -Tactic Notation "exists" constr(x) constr(y) constr(z) constr(w) := exists x ; exists y ; exists z ; exists w. diff --git a/theories/Program/Tactics.v b/theories/Program/Tactics.v index 0cf8d733..c1d958b9 100644 --- a/theories/Program/Tactics.v +++ b/theories/Program/Tactics.v @@ -41,7 +41,7 @@ Ltac do_nat n tac := (** Do something on the last hypothesis, or fail *) Ltac on_last_hyp tac := - match goal with [ H : _ |- _ ] => first [ tac H | fail 1 ] end. + lazymatch goal with [ H : _ |- _ ] => tac H end. (** Destructs one pair, without care regarding naming. *) diff --git a/theories/Reals/intro.tex b/theories/Reals/intro.tex deleted file mode 100644 index 43317258..00000000 --- a/theories/Reals/intro.tex +++ /dev/null @@ -1,4 +0,0 @@ -\section{Reals}\label{Reals} - -This library contains an axiomatization of real numbers. -The main file is \texttt{Reals.v}. diff --git a/theories/Relations/intro.tex b/theories/Relations/intro.tex deleted file mode 100755 index 5056f36f..00000000 --- a/theories/Relations/intro.tex +++ /dev/null @@ -1,23 +0,0 @@ -\section{Relations}\label{Relations} - -This library develops closure properties of relations. - -\begin{itemize} -\item {\tt Relation\_Definitions.v} deals with the general notions - about binary relations (orders, equivalences, ...) - -\item {\tt Relation\_Operators.v} and {\tt Rstar.v} define various - closures of relations (by symmetry, by transitivity, ...) and - lexicographic orderings. - -\item {\tt Operators\_Properties.v} states and proves facts on the - various closures of a relation. - -\item {\tt Relations.v} puts {\tt Relation\_Definitions.v}, {\tt - Relation\_Operators.v} and \\ - {\tt Operators\_Properties.v} together. - -\item {\tt Newman.v} proves Newman's lemma on noetherian and locally - confluent relations. - -\end{itemize} diff --git a/theories/Setoids/intro.tex b/theories/Setoids/intro.tex deleted file mode 100644 index 50cd025d..00000000 --- a/theories/Setoids/intro.tex +++ /dev/null @@ -1 +0,0 @@ -\section{Setoids}\label{Setoids} diff --git a/theories/Sets/intro.tex b/theories/Sets/intro.tex deleted file mode 100755 index 83c2177f..00000000 --- a/theories/Sets/intro.tex +++ /dev/null @@ -1,24 +0,0 @@ -\section{Sets}\label{Sets} - -This is a library on sets defined by their characteristic predicate. -It contains the following modules: - -\begin{itemize} -\item {\tt Ensembles.v} -\item {\tt Constructive\_sets.v}, {\tt Classical\_sets.v} -\item {\tt Relations\_1.v}, {\tt Relations\_2.v}, - {\tt Relations\_3.v}, {\tt Relations\_1\_facts.v}, \\ - {\tt Relations\_2\_facts.v}, {\tt Relations\_3\_facts.v} -\item {\tt Partial\_Order.v}, {\tt Cpo.v} -\item {\tt Powerset.v}, {\tt Powerset\_facts.v}, - {\tt Powerset\_Classical\_facts.v} -\item {\tt Finite\_sets.v}, {\tt Finite\_sets\_facts.v} -\item {\tt Image.v} -\item {\tt Infinite\_sets.v} -\item {\tt Integers.v} -\end{itemize} - -%%% Local Variables: -%%% mode: latex -%%% TeX-master: t -%%% End: diff --git a/theories/Sorting/intro.tex b/theories/Sorting/intro.tex deleted file mode 100644 index 64ae4c88..00000000 --- a/theories/Sorting/intro.tex +++ /dev/null @@ -1 +0,0 @@ -\section{Sorting}\label{Sorting} diff --git a/theories/Vectors/Fin.v b/theories/Vectors/Fin.v index b9bf6c7f..2955184f 100644 --- a/theories/Vectors/Fin.v +++ b/theories/Vectors/Fin.v @@ -152,18 +152,18 @@ Fixpoint L {m} n (p : t m) : t (m + n) := Lemma L_sanity {m} n (p : t m) : proj1_sig (to_nat (L n p)) = proj1_sig (to_nat p). Proof. induction p. - reflexivity. - simpl; destruct (to_nat (L n p)); simpl in *; rewrite IHp. now destruct (to_nat p). +- reflexivity. +- simpl; destruct (to_nat (L n p)); simpl in *; rewrite IHp. now destruct (to_nat p). Qed. - + (** The p{^ th} element of [fin m] viewed as the p{^ th} element of [fin (n + m)] Really really ineficient !!! *) Definition L_R {m} n (p : t m) : t (n + m). Proof. induction n. - exact p. - exact ((fix LS k (p: t k) := +- exact p. +- exact ((fix LS k (p: t k) := match p with |@F1 k' => @F1 (S k') |FS p' => FS (LS _ p') @@ -178,8 +178,8 @@ Fixpoint R {m} n (p : t m) : t (n + m) := Lemma R_sanity {m} n (p : t m) : proj1_sig (to_nat (R n p)) = n + proj1_sig (to_nat p). Proof. induction n. - reflexivity. - simpl; destruct (to_nat (R n p)); simpl in *; rewrite IHn. now destruct (to_nat p). +- reflexivity. +- simpl; destruct (to_nat (R n p)); simpl in *; rewrite IHn. now destruct (to_nat p). Qed. Fixpoint depair {m n} (o : t m) (p : t n) : t (m * n) := @@ -192,9 +192,9 @@ Lemma depair_sanity {m n} (o : t m) (p : t n) : proj1_sig (to_nat (depair o p)) = n * (proj1_sig (to_nat o)) + (proj1_sig (to_nat p)). Proof. induction o ; simpl. - rewrite L_sanity. now rewrite Mult.mult_0_r. +- rewrite L_sanity. now rewrite Mult.mult_0_r. - rewrite R_sanity. rewrite IHo. +- rewrite R_sanity. rewrite IHo. rewrite Plus.plus_assoc. destruct (to_nat o); simpl; rewrite Mult.mult_succ_r. now rewrite (Plus.plus_comm n). Qed. @@ -210,10 +210,10 @@ end. Lemma eqb_nat_eq : forall m n (p : t m) (q : t n), eqb p q = true -> m = n. Proof. intros m n p; revert n; induction p; destruct q; simpl; intros; f_equal. -+ now apply EqNat.beq_nat_true. -+ easy. -+ easy. -+ eapply IHp. eassumption. +- now apply EqNat.beq_nat_true. +- easy. +- easy. +- eapply IHp. eassumption. Qed. Lemma eqb_eq : forall n (p q : t n), eqb p q = true <-> p = q. @@ -231,9 +231,9 @@ Qed. Lemma eq_dec {n} (x y : t n): {x = y} + {x <> y}. Proof. - case_eq (eqb x y); intros. - + left; now apply eqb_eq. - + right. intros Heq. apply <- eqb_eq in Heq. congruence. +case_eq (eqb x y); intros. +- left; now apply eqb_eq. +- right. intros Heq. apply <- eqb_eq in Heq. congruence. Defined. Definition cast: forall {m} (v: t m) {n}, m = n -> t n. diff --git a/theories/Vectors/VectorSpec.v b/theories/Vectors/VectorSpec.v index 7f4228dd..c5278b91 100644 --- a/theories/Vectors/VectorSpec.v +++ b/theories/Vectors/VectorSpec.v @@ -22,6 +22,11 @@ Definition cons_inj {A} {a1 a2} {n} {v1 v2 : t A n} with | eq_refl => conj eq_refl eq_refl end. +Lemma eta {A} {n} (v : t A (S n)) : v = hd v :: tl v. +Proof. +intros; apply caseS with (v:=v); intros; reflexivity. +Defined. + (** Lemmas are done for functions that use [Fin.t] but thanks to [Peano_dec.le_unique], all is true for the one that use [lt] *) @@ -29,12 +34,12 @@ Lemma eq_nth_iff A n (v1 v2: t A n): (forall p1 p2, p1 = p2 -> v1 [@ p1 ] = v2 [@ p2 ]) <-> v1 = v2. Proof. split. - revert n v1 v2; refine (@rect2 _ _ _ _ _); simpl; intros. - reflexivity. - f_equal. apply (H0 Fin.F1 Fin.F1 eq_refl). +- revert n v1 v2; refine (@rect2 _ _ _ _ _); simpl; intros. + + reflexivity. + + f_equal. apply (H0 Fin.F1 Fin.F1 eq_refl). apply H. intros p1 p2 H1; apply (H0 (Fin.FS p1) (Fin.FS p2) (f_equal (@Fin.FS n) H1)). - intros; now f_equal. +- intros; now f_equal. Qed. Lemma nth_order_last A: forall n (v: t A (S n)) (H: n < S n), @@ -47,8 +52,8 @@ Lemma shiftin_nth A a n (v: t A n) k1 k2 (eq: k1 = k2): nth (shiftin a v) (Fin.L_R 1 k1) = nth v k2. Proof. subst k2; induction k1. - generalize dependent n. apply caseS ; intros. now simpl. - generalize dependent n. refine (@caseS _ _ _) ; intros. now simpl. +- generalize dependent n. apply caseS ; intros. now simpl. +- generalize dependent n. refine (@caseS _ _ _) ; intros. now simpl. Qed. Lemma shiftin_last A a n (v: t A n): last (shiftin a v) = a. @@ -60,8 +65,8 @@ Lemma shiftrepeat_nth A: forall n k (v: t A (S n)), nth (shiftrepeat v) (Fin.L_R 1 k) = nth v k. Proof. refine (@Fin.rectS _ _ _); lazy beta; [ intros n v | intros n p H v ]. - revert n v; refine (@caseS _ _ _); simpl; intros. now destruct t. - revert p H. +- revert n v; refine (@caseS _ _ _); simpl; intros. now destruct t. +- revert p H. refine (match v as v' in t _ m return match m as m' return t A m' -> Prop with |S (S n) => fun v => forall p : Fin.t (S n), (forall v0 : t A (S n), (shiftrepeat v0) [@ Fin.L_R 1 p ] = v0 [@p]) -> @@ -84,8 +89,8 @@ Lemma nth_map {A B} (f: A -> B) {n} v (p1 p2: Fin.t n) (eq: p1 = p2): (map f v) [@ p1] = f (v [@ p2]). Proof. subst p2; induction p1. - revert n v; refine (@caseS _ _ _); now simpl. - revert n v p1 IHp1; refine (@caseS _ _ _); now simpl. +- revert n v; refine (@caseS _ _ _); now simpl. +- revert n v p1 IHp1; refine (@caseS _ _ _); now simpl. Qed. Lemma nth_map2 {A B C} (f: A -> B -> C) {n} v w (p1 p2 p3: Fin.t n): @@ -93,8 +98,8 @@ Lemma nth_map2 {A B C} (f: A -> B -> C) {n} v w (p1 p2 p3: Fin.t n): Proof. intros; subst p2; subst p3; revert n v w p1. refine (@rect2 _ _ _ _ _); simpl. - exact (Fin.case0 _). - intros n v1 v2 H a b p; revert n p v1 v2 H; refine (@Fin.caseS _ _ _); +- exact (Fin.case0 _). +- intros n v1 v2 H a b p; revert n p v1 v2 H; refine (@Fin.caseS _ _ _); now simpl. Qed. @@ -103,17 +108,17 @@ Lemma fold_left_right_assoc_eq {A B} {f: A -> B -> A} {n} (v: t B n): forall a, fold_left f a v = fold_right (fun x y => f y x) v a. Proof. assert (forall n h (v: t B n) a, fold_left f (f a h) v = f (fold_left f a v) h). - induction v0. - now simpl. - intros; simpl. rewrite<- IHv0, assoc. now f_equal. - induction v. - reflexivity. - simpl. intros; now rewrite<- (IHv). +- induction v0. + + now simpl. + + intros; simpl. rewrite<- IHv0, assoc. now f_equal. +- induction v. + + reflexivity. + + simpl. intros; now rewrite<- (IHv). Qed. Lemma to_list_of_list_opp {A} (l: list A): to_list (of_list l) = l. Proof. induction l. - reflexivity. - unfold to_list; simpl. now f_equal. +- reflexivity. +- unfold to_list; simpl. now f_equal. Qed. diff --git a/theories/Wellfounded/intro.tex b/theories/Wellfounded/intro.tex deleted file mode 100755 index 126071e2..00000000 --- a/theories/Wellfounded/intro.tex +++ /dev/null @@ -1,4 +0,0 @@ -\section{Well-founded relations}\label{Wellfounded} - -This library gives definitions and results about well-founded relations. - diff --git a/theories/ZArith/intro.tex b/theories/ZArith/intro.tex deleted file mode 100755 index 21e52c19..00000000 --- a/theories/ZArith/intro.tex +++ /dev/null @@ -1,6 +0,0 @@ -\section{Binary integers : ZArith} -The {\tt ZArith} library deals with binary integers (those used -by the {\tt Omega} decision tactic). -Here are defined various arithmetical notions and their properties, -similar to those of {\tt Arith}. - diff --git a/theories/theories.itarget b/theories/theories.itarget index 4519070e..b7de4164 100644 --- a/theories/theories.itarget +++ b/theories/theories.itarget @@ -1,6 +1,7 @@ Arith/vo.otarget Bool/vo.otarget Classes/vo.otarget +Compat/vo.otarget FSets/vo.otarget MSets/vo.otarget MMaps/vo.otarget diff --git a/tools/README.coq-tex b/tools/README.coq-tex deleted file mode 100755 index 5c7606a9..00000000 --- a/tools/README.coq-tex +++ /dev/null @@ -1,13 +0,0 @@ -DESCRIPTION. - -The coq-tex filter extracts Coq phrases embedded in LaTeX files, -evaluates them, and insert the outcome of the evaluation after each -phrase. - -The filter is written in Perl, so you'll need Perl version 4 installed -on your machine. - -USAGE. See the manual page (coq-tex.1). - -AUTHOR. Jean-Christophe Filliatre (jcfillia@lip.ens-lyon.fr) - from caml-tex of Xavier Leroy. diff --git a/tools/README.emacs b/tools/README.emacs index 4d8e3697..4d8e3697 100755..100644 --- a/tools/README.emacs +++ b/tools/README.emacs diff --git a/tools/coq-sl.sty b/tools/coq-sl.sty index 9f6e5480..9f6e5480 100755..100644 --- a/tools/coq-sl.sty +++ b/tools/coq-sl.sty diff --git a/tools/coq_makefile.ml b/tools/coq_makefile.ml index 0931fd55..d3374675 100644 --- a/tools/coq_makefile.ml +++ b/tools/coq_makefile.ml @@ -299,7 +299,7 @@ let install (vfiles,(mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles),_,sds) in printf "find %s/%s -maxdepth 0 -and -empty -exec rmdir -p \\{\\} \\;\\n' >> \"$@\"\n" dir kind in printf "uninstall_me.sh: %s\n" !makefile_name; - print "\techo '#!/bin/sh' > $@ \n"; + print "\techo '#!/bin/sh' > $@\n"; if (not_empty cmxsfiles) then uninstall_by_root where_what_cmxs; uninstall_by_root where_what_oth; if not_empty vfiles then uninstall_one_kind "html" doc_dir; @@ -386,12 +386,12 @@ let implicit () = 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 "$(addsuffix .d,$(MLLIBFILES)): %.mllib.d: %.mllib\n"; - print "\t$(COQDEP) $(OCAMLLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n" in + print "\t$(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 "$(addsuffix .d,$(MLPACKFILES)): %.mlpack.d: %.mlpack\n"; - print "\t$(COQDEP) $(OCAMLLIBS) \"$<\" > \"$@\" || ( RV=$$?; rm -f \"$@\"; exit $${RV} )\n\n"; + print "\t$(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"; @@ -496,7 +496,7 @@ endif\n"; print "\n" let parameters () = - print ".DEFAULT_GOAL := all\n\n# \n"; + print ".DEFAULT_GOAL := all\n\n"; print "# This Makefile may take arguments passed as environment variables:\n"; print "# COQBIN to specify the directory where Coq binaries resides;\n"; print "# TIMECMD set a command to log .v compilation time;\n"; @@ -575,8 +575,13 @@ let main_targets vfiles (mlifiles,ml4files,mlfiles,mllibfiles,mlpackfiles) other let decl_var var = function |[] -> () |l -> - printf "%s:=" var; print_list "\\\n " l; print "\n"; - printf "\n-include $(addsuffix .d,$(%s))\n.SECONDARY: $(addsuffix .d,$(%s))\n\n" var var + printf "%s:=" var; print_list "\\\n " l; print "\n\n"; + print "ifneq ($(filter-out archclean clean cleanall printenv,$(MAKECMDGOALS)),)\n"; + printf "-include $(addsuffix .d,$(%s))\n" var; + print "else\nifeq ($(MAKECMDGOALS),)\n"; + printf "-include $(addsuffix .d,$(%s))\n" var; + print "endif\nendif\n\n"; + printf ".SECONDARY: $(addsuffix .d,$(%s))\n\n" var in section "Files dispatching."; decl_var "VFILES" vfiles; @@ -764,7 +769,7 @@ let ensure_root_dir (v,(mli,ml4,ml,mllib,mlpack),_,_) ((ml_inc,i_inc,r_inc) as l && not_tops mllib && not_tops mlpack) then l else - ((".",here)::ml_inc,(".","Top",here)::i_inc,r_inc) + ((".",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) = @@ -837,11 +842,9 @@ let do_makefile args = if not (makefile = None) then close_out !output_channel; exit 0 -let main () = +let _ = let args = if Array.length Sys.argv = 1 then usage (); List.tl (Array.to_list Sys.argv) in do_makefile args - -let _ = Printexc.catch main () diff --git a/tools/coq_tex.ml b/tools/coq_tex.ml index a2cc8384..dbdc2e9d 100644 --- a/tools/coq_tex.ml +++ b/tools/coq_tex.ml @@ -24,10 +24,7 @@ let hrule = ref false let small = ref false let boot = ref false -let coq_prompt = Str.regexp "Coq < " -let any_prompt = Str.regexp "^[A-Z0-9a-z_\\$']* < " - -let remove_prompt s = Str.replace_first any_prompt "" s +let any_prompt = Str.regexp "[A-Z0-9a-z_\\$']* < " (* First pass: extract the Coq phrases to evaluate from [texfile] * and put them into the file [inputv] *) @@ -58,30 +55,19 @@ let extract texfile inputv = ("Set Printing Width " ^ (string_of_int !linelen) ^".\n"); outside () with End_of_file -> - begin close_in chan_in; close_out chan_out end + (* a dummy command, just in case the last line was a comment *) + output_string chan_out "Set Printing Width 78.\n"; + close_in chan_in; + close_out chan_out (* Second pass: insert the answers of Coq from [coq_output] into the * TeX file [texfile]. The result goes in file [result]. *) -let begin_coq_example = - Str.regexp "\\\\begin{coq_\\(example\\|example\\*\\|example\\#\\)}[ \t]*$" -let begin_coq_eval = Str.regexp "\\\\begin{coq_eval}[ \t]*$" -let end_coq_example = Str.regexp "\\\\end{coq_\\(example\\|example\\*\\|example\\#\\)}[ \t]*$" -let end_coq_eval = Str.regexp "\\\\end{coq_eval}[ \t]*$" -let dot_end_line = Str.regexp "\\.[ \t]*\\((\\*.*\\*)\\)?[ \t]*$" - -let has_match r s = - try let _ = Str.search_forward r s 0 in true with Not_found -> false - -let percent = Str.regexp "%" -let bang = Str.regexp "!" -let expos = Str.regexp "^" - let tex_escaped s = - let dollar = "\\$" and backslash = "\\\\" and expon = "\\^" in - let delims = Str.regexp ("[_{}&%#" ^ dollar ^ backslash ^ expon ^"~ <>'`]") in + let delims = Str.regexp "[_{}&%#$\\^~ <>'`]" in let adapt_delim = function - | "_" | "{" | "}" | "&" | "%" | "#" | "$" as c -> "\\"^c + | "{" | "}" | "&" | "%" | "#" | "$" as c -> "\\"^c + | "_" -> "{\\char`\\_}" | "\\" -> "{\\char'134}" | "^" -> "{\\char'136}" | "~" -> "{\\char'176}" @@ -111,99 +97,106 @@ let insert texfile coq_output result = let c_tex = open_in texfile in let c_coq = open_in coq_output in let c_out = open_out result in - (* next_block k : this function reads the next block of Coq output - * removing the k leading prompts. - * it returns the block as a list of string) *) - let last_read = ref "" in - let next_block k = - if !last_read = "" then last_read := input_line c_coq; - (* skip k prompts *) - for _i = 1 to k do - last_read := remove_prompt !last_read; - done; + (* read lines until a prompt is found (starting from the second line), + purge prompts on the first line and return their number *) + let last_read = ref (input_line c_coq) in + let read_output () = + let first = !last_read in + let nb = ref 0 in + (* remove the leading prompts *) + let rec skip_prompts pos = + if Str.string_match any_prompt first pos then + let () = incr nb in + skip_prompts (Str.match_end ()) + else pos in + let first = + let start = skip_prompts 0 in + String.sub first start (String.length first - start) in (* read and return the following lines until a prompt is found *) let rec read_lines () = let s = input_line c_coq in if Str.string_match any_prompt s 0 then begin last_read := s; [] end else - s :: (read_lines ()) - in - let first = !last_read in first :: (read_lines ()) - in - (* we are just after \end{coq_...} block *) - let rec just_after () = + s :: read_lines () in + (first :: read_lines (), !nb) in + let unhandled_output = ref None in + let read_output () = + match !unhandled_output with + | Some some -> unhandled_output := None; some + | None -> read_output () in + (* we are inside a \begin{coq_...} ... \end{coq_...} block + * show_... tell what kind of block it is *) + let rec inside show_answers show_questions not_first discarded = let s = input_line c_tex in - if Str.string_match begin_coq_example s 0 then begin - inside (Str.matched_group 1 s <> "example*") - (Str.matched_group 1 s <> "example#") 0 false - end - else begin - if !hrule then output_string c_out "\\hrulefill\\\\\n"; - output_string c_out "\\end{flushleft}\n"; - if !small then output_string c_out "\\end{small}\n"; - if Str.string_match begin_coq_eval s 0 then - eval 0 + if s = "" then + inside show_answers show_questions not_first (discarded + 1) + else if not (Str.string_match end_coq s 0) then begin + let (bl,n) = read_output () in + assert (n > discarded); + let n = n - discarded in + if not_first then output_string c_out "\\medskip\n"; + if !verbose then Printf.printf "Coq < %s\n" s; + if show_questions then encapsule false c_out ("Coq < " ^ s); + let rec read_lines k = + if k = 0 then [] + else + let s = input_line c_tex in + if Str.string_match end_coq s 0 then [] + else s :: read_lines (k - 1) in + let al = read_lines (n - 1) in + if !verbose then List.iter (Printf.printf " %s\n") al; + if show_questions then + List.iter (fun s -> encapsule false c_out (" " ^ s)) al; + let la = n - 1 - List.length al in + if la <> 0 then + (* this happens when the block ends with a comment; the output + is for the command at the beginning of the next block *) + unhandled_output := Some (bl, la) else begin - output_string c_out (s ^ "\n"); - outside () + if !verbose then List.iter print_endline bl; + if show_answers then print_block c_out bl; + inside show_answers show_questions (show_answers || show_questions) 0 end - end + end else if discarded > 0 then begin + (* this happens when the block ends with an empty line *) + let (bl,n) = read_output () in + assert (n > discarded); + unhandled_output := Some (bl, n - discarded) + end in (* we are outside of a \begin{coq_...} ... \end{coq_...} block *) - and outside () = - let s = input_line c_tex in - if Str.string_match begin_coq_example s 0 then begin + let rec outside just_after = + let start_block () = if !small then output_string c_out "\\begin{small}\n"; output_string c_out "\\begin{flushleft}\n"; + if !hrule then output_string c_out "\\hrulefill\\\\\n" in + let end_block () = if !hrule then output_string c_out "\\hrulefill\\\\\n"; - inside (Str.matched_group 1 s <> "example*") - (Str.matched_group 1 s <> "example#") 0 true - end else if Str.string_match begin_coq_eval s 0 then - eval 0 - else begin - output_string c_out (s ^ "\n"); - outside () - end - (* we are inside a \begin{coq_example?} ... \end{coq_example?} block - * show_answers tells what kind of block it is - * k is the number of lines read until now *) - and inside show_answers show_questions k first_block = + output_string c_out "\\end{flushleft}\n"; + if !small then output_string c_out "\\end{small}\n" in let s = input_line c_tex in - if Str.string_match end_coq_example s 0 then begin - just_after () + if Str.string_match begin_coq s 0 then begin + let kind = Str.matched_group 1 s in + if kind = "eval" then begin + if just_after then end_block (); + inside false false false 0; + outside false + end else begin + let show_answers = kind <> "example*" in + let show_questions = kind <> "example#" in + if not just_after then start_block (); + inside show_answers show_questions just_after 0; + outside true + end end else begin - let prompt = if k = 0 then "Coq < " else " " in - if !verbose then Printf.printf "%s%s\n" prompt s; - if (not first_block) && k=0 then output_string c_out "\\medskip\n"; - if show_questions then encapsule false c_out (prompt ^ s); - if has_match dot_end_line s then begin - let bl = next_block (succ k) in - if !verbose then List.iter print_endline bl; - if show_answers then print_block c_out bl; - inside show_answers show_questions 0 false - end else - inside show_answers show_questions (succ k) first_block - end - (* we are inside a \begin{coq_eval} ... \end{coq_eval} block - * k is the number of lines read until now *) - and eval k = - let s = input_line c_tex in - if Str.string_match end_coq_eval s 0 then - outside () - else begin - if !verbose then Printf.printf "Coq < %s\n" s; - if has_match dot_end_line s then - let bl = next_block (succ k) in - if !verbose then List.iter print_endline bl; - eval 0 - else - eval (succ k) - end - in + if just_after then end_block (); + output_string c_out (s ^ "\n"); + outside false + end in try - let _ = next_block 0 in (* to skip the Coq banner *) - let _ = next_block 0 in (* to skip the Coq answer to Set Printing Width *) - outside () + let _ = read_output () in (* to skip the Coq banner *) + let _ = read_output () in (* to skip the Coq answer to Set Printing Width *) + outside false with End_of_file -> begin close_in c_tex; close_in c_coq; @@ -212,7 +205,7 @@ let insert texfile coq_output result = (* Process of one TeX file *) -let rm f = try Sys.remove f with any -> () +let rm f = try Sys.remove f with _ -> () let one_file texfile = let inputv = Filename.temp_file "coq_tex" ".v" in @@ -249,7 +242,7 @@ let files = ref [] let parse_cl () = Arg.parse [ "-o", Arg.String (fun s -> output_specified := true; output := s), - "output-file Specifiy the resulting LaTeX file"; + "output-file Specify the resulting LaTeX file"; "-n", Arg.Int (fun n -> linelen := n), "line-width Set the line width"; "-image", Arg.String (fun s -> image := s), @@ -265,7 +258,7 @@ let parse_cl () = "-small", Arg.Set small, " Coq parts are written in small font"; "-boot", Arg.Set boot, - " Launch coqtop with the -boot option" + " Launch coqtop with the -boot option" ] (fun s -> files := s :: !files) "coq-tex [options] file ..." @@ -281,7 +274,7 @@ let find_coqtop () = "coqtop" end -let main () = +let _ = parse_cl (); if !image = "" then image := Filename.quote (find_coqtop ()); if !boot then image := !image ^ " -boot"; @@ -290,9 +283,7 @@ let main () = let _ = Sys.command (!image ^ " -batch") in exit 1 end else begin - Printf.printf "Your version of coqtop seems OK\n"; + (*Printf.printf "Your version of coqtop seems OK\n";*) flush stdout end; List.iter one_file (List.rev !files) - -let _ = Printexc.catch main () diff --git a/tools/coqc.ml b/tools/coqc.ml index 7e822dbe..e7239da6 100644 --- a/tools/coqc.ml +++ b/tools/coqc.ml @@ -30,13 +30,8 @@ let verbose = ref false let rec make_compilation_args = function | [] -> [] | file :: fl -> - let file_noext = - if Filename.check_suffix file ".v" then - Filename.chop_suffix file ".v" - else file - in (if !verbose then "-compile-verbose" else "-compile") - :: file_noext :: (make_compilation_args fl) + :: file :: (make_compilation_args fl) (* compilation of files [files] with command [command] and args [args] *) @@ -109,20 +104,20 @@ let parse_args () = |"-q"|"-full"|"-profile"|"-just-parsing"|"-echo" |"-unsafe"|"-quiet" |"-silent"|"-m"|"-xml"|"-v7"|"-v8"|"-beautify"|"-strict-implicit" |"-dont-load-proofs"|"-load-proofs"|"-force-load-proofs" - |"-impredicative-set"|"-vm"|"-no-native-compiler" + |"-impredicative-set"|"-vm"|"-native-compiler" |"-verbose-compat-notations"|"-no-compat-notations" - |"-indices-matter"|"-quick"|"-color"|"-type-in-type" + |"-indices-matter"|"-quick"|"-type-in-type" |"-async-proofs-always-delegate"|"-async-proofs-never-reopen-branch" as o) :: rem -> parse (cfiles,o::args) rem (* Options for coqtop : b) options with 1 argument *) - | ("-outputstate"|"-inputstate"|"-is"|"-exclude-dir" + | ("-outputstate"|"-inputstate"|"-is"|"-exclude-dir"|"-color" |"-load-vernac-source"|"-l"|"-load-vernac-object" |"-load-ml-source"|"-require"|"-load-ml-object" |"-init-file"|"-dump-glob"|"-compat"|"-coqlib"|"-top" - |"-async-proofs-j" |"-async-proofs-private-flags" |"-async-proofs" + |"-async-proofs-j" |"-async-proofs-private-flags" |"-async-proofs" |"-w" as o) :: rem -> begin match rem with diff --git a/tools/coqdep.ml b/tools/coqdep.ml index 2e0cce6e..110d3060 100644 --- a/tools/coqdep.ml +++ b/tools/coqdep.ml @@ -36,14 +36,6 @@ let warning_mult suf iter = in iter check -let add_coqlib_known recur phys_dir log_dir f = - match get_extension f [".vo"] with - | (basename,".vo") -> - let name = log_dir@[basename] in - let paths = if recur then suffixes name else [name] in - List.iter (fun f -> Hashtbl.add coqlibKnown f ()) paths - | _ -> () - let sort () = let seen = Hashtbl.create 97 in let rec loop file = @@ -55,13 +47,13 @@ let sort () = try while true do match coq_action lb with - | Require sl -> + | Require (from, sl) -> List.iter (fun s -> - try loop (Hashtbl.find vKnown s) - with Not_found -> ()) + match search_v_known ?from s with + | None -> () + | Some f -> loop f) sl - | RequireString s -> loop s | _ -> () done with Fin_fichier -> @@ -297,18 +289,24 @@ struct module DAG = DAG(struct type t = string let compare = compare end) (** TODO: we should share this code with Coqdep_common *) +module VData = struct + type t = string list option * string list + let compare = Pervasives.compare +end + +module VCache = Set.Make(VData) + let treat_coq_file chan = let buf = Lexing.from_channel chan in - let deja_vu_v = ref ([]: string list list) - and deja_vu_ml = ref ([] : string list) in - let mark_v_done acc str = - let seen = List.mem str !deja_vu_v in + let deja_vu_v = ref VCache.empty in + let deja_vu_ml = ref StrSet.empty in + let mark_v_done from acc str = + let seen = VCache.mem (from, str) !deja_vu_v in if not seen then - let () = addQueue deja_vu_v str in - try - let file_str = Hashtbl.find vKnown str in - (canonize file_str, !suffixe) :: acc - with Not_found -> acc + let () = deja_vu_v := VCache.add (from, str) !deja_vu_v in + match search_v_known ?from str with + | None -> acc + | Some file_str -> (canonize file_str, !suffixe) :: acc else acc in let rec loop acc = @@ -317,11 +315,8 @@ let treat_coq_file chan = | None -> acc | Some action -> let acc = match action with - | Require strl -> - List.fold_left mark_v_done acc strl - | RequireString s -> - let str = Filename.basename s in - mark_v_done acc [str] + | Require (from, strl) -> + List.fold_left (fun accu v -> mark_v_done from accu v) acc strl | Declare sl -> let declare suff dir s = let base = file_name s dir in @@ -330,8 +325,8 @@ let treat_coq_file chan = in let decl acc str = let s = basename_noext str in - if not (List.mem s !deja_vu_ml) then - let () = addQueue deja_vu_ml s in + if not (StrSet.mem s !deja_vu_ml) then + let () = deja_vu_ml := StrSet.add s !deja_vu_ml in match search_mllib_known s with | Some mldir -> (declare ".cma" mldir s) :: acc | None -> @@ -343,13 +338,12 @@ let treat_coq_file chan = List.fold_left decl acc sl | Load str -> let str = Filename.basename str in - let seen = List.mem [str] !deja_vu_v in + let seen = VCache.mem (None, [str]) !deja_vu_v in if not seen then - let () = addQueue deja_vu_v [str] in - try - let file_str = Hashtbl.find vKnown [str] in - (canonize file_str, ".v") :: acc - with Not_found -> acc + let () = deja_vu_v := VCache.add (None, [str]) !deja_vu_v in + match search_v_known [str] with + | None -> acc + | Some file_str -> (canonize file_str, ".v") :: acc else acc | AddLoadPath _ | AddRecLoadPath _ -> acc (** TODO *) in @@ -461,7 +455,7 @@ let rec parse = function | "-R" :: ([] | [_]) -> usage () | "-dumpgraph" :: f :: ll -> option_dump := Some (false, f); parse ll | "-dumpgraphbox" :: f :: ll -> option_dump := Some (true, f); parse ll - | "-exclude-dir" :: r :: ll -> norec_dirnames := r::!norec_dirnames; parse ll + | "-exclude-dir" :: r :: ll -> norec_dirnames := StrSet.add r !norec_dirnames; parse ll | "-exclude-dir" :: [] -> usage () | "-coqlib" :: r :: ll -> Flags.coqlib_spec := true; Flags.coqlib := r; parse ll | "-coqlib" :: [] -> usage () diff --git a/tools/coqdep_boot.ml b/tools/coqdep_boot.ml index bc3435a6..64ce66d2 100644 --- a/tools/coqdep_boot.ml +++ b/tools/coqdep_boot.ml @@ -25,12 +25,12 @@ let rec parse = function (* To solve conflict (e.g. same filename in kernel and checker) we allow to state an explicit order *) add_caml_dir r; - norec_dirs:=r::!norec_dirs; + norec_dirs := StrSet.add r !norec_dirs; parse ll | f :: ll -> treat_file None f; parse ll | [] -> () -let coqdep_boot () = +let _ = let () = option_boot := true in if Array.length Sys.argv < 2 then exit 1; parse (List.tl (Array.to_list Sys.argv)); @@ -47,5 +47,3 @@ let coqdep_boot () = end; if !option_c then mL_dependencies (); coq_dependencies () - -let _ = Printexc.catch coqdep_boot () diff --git a/tools/coqdep_common.ml b/tools/coqdep_common.ml index 2e6a15ce..c1111375 100644 --- a/tools/coqdep_common.ml +++ b/tools/coqdep_common.ml @@ -17,6 +17,11 @@ open Unix options (see for instance [option_natdynlk] below). *) +module StrSet = Set.Make(String) + +module StrList = struct type t = string list let compare = compare end +module StrListMap = Map.Make(StrList) + let stderr = Pervasives.stderr let stdout = Pervasives.stdout @@ -26,8 +31,8 @@ let option_natdynlk = ref true let option_boot = ref false let option_mldep = ref None -let norec_dirs = ref ([] : string list) -let norec_dirnames = ref ["CVS"; "_darcs"] +let norec_dirs = ref StrSet.empty +let norec_dirnames = ref (List.fold_right StrSet.add ["CVS"; "_darcs"] StrSet.empty) let suffixe = ref ".vo" @@ -86,18 +91,18 @@ let vAccu = ref ([] : (string * string) list) let addQueue q v = q := v :: !q -let safe_hash_add cmp clq q (k,v) = +let safe_hash_add cmp clq q (k, (v, b)) = try - let v2 = Hashtbl.find q k in + let (v2, _) = Hashtbl.find q k in if not (cmp v v2) then - let rec add_clash = function - (k1,l1)::cltl when k=k1 -> (k1,v::l1)::cltl - | cl::cltl -> cl::add_clash cltl - | [] -> [(k,[v;v2])] in - clq := add_clash !clq; + let nv = + try v :: StrListMap.find k !clq + with Not_found -> [v; v2] + in + clq := StrListMap.add k nv !clq; (* overwrite previous bindings, as coqc does *) - Hashtbl.add q k v - with Not_found -> Hashtbl.add q k v + Hashtbl.add q k (v, b) + with Not_found -> Hashtbl.add q k (v, b) (** Files found in the loadpaths. For the ML files, the string is the basename without extension. @@ -126,20 +131,53 @@ let add_mli_known, iter_mli_known, search_mli_known = mkknown () let add_mllib_known, _, search_mllib_known = mkknown () let add_mlpack_known, _, search_mlpack_known = mkknown () -let vKnown = (Hashtbl.create 19 : (string list, string) Hashtbl.t) +let vKnown = (Hashtbl.create 19 : (string list, string * bool) Hashtbl.t) +(** The associated boolean is true if this is a root path. *) let coqlibKnown = (Hashtbl.create 19 : (string list, unit) Hashtbl.t) -let clash_v = ref ([]: (string list * string list) list) +let get_prefix p l = + let rec drop_prefix_rec = function + | (h1::tp, h2::tl) when h1 = h2 -> drop_prefix_rec (tp,tl) + | ([], tl) -> Some tl + | _ -> None + in + drop_prefix_rec (p, l) + +let search_table (type r) is_root table ?from s = match from with +| None -> Hashtbl.find table s +| Some from -> + let module M = struct exception Found of r end in + let iter logpath binding = + if is_root binding then match get_prefix from logpath with + | None -> () + | Some rem -> + match get_prefix (List.rev s) (List.rev rem) with + | None -> () + | Some _ -> raise (M.Found binding) + in + try Hashtbl.iter iter table; raise Not_found + with M.Found s -> s + +let search_v_known ?from s = + let is_root (_, root) = root in + try + let (phys_dir, _) = search_table is_root vKnown ?from s in + Some phys_dir + with Not_found -> None + +let is_in_coqlib ?from s = + let is_root _ = true in + try search_table is_root coqlibKnown ?from s; true with Not_found -> false + +let clash_v = ref (StrListMap.empty : string list StrListMap.t) let error_cannot_parse s (i,j) = Printf.eprintf "File \"%s\", characters %i-%i: Syntax error\n" s i j; exit 1 let warning_module_notfound f s = - eprintf "*** Warning: in file %s, library " f; - eprintf "%s.v is required and has not been found in the loadpath!\n" - (String.concat "." s); - flush stderr + eprintf "*** Warning: in file %s, library %s is required and has not been found in the loadpath!\n%!" + f (String.concat "." s) let warning_notfound f s = eprintf "*** Warning: in file %s, the file " f; @@ -152,7 +190,7 @@ let warning_declare f s = flush stderr let warning_clash file dir = - match List.assoc dir !clash_v with + match StrListMap.find dir !clash_v with (f1::f2::fl) -> let f = Filename.basename f1 in let d1 = Filename.dirname f1 in @@ -165,9 +203,11 @@ let warning_clash file dir = eprintf "%s and %s; used the latter)\n" d2 d1 | _ -> assert false -let safe_assoc verbose file k = - if verbose && List.mem_assoc k !clash_v then warning_clash file k; - Hashtbl.find vKnown k +let safe_assoc from verbose file k = + if verbose && StrListMap.mem k !clash_v then warning_clash file k; + match search_v_known ?from k with + | None -> raise Not_found + | Some path -> path let absolute_dir dir = let current = Sys.getcwd () in @@ -222,16 +262,16 @@ let autotraite_fichier_ML md ext = try let chan = open_in (md ^ ext) in let buf = Lexing.from_channel chan in - let deja_vu = ref [md] in + let deja_vu = ref (StrSet.singleton md) in let a_faire = ref "" in let a_faire_opt = ref "" in begin try while true do let (Use_module str) = caml_action buf in - if List.mem str !deja_vu then + if StrSet.mem str !deja_vu then () else begin - addQueue deja_vu str; + deja_vu := StrSet.add str !deja_vu; let byte,opt = depend_ML str in a_faire := !a_faire ^ byte; a_faire_opt := !a_faire_opt ^ opt @@ -307,38 +347,39 @@ let canonize f = | (f,_) :: _ -> escape f | _ -> escape f +module VData = struct + type t = string list option * string list + let compare = Pervasives.compare +end + +module VCache = Set.Make(VData) + let rec traite_fichier_Coq suffixe verbose f = try let chan = open_in f in let buf = Lexing.from_channel chan in - let deja_vu_v = ref ([]: string list list) - and deja_vu_ml = ref ([] : string list) in + let deja_vu_v = ref VCache.empty in + let deja_vu_ml = ref StrSet.empty in try while true do let tok = coq_action buf in match tok with - | Require strl -> + | Require (from, strl) -> List.iter (fun str -> - if not (List.mem str !deja_vu_v) then begin - addQueue deja_vu_v str; + if not (VCache.mem (from, str) !deja_vu_v) then begin + deja_vu_v := VCache.add (from, str) !deja_vu_v; try - let file_str = safe_assoc verbose f str in + let file_str = safe_assoc from verbose f str in printf " %s%s" (canonize file_str) suffixe with Not_found -> - if verbose && not (Hashtbl.mem coqlibKnown str) then + if verbose && not (is_in_coqlib ?from str) then + let str = + match from with + | None -> str + | Some pth -> pth @ str + in warning_module_notfound f str end) strl - | RequireString s -> - let str = Filename.basename s in - if not (List.mem [str] !deja_vu_v) then begin - addQueue deja_vu_v [str]; - try - let file_str = Hashtbl.find vKnown [str] in - printf " %s%s" (canonize file_str) suffixe - with Not_found -> - if not (Hashtbl.mem coqlibKnown [str]) then - warning_notfound f s - end | Declare sl -> let declare suff dir s = let base = file_name s dir in @@ -347,8 +388,8 @@ let rec traite_fichier_Coq suffixe verbose f = in let decl str = let s = basename_noext str in - if not (List.mem s !deja_vu_ml) then begin - addQueue deja_vu_ml s; + if not (StrSet.mem s !deja_vu_ml) then begin + deja_vu_ml := StrSet.add s !deja_vu_ml; match search_mllib_known s with | Some mldir -> declare ".cma" mldir s | None -> @@ -362,10 +403,10 @@ let rec traite_fichier_Coq suffixe verbose f = in List.iter decl sl | Load str -> let str = Filename.basename str in - if not (List.mem [str] !deja_vu_v) then begin - addQueue deja_vu_v [str]; + if not (VCache.mem (None, [str]) !deja_vu_v) then begin + deja_vu_v := VCache.add (None, [str]) !deja_vu_v; try - let file_str = Hashtbl.find vKnown [str] in + let (file_str, _) = Hashtbl.find vKnown [str] in let canon = canonize file_str in printf " %s.v" canon; traite_fichier_Coq suffixe true (canon ^ ".v") @@ -449,14 +490,24 @@ let add_caml_known phys_dir _ f = | ".mlpack" -> add_mlpack_known basename (Some phys_dir) suff | _ -> () +let add_coqlib_known recur phys_dir log_dir f = + match get_extension f [".vo"] with + | (basename,".vo") -> + let name = log_dir@[basename] in + let paths = if recur then suffixes name else [name] in + List.iter (fun f -> Hashtbl.add coqlibKnown f ()) paths + | _ -> () + let add_known recur phys_dir log_dir f = match get_extension f [".v";".vo"] with | (basename,".v") -> let name = log_dir@[basename] in let file = phys_dir//basename in - let paths = if recur then suffixes name else [name] in - List.iter - (fun n -> safe_hash_add compare_file clash_v vKnown (n,file)) paths + let () = safe_hash_add compare_file clash_v vKnown (name, (file, true)) in + if recur then + let paths = List.tl (suffixes name) in + let iter n = safe_hash_add compare_file clash_v vKnown (n, (file, false)) in + List.iter iter paths | (basename,".vo") when not(!option_boot) -> let name = log_dir@[basename] in let paths = if recur then suffixes name else [name] in @@ -477,9 +528,9 @@ let rec add_directory recur add_file phys_dir log_dir = let phys_f = if phys_dir = "." then f else phys_dir//f in match try (stat phys_f).st_kind with _ -> S_BLK with | S_DIR when recur -> - if List.mem f !norec_dirnames then () + if StrSet.mem f !norec_dirnames then () else - if List.mem phys_f !norec_dirs then () + if StrSet.mem phys_f !norec_dirs then () else add_directory recur add_file phys_f (log_dir@[f]) | S_REG -> add_file phys_dir log_dir f diff --git a/tools/coqdep_common.mli b/tools/coqdep_common.mli index 71b96ca0..d610a055 100644 --- a/tools/coqdep_common.mli +++ b/tools/coqdep_common.mli @@ -6,13 +6,15 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +module StrSet : Set.S with type elt = string + val option_c : bool ref val option_noglob : bool ref val option_boot : bool ref val option_natdynlk : bool ref val option_mldep : string option ref -val norec_dirs : string list ref -val norec_dirnames : string list ref +val norec_dirs : StrSet.t ref +val norec_dirnames : StrSet.t ref val suffixe : string ref type dir = string option val ( // ) : string -> string -> string @@ -31,8 +33,7 @@ val iter_mli_known : (string -> dir -> unit) -> unit val search_mli_known : string -> dir option val add_mllib_known : string -> dir -> string -> unit val search_mllib_known : string -> dir option -val vKnown : (string list, string) Hashtbl.t -val coqlibKnown : (string list, unit) Hashtbl.t +val search_v_known : ?from:string list -> string list -> string option val file_name : string -> string option -> string val escape : string -> string val canonize : string -> string @@ -40,6 +41,7 @@ val mL_dependencies : unit -> unit val coq_dependencies : unit -> unit val suffixes : 'a list -> 'a list list val add_known : bool -> string -> string list -> string -> unit +val add_coqlib_known : bool -> string -> string list -> string -> unit val add_caml_known : string -> string list -> string -> unit val add_directory : bool -> diff --git a/tools/coqdep_lexer.mli b/tools/coqdep_lexer.mli index b447030a..84c9ba79 100644 --- a/tools/coqdep_lexer.mli +++ b/tools/coqdep_lexer.mli @@ -11,8 +11,7 @@ type mL_token = Use_module of string type qualid = string list type coq_token = - Require of qualid list - | RequireString of string + Require of qualid option * qualid list | Declare of string list | Load of string | AddLoadPath of string diff --git a/tools/coqdep_lexer.mll b/tools/coqdep_lexer.mll index 8ecc419c..291bc55f 100644 --- a/tools/coqdep_lexer.mll +++ b/tools/coqdep_lexer.mll @@ -16,8 +16,7 @@ type qualid = string list type coq_token = - | Require of qualid list - | RequireString of string + | Require of qualid option * qualid list | Declare of string list | Load of string | AddLoadPath of string @@ -271,16 +270,9 @@ and require_file = parse module_names := [coq_qual_id_tail lexbuf]; let qid = coq_qual_id_list lexbuf in parse_dot lexbuf; - match !from_pre_ident with - None -> - Require qid - | Some from -> - (from_pre_ident := None ; - Require (List.map (fun x -> from @ x) qid)) } - | '"' [^'"']* '"' (*'"'*) - { let s = Lexing.lexeme lexbuf in - parse_dot lexbuf; - RequireString (unquote_vfile_string s) } + let from = !from_pre_ident in + from_pre_ident := None; + Require (from, qid) } | eof { syntax_error lexbuf } | _ diff --git a/tools/coqdoc/cpretty.mll b/tools/coqdoc/cpretty.mll index cb704146..d2892167 100644 --- a/tools/coqdoc/cpretty.mll +++ b/tools/coqdoc/cpretty.mll @@ -320,6 +320,7 @@ let def_token = | "Instance" | "Declare" space+ "Instance" | "Global" space+ "Instance" + | "Functional" space+ "Scheme" let decl_token = "Hypothesis" diff --git a/tools/coqdoc/main.ml b/tools/coqdoc/main.ml index 9531cd2b..22febd6a 100644 --- a/tools/coqdoc/main.ml +++ b/tools/coqdoc/main.ml @@ -61,8 +61,8 @@ let usage () = prerr_endline " --coqlib_path <dir> set the path where Coq files are installed"; prerr_endline " -R <dir> <coqdir> map physical dir to Coq dir"; prerr_endline " -Q <dir> <coqdir> map physical dir to Coq dir"; - prerr_endline " --latin1 set ISO-8859-1 input language"; - prerr_endline " --utf8 set UTF-8 input language"; + prerr_endline " --latin1 set ISO-8859-1 mode"; + prerr_endline " --utf8 set UTF-8 mode"; prerr_endline " --charset <string> set HTML charset"; prerr_endline " --inputenc <string> set LaTeX input encoding"; prerr_endline " --interpolate try to typeset identifiers in comments using definitions in the same module"; @@ -557,10 +557,8 @@ let produce_output fl = (*s \textbf{Main program.} Print the banner, parse the command line, read the files and then call [produce_document] from module [Web]. *) -let main () = +let _ = let files = parse () in Index.init_coqlib_library (); if not !quiet then banner (); if files <> [] then produce_output files - -let _ = Printexc.catch main () diff --git a/tools/coqdoc/output.ml b/tools/coqdoc/output.ml index 06030c45..8589f94a 100644 --- a/tools/coqdoc/output.ml +++ b/tools/coqdoc/output.ml @@ -197,8 +197,11 @@ module Latex = struct printf "\n"; printf "%%Warning: tipa declares many non-standard macros used by utf8x to\n"; printf "%%interpret utf8 characters but extra packages might have to be added\n"; - printf "%%(e.g. \"textgreek\" for Greek letters not already in tipa).\n"; - printf "%%Use coqdoc's option -p to add new packages.\n"; + printf "%%such as \"textgreek\" for Greek letters not already in tipa\n"; + printf "%%or \"stmaryrd\" for mathematical symbols.\n"; + printf "%%Utf8 codes missing a LaTeX interpretation can be defined by using\n"; + printf "%%\\DeclareUnicodeCharacter{code}{interpretation}.\n"; + printf "%%Use coqdoc's option -p to add new packages or declarations.\n"; printf "\\usepackage{tipa}\n"; printf "\n" diff --git a/tools/coqwc.mll b/tools/coqwc.mll index 417ec535..9a42553d 100644 --- a/tools/coqwc.mll +++ b/tools/coqwc.mll @@ -276,7 +276,7 @@ let rec parse = function (*s Main program. *) -let main () = +let _ = let files = parse (List.tl (Array.to_list Sys.argv)) in if not (!spec_only || !proof_only) then printf " spec proof comments\n"; @@ -285,8 +285,6 @@ let main () = | [f] -> process_file f | _ -> List.iter process_file files; print_totals () -let _ = Printexc.catch main () - (*i*)}(*i*) diff --git a/tools/fake_ide.ml b/tools/fake_ide.ml index c2b12668..a9a7251c 100644 --- a/tools/fake_ide.ml +++ b/tools/fake_ide.ml @@ -90,7 +90,7 @@ module Parser = struct (* {{{ *) in find ~-1 0 else raise (Err ("Balanced "^String.make 1 c^" not found in: "^s)) - let eat_blanks s = snd (eat_rex "[ \n\t]*") s + let eat_blanks s = snd (eat_rex "[ \r\n\t]*") s let s = ref "" @@ -257,6 +257,9 @@ let eval_print l coq = | [ Tok(_,"WAIT") ] -> let phrase = "Stm Wait." in eval_call (query (phrase,tip_id())) coq + | [ Tok(_,"JOIN") ] -> + let phrase = "Stm JoinDocument." in + eval_call (query (phrase,tip_id())) coq | [ Tok(_,"ASSERT"); Tok(_,"TIP"); Tok(_,id) ] -> let to_id, _ = get_id id in if not(Stateid.equal (Document.tip doc) to_id) then error "Wrong tip" @@ -273,6 +276,7 @@ let grammar = ; Seq [Item (eat_rex "EDIT_AT"); Item eat_id] ; Seq [Item (eat_rex "QUERY"); Opt (Item eat_id); Item eat_phrase] ; Seq [Item (eat_rex "WAIT")] + ; Seq [Item (eat_rex "JOIN")] ; Seq [Item (eat_rex "GOALS")] ; Seq [Item (eat_rex "FAILGOALS")] ; Seq [Item (eat_rex "ASSERT"); Item (eat_rex "TIP"); Item eat_id ] diff --git a/tools/gallina.ml b/tools/gallina.ml index 279919c5..5ce19e7f 100644 --- a/tools/gallina.ml +++ b/tools/gallina.ml @@ -39,7 +39,7 @@ let traite_stdin () = with Sys_error _ -> () -let gallina () = +let _ = let lg_command = Array.length Sys.argv in if lg_command < 2 then begin output_string stderr "Usage: gallina [-] [-stdout] file1 file2 ...\n"; @@ -59,6 +59,3 @@ let gallina () = traite_stdin () else List.iter traite_fichier !vfiles - -let _ = Printexc.catch gallina () - diff --git a/library/assumptions.ml b/toplevel/assumptions.ml index 62645b23..a6bd968e 100644 --- a/library/assumptions.ml +++ b/toplevel/assumptions.ml @@ -22,34 +22,7 @@ open Term open Declarations open Mod_subst open Globnames - -type context_object = - | Variable of Id.t (* A section variable or a Let definition *) - | Axiom of constant (* An axiom or a constant. *) - | Opaque of constant (* An opaque constant. *) - | Transparent of constant - -(* Defines a set of [assumption] *) -module OrderedContextObject = -struct - type t = context_object - let compare x y = - match x , y with - | Variable i1 , Variable i2 -> Id.compare i1 i2 - | Axiom k1 , Axiom k2 -> con_ord k1 k2 - | Opaque k1 , Opaque k2 -> con_ord k1 k2 - | Transparent k1 , Transparent k2 -> con_ord k1 k2 - | Axiom _ , Variable _ -> 1 - | Opaque _ , Variable _ - | Opaque _ , Axiom _ -> 1 - | Transparent _ , Variable _ - | Transparent _ , Axiom _ - | Transparent _ , Opaque _ -> 1 - | _ , _ -> -1 -end - -module ContextObjectSet = Set.Make (OrderedContextObject) -module ContextObjectMap = Map.Make (OrderedContextObject) +open Printer (** For a constant c in a module sealed by an interface (M:T and not M<:T), [Global.lookup_constant] may return a [constant_body] @@ -82,7 +55,7 @@ let rec fields_of_functor f subs mp0 args = function match args with | [] -> assert false (* we should only encounter applied functors *) | mpa :: args -> - let subs = add_mbid mbid mpa empty_delta_resolver (*TODO*) subs in + let subs = join (map_mbid mbid mpa empty_delta_resolver (*TODO*)) subs in fields_of_functor f subs mp0 args e let rec lookup_module_in_impl mp = @@ -91,11 +64,11 @@ let rec lookup_module_in_impl mp = (* The module we search might not be exported by its englobing module(s). We access the upper layer, and then do a manual search *) match mp with - | MPfile _ | MPbound _ -> - raise Not_found (* should have been found by [lookup_module] *) - | MPdot (mp',lab') -> - let fields = memoize_fields_of_mp mp' in - search_mod_label lab' fields + | MPfile _ -> raise Not_found (* can happen if mp is an open module *) + | MPbound _ -> assert false + | MPdot (mp',lab') -> + let fields = memoize_fields_of_mp mp' in + search_mod_label lab' fields and memoize_fields_of_mp mp = try MPmap.find mp !modcache @@ -161,7 +134,16 @@ let lookup_constant cst = (** Graph traversal of an object, collecting on the way the dependencies of traversed objects *) -let rec traverse accu t = match kind_of_term t with + +let label_of = function + | ConstRef kn -> pi3 (repr_con kn) + | IndRef (kn,_) + | ConstructRef ((kn,_),_) -> pi3 (repr_mind kn) + | VarRef id -> Label.of_id id + +let push (r : Context.rel_declaration) (ctx : Context.rel_context) = r :: ctx + +let rec traverse current ctx accu t = match kind_of_term t with | Var id -> let body () = match Global.lookup_named id with (_, body, _) -> body in traverse_object accu body (VarRef id) @@ -173,22 +155,44 @@ let rec traverse accu t = match kind_of_term t with | Construct (cst, _) -> traverse_object accu (fun () -> None) (ConstructRef cst) | Meta _ | Evar _ -> assert false -| _ -> Constr.fold traverse accu t - -and traverse_object (curr, data) body obj = - let data = - if Refmap.mem obj data then data - else match body () with - | None -> Refmap.add obj Refset.empty data +| Case (_,oty,c,[||]) -> + (* non dependent match on an inductive with no constructors *) + begin match Constr.(kind oty, kind c) with + | Lambda(Anonymous,_,oty), Const (kn, _) + when Vars.noccurn 1 oty && + not (Declareops.constant_has_body (lookup_constant kn)) -> + let body () = Global.body_of_constant_body (lookup_constant kn) in + traverse_object + ~inhabits:(current,ctx,Vars.subst1 mkProp oty) accu body (ConstRef kn) + | _ -> + Termops.fold_constr_with_full_binders push (traverse current) ctx accu t + end +| _ -> Termops.fold_constr_with_full_binders push (traverse current) ctx accu t + +and traverse_object ?inhabits (curr, data, ax2ty) body obj = + let data, ax2ty = + let already_in = Refmap_env.mem obj data in + match body () with + | None -> + let data = + if not already_in then Refmap_env.add obj Refset_env.empty data else data in + let ax2ty = + if Option.is_empty inhabits then ax2ty else + let ty = Option.get inhabits in + try let l = Refmap_env.find obj ax2ty in Refmap_env.add obj (ty::l) ax2ty + with Not_found -> Refmap_env.add obj [ty] ax2ty in + data, ax2ty | Some body -> - let (contents, data) = traverse (Refset.empty, data) body in - Refmap.add obj contents data + if already_in then data, ax2ty else + let contents,data,ax2ty = + traverse (label_of obj) [] (Refset_env.empty,data,ax2ty) body in + Refmap_env.add obj contents data, ax2ty in - (Refset.add obj curr, data) + (Refset_env.add obj curr, data, ax2ty) -let traverse t = +let traverse current t = let () = modcache := MPmap.empty in - traverse (Refset.empty, Refmap.empty) t + traverse current [] (Refset_env.empty, Refmap_env.empty, Refmap_env.empty) t (** Hopefully bullet-proof function to recover the type of a constant. It just ignores all the universe stuff. There are many issues that can arise when @@ -198,10 +202,10 @@ let type_of_constant cb = match cb.Declarations.const_type with | Declarations.TemplateArity (ctx, arity) -> Term.mkArity (ctx, Sorts.sort_of_univ arity.Declarations.template_level) -let assumptions ?(add_opaque=false) ?(add_transparent=false) st t = +let assumptions ?(add_opaque=false) ?(add_transparent=false) st gr t = let (idts, knst) = st in (** Only keep the transitive dependencies *) - let (_, graph) = traverse t in + let (_, graph, ax2ty) = traverse (label_of gr) t in let fold obj _ accu = match obj with | VarRef id -> let (_, body, t) = Global.lookup_named id in @@ -211,7 +215,8 @@ let assumptions ?(add_opaque=false) ?(add_transparent=false) st t = let cb = lookup_constant kn in if not (Declareops.constant_has_body cb) then let t = type_of_constant cb in - ContextObjectMap.add (Axiom kn) t accu + let l = try Refmap_env.find obj ax2ty with Not_found -> [] in + ContextObjectMap.add (Axiom (kn,l)) t accu else if add_opaque && (Declareops.is_opaque cb || not (Cpred.mem kn knst)) then let t = type_of_constant cb in ContextObjectMap.add (Opaque kn) t accu @@ -222,4 +227,4 @@ let assumptions ?(add_opaque=false) ?(add_transparent=false) st t = accu | IndRef _ | ConstructRef _ -> accu in - Refmap.fold fold graph ContextObjectMap.empty + Refmap_env.fold fold graph ContextObjectMap.empty diff --git a/library/assumptions.mli b/toplevel/assumptions.mli index bb36a972..9c9f81bd 100644 --- a/library/assumptions.mli +++ b/toplevel/assumptions.mli @@ -10,19 +10,7 @@ open Util open Names open Term open Globnames - -(** A few declarations for the "Print Assumption" command - @author spiwack *) -type context_object = - | Variable of Id.t (** A section variable or a Let definition *) - | Axiom of constant (** An axiom or a constant. *) - | Opaque of constant (** An opaque constant. *) - | Transparent of constant (** A transparent constant *) - -(** AssumptionSet.t is a set of [assumption] *) -module ContextObjectSet : Set.S with type elt = context_object -module ContextObjectMap : Map.ExtS - with type key = context_object and module Set := ContextObjectSet +open Printer (** Collects all the objects on which a term directly relies, bypassing kernel opacity, together with the recursive dependence DAG of objects. @@ -31,11 +19,14 @@ module ContextObjectMap : Map.ExtS sealed inside opaque modules. Do not try to do anything fancy with those terms apart from printing them, otherwise demons may fly out of your nose. *) -val traverse : constr -> (Refset.t * Refset.t Refmap.t) +val traverse : + Label.t -> constr -> + (Refset_env.t * Refset_env.t Refmap_env.t * + (label * Context.rel_context * types) list Refmap_env.t) (** Collects all the assumptions (optionally including opaque definitions) on which a term relies (together with their type). The above warning of {!traverse} also applies. *) val assumptions : - ?add_opaque:bool -> ?add_transparent:bool -> transparent_state -> constr -> - Term.types ContextObjectMap.t + ?add_opaque:bool -> ?add_transparent:bool -> transparent_state -> + global_reference -> constr -> Term.types ContextObjectMap.t diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml index 26b54a73..7a89b9f5 100644 --- a/toplevel/auto_ind_decl.ml +++ b/toplevel/auto_ind_decl.ml @@ -19,6 +19,7 @@ open Termops open Declarations open Names open Globnames +open Nameops open Inductiveops open Tactics open Ind_tables @@ -54,6 +55,7 @@ exception InductiveWithProduct exception InductiveWithSort exception ParameterWithoutEquality of constant exception NonSingletonProp of inductive +exception DecidabilityMutualNotSupported let dl = Loc.ghost @@ -109,7 +111,7 @@ let check_bool_is_defined () = let beq_scheme_kind_aux = ref (fun _ -> failwith "Undefined") -let build_beq_scheme kn = +let build_beq_scheme mode kn = check_bool_is_defined (); (* fetching global env *) let env = Global.env() in @@ -177,23 +179,22 @@ let build_beq_scheme kn = let rec aux c = let (c,a) = Reductionops.whd_betaiota_stack Evd.empty c in match kind_of_term c with - | Rel x -> mkRel (x-nlist+ndx), Declareops.no_seff - | Var x -> mkVar (id_of_string ("eq_"^(string_of_id x))), Declareops.no_seff + | Rel x -> mkRel (x-nlist+ndx), Safe_typing.empty_private_constants + | Var x -> mkVar (id_of_string ("eq_"^(string_of_id x))), Safe_typing.empty_private_constants | Cast (x,_,_) -> aux (applist (x,a)) | App _ -> assert false | Ind ((kn',i as ind'),u) (*FIXME: universes *) -> - if eq_mind kn kn' then mkRel(eqA-nlist-i+nb_ind-1), Declareops.no_seff + if eq_mind kn kn' then mkRel(eqA-nlist-i+nb_ind-1), Safe_typing.empty_private_constants else begin try let eq, eff = - let c, eff = find_scheme (!beq_scheme_kind_aux()) (kn',i) in + let c, eff = find_scheme ~mode (!beq_scheme_kind_aux()) (kn',i) in mkConst c, eff in let eqa, eff = let eqa, effs = List.split (List.map aux a) in Array.of_list eqa, - Declareops.union_side_effects - (Declareops.flatten_side_effects (List.rev effs)) - eff in + List.fold_left Safe_typing.concat_private eff (List.rev effs) + in let args = Array.append (Array.of_list (List.map (fun x -> lift lifti x) a)) eqa in @@ -236,7 +237,7 @@ let build_beq_scheme kn = let constrsi = constrs (3+nparrec) in let n = Array.length constrsi in let ar = Array.make n (Lazy.force ff) in - let eff = ref Declareops.no_seff in + let eff = ref Safe_typing.empty_private_constants in for i=0 to n-1 do let nb_cstr_args = List.length constrsi.(i).cs_args in let ar2 = Array.make n (Lazy.force ff) in @@ -254,7 +255,7 @@ let build_beq_scheme kn = (nb_cstr_args+ndx+1) cc in - eff := Declareops.union_side_effects eff' !eff; + eff := Safe_typing.concat_private eff' !eff; Array.set eqs ndx (mkApp (eqA, [|mkRel (ndx+1+nb_cstr_args);mkRel (ndx+1)|] @@ -286,7 +287,7 @@ let build_beq_scheme kn = let names = Array.make nb_ind Anonymous and types = Array.make nb_ind mkSet and cores = Array.make nb_ind mkSet in - let eff = ref Declareops.no_seff in + let eff = ref Safe_typing.empty_private_constants in let u = Univ.Instance.empty in for i=0 to (nb_ind-1) do names.(i) <- Name (Id.of_string (rec_name i)); @@ -294,7 +295,7 @@ let build_beq_scheme kn = (mkArrow (mkFullInd ((kn,i),u) 1) (Lazy.force bb)); let c, eff' = make_one_eq i in cores.(i) <- c; - eff := Declareops.union_side_effects eff' !eff + eff := Safe_typing.concat_private eff' !eff done; (Array.init nb_ind (fun i -> let kelim = Inductive.elim_sorts (mib,mib.mind_packets.(i)) in @@ -302,7 +303,7 @@ let build_beq_scheme kn = raise (NonSingletonProp (kn,i)); let fix = mkFix (((Array.make nb_ind 0),i),(names,types,cores)) in create_input fix), - Evd.empty_evar_universe_context (* FIXME *)), + Evd.make_evar_universe_context (Global.env ()) None), !eff let beq_scheme_kind = declare_mutual_scheme_object "_beq" build_beq_scheme @@ -328,7 +329,7 @@ let destruct_ind c = so from Ai we can find the the correct eq_Ai bl_ai or lb_ai *) (* used in the leib -> bool side*) -let do_replace_lb lb_scheme_key aavoid narg p q = +let do_replace_lb mode lb_scheme_key aavoid narg p q = let avoid = Array.of_list aavoid in let do_arg v offset = try @@ -338,7 +339,8 @@ let do_replace_lb lb_scheme_key aavoid narg p q = let rec find i = if Id.equal avoid.(n-i) s then avoid.(n-i-x) else (if i<n then find (i+1) - else error ("Var "^(Id.to_string s)^" seems unknown.") + else errorlabstrm "AutoIndDecl.do_replace_lb" + (str "Var " ++ pr_id s ++ str " seems unknown.") ) in mkVar (find 1) with e when Errors.noncritical e -> @@ -353,11 +355,11 @@ let do_replace_lb lb_scheme_key aavoid narg p q = ) in Proofview.Goal.nf_enter begin fun gl -> - let type_of_pq = Tacmach.New.of_old (fun gl -> pf_type_of gl p) gl in + let type_of_pq = Tacmach.New.of_old (fun gl -> pf_unsafe_type_of gl p) gl in let u,v = destruct_ind type_of_pq in let lb_type_of_p = try - let c, eff = find_scheme lb_scheme_key (out_punivs u) (*FIXME*) in + let c, eff = find_scheme ~mode lb_scheme_key (out_punivs u) (*FIXME*) in Proofview.tclUNIT (mkConst c, eff) with Not_found -> (* spiwack: the format of this error message should probably @@ -369,7 +371,7 @@ let do_replace_lb lb_scheme_key aavoid narg p q = Printer.pr_constr type_of_pq ++ str " first.") in - Proofview.tclZERO (Errors.UserError("",err_msg)) + Tacticals.New.tclZEROMSG err_msg in lb_type_of_p >>= fun (lb_type_of_p,eff) -> let lb_args = Array.append (Array.append @@ -385,7 +387,7 @@ let do_replace_lb lb_scheme_key aavoid narg p q = end (* used in the bool -> leib side *) -let do_replace_bl bl_scheme_key (ind,u as indu) aavoid narg lft rgt = +let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt = let avoid = Array.of_list aavoid in let do_arg v offset = try @@ -395,7 +397,8 @@ let do_replace_bl bl_scheme_key (ind,u as indu) aavoid narg lft rgt = let rec find i = if Id.equal avoid.(n-i) s then avoid.(n-i-x) else (if i<n then find (i+1) - else error ("Var "^(Id.to_string s)^" seems unknown.") + else errorlabstrm "AutoIndDecl.do_replace_bl" + (str "Var " ++ pr_id s ++ str " seems unknown.") ) in mkVar (find 1) with e when Errors.noncritical e -> @@ -414,7 +417,7 @@ let do_replace_bl bl_scheme_key (ind,u as indu) aavoid narg lft rgt = match (l1,l2) with | (t1::q1,t2::q2) -> Proofview.Goal.enter begin fun gl -> - let tt1 = Tacmach.New.pf_type_of gl t1 in + let tt1 = Tacmach.New.pf_unsafe_type_of gl t1 in if eq_constr t1 t2 then aux q1 q2 else ( let u,v = try destruct_ind tt1 @@ -456,28 +459,28 @@ let do_replace_bl bl_scheme_key (ind,u as indu) aavoid narg lft rgt = ) end | ([],[]) -> Proofview.tclUNIT () - | _ -> Proofview.tclZERO (UserError ("" , str"Both side of the equality must have the same arity.")) + | _ -> Tacticals.New.tclZEROMSG (str "Both side of the equality must have the same arity.") in begin try Proofview.tclUNIT (destApp lft) - with DestKO -> Proofview.tclZERO (UserError ("" , str"replace failed.")) + with DestKO -> Tacticals.New.tclZEROMSG (str "replace failed.") end >>= fun (ind1,ca1) -> begin try Proofview.tclUNIT (destApp rgt) - with DestKO -> Proofview.tclZERO (UserError ("" , str"replace failed.")) + with DestKO -> Tacticals.New.tclZEROMSG (str "replace failed.") end >>= fun (ind2,ca2) -> begin try Proofview.tclUNIT (out_punivs (destInd ind1)) with DestKO -> begin try Proofview.tclUNIT (fst (fst (destConstruct ind1))) - with DestKO -> Proofview.tclZERO (UserError ("" , str"The expected type is an inductive one.")) + with DestKO -> Tacticals.New.tclZEROMSG (str "The expected type is an inductive one.") end end >>= fun (sp1,i1) -> begin try Proofview.tclUNIT (out_punivs (destInd ind2)) with DestKO -> begin try Proofview.tclUNIT (fst (fst (destConstruct ind2))) - with DestKO -> Proofview.tclZERO (UserError ("" , str"The expected type is an inductive one.")) + with DestKO -> Tacticals.New.tclZEROMSG (str "The expected type is an inductive one.") end end >>= fun (sp2,i2) -> if not (eq_mind sp1 sp2) || not (Int.equal i1 i2) - then Proofview.tclZERO (UserError ("" , str"Eq should be on the same type")) + then Tacticals.New.tclZEROMSG (str "Eq should be on the same type") else aux (Array.to_list ca1) (Array.to_list ca2) (* @@ -502,8 +505,8 @@ let eqI ind l = (List.map (fun (_,seq,_,_)-> mkVar seq) list_id )) and e, eff = try let c, eff = find_scheme beq_scheme_kind ind in mkConst c, eff - with Not_found -> error - ("The boolean equality on "^(string_of_mind (fst ind))^" is needed."); + with Not_found -> errorlabstrm "AutoIndDecl.eqI" + (str "The boolean equality on " ++ pr_mind (fst ind) ++ str " is needed."); in (if Array.equal eq_constr eA [||] then e else mkApp(e,eA)), eff (**********************************************************************) @@ -547,7 +550,7 @@ let compute_bl_goal ind lnamesparrec nparrec = (mkApp(Lazy.force eq,[|mkFullInd (ind,u) (nparrec+3);mkVar n;mkVar m|])) ))), eff -let compute_bl_tact bl_scheme_key ind lnamesparrec nparrec = +let compute_bl_tact mode bl_scheme_key ind lnamesparrec nparrec = let list_id = list_id lnamesparrec in let avoid = ref [] in let first_intros = @@ -604,16 +607,16 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). if eq_gr (IndRef indeq) Coqlib.glob_eq then Tacticals.New.tclTHEN - (do_replace_bl bl_scheme_key ind + (do_replace_bl mode bl_scheme_key ind (!avoid) nparrec (ca.(2)) (ca.(1))) Auto.default_auto else - Proofview.tclZERO (UserError ("",str"Failure while solving Boolean->Leibniz.")) - | _ -> Proofview.tclZERO (UserError ("", str"Failure while solving Boolean->Leibniz.")) + Tacticals.New.tclZEROMSG (str "Failure while solving Boolean->Leibniz.") + | _ -> Tacticals.New.tclZEROMSG (str" Failure while solving Boolean->Leibniz.") ) - | _ -> Proofview.tclZERO (UserError ("", str"Failure while solving Boolean->Leibniz.")) + | _ -> Tacticals.New.tclZEROMSG (str "Failure while solving Boolean->Leibniz.") end ] @@ -621,7 +624,12 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). let bl_scheme_kind_aux = ref (fun _ -> failwith "Undefined") -let make_bl_scheme mind = +let side_effect_of_mode = function + | Declare.UserAutomaticRequest -> false + | Declare.InternalTacticRequest -> true + | Declare.UserIndividualRequest -> false + +let make_bl_scheme mode mind = let mib = Global.lookup_mind mind in if not (Int.equal (Array.length mib.mind_packets) 1) then errorlabstrm "" @@ -632,9 +640,10 @@ let make_bl_scheme mind = let lnonparrec,lnamesparrec = (* TODO subst *) context_chop (nparams-nparrec) mib.mind_params_ctxt in let bl_goal, eff = compute_bl_goal ind lnamesparrec nparrec in - let ctx = Evd.empty_evar_universe_context (*FIXME univs *) in - let (ans, _, ctx) = Pfedit.build_by_tactic (Global.env()) ctx bl_goal - (compute_bl_tact (!bl_scheme_kind_aux()) (ind, Univ.Instance.empty) lnamesparrec nparrec) + let ctx = Evd.make_evar_universe_context (Global.env ()) None in + let side_eff = side_effect_of_mode mode in + let (ans, _, ctx) = Pfedit.build_by_tactic ~side_eff (Global.env()) ctx bl_goal + (compute_bl_tact mode (!bl_scheme_kind_aux()) (ind, Univ.Instance.empty) lnamesparrec nparrec) in ([|ans|], ctx), eff @@ -684,7 +693,7 @@ let compute_lb_goal ind lnamesparrec nparrec = (mkApp(eq,[|bb;mkApp(eqI,[|mkVar n;mkVar m|]);tt|])) ))), eff -let compute_lb_tact lb_scheme_key ind lnamesparrec nparrec = +let compute_lb_tact mode lb_scheme_key ind lnamesparrec nparrec = let list_id = list_id lnamesparrec in let avoid = ref [] in let first_intros = @@ -728,22 +737,22 @@ let compute_lb_tact lb_scheme_key ind lnamesparrec nparrec = | App(c,ca) -> (match (kind_of_term ca.(1)) with | App(c',ca') -> let n = Array.length ca' in - do_replace_lb lb_scheme_key + do_replace_lb mode lb_scheme_key (!avoid) nparrec ca'.(n-2) ca'.(n-1) | _ -> - Proofview.tclZERO (UserError ("",str"Failure while solving Leibniz->Boolean.")) + Tacticals.New.tclZEROMSG (str "Failure while solving Leibniz->Boolean.") ) | _ -> - Proofview.tclZERO (UserError ("",str"Failure while solving Leibniz->Boolean.")) + Tacticals.New.tclZEROMSG (str "Failure while solving Leibniz->Boolean.") end ] end let lb_scheme_kind_aux = ref (fun () -> failwith "Undefined") -let make_lb_scheme mind = +let make_lb_scheme mode mind = let mib = Global.lookup_mind mind in if not (Int.equal (Array.length mib.mind_packets) 1) then errorlabstrm "" @@ -754,11 +763,12 @@ let make_lb_scheme mind = let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in let lb_goal, eff = compute_lb_goal ind lnamesparrec nparrec in - let ctx = Evd.empty_evar_universe_context in - let (ans, _, ctx) = Pfedit.build_by_tactic (Global.env()) ctx lb_goal - (compute_lb_tact (!lb_scheme_kind_aux()) ind lnamesparrec nparrec) + let ctx = Evd.make_evar_universe_context (Global.env ()) None in + let side_eff = side_effect_of_mode mode in + let (ans, _, ctx) = Pfedit.build_by_tactic ~side_eff (Global.env()) ctx lb_goal + (compute_lb_tact mode (!lb_scheme_kind_aux()) ind lnamesparrec nparrec) in - ([|ans|], ctx (* FIXME *)), eff + ([|ans|], ctx), eff let lb_scheme_kind = declare_mutual_scheme_object "_dec_lb" make_lb_scheme @@ -856,17 +866,15 @@ let compute_dec_tact ind lnamesparrec nparrec = let c, eff = find_scheme bl_scheme_kind ind in Proofview.tclUNIT (mkConst c,eff) with Not_found -> - Proofview.tclZERO (UserError ("",str"Error during the decidability part, boolean to leibniz"++ - str" equality is required.")) + Tacticals.New.tclZEROMSG (str "Error during the decidability part, boolean to leibniz equality is required.") end >>= fun (blI,eff') -> begin try let c, eff = find_scheme lb_scheme_kind ind in Proofview.tclUNIT (mkConst c,eff) with Not_found -> - Proofview.tclZERO (UserError ("",str"Error during the decidability part, leibniz to boolean"++ - str" equality is required.")) + Tacticals.New.tclZEROMSG (str "Error during the decidability part, leibniz to boolean equality is required.") end >>= fun (lbI,eff'') -> - let eff = (Declareops.union_side_effects eff'' (Declareops.union_side_effects eff' eff)) in + let eff = (Safe_typing.concat_private eff'' (Safe_typing.concat_private eff' eff)) in Tacticals.New.tclTHENLIST [ Proofview.tclEFFECTS eff; intros_using fresh_first_intros; @@ -917,22 +925,23 @@ let compute_dec_tact ind lnamesparrec nparrec = ] end -let make_eq_decidability mind = +let make_eq_decidability mode mind = let mib = Global.lookup_mind mind in if not (Int.equal (Array.length mib.mind_packets) 1) then - anomaly (Pp.str "Decidability lemma for mutual inductive types not supported"); + raise DecidabilityMutualNotSupported; let ind = (mind,0) in let nparams = mib.mind_nparams in let nparrec = mib.mind_nparams_rec in let u = Univ.Instance.empty in - let ctx = Evd.empty_evar_universe_context (* FIXME *)in + let ctx = Evd.make_evar_universe_context (Global.env ()) None in let lnonparrec,lnamesparrec = context_chop (nparams-nparrec) mib.mind_params_ctxt in - let (ans, _, ctx) = Pfedit.build_by_tactic (Global.env()) ctx + let side_eff = side_effect_of_mode mode in + let (ans, _, ctx) = Pfedit.build_by_tactic ~side_eff (Global.env()) ctx (compute_dec_goal (ind,u) lnamesparrec nparrec) (compute_dec_tact ind lnamesparrec nparrec) in - ([|ans|], ctx), Declareops.no_seff + ([|ans|], ctx), Safe_typing.empty_private_constants let eq_dec_scheme_kind = declare_mutual_scheme_object "_eq_dec" make_eq_decidability diff --git a/toplevel/auto_ind_decl.mli b/toplevel/auto_ind_decl.mli index 80787298..20a3d5d7 100644 --- a/toplevel/auto_ind_decl.mli +++ b/toplevel/auto_ind_decl.mli @@ -23,6 +23,7 @@ exception InductiveWithProduct exception InductiveWithSort exception ParameterWithoutEquality of constant exception NonSingletonProp of inductive +exception DecidabilityMutualNotSupported val beq_scheme_kind : mutual scheme_kind val build_beq_scheme : mutual_scheme_object_function diff --git a/toplevel/cerrors.ml b/toplevel/cerrors.ml index b29ba1ef..accba312 100644 --- a/toplevel/cerrors.ml +++ b/toplevel/cerrors.ml @@ -20,7 +20,7 @@ let print_loc loc = let loc = Loc.unloc loc in (int (fst loc) ++ str"-" ++ int (snd loc)) -let guill s = "\""^s^"\"" +let guill s = str "\"" ++ str s ++ str "\"" (** Invariant : exceptions embedded in EvaluatedError satisfy Errors.noncritical *) @@ -33,10 +33,10 @@ exception EvaluatedError of std_ppcmds * exn option let explain_exn_default = function (* Basic interaction exceptions *) - | Stream.Error txt -> hov 0 (str ("Syntax error: " ^ txt ^ ".")) - | Compat.Token.Error txt -> hov 0 (str ("Syntax error: " ^ txt ^ ".")) + | Stream.Error txt -> hov 0 (str "Syntax error: " ++ str txt ++ str ".") + | Compat.Token.Error txt -> hov 0 (str "Syntax error: " ++ str txt ++ str ".") | Lexer.Error.E err -> hov 0 (str (Lexer.Error.to_string err)) - | Sys_error msg -> hov 0 (str ("System error: " ^ guill msg)) + | Sys_error msg -> hov 0 (str "System error: " ++ guill msg) | Out_of_memory -> hov 0 (str "Out of memory.") | Stack_overflow -> hov 0 (str "Stack overflow.") | Timeout -> hov 0 (str "Timeout!") @@ -110,9 +110,16 @@ let rec strip_wrapping_exceptions = function strip_wrapping_exceptions e | exc -> exc -let process_vernac_interp_error ?(with_header=true) (exc, info) = +let process_vernac_interp_error ?(allow_uncaught=true) ?(with_header=true) (exc, info) = let exc = strip_wrapping_exceptions exc in let e = process_vernac_interp_error with_header (exc, info) in + let () = + if not allow_uncaught && not (Errors.handled (fst e)) then + let (e, info) = e in + let msg = str "Uncaught exception " ++ str (Printexc.to_string e) in + let err = Errors.make_anomaly msg in + Util.iraise (err, info) + in let ltac_trace = Exninfo.get info Proof_type.ltac_trace_info in let loc = Option.default Loc.ghost (Loc.get_loc info) in match ltac_trace with diff --git a/toplevel/cerrors.mli b/toplevel/cerrors.mli index 100b3772..729686f3 100644 --- a/toplevel/cerrors.mli +++ b/toplevel/cerrors.mli @@ -12,7 +12,7 @@ val print_loc : Loc.t -> Pp.std_ppcmds (** Pre-explain a vernac interpretation error *) -val process_vernac_interp_error : ?with_header:bool -> Util.iexn -> Util.iexn +val process_vernac_interp_error : ?allow_uncaught:bool -> ?with_header:bool -> Util.iexn -> Util.iexn (** General explain function. Should not be used directly now, see instead function [Errors.print] and variants *) diff --git a/toplevel/class.ml b/toplevel/class.ml index 6a485d52..da662403 100644 --- a/toplevel/class.ml +++ b/toplevel/class.ml @@ -186,8 +186,9 @@ let error_not_transparent source = let build_id_coercion idf_opt source poly = let env = Global.env () in - let vs, ctx = match source with - | CL_CONST sp -> Universes.fresh_global_instance env (ConstRef sp) + let sigma = Evd.from_env env in + let sigma, vs = match source with + | CL_CONST sp -> Evd.fresh_global env sigma (ConstRef sp) | _ -> error_not_transparent source in let c = match constant_opt_value_in env (destConst vs) with | Some c -> c @@ -208,8 +209,8 @@ let build_id_coercion idf_opt source poly = (* juste pour verification *) let _ = if not - (Reductionops.is_conv_leq env Evd.empty - (Typing.type_of env Evd.empty val_f) typ_f) + (Reductionops.is_conv_leq env sigma + (Typing.unsafe_type_of env sigma val_f) typ_f) then errorlabstrm "" (strbrk "Cannot be defined as coercion (maybe a bad number of arguments).") @@ -218,13 +219,13 @@ let build_id_coercion idf_opt source poly = match idf_opt with | Some idf -> idf | None -> - let cl,u,_ = find_class_type Evd.empty t in + let cl,u,_ = find_class_type sigma t in Id.of_string ("Id_"^(ident_key_of_class source)^"_"^ (ident_key_of_class cl)) in let constr_entry = (* Cast is necessary to express [val_f] is identity *) DefinitionEntry - (definition_entry ~types:typ_f ~poly ~univs:(Univ.ContextSet.to_context ctx) + (definition_entry ~types:typ_f ~poly ~univs:(snd (Evd.universe_context sigma)) ~inline:true (mkCast (val_f, DEFAULTcast, typ_f))) in let decl = (constr_entry, IsDefinition IdentityCoercion) in diff --git a/toplevel/classes.ml b/toplevel/classes.ml index 33891ad9..c354c7d3 100644 --- a/toplevel/classes.ml +++ b/toplevel/classes.ml @@ -185,9 +185,9 @@ let new_instance ?(abstract=false) ?(global=false) poly ctx (instid, bk, cl) pro nf t in Evarutil.check_evars env Evd.empty !evars termtype; - let ctx = Evd.universe_context !evars in - let cst = Declare.declare_constant ~internal:Declare.KernelSilent id - (Entries.ParameterEntry + let pl, ctx = Evd.universe_context !evars in + let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id + (ParameterEntry (None,poly,(termtype,ctx),None), Decl_kinds.IsAssumption Decl_kinds.Logical) in instance_hook k None global imps ?hook (ConstRef cst); id end @@ -347,7 +347,7 @@ let named_of_rel_context l = let context poly l = let env = Global.env() in - let evars = ref Evd.empty in + let evars = ref (Evd.from_env env) in let _, ((env', fullctx), impls) = interp_context_evars env evars l in let subst = Evarutil.evd_comb0 Evarutil.nf_evars_and_universes evars in let fullctx = Context.map_rel_context subst fullctx in @@ -358,12 +358,14 @@ let context poly l = with e when Errors.noncritical e -> error "Anonymous variables not allowed in contexts." in - let uctx = Evd.universe_context_set !evars in + let uctx = ref (Evd.universe_context_set !evars) in let fn status (id, b, t) = if Lib.is_modtype () && not (Lib.sections_are_opened ()) then - let uctx = Univ.ContextSet.to_context uctx in - let decl = (ParameterEntry (None,poly,(t,uctx),None), IsAssumption Logical) in - let cst = Declare.declare_constant ~internal:Declare.KernelSilent id decl in + let ctx = Univ.ContextSet.to_context !uctx in + (* Declare the universe context once *) + let () = uctx := Univ.ContextSet.empty in + let decl = (ParameterEntry (None,poly,(t,ctx),None), IsAssumption Logical) in + let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest id decl in match class_of_constr t with | Some (rels, ((tc,_), args) as _cl) -> add_instance (Typeclasses.new_instance tc None false (*FIXME*) @@ -379,8 +381,9 @@ let context poly l = let impl = List.exists test impls in let decl = (Discharge, poly, Definitional) in let nstatus = - pi3 (Command.declare_assumption false decl (t, uctx) [] impl + pi3 (Command.declare_assumption false decl (t, !uctx) [] [] impl Vernacexpr.NoInline (Loc.ghost, id)) in - status && nstatus + let () = uctx := Univ.ContextSet.empty in + status && nstatus in List.fold_left fn true (List.rev ctx) diff --git a/toplevel/command.ml b/toplevel/command.ml index 754ad852..3d338ee0 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -38,16 +38,16 @@ open Indschemes open Misctypes open Vernacexpr -let do_universe l = Declare.do_universe l -let do_constraint l = Declare.do_constraint l +let do_universe poly l = Declare.do_universe poly l +let do_constraint poly l = Declare.do_constraint poly l -let rec under_binders env f n c = - if Int.equal n 0 then snd (f env Evd.empty c) else +let rec under_binders env sigma f n c = + if Int.equal n 0 then snd (f env sigma c) else match kind_of_term c with | Lambda (x,t,c) -> - mkLambda (x,t,under_binders (push_rel (x,None,t) env) f (n-1) c) + mkLambda (x,t,under_binders (push_rel (x,None,t) env) sigma f (n-1) c) | LetIn (x,b,t,c) -> - mkLetIn (x,b,t,under_binders (push_rel (x,Some b,t) env) f (n-1) c) + mkLetIn (x,b,t,under_binders (push_rel (x,Some b,t) env) sigma f (n-1) c) | _ -> assert false let rec complete_conclusion a cs = function @@ -67,22 +67,23 @@ let rec complete_conclusion a cs = function (* 1| Constant definitions *) -let red_constant_entry n ce = function +let red_constant_entry n ce sigma = function | None -> ce | Some red -> let proof_out = ce.const_entry_body in let env = Global.env () in { ce with const_entry_body = Future.chain ~greedy:true ~pure:true proof_out (fun ((body,ctx),eff) -> - (under_binders env + (under_binders env sigma (fst (reduction_of_red_expr env red)) n body,ctx),eff) } -let interp_definition bl p red_option c ctypopt = +let interp_definition pl bl p red_option c ctypopt = let env = Global.env() in - let evdref = ref (Evd.from_env env) in + let ctx = Evd.make_evar_universe_context env pl in + let evdref = ref (Evd.from_ctx ctx) in let impls, ((env_bl, ctx), imps1) = interp_context_evars env evdref bl in let nb_args = List.length ctx in - let imps,ce = + let imps,pl,ce = match ctypopt with None -> let subst = evd_comb0 Evd.nf_univ_variables evdref in @@ -92,10 +93,10 @@ let interp_definition bl p red_option c ctypopt = let nf,subst = Evarutil.e_nf_evars_and_universes evdref in let body = nf (it_mkLambda_or_LetIn c ctx) in let vars = Universes.universes_of_constr body in - let ctx = Universes.restrict_universe_context - (Evd.universe_context_set !evdref) vars in - imps1@(Impargs.lift_implicits nb_args imps2), - definition_entry ~univs:(Univ.ContextSet.to_context ctx) ~poly:p body + let evd = Evd.restrict_universe_context !evdref vars in + let pl, uctx = Evd.universe_context ?names:pl evd in + imps1@(Impargs.lift_implicits nb_args imps2), pl, + definition_entry ~univs:uctx ~poly:p body | Some ctyp -> let ty, impsty = interp_type_evars_impls ~impls env_bl evdref ctyp in let subst = evd_comb0 Evd.nf_univ_variables evdref in @@ -118,15 +119,15 @@ let interp_definition bl p red_option c ctypopt = strbrk "The term declares more implicits than the type here."); let vars = Univ.LSet.union (Universes.universes_of_constr body) (Universes.universes_of_constr typ) in - let ctx = Universes.restrict_universe_context - (Evd.universe_context_set !evdref) vars in - imps1@(Impargs.lift_implicits nb_args impsty), + let ctx = Evd.restrict_universe_context !evdref vars in + let pl, uctx = Evd.universe_context ?names:pl ctx in + imps1@(Impargs.lift_implicits nb_args impsty), pl, definition_entry ~types:typ ~poly:p - ~univs:(Univ.ContextSet.to_context ctx) body + ~univs:uctx body in - red_constant_entry (rel_context_length ctx) ce red_option, !evdref, imps + red_constant_entry (rel_context_length ctx) ce !evdref red_option, !evdref, pl, imps -let check_definition (ce, evd, imps) = +let check_definition (ce, evd, _, imps) = check_evars_are_solved (Global.env ()) evd (Evd.empty,evd); ce @@ -139,11 +140,12 @@ let get_locality id = function | Local -> true | Global -> false -let declare_global_definition ident ce local k imps = +let declare_global_definition ident ce local k pl imps = let local = get_locality ident local in let kn = declare_constant ident ~local (DefinitionEntry ce, IsDefinition k) in let gr = ConstRef kn in let () = maybe_declare_manual_implicits false gr imps in + let () = Universes.register_universe_binders gr pl in let () = definition_message ident in gr @@ -151,7 +153,8 @@ let declare_definition_hook = ref ignore let set_declare_definition_hook = (:=) declare_definition_hook let get_declare_definition_hook () = !declare_definition_hook -let declare_definition ident (local, p, k) ce imps hook = +let declare_definition ident (local, p, k) ce pl imps hook = + let fix_exn = Future.fix_exn_of ce.const_entry_body in let () = !declare_definition_hook ce in let r = match local with | Discharge when Lib.sections_are_opened () -> @@ -167,17 +170,18 @@ let declare_definition ident (local, p, k) ce imps hook = in gr | Discharge | Local | Global -> - declare_global_definition ident ce local k imps in - Lemmas.call_hook (Future.fix_exn_of ce.Entries.const_entry_body) hook local r + declare_global_definition ident ce local k pl imps in + Lemmas.call_hook fix_exn hook local r -let _ = Obligations.declare_definition_ref := declare_definition +let _ = Obligations.declare_definition_ref := + (fun i k c imps hook -> declare_definition i k c [] imps hook) -let do_definition ident k bl red_option c ctypopt hook = - let (ce, evd, imps as def) = interp_definition bl (pi2 k) red_option c ctypopt in +let do_definition ident k pl bl red_option c ctypopt hook = + let (ce, evd, pl, imps as def) = interp_definition pl bl (pi2 k) red_option c ctypopt in if Flags.is_program_mode () then let env = Global.env () in let (c,ctx), sideff = Future.force ce.const_entry_body in - assert(Declareops.side_effects_is_empty sideff); + assert(Safe_typing.empty_private_constants = sideff); assert(Univ.ContextSet.is_empty ctx); let typ = match ce.const_entry_type with | Some t -> t @@ -191,13 +195,14 @@ let do_definition ident k bl red_option c ctypopt hook = ignore(Obligations.add_definition ident ~term:c cty ctx ~implicits:imps ~kind:k ~hook obls) else let ce = check_definition def in - ignore(declare_definition ident k ce imps + ignore(declare_definition ident k ce pl imps (Lemmas.mk_hook (fun l r -> Lemmas.call_hook (fun exn -> exn) hook l r;r))) (* 2| Variable/Hypothesis/Parameter/Axiom declarations *) -let declare_assumption is_coe (local,p,kind) (c,ctx) imps impl nl (_,ident) = match local with +let declare_assumption is_coe (local,p,kind) (c,ctx) pl imps impl nl (_,ident) = +match local with | Discharge when Lib.sections_are_opened () -> let decl = (Lib.cwd(), SectionLocalAssum ((c,ctx),p,impl), IsAssumption kind) in let _ = declare_variable ident decl in @@ -224,6 +229,7 @@ let declare_assumption is_coe (local,p,kind) (c,ctx) imps impl nl (_,ident) = ma let kn = declare_constant ident ~local decl in let gr = ConstRef kn in let () = maybe_declare_manual_implicits false gr imps in + let () = Universes.register_universe_binders gr pl in let () = assumption_message ident in let () = Typeclasses.declare_instance None false gr in let () = if is_coe then Class.try_add_new_coercion gr local p in @@ -240,14 +246,17 @@ let interp_assumption evdref env impls bl c = let ctx = Evd.universe_context_set evd in ((nf ty, ctx), impls) -let declare_assumptions idl is_coe k c imps impl_is_on nl = - let refs, status = - List.fold_left (fun (refs,status) id -> - let ref',u',status' = declare_assumption is_coe k c imps impl_is_on nl id in - (ref',u')::refs, status' && status) ([],true) idl in +let declare_assumptions idl is_coe k (c,ctx) pl imps impl_is_on nl = + let refs, status, _ = + List.fold_left (fun (refs,status,ctx) id -> + let ref',u',status' = + declare_assumption is_coe k (c,ctx) pl imps impl_is_on nl id in + (ref',u')::refs, status' && status, Univ.ContextSet.empty) + ([],true,ctx) idl + in List.rev refs, status -let do_assumptions (_, poly, _ as kind) nl l = +let do_assumptions_unbound_univs (_, poly, _ as kind) nl l = let env = Global.env () in let evdref = ref (Evd.from_env env) in let l = @@ -273,13 +282,52 @@ let do_assumptions (_, poly, _ as kind) nl l = let l = List.map (on_pi2 (nf_evar evd)) l in snd (List.fold_left (fun (subst,status) ((is_coe,idl),t,(ctx,imps)) -> let t = replace_vars subst t in - let (refs,status') = declare_assumptions idl is_coe kind (t,ctx) imps false nl in + let (refs,status') = declare_assumptions idl is_coe kind (t,ctx) [] imps false nl in let subst' = List.map2 (fun (_,id) (c,u) -> (id,Universes.constr_of_global_univ (c,u))) idl refs in (subst'@subst, status' && status)) ([],true) l) +let do_assumptions_bound_univs coe kind nl id pl c = + let env = Global.env () in + let ctx = Evd.make_evar_universe_context env pl in + let evdref = ref (Evd.from_ctx ctx) in + let ty, impls = interp_type_evars_impls env evdref c in + let nf, subst = Evarutil.e_nf_evars_and_universes evdref in + let ty = nf ty in + let vars = Universes.universes_of_constr ty in + let evd = Evd.restrict_universe_context !evdref vars in + let pl, uctx = Evd.universe_context ?names:pl evd in + let uctx = Univ.ContextSet.of_context uctx in + let (_, _, st) = declare_assumption coe kind (ty, uctx) pl impls false nl id in + st + +let do_assumptions kind nl l = match l with +| [coe, ([id, Some pl], c)] -> + let () = match kind with + | (Discharge, _, _) when Lib.sections_are_opened () -> + let loc = fst id in + let msg = Pp.str "Section variables cannot be polymorphic." in + user_err_loc (loc, "", msg) + | _ -> () + in + do_assumptions_bound_univs coe kind nl id (Some pl) c +| _ -> + let map (coe, (idl, c)) = + let map (id, univs) = match univs with + | None -> id + | Some _ -> + let loc = fst id in + let msg = + Pp.str "Assumptions with bound universes can only be defined one at a time." in + user_err_loc (loc, "", msg) + in + (coe, (List.map map idl, c)) + in + let l = List.map map l in + do_assumptions_unbound_univs kind nl l + (* 3a| Elimination schemes for mutual inductive definitions *) (* 3b| Mutual inductive definitions *) @@ -290,6 +338,7 @@ let push_types env idl tl = type structured_one_inductive_expr = { ind_name : Id.t; + ind_univs : lident list option; ind_arity : constr_expr; ind_lc : (Id.t * constr_expr) list } @@ -360,8 +409,7 @@ let make_conclusion_flexible evdref ty poly = else () let is_impredicative env u = - u = Prop Null || - (engagement env = Some Declarations.ImpredicativeSet && u = Prop Pos) + u = Prop Null || (is_impredicative_set env && u = Prop Pos) let interp_ind_arity env evdref ind = let c = intern_gen IsType env ind.ind_arity in @@ -402,20 +450,33 @@ let extract_level env evd min tys = sign_level env evd ((Anonymous, None, concl) :: ctx)) tys in sup_list min sorts +let is_flexible_sort evd u = + match Univ.Universe.level u with + | Some l -> Evd.is_flexible_level evd l + | None -> false + let inductive_levels env evdref poly arities inds = - let destarities = List.map (Reduction.dest_arity env) arities in - let levels = List.map (fun (ctx,a) -> + let destarities = List.map (fun x -> x, Reduction.dest_arity env x) arities in + let levels = List.map (fun (x,(ctx,a)) -> if a = Prop Null then None else Some (univ_of_sort a)) destarities in let cstrs_levels, min_levels, sizes = CList.split3 - (List.map2 (fun (_,tys,_) (ctx,du) -> + (List.map2 (fun (_,tys,_) (arity,(ctx,du)) -> let len = List.length tys in + let minlev = Sorts.univ_of_sort du in let minlev = if len > 1 && not (is_impredicative env du) then - Univ.type0_univ - else Univ.type0m_univ + Univ.sup minlev Univ.type0_univ + else minlev + in + let minlev = + (** Indices contribute. *) + if Indtypes.is_indices_matter () && List.length ctx > 0 then ( + let ilev = sign_level env !evdref ctx in + Univ.sup ilev minlev) + else minlev in let clev = extract_level env !evdref minlev tys in (clev, minlev, len)) inds destarities) @@ -425,32 +486,25 @@ let inductive_levels env evdref poly arities inds = let levels' = Universes.solve_constraints_system (Array.of_list levels) (Array.of_list cstrs_levels) (Array.of_list min_levels) in - let evd = - CList.fold_left3 (fun evd cu (ctx,du) len -> + let evd, arities = + CList.fold_left3 (fun (evd, arities) cu (arity,(ctx,du)) len -> if is_impredicative env du then (** Any product is allowed here. *) - evd + evd, arity :: arities else (** If in a predicative sort, or asked to infer the type, we take the max of: - indices (if in indices-matter mode) - constructors - Type(1) if there is more than 1 constructor *) - let evd = - (** Indices contribute. *) - if Indtypes.is_indices_matter () && List.length ctx > 0 then ( - let ilev = sign_level env !evdref ctx in - Evd.set_leq_sort env evd (Type ilev) du) - else evd - in (** Constructors contribute. *) let evd = if Sorts.is_set du then if not (Evd.check_leq evd cu Univ.type0_univ) then raise (Indtypes.InductiveError Indtypes.LargeNonPropInductiveNotInType) else evd - else - Evd.set_leq_sort env evd (Type cu) du + else evd + (* Evd.set_leq_sort env evd (Type cu) du *) in let evd = if len >= 2 && Univ.is_type0m_univ cu then @@ -459,9 +513,20 @@ let inductive_levels env evdref poly arities inds = land in Prop directly (no informative arguments as well). *) Evd.set_leq_sort env evd (Prop Pos) du else evd - in evd) - !evdref (Array.to_list levels') destarities sizes - in evdref := evd; arities + in + let duu = Sorts.univ_of_sort du in + let evd = + if not (Univ.is_small_univ duu) && Evd.check_eq evd cu duu then + if is_flexible_sort evd duu then + if Evd.check_leq evd Univ.type0_univ duu then + evd + else Evd.set_eq_sort env evd (Prop Null) du + else evd + else Evd.set_eq_sort env evd (Type cu) du + in + (evd, arity :: arities)) + (!evdref,[]) (Array.to_list levels') destarities sizes + in evdref := evd; List.rev arities let check_named (loc, na) = match na with | Name _ -> () @@ -479,12 +544,14 @@ let interp_mutual_inductive (paramsl,indl) notations poly prv finite = check_all_names_different indl; List.iter check_param paramsl; let env0 = Global.env() in - let evdref = ref Evd.(from_env env0) in + let pl = (List.hd indl).ind_univs in + let ctx = Evd.make_evar_universe_context env0 pl in + let evdref = ref Evd.(from_ctx ctx) in let _, ((env_params, ctx_params), userimpls) = interp_context_evars env0 evdref paramsl in let indnames = List.map (fun ind -> ind.ind_name) indl in - + (* Names of parameters as arguments of the inductive type (defs removed) *) let assums = List.filter(fun (_,b,_) -> Option.is_empty b) ctx_params in let params = List.map (fun (na,_,_) -> out_name na) assums in @@ -526,6 +593,7 @@ let interp_mutual_inductive (paramsl,indl) notations poly prv finite = let constructors = List.map (fun (idl,cl,impsl) -> (idl,List.map nf' cl,impsl)) constructors in let ctx_params = map_rel_context nf ctx_params in let evd = !evdref in + let pl, uctx = Evd.universe_context ?names:pl evd in List.iter (check_evars env_params Evd.empty evd) arities; iter_rel_context (check_evars env0 Evd.empty evd) ctx_params; List.iter (fun (_,ctyps,_) -> @@ -553,8 +621,8 @@ let interp_mutual_inductive (paramsl,indl) notations poly prv finite = mind_entry_inds = entries; mind_entry_polymorphic = poly; mind_entry_private = if prv then Some false else None; - mind_entry_universes = Evd.universe_context evd }, - impls + mind_entry_universes = uctx }, + pl, impls (* Very syntactical equality *) let eq_local_binders bl1 bl2 = @@ -575,8 +643,8 @@ let extract_params indl = params let extract_inductive indl = - List.map (fun ((_,indname),_,ar,lc) -> { - ind_name = indname; + List.map (fun (((_,indname),pl),_,ar,lc) -> { + ind_name = indname; ind_univs = pl; ind_arity = Option.cata (fun x -> x) (CSort (Loc.ghost,GType [])) ar; ind_lc = List.map (fun (_,((_,id),t)) -> (id,t)) lc }) indl @@ -603,14 +671,13 @@ let is_recursive mie = List.exists (fun t -> is_recursive_constructor (nparams+1) t) ind.mind_entry_lc | _ -> false -let declare_mutual_inductive_with_eliminations mie impls = +let declare_mutual_inductive_with_eliminations mie pl impls = (* spiwack: raises an error if the structure is supposed to be non-recursive, but isn't *) begin match mie.mind_entry_finite with | BiFinite when is_recursive mie -> if Option.has_some mie.mind_entry_record then - error ("Records declared with the keywords Record or Structure cannot be recursive." ^ - "You can, however, define recursive records using the Inductive or CoInductive command.") + error "Records declared with the keywords Record or Structure cannot be recursive. You can, however, define recursive records using the Inductive or CoInductive command." else error ("Types declared with the keyword Variant cannot be recursive. Recursive types are defined with the Inductive and CoInductive command.") | _ -> () @@ -619,12 +686,15 @@ let declare_mutual_inductive_with_eliminations mie impls = let (_, kn), prim = declare_mind mie in let mind = Global.mind_of_delta_kn kn in List.iteri (fun i (indimpls, constrimpls) -> - let ind = (mind,i) in - maybe_declare_manual_implicits false (IndRef ind) indimpls; - List.iteri - (fun j impls -> - maybe_declare_manual_implicits false (ConstructRef (ind, succ j)) impls) - constrimpls) + let ind = (mind,i) in + let gr = IndRef ind in + maybe_declare_manual_implicits false gr indimpls; + Universes.register_universe_binders gr pl; + List.iteri + (fun j impls -> + maybe_declare_manual_implicits false + (ConstructRef (ind, succ j)) impls) + constrimpls) impls; let warn_prim = match mie.mind_entry_record with Some (Some _) -> not prim | _ -> false in if_verbose msg_info (minductive_message warn_prim names); @@ -639,14 +709,14 @@ type one_inductive_impls = let do_mutual_inductive indl poly prv finite = let indl,coes,ntns = extract_mutual_inductive_declaration_components indl in (* Interpret the types *) - let mie,impls = interp_mutual_inductive indl ntns poly prv finite in + let mie,pl,impls = interp_mutual_inductive indl ntns poly prv finite in (* Declare the mutual inductive block with its associated schemes *) - ignore (declare_mutual_inductive_with_eliminations mie impls); + ignore (declare_mutual_inductive_with_eliminations mie pl impls); (* Declare the possible notations of inductive types *) List.iter Metasyntax.add_notation_interpretation ntns; (* Declare the coercions *) List.iter (fun qid -> Class.try_add_new_coercion (locate qid) false poly) coes - + (* 3c| Fixpoints and co-fixpoints *) (* An (unoptimized) function that maps preorders to partial orders... @@ -697,19 +767,19 @@ let rec partial_order cmp = function let non_full_mutual_message x xge y yge isfix rest = let reason = if Id.List.mem x yge then - Id.to_string y^" depends on "^Id.to_string x^" but not conversely" + pr_id y ++ str " depends on " ++ pr_id x ++ str " but not conversely" else if Id.List.mem y xge then - Id.to_string x^" depends on "^Id.to_string y^" but not conversely" + pr_id x ++ str " depends on " ++ pr_id y ++ str " but not conversely" else - Id.to_string y^" and "^Id.to_string x^" are not mutually dependent" in - let e = if List.is_empty rest then reason else "e.g.: "^reason in + pr_id y ++ str " and " ++ pr_id x ++ str " are not mutually dependent" in + let e = if List.is_empty rest then reason else str "e.g., " ++ reason in let k = if isfix then "fixpoint" else "cofixpoint" in let w = if isfix - then strbrk "Well-foundedness check may fail unexpectedly." ++ fnl() + then str "Well-foundedness check may fail unexpectedly." ++ fnl() else mt () in - strbrk ("Not a fully mutually defined "^k) ++ fnl () ++ - strbrk ("("^e^").") ++ fnl () ++ w + str "Not a fully mutually defined " ++ str k ++ fnl () ++ + str "(" ++ e ++ str ")." ++ fnl () ++ w let check_mutuality env isfix fixl = let names = List.map fst fixl in @@ -725,6 +795,7 @@ let check_mutuality env isfix fixl = type structured_fixpoint_expr = { fix_name : Id.t; + fix_univs : lident list option; fix_annot : Id.t Loc.located option; fix_binders : local_binder list; fix_body : constr_expr option; @@ -734,7 +805,7 @@ type structured_fixpoint_expr = { let interp_fix_context env evdref isfix fix = let before, after = if isfix then split_at_annot fix.fix_binders fix.fix_annot else [], fix.fix_binders in let impl_env, ((env', ctx), imps) = interp_context_evars env evdref before in - let impl_env', ((env'', ctx'), imps') = interp_context_evars ~impl_env env' evdref after in + let impl_env', ((env'', ctx'), imps') = interp_context_evars ~impl_env ~shift:(List.length before) env' evdref after in let annot = Option.map (fun _ -> List.length (assums_of_rel_context ctx)) fix.fix_annot in ((env'', ctx' @ ctx), (impl_env',imps @ imps'), annot) @@ -749,11 +820,12 @@ let interp_fix_body env_rec evdref impls (_,ctx) fix ccl = let build_fix_type (_,ctx) ccl = it_mkProd_or_LetIn ccl ctx -let declare_fix ?(opaque = false) (_,poly,_ as kind) ctx f ((def,_),eff) t imps = +let declare_fix ?(opaque = false) (_,poly,_ as kind) pl ctx f ((def,_),eff) t imps = let ce = definition_entry ~opaque ~types:t ~poly ~univs:ctx ~eff def in - declare_definition f kind ce imps (Lemmas.mk_hook (fun _ r -> r)) + declare_definition f kind ce pl imps (Lemmas.mk_hook (fun _ r -> r)) -let _ = Obligations.declare_fix_ref := declare_fix +let _ = Obligations.declare_fix_ref := + (fun ?opaque k ctx f d t imps -> declare_fix ?opaque k [] ctx f d t imps) let prepare_recursive_declaration fixnames fixtypes fixdefs = let defs = List.map (subst_vars (List.rev fixnames)) fixdefs in @@ -848,7 +920,7 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = let binders_env = push_rel_context binders_rel env in let rel, _ = interp_constr_evars_impls env evdref r in let () = check_evars_are_solved env !evdref (Evd.empty,!evdref) in - let relty = Typing.type_of env !evdref rel in + let relty = Typing.unsafe_type_of env !evdref rel in let relargty = let error () = user_err_loc (constr_loc r, @@ -941,7 +1013,7 @@ let build_wellfounded (recname,n,bl,arityc,body) r measure notation = let hook l gr = let body = it_mkLambda_or_LetIn (mkApp (Universes.constr_of_global gr, [|make|])) binders_rel in let ty = it_mkProd_or_LetIn top_arity binders_rel in - let univs = Evd.universe_context !evdref in + let pl, univs = Evd.universe_context !evdref in (*FIXME poly? *) let ce = definition_entry ~types:ty ~univs (Evarutil.nf_evar !evdref body) in (** FIXME: include locality *) @@ -975,7 +1047,17 @@ let interp_recursive isfix fixl notations = let fixnames = List.map (fun fix -> fix.fix_name) fixl in (* Interp arities allowing for unresolved types *) - let evdref = ref (Evd.from_env env) in + let all_universes = + List.fold_right (fun sfe acc -> + match sfe.fix_univs , acc with + | None , acc -> acc + | x , None -> x + | Some ls , Some us -> + if not (CList.for_all2eq (fun x y -> Id.equal (snd x) (snd y)) ls us) then + error "(co)-recursive definitions should all have the same universe binders"; + Some (ls @ us)) fixl None in + let ctx = Evd.make_evar_universe_context env all_universes in + let evdref = ref (Evd.from_ctx ctx) in let fixctxs, fiximppairs, fixannots = List.split3 (List.map (interp_fix_context env evdref isfix) fixl) in let fixctximpenvs, fixctximps = List.split fiximppairs in @@ -989,7 +1071,7 @@ let interp_recursive isfix fixl notations = List.fold_left2 (fun env' id t -> if Flags.is_program_mode () then - let sort = Evarutil.evd_comb1 (Typing.e_type_of ~refresh:true env) evdref t in + let sort = Evarutil.evd_comb1 (Typing.type_of ~refresh:true env) evdref t in let fixprot = try let app = mkApp (delayed_force fix_proto, [|sort; t|]) in @@ -1022,7 +1104,7 @@ let interp_recursive isfix fixl notations = let fixctxnames = List.map (fun (_,ctx) -> List.map pi1 ctx) fixctxs in (* Build the fix declaration block *) - (env,rec_sign,evd), (fixnames,fixdefs,fixtypes), List.combine3 fixctxnames fiximps fixannots + (env,rec_sign,all_universes,evd), (fixnames,fixdefs,fixtypes), List.combine3 fixctxnames fiximps fixannots let check_recursive isfix env evd (fixnames,fixdefs,_) = check_evars_are_solved env evd (Evd.empty,evd); @@ -1032,16 +1114,16 @@ let check_recursive isfix env evd (fixnames,fixdefs,_) = end let interp_fixpoint l ntns = - let (env,_,evd),fix,info = interp_recursive true l ntns in + let (env,_,pl,evd),fix,info = interp_recursive true l ntns in check_recursive true env evd fix; - (fix,Evd.evar_universe_context evd,info) + (fix,pl,Evd.evar_universe_context evd,info) let interp_cofixpoint l ntns = - let (env,_,evd),fix,info = interp_recursive false l ntns in + let (env,_,pl,evd),fix,info = interp_recursive false l ntns in check_recursive false env evd fix; - fix,Evd.evar_universe_context evd,info + (fix,pl,Evd.evar_universe_context evd,info) -let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),ctx,fiximps) indexes ntns = +let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) indexes ntns = if List.exists Option.is_empty fixdefs then (* Some bodies to define by proof *) let thms = @@ -1052,7 +1134,7 @@ let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),ctx,fiximps) indexe let init_tac = Option.map (List.map Proofview.V82.tactic) init_tac in - let evd = Evd.from_env ~ctx Environ.empty_env in + let evd = Evd.from_ctx ctx in Lemmas.start_proof_with_initialization (Global,poly,DefinitionBody Fixpoint) evd (Some(false,indexes,init_tac)) thms None (Lemmas.mk_hook (fun _ _ -> ())) else begin @@ -1065,11 +1147,11 @@ let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),ctx,fiximps) indexe let vars = Universes.universes_of_constr (mkFix ((indexes,0),fixdecls)) in let fixdecls = List.map_i (fun i _ -> mkFix ((indexes,i),fixdecls)) 0 fixnames in - let ctx = Evd.evar_universe_context_set ctx in - let ctx = Universes.restrict_universe_context ctx vars in - let fixdecls = List.map Term_typing.mk_pure_proof fixdecls in - let ctx = Univ.ContextSet.to_context ctx in - ignore (List.map4 (declare_fix (local, poly, Fixpoint) ctx) + let evd = Evd.from_ctx ctx in + let evd = Evd.restrict_universe_context evd vars in + let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in + let pl, ctx = Evd.universe_context ?names:pl evd in + ignore (List.map4 (declare_fix (local, poly, Fixpoint) pl ctx) fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) fixpoint_message (Some indexes) fixnames; @@ -1077,7 +1159,7 @@ let declare_fixpoint local poly ((fixnames,fixdefs,fixtypes),ctx,fiximps) indexe (* Declare notations *) List.iter Metasyntax.add_notation_interpretation ntns -let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),ctx,fiximps) ntns = +let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),pl,ctx,fiximps) ntns = if List.exists Option.is_empty fixdefs then (* Some bodies to define by proof *) let thms = @@ -1088,19 +1170,21 @@ let declare_cofixpoint local poly ((fixnames,fixdefs,fixtypes),ctx,fiximps) ntns let init_tac = Option.map (List.map Proofview.V82.tactic) init_tac in - let evd = Evd.from_env ~ctx Environ.empty_env in - Lemmas.start_proof_with_initialization (Global,poly, DefinitionBody CoFixpoint) + let evd = Evd.from_ctx ctx in + Lemmas.start_proof_with_initialization (Global,poly, DefinitionBody CoFixpoint) evd (Some(true,[],init_tac)) thms None (Lemmas.mk_hook (fun _ _ -> ())) else begin (* We shortcut the proof process *) let fixdefs = List.map Option.get fixdefs in let fixdecls = prepare_recursive_declaration fixnames fixtypes fixdefs in let fixdecls = List.map_i (fun i _ -> mkCoFix (i,fixdecls)) 0 fixnames in - let fixdecls = List.map Term_typing.mk_pure_proof fixdecls in + let vars = Universes.universes_of_constr (List.hd fixdecls) in + let fixdecls = List.map Safe_typing.mk_pure_proof fixdecls in let fiximps = List.map (fun (len,imps,idx) -> imps) fiximps in - let ctx = Evd.evar_universe_context_set ctx in - let ctx = Univ.ContextSet.to_context ctx in - ignore (List.map4 (declare_fix (local, poly, CoFixpoint) ctx) + let evd = Evd.from_ctx ctx in + let evd = Evd.restrict_universe_context evd vars in + let pl, ctx = Evd.universe_context ?names:pl evd in + ignore (List.map4 (declare_fix (local, poly, CoFixpoint) pl ctx) fixnames fixdecls fixtypes fiximps); (* Declare the recursive definitions *) cofixpoint_message fixnames @@ -1116,15 +1200,17 @@ let extract_decreasing_argument limit = function let extract_fixpoint_components limit l = let fixl, ntnl = List.split l in - let fixl = List.map (fun ((_,id),ann,bl,typ,def) -> + let fixl = List.map (fun (((_,id),pl),ann,bl,typ,def) -> let ann = extract_decreasing_argument limit ann in - {fix_name = id; fix_annot = ann; fix_binders = bl; fix_body = def; fix_type = typ}) fixl in + {fix_name = id; fix_annot = ann; fix_univs = pl; + fix_binders = bl; fix_body = def; fix_type = typ}) fixl in fixl, List.flatten ntnl let extract_cofixpoint_components l = let fixl, ntnl = List.split l in - List.map (fun ((_,id),bl,typ,def) -> - {fix_name = id; fix_annot = None; fix_binders = bl; fix_body = def; fix_type = typ}) fixl, + List.map (fun (((_,id),pl),bl,typ,def) -> + {fix_name = id; fix_annot = None; fix_univs = pl; + fix_binders = bl; fix_body = def; fix_type = typ}) fixl, List.flatten ntnl let out_def = function @@ -1133,7 +1219,7 @@ let out_def = function let do_program_recursive local p fixkind fixl ntns = let isfix = fixkind != Obligations.IsCoFixpoint in - let (env, rec_sign, evd), fix, info = + let (env, rec_sign, pl, evd), fix, info = interp_recursive isfix fixl ntns in (* Program-specific code *) @@ -1177,7 +1263,7 @@ let do_program_recursive local p fixkind fixl ntns = let do_program_fixpoint local poly l = let g = List.map (fun ((_,wf,_,_,_),_) -> wf) l in match g, l with - | [(n, CWfRec r)], [(((_,id),_,bl,typ,def),ntn)] -> + | [(n, CWfRec r)], [((((_,id),_),_,bl,typ,def),ntn)] -> let recarg = match n with | Some n -> mkIdentC (snd n) @@ -1186,7 +1272,7 @@ let do_program_fixpoint local poly l = (str "Recursive argument required for well-founded fixpoints") in build_wellfounded (id, n, bl, typ, out_def def) r recarg ntn - | [(n, CMeasureRec (m, r))], [(((_,id),_,bl,typ,def),ntn)] -> + | [(n, CMeasureRec (m, r))], [((((_,id),_),_,bl,typ,def),ntn)] -> build_wellfounded (id, n, bl, typ, out_def def) (Option.default (CRef (lt_ref,None)) r) m ntn @@ -1203,9 +1289,9 @@ let do_fixpoint local poly l = if Flags.is_program_mode () then do_program_fixpoint local poly l else let fixl, ntns = extract_fixpoint_components true l in - let fix = interp_fixpoint fixl ntns in + let (_, _, _, info as fix) = interp_fixpoint fixl ntns in let possible_indexes = - List.map compute_possible_guardness_evidences (pi3 fix) in + List.map compute_possible_guardness_evidences info in declare_fixpoint local poly fix possible_indexes ntns let do_cofixpoint local poly l = diff --git a/toplevel/command.mli b/toplevel/command.mli index 3a38e52c..8e2d9c6f 100644 --- a/toplevel/command.mli +++ b/toplevel/command.mli @@ -20,25 +20,27 @@ open Pfedit (** This file is about the interpretation of raw commands into typed ones and top-level declaration of the main Gallina objects *) -val do_universe : Id.t Loc.located list -> unit -val do_constraint : (Id.t Loc.located * Univ.constraint_type * Id.t Loc.located) list -> unit +val do_universe : polymorphic -> Id.t Loc.located list -> unit +val do_constraint : polymorphic -> + (Id.t Loc.located * Univ.constraint_type * Id.t Loc.located) list -> unit (** {6 Hooks for Pcoq} *) -val set_declare_definition_hook : (definition_entry -> unit) -> unit -val get_declare_definition_hook : unit -> (definition_entry -> unit) +val set_declare_definition_hook : (Safe_typing.private_constants definition_entry -> unit) -> unit +val get_declare_definition_hook : unit -> (Safe_typing.private_constants definition_entry -> unit) (** {6 Definitions/Let} *) val interp_definition : - local_binder list -> polymorphic -> red_expr option -> constr_expr -> - constr_expr option -> definition_entry * Evd.evar_map * Impargs.manual_implicits + lident list option -> local_binder list -> polymorphic -> red_expr option -> constr_expr -> + constr_expr option -> Safe_typing.private_constants definition_entry * Evd.evar_map * + Universes.universe_binders * Impargs.manual_implicits val declare_definition : Id.t -> definition_kind -> - definition_entry -> Impargs.manual_implicits -> + Safe_typing.private_constants definition_entry -> Universes.universe_binders -> Impargs.manual_implicits -> Globnames.global_reference Lemmas.declaration_hook -> Globnames.global_reference -val do_definition : Id.t -> definition_kind -> +val do_definition : Id.t -> definition_kind -> lident list option -> local_binder list -> red_expr option -> constr_expr -> constr_expr option -> unit Lemmas.declaration_hook -> unit @@ -52,12 +54,12 @@ val do_definition : Id.t -> definition_kind -> nor in a module type and meant to be instantiated. *) val declare_assumption : coercion_flag -> assumption_kind -> types Univ.in_universe_context_set -> - Impargs.manual_implicits -> + Universes.universe_binders -> Impargs.manual_implicits -> bool (** implicit *) -> Vernacexpr.inline -> variable Loc.located -> global_reference * Univ.Instance.t * bool val do_assumptions : locality * polymorphic * assumption_object_kind -> - Vernacexpr.inline -> simple_binder with_coercion list -> bool + Vernacexpr.inline -> (plident list * constr_expr) with_coercion list -> bool (* val declare_assumptions : variable Loc.located list -> *) (* coercion_flag -> assumption_kind -> types Univ.in_universe_context_set -> *) @@ -70,6 +72,7 @@ val do_assumptions : locality * polymorphic * assumption_object_kind -> type structured_one_inductive_expr = { ind_name : Id.t; + ind_univs : lident list option; ind_arity : constr_expr; ind_lc : (Id.t * constr_expr) list } @@ -90,13 +93,13 @@ type one_inductive_impls = val interp_mutual_inductive : structured_inductive_expr -> decl_notation list -> polymorphic -> private_flag -> Decl_kinds.recursivity_kind -> - mutual_inductive_entry * one_inductive_impls list + mutual_inductive_entry * Universes.universe_binders * one_inductive_impls list (** Registering a mutual inductive definition together with its associated schemes *) val declare_mutual_inductive_with_eliminations : - mutual_inductive_entry -> one_inductive_impls list -> + mutual_inductive_entry -> Universes.universe_binders -> one_inductive_impls list -> mutual_inductive (** Entry points for the vernacular commands Inductive and CoInductive *) @@ -109,6 +112,7 @@ val do_mutual_inductive : type structured_fixpoint_expr = { fix_name : Id.t; + fix_univs : lident list option; fix_annot : Id.t Loc.located option; fix_binders : local_binder list; fix_body : constr_expr option; @@ -133,24 +137,24 @@ type recursive_preentry = val interp_fixpoint : structured_fixpoint_expr list -> decl_notation list -> - recursive_preentry * Evd.evar_universe_context * + recursive_preentry * lident list option * Evd.evar_universe_context * (Name.t list * Impargs.manual_implicits * int option) list val interp_cofixpoint : structured_fixpoint_expr list -> decl_notation list -> - recursive_preentry * Evd.evar_universe_context * + recursive_preentry * lident list option * Evd.evar_universe_context * (Name.t list * Impargs.manual_implicits * int option) list (** Registering fixpoints and cofixpoints in the environment *) val declare_fixpoint : locality -> polymorphic -> - recursive_preentry * Evd.evar_universe_context * + recursive_preentry * lident list option * Evd.evar_universe_context * (Name.t list * Impargs.manual_implicits * int option) list -> lemma_possible_guards -> decl_notation list -> unit val declare_cofixpoint : locality -> polymorphic -> - recursive_preentry * Evd.evar_universe_context * + recursive_preentry * lident list option * Evd.evar_universe_context * (Name.t list * Impargs.manual_implicits * int option) list -> decl_notation list -> unit @@ -166,5 +170,5 @@ val do_cofixpoint : val check_mutuality : Environ.env -> bool -> (Id.t * types) list -> unit -val declare_fix : ?opaque:bool -> definition_kind -> Univ.universe_context -> Id.t -> - Entries.proof_output -> types -> Impargs.manual_implicits -> global_reference +val declare_fix : ?opaque:bool -> definition_kind -> Universes.universe_binders -> Univ.universe_context -> Id.t -> + Safe_typing.private_constants Entries.proof_output -> types -> Impargs.manual_implicits -> global_reference diff --git a/toplevel/coqinit.ml b/toplevel/coqinit.ml index f1d8a492..eca344b2 100644 --- a/toplevel/coqinit.ml +++ b/toplevel/coqinit.ml @@ -130,10 +130,11 @@ let init_ocaml_path () = [ "grammar" ]; [ "ide" ] ] let get_compat_version = function + | "8.5" -> Flags.Current | "8.4" -> Flags.V8_4 | "8.3" -> Flags.V8_3 | "8.2" -> Flags.V8_2 | ("8.1" | "8.0") as s -> - msg_warning (strbrk ("Compatibility with version "^s^" not supported.")); + msg_warning (str "Compatibility with version " ++ str s ++ str " not supported."); Flags.V8_2 - | s -> Errors.error ("Unknown compatibility version \""^s^"\".") + | s -> Errors.errorlabstrm "get_compat_version" (str "Unknown compatibility version \"" ++ str s ++ str "\".") diff --git a/toplevel/coqloop.ml b/toplevel/coqloop.ml index 52fa9e01..caaf8054 100644 --- a/toplevel/coqloop.ml +++ b/toplevel/coqloop.ml @@ -176,7 +176,7 @@ let print_location_in_file {outer=s;inner=fname} loc = try let (line, bol) = line_of_pos 1 0 0 in hov 0 (* No line break so as to follow emacs error message format *) - (errstrm ++ str"File " ++ str ("\""^fname^"\"") ++ + (errstrm ++ str"File " ++ str "\"" ++ str fname ++ str "\"" ++ str", line " ++ int line ++ str", characters " ++ Cerrors.print_loc (Loc.make_loc (bp-bol,ep-bol))) ++ str":" ++ fnl () diff --git a/toplevel/coqtop.ml b/toplevel/coqtop.ml index e9e86953..72966a4a 100644 --- a/toplevel/coqtop.ml +++ b/toplevel/coqtop.ml @@ -20,12 +20,6 @@ let () = at_exit flush_all let ( / ) = Filename.concat -let fatal_error info anomaly = - let msg = info ++ fnl () in - pp_with ~pp_tag:Ppstyle.pp_tag !Pp_control.err_ft msg; - flush_all (); - exit (if anomaly then 129 else 1) - let get_version_date () = try let ch = open_in (Envars.coqlib () / "revision") in @@ -38,7 +32,7 @@ let get_version_date () = let print_header () = let (ver,rev) = get_version_date () in - ppnl (str ("Welcome to Coq "^ver^" ("^rev^")")); + ppnl (str "Welcome to Coq " ++ str ver ++ str " (" ++ str rev ++ str ")"); pp_flush () let warning s = msg_warning (strbrk s) @@ -47,8 +41,8 @@ let toploop = ref None let color : [`ON | `AUTO | `OFF] ref = ref `AUTO let set_color = function -| "on" -> color := `ON -| "off" -> color := `OFF +| "yes" | "on" -> color := `ON +| "no" | "off" -> color := `OFF | "auto" -> color := `AUTO | _ -> prerr_endline ("Error: on/off/auto expected after option color"); exit 1 @@ -58,7 +52,10 @@ let init_color () = | `ON -> true | `AUTO -> Terminal.has_style Unix.stdout && - Terminal.has_style Unix.stderr + Terminal.has_style Unix.stderr && + (* emacs compilation buffer does not support colors by default, + its TERM variable is set to "dumb". *) + Unix.getenv "TERM" <> "dumb" in if has_color then begin let colors = try Some (Sys.getenv "COQ_COLORS") with Not_found -> None in @@ -97,23 +94,43 @@ let output_context = ref false let memory_stat = ref false let print_memory_stat () = - if !memory_stat then + begin (* -m|--memory from the command-line *) + if !memory_stat then ppnl - (str "total heap size = " ++ int (CObj.heap_size_kb ()) ++ str " kbytes") + (str "total heap size = " ++ int (CObj.heap_size_kb ()) ++ str " kbytes"); + end; + begin + (* operf-macro interface: + https://github.com/OCamlPro/operf-macro *) + try + let fn = Sys.getenv "OCAML_GC_STATS" in + let oc = open_out fn in + Gc.print_stat oc; + close_out oc + with _ -> () + end let _ = at_exit print_memory_stat -let engagement = ref None -let set_engagement c = engagement := Some c +let impredicative_set = ref Declarations.PredicativeSet +let set_impredicative_set c = impredicative_set := Declarations.ImpredicativeSet +let type_in_type = ref Declarations.StratifiedType +let set_type_in_type () = type_in_type := Declarations.TypeInType let engage () = - match !engagement with Some c -> Global.set_engagement c | None -> () - -let type_in_type = ref false -let set_type_in_type () = type_in_type := true -let set_hierarchy () = if !type_in_type then Global.set_type_in_type () + Global.set_engagement (!impredicative_set,!type_in_type) let set_batch_mode () = batch_mode := true +let user_warning = ref false +(** User explicitly set warning *) + +let set_warning p = + let () = user_warning := true in + match p with + | "all" -> make_warn true + | "none" -> make_warn false + | _ -> prerr_endline ("Error: all/none expected after option w"); exit 1 + let toplevel_default_name = DirPath.make [Id.of_string "Top"] let toplevel_name = ref (Some toplevel_default_name) let set_toplevel_name dir = @@ -127,13 +144,19 @@ let inputstate = ref "" let set_inputstate s = let () = msg_warning (str "The inputstate option is deprecated and discouraged.") in inputstate:=s -let inputstate () = if not (String.is_empty !inputstate) then intern_state !inputstate +let inputstate () = + if not (String.is_empty !inputstate) then + let fname = Loadpath.locate_file (CUnix.make_suffix !inputstate ".coq") in + intern_state fname let outputstate = ref "" let set_outputstate s = let () = msg_warning (str "The outputstate option is deprecated and discouraged.") in outputstate:=s -let outputstate () = if not (String.is_empty !outputstate) then extern_state !outputstate +let outputstate () = + if not (String.is_empty !outputstate) then + let fname = CUnix.make_suffix !outputstate ".coq" in + extern_state fname let set_include d p implicit = let p = dirpath_of_string p in @@ -145,6 +168,7 @@ let add_load_vernacular verb s = let load_vernacular () = List.iter (fun (s,b) -> + let s = Loadpath.locate_file s in if Flags.do_beautify () then with_option beautify_file (Vernac.load_vernac b) s else @@ -154,8 +178,8 @@ let load_vernacular () = let load_vernacular_obj = ref ([] : string list) let add_vernac_obj s = load_vernacular_obj := s :: !load_vernacular_obj let load_vernac_obj () = - List.iter (fun f -> Library.require_library_from_file None f None) - (List.rev !load_vernacular_obj) + let map dir = Qualid (Loc.ghost, qualid_of_string dir) in + Vernacentries.vernac_require None None (List.rev_map map !load_vernacular_obj) let require_prelude () = let vo = Envars.coqlib () / "theories/Init/Prelude.vo" in @@ -168,9 +192,9 @@ let require_prelude () = let require_list = ref ([] : string list) let add_require s = require_list := s :: !require_list let require () = - if !load_init then silently require_prelude (); - List.iter (fun s -> Library.require_library_from_file None s (Some false)) - (List.rev !require_list) + let () = if !load_init then silently require_prelude () in + let map dir = Qualid (Loc.ghost, qualid_of_string dir) in + Vernacentries.vernac_require None (Some false) (List.rev_map map !require_list) let compile_list = ref ([] : (bool * string) list) @@ -209,15 +233,6 @@ let compile_files () = compile_file vf) (List.rev l) -(*s options for the virtual machine *) - -let boxed_val = ref false -let use_vm = ref false - -let set_vm_opt () = - Vm.set_transp_values (not !boxed_val); - Vconv.set_use_vm !use_vm - (** Options for proof general *) let set_emacs () = @@ -276,7 +291,16 @@ let print_style_tags () = in print_string opt in - List.iter iter tags; + let make (t, st) = match st with + | None -> None + | Some st -> + let tags = List.map string_of_int (Terminal.repr st) in + let t = String.concat "." (Ppstyle.repr t) in + Some (t ^ "=" ^ String.concat ";" tags) + in + let repr = List.map_filter make tags in + let () = Printf.printf "COQ_COLORS=\"%s\"\n" (String.concat ":" repr) in + let () = List.iter iter tags in flush_all () let error_missing_arg s = @@ -300,8 +324,8 @@ let get_priority opt s = prerr_endline ("Error: low/high expected after "^opt); exit 1 let get_async_proofs_mode opt = function - | "off" -> Flags.APoff - | "on" -> Flags.APon + | "no" | "off" -> Flags.APoff + | "yes" | "on" -> Flags.APon | "lazy" -> Flags.APonLazy | _ -> prerr_endline ("Error: on/off/lazy expected after "^opt); exit 1 @@ -315,8 +339,8 @@ let set_worker_id opt s = Flags.async_proofs_worker_id := s let get_bool opt = function - | "yes" -> true - | "no" -> false + | "yes" | "on" -> true + | "no" | "off" -> false | _ -> prerr_endline ("Error: yes/no expected after option "^opt); exit 1 let get_int opt n = @@ -326,7 +350,8 @@ let get_int opt n = let get_host_port opt s = match CString.split ':' s with - | [host; port] -> Some (Spawned.Socket(host, int_of_string port)) + | [host; portr; portw] -> + Some (Spawned.Socket(host, int_of_string portr, int_of_string portw)) | ["stdfds"] -> Some Spawned.AnonPipe | _ -> prerr_endline ("Error: host:port or stdfds expected after option "^opt); @@ -472,6 +497,7 @@ let parse_args arglist = |"-control-channel" -> Spawned.control_channel := get_host_port opt (next()) |"-vio2vo" -> add_compile false (next ()); Flags.compilation_mode := Vio2Vo |"-toploop" -> toploop := Some (next ()) + |"-w" -> set_warning (next ()) (* Options with zero arg *) |"-async-queries-always-delegate" @@ -481,6 +507,7 @@ let parse_args arglist = |"-async-proofs-never-reopen-branch" -> Flags.async_proofs_never_reopen_branch := true; |"-batch" -> set_batch_mode () + |"-test-mode" -> test_mode := true |"-beautify" -> make_beautify true |"-boot" -> boot := true; no_load_rc () |"-bt" -> Backtrace.record_backtrace true @@ -491,18 +518,21 @@ let parse_args arglist = |"-filteropts" -> filter_opts := true |"-h"|"-H"|"-?"|"-help"|"--help" -> usage () |"-ideslave" -> toploop := Some "coqidetop"; Flags.ide_slave := true - |"-impredicative-set" -> set_engagement Declarations.ImpredicativeSet + |"-impredicative-set" -> set_impredicative_set () |"-indices-matter" -> Indtypes.enforce_indices_matter () |"-just-parsing" -> Vernac.just_parsing := true |"-m"|"--memory" -> memory_stat := true |"-noinit"|"-nois" -> load_init := false |"-no-compat-notations" -> no_compat_ntn := true |"-no-glob"|"-noglob" -> Dumpglob.noglob (); glob_opt := true - |"-no-native-compiler" -> no_native_compiler := true + |"-native-compiler" -> + if Coq_config.no_native_compiler then + warning "Native compilation was disabled at configure time." + else native_compiler := true |"-notop" -> unset_toplevel_name () |"-output-context" -> output_context := true |"-q" -> no_load_rc () - |"-quiet"|"-silent" -> Flags.make_silent true + |"-quiet"|"-silent" -> Flags.make_silent true; Flags.make_warn false |"-quick" -> Flags.compilation_mode := BuildVio |"-list-tags" -> print_tags := true |"-time" -> Flags.time := true @@ -510,7 +540,6 @@ let parse_args arglist = |"-unicode" -> add_require "Utf8_core" |"-v"|"--version" -> Usage.version (exitcode ()) |"-verbose-compat-notations" -> verb_compat_ntn := true - |"-vm" -> use_vm := true |"-where" -> print_where := true (* Deprecated options *) @@ -570,9 +599,7 @@ let init arglist = if_verbose print_header (); inputstate (); Mltop.init_known_plugins (); - set_vm_opt (); engage (); - set_hierarchy (); (* Be careful to set these variables after the inputstate *) Syntax_def.set_verbose_compat_notations !verb_compat_ntn; Syntax_def.set_compat_notations (not !no_compat_ntn); @@ -597,7 +624,8 @@ let init arglist = if !batch_mode then mt () else str "Error during initialization:" ++ fnl () in - fatal_error (msg ++ Coqloop.print_toplevel_error any) (Errors.is_anomaly (fst any)) + let is_anomaly e = Errors.is_anomaly e || not (Errors.handled e) in + fatal_error (msg ++ Coqloop.print_toplevel_error any) (is_anomaly (fst any)) end; if !batch_mode then begin flush_all(); @@ -613,6 +641,7 @@ let start () = let () = init_toplevel (List.tl (Array.to_list Sys.argv)) in (* In batch mode, Coqtop has already exited at this point. In interactive one, dump glob is nothing but garbage ... *) + if not !user_warning then make_warn true; !toploop_run (); exit 1 diff --git a/toplevel/coqtop.mli b/toplevel/coqtop.mli index 356ccdcc..67044745 100644 --- a/toplevel/coqtop.mli +++ b/toplevel/coqtop.mli @@ -8,7 +8,7 @@ (** The Coq main module. The following function [start] will parse the command line, print the banner, initialize the load path, load the input - state, load the files given on the command line, load the ressource file, + state, load the files given on the command line, load the resource file, produce the output state if any, and finally will launch [Coqloop.loop]. *) val init_toplevel : string list -> unit diff --git a/toplevel/discharge.ml b/toplevel/discharge.ml index 7d5d61fb..b6da21e5 100644 --- a/toplevel/discharge.ml +++ b/toplevel/discharge.ml @@ -20,8 +20,8 @@ open Cooking (* Discharging mutual inductive *) let detype_param = function - | (Name id,None,p) -> id, Entries.LocalAssum p - | (Name id,Some p,_) -> id, Entries.LocalDef p + | (Name id,None,p) -> id, LocalAssum p + | (Name id,Some p,_) -> id, LocalDef p | (Anonymous,_,_) -> anomaly (Pp.str "Unnamed inductive local variable") (* Replace diff --git a/toplevel/himsg.ml b/toplevel/himsg.ml index 5429e660..8f380830 100644 --- a/toplevel/himsg.ml +++ b/toplevel/himsg.ml @@ -783,7 +783,7 @@ let explain_pretype_error env sigma err = let {uj_val = c; uj_type = actty} = j in let (env, c, actty, expty), e = contract3' env c actty t e in let j = {uj_val = c; uj_type = actty} in - explain_actual_type env sigma j t (Some e) + explain_actual_type env sigma j expty (Some e) | UnifOccurCheck (ev,rhs) -> explain_occur_check env sigma ev rhs | UnsolvableImplicit (evk,exp) -> explain_unsolvable_implicit env sigma evk exp | VarNotFound id -> explain_var_not_found env id @@ -872,11 +872,11 @@ let explain_not_match_error = function quote (Univ.pr_constraints (Evd.pr_evd_level Evd.empty) cst) let explain_signature_mismatch l spec why = - str "Signature components for label " ++ str (Label.to_string l) ++ + str "Signature components for label " ++ pr_label l ++ str " do not match:" ++ spc () ++ explain_not_match_error why ++ str "." let explain_label_already_declared l = - str ("The label "^Label.to_string l^" is already declared.") + str "The label " ++ pr_label l ++ str " is already declared." let explain_application_to_not_path _ = strbrk "A module cannot be applied to another module application or " ++ @@ -924,9 +924,6 @@ let explain_label_missing l s = str "The field " ++ str (Label.to_string l) ++ str " is missing in " ++ str s ++ str "." -let explain_higher_order_include () = - str "You cannot Include a higher-order structure." - let explain_module_error = function | SignatureMismatch (l,spec,err) -> explain_signature_mismatch l spec err | LabelAlreadyDeclared l -> explain_label_already_declared l @@ -943,7 +940,6 @@ let explain_module_error = function | IncorrectWithConstraint l -> explain_incorrect_label_constraint l | GenerativeModuleExpected l -> explain_generative_module_expected l | LabelMissing (l,s) -> explain_label_missing l s - | HigherOrderInclude -> explain_higher_order_include () (* Module internalization errors *) @@ -1086,7 +1082,7 @@ let error_bad_ind_parameters env c n v1 v2 = let pv1 = pr_lconstr_env env Evd.empty v1 in let pv2 = pr_lconstr_env env Evd.empty v2 in str "Last occurrence of " ++ pv2 ++ str " must have " ++ pv1 ++ - str " as " ++ pr_nth n ++ str " argument in " ++ brk(1,1) ++ pc ++ str "." + str " as " ++ pr_nth n ++ str " argument in" ++ brk(1,1) ++ pc ++ str "." let error_same_names_types id = str "The name" ++ spc () ++ pr_id id ++ spc () ++ @@ -1170,18 +1166,18 @@ let explain_bad_constructor env cstr ind = str "is expected." let decline_string n s = - if Int.equal n 0 then "no "^s^"s" - else if Int.equal n 1 then "1 "^s - else (string_of_int n^" "^s^"s") + if Int.equal n 0 then str "no " ++ str s ++ str "s" + else if Int.equal n 1 then str "1 " ++ str s + else (int n ++ str " " ++ str s ++ str "s") let explain_wrong_numarg_constructor env cstr n = str "The constructor " ++ pr_constructor env cstr ++ str " (in type " ++ pr_inductive env (inductive_of_constructor cstr) ++ - str ") expects " ++ str (decline_string n "argument") ++ str "." + str ") expects " ++ decline_string n "argument" ++ str "." let explain_wrong_numarg_inductive env ind n = str "The inductive type " ++ pr_inductive env ind ++ - str " expects " ++ str (decline_string n "argument") ++ str "." + str " expects " ++ decline_string n "argument" ++ str "." let explain_unused_clause env pats = (* Without localisation diff --git a/toplevel/ind_tables.ml b/toplevel/ind_tables.ml index 138e5189..dde801a7 100644 --- a/toplevel/ind_tables.ml +++ b/toplevel/ind_tables.ml @@ -23,15 +23,15 @@ open Util open Declare open Entries open Decl_kinds +open Pp (**********************************************************************) (* Registering schemes in the environment *) - type mutual_scheme_object_function = - mutual_inductive -> constr array Evd.in_evar_universe_context * Declareops.side_effects + internal_flag -> mutual_inductive -> constr array Evd.in_evar_universe_context * Safe_typing.private_constants type individual_scheme_object_function = - inductive -> constr Evd.in_evar_universe_context * Declareops.side_effects + internal_flag -> inductive -> constr Evd.in_evar_universe_context * Safe_typing.private_constants type 'a scheme_kind = string @@ -87,7 +87,8 @@ let declare_scheme_object s aux f = try let _ = Hashtbl.find scheme_object_table key in (* let aux_msg = if aux="" then "" else " (with key "^aux^")" in*) - error ("Scheme object "^key^" already declared.") + errorlabstrm "IndTables.declare_scheme_object" + (str "Scheme object " ++ str key ++ str " already declared.") with Not_found -> Hashtbl.add scheme_object_table key (s,f); key @@ -112,8 +113,8 @@ let is_visible_name id = let compute_name internal id = match internal with - | KernelVerbose | UserVerbose -> id - | KernelSilent -> + | UserAutomaticRequest | UserIndividualRequest -> id + | InternalTacticRequest -> Namegen.next_ident_away_from (add_prefix "internal_" id) is_visible_name let define internal id c p univs = @@ -123,7 +124,9 @@ let define internal id c p univs = let c = Vars.subst_univs_fn_constr (Universes.make_opt_subst (Evd.evar_universe_context_subst ctx)) c in let entry = { - const_entry_body = Future.from_val ((c,Univ.ContextSet.empty), Declareops.no_seff); + const_entry_body = + Future.from_val ((c,Univ.ContextSet.empty), + Safe_typing.empty_private_constants); const_entry_secctx = None; const_entry_type = None; const_entry_polymorphic = p; @@ -134,66 +137,65 @@ let define internal id c p univs = } in let kn = fd id (DefinitionEntry entry, Decl_kinds.IsDefinition Scheme) in let () = match internal with - | KernelSilent -> () + | InternalTacticRequest -> () | _-> definition_message id in kn -let define_individual_scheme_base kind suff f internal idopt (mind,i as ind) = - let (c, ctx), eff = f ind in +let define_individual_scheme_base kind suff f mode idopt (mind,i as ind) = + let (c, ctx), eff = f mode ind in let mib = Global.lookup_mind mind in let id = match idopt with | Some id -> id | None -> add_suffix mib.mind_packets.(i).mind_typename suff in - let const = define internal id c mib.mind_polymorphic ctx in + let const = define mode id c mib.mind_polymorphic ctx in declare_scheme kind [|ind,const|]; - const, Declareops.cons_side_effects - (Safe_typing.sideff_of_scheme kind (Global.safe_env()) [ind,const]) eff + const, Safe_typing.add_private + (Safe_typing.private_con_of_scheme kind (Global.safe_env()) [ind,const]) eff -let define_individual_scheme kind internal names (mind,i as ind) = +let define_individual_scheme kind mode names (mind,i as ind) = match Hashtbl.find scheme_object_table kind with | _,MutualSchemeFunction f -> assert false | s,IndividualSchemeFunction f -> - define_individual_scheme_base kind s f internal names ind + define_individual_scheme_base kind s f mode names ind -let define_mutual_scheme_base kind suff f internal names mind = - let (cl, ctx), eff = f mind in +let define_mutual_scheme_base kind suff f mode names mind = + let (cl, ctx), eff = f mode mind in let mib = Global.lookup_mind mind in let ids = Array.init (Array.length mib.mind_packets) (fun i -> try Int.List.assoc i names with Not_found -> add_suffix mib.mind_packets.(i).mind_typename suff) in - let consts = Array.map2 (fun id cl -> - define internal id cl mib.mind_polymorphic ctx) ids cl in + define mode id cl mib.mind_polymorphic ctx) ids cl in let schemes = Array.mapi (fun i cst -> ((mind,i),cst)) consts in declare_scheme kind schemes; consts, - Declareops.cons_side_effects - (Safe_typing.sideff_of_scheme + Safe_typing.add_private + (Safe_typing.private_con_of_scheme kind (Global.safe_env()) (Array.to_list schemes)) eff -let define_mutual_scheme kind internal names mind = +let define_mutual_scheme kind mode names mind = match Hashtbl.find scheme_object_table kind with | _,IndividualSchemeFunction _ -> assert false | s,MutualSchemeFunction f -> - define_mutual_scheme_base kind s f internal names mind + define_mutual_scheme_base kind s f mode names mind let find_scheme_on_env_too kind ind = let s = String.Map.find kind (Indmap.find ind !scheme_map) in - s, Declareops.cons_side_effects - (Safe_typing.sideff_of_scheme + s, Safe_typing.add_private + (Safe_typing.private_con_of_scheme kind (Global.safe_env()) [ind, s]) - Declareops.no_seff + Safe_typing.empty_private_constants -let find_scheme kind (mind,i as ind) = +let find_scheme ?(mode=InternalTacticRequest) kind (mind,i as ind) = try find_scheme_on_env_too kind ind with Not_found -> match Hashtbl.find scheme_object_table kind with | s,IndividualSchemeFunction f -> - define_individual_scheme_base kind s f KernelSilent None ind + define_individual_scheme_base kind s f mode None ind | s,MutualSchemeFunction f -> - let ca, eff = define_mutual_scheme_base kind s f KernelSilent [] mind in + let ca, eff = define_mutual_scheme_base kind s f mode [] mind in ca.(i), eff let check_scheme kind ind = diff --git a/toplevel/ind_tables.mli b/toplevel/ind_tables.mli index 98eaac09..abd951c3 100644 --- a/toplevel/ind_tables.mli +++ b/toplevel/ind_tables.mli @@ -8,6 +8,7 @@ open Term open Names +open Declare (** This module provides support for registering inductive scheme builders, declaring schemes and generating schemes on demand *) @@ -19,9 +20,9 @@ type individual type 'a scheme_kind type mutual_scheme_object_function = - mutual_inductive -> constr array Evd.in_evar_universe_context * Declareops.side_effects + internal_flag -> mutual_inductive -> constr array Evd.in_evar_universe_context * Safe_typing.private_constants type individual_scheme_object_function = - inductive -> constr Evd.in_evar_universe_context * Declareops.side_effects + internal_flag -> inductive -> constr Evd.in_evar_universe_context * Safe_typing.private_constants (** Main functions to register a scheme builder *) @@ -32,21 +33,17 @@ val declare_individual_scheme_object : string -> ?aux:string -> individual_scheme_object_function -> individual scheme_kind -(* -val declare_scheme : 'a scheme_kind -> (inductive * constant) array -> unit -*) - (** Force generation of a (mutually) scheme with possibly user-level names *) val define_individual_scheme : individual scheme_kind -> - Declare.internal_flag (** internal *) -> - Id.t option -> inductive -> constant * Declareops.side_effects + internal_flag (** internal *) -> + Id.t option -> inductive -> constant * Safe_typing.private_constants -val define_mutual_scheme : mutual scheme_kind -> Declare.internal_flag (** internal *) -> - (int * Id.t) list -> mutual_inductive -> constant array * Declareops.side_effects +val define_mutual_scheme : mutual scheme_kind -> internal_flag (** internal *) -> + (int * Id.t) list -> mutual_inductive -> constant array * Safe_typing.private_constants (** Main function to retrieve a scheme in the cache or to generate it *) -val find_scheme : 'a scheme_kind -> inductive -> constant * Declareops.side_effects +val find_scheme : ?mode:internal_flag -> 'a scheme_kind -> inductive -> constant * Safe_typing.private_constants val check_scheme : 'a scheme_kind -> inductive -> bool diff --git a/toplevel/indschemes.ml b/toplevel/indschemes.ml index fbc45b4a..f16e6e3f 100644 --- a/toplevel/indschemes.ml +++ b/toplevel/indschemes.ml @@ -129,7 +129,7 @@ let define id internal ctx c t = const_entry_secctx = None; const_entry_type = t; const_entry_polymorphic = true; - const_entry_universes = Evd.universe_context ctx; + const_entry_universes = snd (Evd.universe_context ctx); const_entry_opaque = false; const_entry_inline_code = false; const_entry_feedback = None; @@ -146,8 +146,8 @@ let declare_beq_scheme_gen internal names kn = let alarm what internal msg = let debug = false in match internal with - | KernelVerbose - | KernelSilent -> + | UserAutomaticRequest + | InternalTacticRequest -> (if debug then msg_warning (hov 0 msg ++ fnl () ++ what ++ str " not defined.")) @@ -180,10 +180,12 @@ let try_declare_scheme what f internal names kn = (strbrk "Required constant " ++ str s ++ str " undefined.") | AlreadyDeclared msg -> alarm what internal (msg ++ str ".") + | DecidabilityMutualNotSupported -> + alarm what internal + (str "Decidability lemma for mutual inductive types not supported.") | e when Errors.noncritical e -> - alarm what internal - (str "Unknown exception during scheme creation: "++ - str (Printexc.to_string e)) + alarm what internal + (str "Unexpected error during scheme creation: " ++ Errors.print e) let beq_scheme_msg mind = let mib = Global.lookup_mind mind in @@ -193,13 +195,13 @@ let beq_scheme_msg mind = (List.init (Array.length mib.mind_packets) (fun i -> (mind,i))) let declare_beq_scheme_with l kn = - try_declare_scheme (beq_scheme_msg kn) declare_beq_scheme_gen UserVerbose l kn + try_declare_scheme (beq_scheme_msg kn) declare_beq_scheme_gen UserIndividualRequest l kn let try_declare_beq_scheme kn = (* TODO: handle Fix, eventually handle proof-irrelevance; improve decidability by depending on decidability for the parameters rather than on the bl and lb properties *) - try_declare_scheme (beq_scheme_msg kn) declare_beq_scheme_gen KernelVerbose [] kn + try_declare_scheme (beq_scheme_msg kn) declare_beq_scheme_gen UserAutomaticRequest [] kn let declare_beq_scheme = declare_beq_scheme_with [] @@ -213,7 +215,7 @@ let declare_one_case_analysis_scheme ind = induction scheme, the other ones share the same code with the apropriate type *) if Sorts.List.mem InType kelim then - ignore (define_individual_scheme dep KernelVerbose None ind) + ignore (define_individual_scheme dep UserAutomaticRequest None ind) (* Induction/recursion schemes *) @@ -236,7 +238,7 @@ let declare_one_induction_scheme ind = List.map_filter (fun (sort,kind) -> if Sorts.List.mem sort kelim then Some kind else None) (if from_prop then kinds_from_prop else kinds_from_type) in - List.iter (fun kind -> ignore (define_individual_scheme kind KernelVerbose None ind)) + List.iter (fun kind -> ignore (define_individual_scheme kind UserAutomaticRequest None ind)) elims let declare_induction_schemes kn = @@ -259,11 +261,11 @@ let eq_dec_scheme_msg ind = (* TODO: mutual inductive case *) let declare_eq_decidability_scheme_with l kn = try_declare_scheme (eq_dec_scheme_msg (kn,0)) - declare_eq_decidability_gen UserVerbose l kn + declare_eq_decidability_gen UserIndividualRequest l kn let try_declare_eq_decidability kn = try_declare_scheme (eq_dec_scheme_msg (kn,0)) - declare_eq_decidability_gen KernelVerbose [] kn + declare_eq_decidability_gen UserAutomaticRequest [] kn let declare_eq_decidability = declare_eq_decidability_scheme_with [] @@ -272,17 +274,17 @@ let ignore_error f x = let declare_rewriting_schemes ind = if Hipattern.is_inductive_equality ind then begin - ignore (define_individual_scheme rew_r2l_scheme_kind KernelVerbose None ind); - ignore (define_individual_scheme rew_r2l_dep_scheme_kind KernelVerbose None ind); + ignore (define_individual_scheme rew_r2l_scheme_kind UserAutomaticRequest None ind); + ignore (define_individual_scheme rew_r2l_dep_scheme_kind UserAutomaticRequest None ind); ignore (define_individual_scheme rew_r2l_forward_dep_scheme_kind - KernelVerbose None ind); + UserAutomaticRequest None ind); (* These ones expect the equality to be symmetric; the first one also *) (* needs eq *) - ignore_error (define_individual_scheme rew_l2r_scheme_kind KernelVerbose None) ind; + ignore_error (define_individual_scheme rew_l2r_scheme_kind UserAutomaticRequest None) ind; ignore_error - (define_individual_scheme rew_l2r_dep_scheme_kind KernelVerbose None) ind; + (define_individual_scheme rew_l2r_dep_scheme_kind UserAutomaticRequest None) ind; ignore_error - (define_individual_scheme rew_l2r_forward_dep_scheme_kind KernelVerbose None) ind + (define_individual_scheme rew_l2r_forward_dep_scheme_kind UserAutomaticRequest None) ind end let declare_congr_scheme ind = @@ -291,7 +293,7 @@ let declare_congr_scheme ind = try Coqlib.check_required_library Coqlib.logic_module_name; true with e when Errors.noncritical e -> false then - ignore (define_individual_scheme congr_scheme_kind KernelVerbose None ind) + ignore (define_individual_scheme congr_scheme_kind UserAutomaticRequest None ind) else msg_warning (strbrk "Cannot build congruence scheme because eq is not found") end @@ -299,7 +301,7 @@ let declare_congr_scheme ind = let declare_sym_scheme ind = if Hipattern.is_inductive_equality ind then (* Expect the equality to be symmetric *) - ignore_error (define_individual_scheme sym_scheme_kind KernelVerbose None) ind + ignore_error (define_individual_scheme sym_scheme_kind UserAutomaticRequest None) ind (* Scheme command *) @@ -369,8 +371,8 @@ let do_mutual_induction_scheme lnamedepindsort = let declare decl fi lrecref = let decltype = Retyping.get_type_of env0 sigma decl in (* let decltype = refresh_universes decltype in *) - let proof_output = Future.from_val ((decl,Univ.ContextSet.empty),Declareops.no_seff) in - let cst = define fi UserVerbose sigma proof_output (Some decltype) in + let proof_output = Future.from_val ((decl,Univ.ContextSet.empty),Safe_typing.empty_private_constants) in + let cst = define fi UserIndividualRequest sigma proof_output (Some decltype) in ConstRef cst :: lrecref in let _ = List.fold_right2 declare listdecl lrecnames [] in @@ -421,7 +423,7 @@ let fold_left' f = function let build_combined_scheme env schemes = let defs = List.map (fun cst -> (* FIXME *) - let evd, c = Evd.fresh_constant_instance env Evd.empty cst in + let evd, c = Evd.fresh_constant_instance env (Evd.from_env env) cst in (c, Typeops.type_of_constant_in env c)) schemes in (* let nschemes = List.length schemes in *) let find_inductive ty = @@ -467,8 +469,8 @@ let do_combined_scheme name schemes = schemes in let body,typ = build_combined_scheme (Global.env ()) csts in - let proof_output = Future.from_val ((body,Univ.ContextSet.empty),Declareops.no_seff) in - ignore (define (snd name) UserVerbose Evd.empty proof_output (Some typ)); + let proof_output = Future.from_val ((body,Univ.ContextSet.empty),Safe_typing.empty_private_constants) in + ignore (define (snd name) UserIndividualRequest Evd.empty proof_output (Some typ)); fixpoint_message None [snd name] (**********************************************************************) diff --git a/toplevel/locality.ml b/toplevel/locality.ml index f711dad9..1145a20b 100644 --- a/toplevel/locality.ml +++ b/toplevel/locality.ml @@ -6,6 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Pp + (** * Managing locality *) let local_of_bool = function @@ -16,7 +18,8 @@ let check_locality locality_flag = match locality_flag with | Some b -> let s = if b then "Local" else "Global" in - Errors.error ("This command does not support the \""^s^"\" prefix.") + Errors.errorlabstrm "Locality.check_locality" + (str "This command does not support the \"" ++ str s ++ str "\" prefix.") | None -> () (** Extracting the locality flag *) diff --git a/toplevel/metasyntax.ml b/toplevel/metasyntax.ml index 639ec1e6..7616bfff 100644 --- a/toplevel/metasyntax.ml +++ b/toplevel/metasyntax.ml @@ -84,8 +84,14 @@ type tactic_grammar_obj = { tacobj_body : Tacexpr.glob_tactic_expr } +let check_key key = + if Tacenv.check_alias key then + error "Conflicting tactic notations keys. This can happen when including \ + twice the same module." + let cache_tactic_notation (_, tobj) = let key = tobj.tacobj_key in + let () = check_key key in Tacenv.register_alias key tobj.tacobj_body; Egramcoq.extend_tactic_grammar key tobj.tacobj_tacgram; Pptactic.declare_notation_tactic_pprule key tobj.tacobj_tacpp @@ -97,6 +103,7 @@ let open_tactic_notation i (_, tobj) = let load_tactic_notation i (_, tobj) = let key = tobj.tacobj_key in + let () = check_key key in (** Only add the printing and interpretation rules. *) Tacenv.register_alias key tobj.tacobj_body; Pptactic.declare_notation_tactic_pprule key tobj.tacobj_tacpp; @@ -387,7 +394,8 @@ let rec find_pattern nt xl = function | _, Break s :: _ | Break s :: _, _ -> error ("A break occurs on one side of \"..\" but not on the other side.") | _, Terminal s :: _ | Terminal s :: _, _ -> - error ("The token \""^s^"\" occurs on one side of \"..\" but not on the other side.") + errorlabstrm "Metasyntax.find_pattern" + (str "The token \"" ++ str s ++ str "\" occurs on one side of \"..\" but not on the other side.") | _, [] -> error msg_expected_form_of_recursive_notation | ((SProdList _ | NonTerminal _) :: _), _ | _, (SProdList _ :: _) -> @@ -448,7 +456,8 @@ let rec get_notation_vars = function let vars = get_notation_vars sl in if Id.equal id ldots_var then vars else if Id.List.mem id vars then - error ("Variable "^Id.to_string id^" occurs more than once.") + errorlabstrm "Metasyntax.get_notation_vars" + (str "Variable " ++ pr_id id ++ str " occurs more than once.") else id::vars | (Terminal _ | Break _) :: sl -> get_notation_vars sl @@ -461,8 +470,8 @@ let analyze_notation_tokens l = recvars, List.subtract Id.equal vars (List.map snd recvars), l let error_not_same_scope x y = - error ("Variables "^Id.to_string x^" and "^Id.to_string y^ - " must be in the same scope.") + errorlabstrm "Metasyntax.error_not_name_scope" + (str "Variables " ++ pr_id x ++ str " and " ++ pr_id y ++ str " must be in the same scope.") (**********************************************************************) (* Build pretty-printing rules *) @@ -710,7 +719,7 @@ let is_not_small_constr = function let rec define_keywords_aux = function | GramConstrNonTerminal(e,Some _) as n1 :: GramConstrTerminal(IDENT k) :: l when is_not_small_constr e -> - Flags.if_verbose msg_info (strbrk ("Identifier '"^k^"' now a keyword")); + Flags.if_verbose msg_info (str "Identifier '" ++ str k ++ str "' now a keyword"); Lexer.add_keyword k; n1 :: GramConstrTerminal(KEYWORD k) :: define_keywords_aux l | n :: l -> n :: define_keywords_aux l @@ -719,7 +728,7 @@ let rec define_keywords_aux = function (* Ensure that IDENT articulation terminal symbols are keywords *) let define_keywords = function | GramConstrTerminal(IDENT k)::l -> - Flags.if_verbose msg_info (strbrk ("Identifier '"^k^"' now a keyword")); + Flags.if_verbose msg_info (str "Identifier '" ++ str k ++ str "' now a keyword"); Lexer.add_keyword k; GramConstrTerminal(KEYWORD k) :: define_keywords_aux l | l -> define_keywords_aux l @@ -804,7 +813,7 @@ let pr_level ntn (from,args) = let error_incompatible_level ntn oldprec prec = errorlabstrm "" - (str ("Notation "^ntn^" is already defined") ++ spc() ++ + (str "Notation " ++ str ntn ++ str " is already defined" ++ spc() ++ pr_level ntn oldprec ++ spc() ++ str "while it is now required to be" ++ spc() ++ pr_level ntn prec ++ str ".") @@ -871,14 +880,16 @@ let interp_modifiers modl = | SetEntryType (s,typ) :: l -> let id = Id.of_string s in if Id.List.mem_assoc id etyps then - error (s^" is already assigned to an entry or constr level."); + errorlabstrm "Metasyntax.interp_modifiers" + (str s ++ str " is already assigned to an entry or constr level."); interp assoc level ((id,typ)::etyps) format extra l | SetItemLevel ([],n) :: l -> interp assoc level etyps format extra l | SetItemLevel (s::idl,n) :: l -> let id = Id.of_string s in if Id.List.mem_assoc id etyps then - error (s^" is already assigned to an entry or constr level."); + errorlabstrm "Metasyntax.interp_modifiers" + (str s ++ str " is already assigned to an entry or constr level."); let typ = ETConstr (n,()) in interp assoc level ((id,typ)::etyps) format extra (SetItemLevel (idl,n)::l) | SetLevel n :: l -> @@ -905,7 +916,8 @@ let check_infix_modifiers modifiers = let check_useless_entry_types recvars mainvars etyps = let vars = let (l1,l2) = List.split recvars in l1@l2@mainvars in match List.filter (fun (x,etyp) -> not (List.mem x vars)) etyps with - | (x,_)::_ -> error (Id.to_string x ^ " is unbound in the notation.") + | (x,_)::_ -> errorlabstrm "Metasyntax.check_useless_entry_types" + (pr_id x ++ str " is unbound in the notation.") | _ -> () let no_syntax_modifiers = function @@ -1371,7 +1383,10 @@ let add_infix local ((loc,inf),modifiers) pr sc = (**********************************************************************) (* Delimiters and classes bound to scopes *) -type scope_command = ScopeDelim of string | ScopeClasses of scope_class list +type scope_command = + | ScopeDelim of string + | ScopeClasses of scope_class list + | ScopeRemove let load_scope_command _ (_,(scope,dlm)) = Notation.declare_scope scope @@ -1381,6 +1396,7 @@ let open_scope_command i (_,(scope,o)) = match o with | ScopeDelim dlm -> Notation.declare_delimiters scope dlm | ScopeClasses cl -> List.iter (Notation.declare_scope_class scope) cl + | ScopeRemove -> Notation.remove_delimiters scope let cache_scope_command o = load_scope_command 1 o; @@ -1406,6 +1422,9 @@ let inScopeCommand : scope_name * scope_command -> obj = let add_delimiters scope key = Lib.add_anonymous_leaf (inScopeCommand(scope,ScopeDelim key)) +let remove_delimiters scope = + Lib.add_anonymous_leaf (inScopeCommand(scope,ScopeRemove)) + let add_class_scope scope cl = Lib.add_anonymous_leaf (inScopeCommand(scope,ScopeClasses cl)) diff --git a/toplevel/metasyntax.mli b/toplevel/metasyntax.mli index 38a37757..f22839f4 100644 --- a/toplevel/metasyntax.mli +++ b/toplevel/metasyntax.mli @@ -39,6 +39,7 @@ val add_notation_extra_printing_rule : string -> string -> string -> unit (** Declaring delimiter keys and default scopes *) val add_delimiters : scope_name -> string -> unit +val remove_delimiters : scope_name -> unit val add_class_scope : scope_name -> scope_class list -> unit (** Add only the interpretation of a notation that already has pa/pp rules *) diff --git a/toplevel/mltop.ml b/toplevel/mltop.ml index 0b6fc48c..a7fb7a58 100644 --- a/toplevel/mltop.ml +++ b/toplevel/mltop.ml @@ -164,7 +164,7 @@ let add_rec_ml_dir unix_path = let convert_string d = try Names.Id.of_string d with UserError _ -> - msg_warning (str ("Directory "^d^" cannot be used as a Coq identifier (skipped)")); + msg_warning (str "Directory " ++ str d ++ str " cannot be used as a Coq identifier (skipped)"); raise Exit let add_rec_path ~unix_path ~coq_root ~implicit = @@ -184,7 +184,7 @@ let add_rec_path ~unix_path ~coq_root ~implicit = let () = List.iter add dirs in Loadpath.add_load_path unix_path ~implicit coq_root else - msg_warning (str ("Cannot open " ^ unix_path)) + msg_warning (str "Cannot open " ++ str unix_path) (* convertit un nom quelconque en nom de fichier ou de module *) let mod_of_name name = @@ -321,13 +321,13 @@ let reset_loaded_modules () = loaded_modules := [] let if_verbose_load verb f name ?path fname = if not verb then f name ?path fname else - let info = "[Loading ML file "^fname^" ..." in + let info = str "[Loading ML file " ++ str fname ++ str " ..." in try let path = f name ?path fname in - msg_info (str (info^" done]")); + msg_info (info ++ str " done]"); path with reraise -> - msg_info (str (info^" failed]")); + msg_info (info ++ str " failed]"); raise reraise (** Load a module for the first time (i.e. dynlink it) @@ -340,7 +340,8 @@ let trigger_ml_object verb cache reinit ?path name = add_loaded_module name (known_module_path name); if cache then perform_cache_obj name end else if not has_dynlink then - error ("Dynamic link not supported (module "^name^")") + errorlabstrm "Mltop.trigger_ml_object" + (str "Dynamic link not supported (module " ++ str name ++ str ")") else begin let file = file_of_name (Option.default name path) in let path = diff --git a/toplevel/obligations.ml b/toplevel/obligations.ml index 523134b5..9019f486 100644 --- a/toplevel/obligations.ml +++ b/toplevel/obligations.ml @@ -306,7 +306,7 @@ type fixpoint_kind = type notations = (Vernacexpr.lstring * Constrexpr.constr_expr * Notation_term.scope_name option) list -type program_info = { +type program_info_aux = { prg_name: Id.t; prg_body: constr; prg_type: constr; @@ -322,6 +322,13 @@ type program_info = { prg_opaque : bool; } +type program_info = program_info_aux Ephemeron.key + +let get_info x = + try Ephemeron.get x + with Ephemeron.InvalidKey -> + Errors.anomaly Pp.(str "Program obligation can't be accessed by a worker") + let assumption_message = Declare.assumption_message let (set_default_tactic, get_default_tactic, print_default_tactic) = @@ -452,23 +459,10 @@ let subst_deps_obl obls obl = module ProgMap = Map.Make(Id) -let map_replace k v m = ProgMap.add k v (ProgMap.remove k m) +let map_replace k v m = ProgMap.add k (Ephemeron.create v) (ProgMap.remove k m) let map_keys m = ProgMap.fold (fun k _ l -> k :: l) m [] -let map_cardinal m = - let i = ref 0 in - ProgMap.iter (fun _ _ -> incr i) m; - !i - -exception Found of program_info - -let map_first m = - try - ProgMap.iter (fun _ v -> raise (Found v)) m; - assert(false) - with Found x -> x - let from_prg : program_info ProgMap.t ref = Summary.ref ProgMap.empty ~name:"program-tcc-table" @@ -514,16 +508,17 @@ let declare_definition prg = let nf = Universes.nf_evars_and_universes_opt_subst (fun x -> None) (Evd.evar_universe_context_subst prg.prg_ctx) in let opaque = prg.prg_opaque in + let fix_exn = Stm.get_fix_exn () in let ce = - definition_entry ~opaque ~types:(nf typ) ~poly:(pi2 prg.prg_kind) - ~univs:(Evd.evar_context_universe_context prg.prg_ctx) (nf body) + definition_entry ~fix_exn + ~opaque ~types:(nf typ) ~poly:(pi2 prg.prg_kind) + ~univs:(Evd.evar_context_universe_context prg.prg_ctx) (nf body) in progmap_remove prg; !declare_definition_ref prg.prg_name prg.prg_kind ce prg.prg_implicits - (Lemmas.mk_hook (fun l r -> - Lemmas.call_hook (fun exn -> exn) prg.prg_hook l r; r)) - + (Lemmas.mk_hook (fun l r -> Lemmas.call_hook fix_exn prg.prg_hook l r; r)) + open Pp let rec lam_index n t acc = @@ -547,7 +542,7 @@ let compute_possible_guardness_evidences (n,_) fixbody fixtype = let ctx = fst (decompose_prod_n_assum m fixtype) in List.map_i (fun i _ -> i) 0 ctx -let mk_proof c = ((c, Univ.ContextSet.empty), Declareops.no_seff) +let mk_proof c = ((c, Univ.ContextSet.empty), Safe_typing.empty_private_constants) let declare_mutual_definition l = let len = List.length l in @@ -606,12 +601,17 @@ let shrink_body c = else mkLambda (n,t,b), succ i, mkRel i :: args) (b, 1, []) ctx in List.map (fun (c,t) -> (c,None,t)) ctx, b', Array.of_list args - + +let unfold_entry cst = Hints.HintsUnfoldEntry [EvalConstRef cst] + +let add_hint local prg cst = + Hints.add_hints local [Id.to_string prg.prg_name] (unfold_entry cst) + let declare_obligation prg obl body ty uctx = let body = prg.prg_reduce body in let ty = Option.map prg.prg_reduce ty in match obl.obl_status with - | Evar_kinds.Expand -> { obl with obl_body = Some (TermObl body) } + | Evar_kinds.Expand -> false, { obl with obl_body = Some (TermObl body) } | Evar_kinds.Define opaque -> let opaque = if get_proofs_transparency () then false else opaque in let poly = pi2 prg.prg_kind in @@ -619,8 +619,9 @@ let declare_obligation prg obl body ty uctx = if get_shrink_obligations () && not poly then shrink_body body else [], body, [||] in + let body = ((body,Univ.ContextSet.empty),Safe_typing.empty_private_constants) in let ce = - { const_entry_body = Future.from_val((body,Univ.ContextSet.empty),Declareops.no_seff); + { const_entry_body = Future.from_val ~fix_exn:(fun x -> x) body; const_entry_secctx = None; const_entry_type = if List.is_empty ctx then ty else None; const_entry_polymorphic = poly; @@ -633,11 +634,9 @@ let declare_obligation prg obl body ty uctx = let constant = Declare.declare_constant obl.obl_name ~local:true (DefinitionEntry ce,IsProof Property) in - if not opaque then - Hints.add_hints false [Id.to_string prg.prg_name] - (Hints.HintsUnfoldEntry [EvalConstRef constant]); + if not opaque then add_hint false prg constant; definition_message obl.obl_name; - { obl with obl_body = + true, { obl with obl_body = if poly then Some (DefinedObl constant) else @@ -670,17 +669,33 @@ let init_prog_info ?(opaque = false) n b t ctx deps fixkind notations obls impls prg_hook = hook; prg_opaque = opaque; } +let map_cardinal m = + let i = ref 0 in + ProgMap.iter (fun _ v -> + if snd (Ephemeron.get v).prg_obligations > 0 then incr i) m; + !i + +exception Found of program_info + +let map_first m = + try + ProgMap.iter (fun _ v -> + if snd (Ephemeron.get v).prg_obligations > 0 then + raise (Found v)) m; + assert(false) + with Found x -> x + let get_prog name = let prg_infos = !from_prg in match name with Some n -> - (try ProgMap.find n prg_infos + (try get_info (ProgMap.find n prg_infos) with Not_found -> raise (NoObligations (Some n))) | None -> (let n = map_cardinal prg_infos in match n with 0 -> raise (NoObligations None) - | 1 -> map_first prg_infos + | 1 -> get_info (map_first prg_infos) | _ -> error ("More than one program with unsolved obligations: "^ String.concat ", " @@ -690,7 +705,7 @@ let get_prog name = let get_any_prog () = let prg_infos = !from_prg in let n = map_cardinal prg_infos in - if n > 0 then map_first prg_infos + if n > 0 then get_info (map_first prg_infos) else raise (NoObligations None) let get_prog_err n = @@ -730,7 +745,7 @@ let update_obls prg obls rem = progmap_remove prg'; Defined kn | l -> - let progs = List.map (fun x -> ProgMap.find x !from_prg) prg'.prg_deps in + let progs = List.map (fun x -> get_info (ProgMap.find x !from_prg)) prg'.prg_deps in if List.for_all (fun x -> obligations_solved x) progs then let kn = declare_mutual_definition progs in Defined (ConstRef kn) @@ -767,7 +782,7 @@ let not_transp_msg = str "Obligation should be transparent but was declared opaque." ++ spc () ++ str"Use 'Defined' instead." -let error_not_transp () = pperror not_transp_msg +let err_not_transp () = pperror not_transp_msg let rec string_of_list sep f = function [] -> "" @@ -783,81 +798,68 @@ let solve_by_tac name evi t poly ctx = let (entry,_,ctx') = Pfedit.build_constant_by_tactic id ~goal_kind:(goal_kind poly) ctx evi.evar_hyps concl (Tacticals.New.tclCOMPLETE t) in let env = Global.env () in - let entry = Term_typing.handle_entry_side_effects env entry in - let body, eff = Future.force entry.Entries.const_entry_body in - assert(Declareops.side_effects_is_empty eff); - assert(Univ.ContextSet.is_empty (snd body)); + let entry = Safe_typing.inline_private_constants_in_definition_entry env entry in + let body, eff = Future.force entry.const_entry_body in + assert(Safe_typing.empty_private_constants = eff); + let ctx' = Evd.merge_context_set ~sideff:true Evd.univ_rigid (Evd.from_ctx ctx') (snd body) in Inductiveops.control_only_guard (Global.env ()) (fst body); - (fst body), entry.Entries.const_entry_type, ctx' + (fst body), entry.const_entry_type, Evd.evar_universe_context ctx' + +let obligation_hook prg obl num auto ctx' _ gr = + let obls, rem = prg.prg_obligations in + let cst = match gr with ConstRef cst -> cst | _ -> assert false in + let transparent = evaluable_constant cst (Global.env ()) in + let () = match obl.obl_status with + | Evar_kinds.Expand -> if not transparent then err_not_transp () + | Evar_kinds.Define op -> if not op && not transparent then err_not_transp () + in + let obl = { obl with obl_body = Some (DefinedObl cst) } in + let () = if transparent then add_hint true prg cst in + let obls = Array.copy obls in + let _ = obls.(num) <- obl in + let ctx' = match ctx' with None -> prg.prg_ctx | Some ctx' -> ctx' in + let ctx' = + if not (pi2 prg.prg_kind) (* Not polymorphic *) then + (* The universe context was declared globally, we continue + from the new global environment. *) + Evd.evar_universe_context (Evd.from_env (Global.env ())) + else ctx' + in + let prg = { prg with prg_ctx = ctx' } in + let () = + try ignore (update_obls prg obls (pred rem)) + with e when Errors.noncritical e -> + let e = Errors.push e in + pperror (Errors.iprint (Cerrors.process_vernac_interp_error e)) + in + if pred rem > 0 then begin + let deps = dependencies obls num in + if not (Int.Set.is_empty deps) then + ignore (auto (Some prg.prg_name) None deps) + end let rec solve_obligation prg num tac = let user_num = succ num in let obls, rem = prg.prg_obligations in let obl = obls.(num) in + let remaining = deps_remaining obls obl.obl_deps in + let () = if not (Option.is_empty obl.obl_body) then - pperror (str "Obligation" ++ spc () ++ int user_num ++ str "already" ++ spc() ++ str "solved.") - else - match deps_remaining obls obl.obl_deps with - | [] -> - let obl = subst_deps_obl obls obl in - let kind = kind_of_obligation (pi2 prg.prg_kind) obl.obl_status in - let evd = Evd.from_env ~ctx:prg.prg_ctx Environ.empty_env in - Lemmas.start_proof_univs obl.obl_name kind evd obl.obl_type - (fun ctx' -> Lemmas.mk_hook (fun strength gr -> - let cst = match gr with ConstRef cst -> cst | _ -> assert false in - let obl = - let transparent = evaluable_constant cst (Global.env ()) in - let body = - match obl.obl_status with - | Evar_kinds.Expand -> - if not transparent then error_not_transp () - else DefinedObl cst - | Evar_kinds.Define opaque -> - if not opaque && not transparent then error_not_transp () - else DefinedObl cst - in - if transparent then - Hints.add_hints true [Id.to_string prg.prg_name] - (Hints.HintsUnfoldEntry [EvalConstRef cst]); - { obl with obl_body = Some body } - in - let obls = Array.copy obls in - let _ = obls.(num) <- obl in - let ctx' = - let ctx = - match ctx' with - | None -> prg.prg_ctx - | Some ctx' -> ctx' - in - if not (pi2 prg.prg_kind) (* Not polymorphic *) then - (* This context is already declared globally, we cannot - instantiate the rigid variables anymore *) - Evd.abstract_undefined_variables ctx - else ctx - in - let res = - try update_obls - {prg with prg_body = prg.prg_body; - prg_type = prg.prg_type; - prg_ctx = ctx' } - - obls (pred rem) - with e when Errors.noncritical e -> - let e = Errors.push e in - pperror (Errors.iprint (Cerrors.process_vernac_interp_error e)) - in - match res with - | Remain n when n > 0 -> - let deps = dependencies obls num in - if not (Int.Set.is_empty deps) then - ignore(auto_solve_obligations (Some prg.prg_name) None ~oblset:deps) - | _ -> ())); - trace (str "Started obligation " ++ int user_num ++ str " proof: " ++ - Printer.pr_constr_env (Global.env ()) Evd.empty obl.obl_type); - ignore (Pfedit.by (snd (get_default_tactic ()))); - Option.iter (fun tac -> Pfedit.set_end_tac tac) tac - | l -> pperror (str "Obligation " ++ int user_num ++ str " depends on obligation(s) " - ++ str (string_of_list ", " (fun x -> string_of_int (succ x)) l)) + pperror (str "Obligation" ++ spc () ++ int user_num ++ str "already" ++ spc() ++ str "solved."); + if not (List.is_empty remaining) then + pperror (str "Obligation " ++ int user_num ++ str " depends on obligation(s) " + ++ str (string_of_list ", " (fun x -> string_of_int (succ x)) remaining)); + in + let obl = subst_deps_obl obls obl in + let kind = kind_of_obligation (pi2 prg.prg_kind) obl.obl_status in + let evd = Evd.from_ctx prg.prg_ctx in + let auto n tac oblset = auto_solve_obligations n ~oblset tac in + let hook ctx = Lemmas.mk_hook (obligation_hook prg obl num auto ctx) in + let () = Lemmas.start_proof_univs obl.obl_name kind evd obl.obl_type hook in + let () = trace (str "Started obligation " ++ int user_num ++ str " proof: " ++ + Printer.pr_constr_env (Global.env ()) Evd.empty obl.obl_type) in + let _ = Pfedit.by (snd (get_default_tactic ())) in + Option.iter (fun tac -> Pfedit.set_end_tac tac) tac and obligation (user_num, name, typ) tac = let num = pred user_num in @@ -892,8 +894,13 @@ and solve_obligation_by_tac prg obls i tac = (pi2 !prg.prg_kind) !prg.prg_ctx in let uctx = Evd.evar_context_universe_context ctx in - prg := {!prg with prg_ctx = ctx}; - obls.(i) <- declare_obligation !prg obl t ty uctx; + let () = prg := {!prg with prg_ctx = ctx} in + let def, obl' = declare_obligation !prg obl t ty uctx in + obls.(i) <- obl'; + if def && not (pi2 !prg.prg_kind) then ( + (* Declare the term constraints with the first obligation only *) + let ctx' = Evd.evar_universe_context (Evd.from_env (Global.env ())) in + prg := {!prg with prg_ctx = ctx'}); true else false with e when Errors.noncritical e -> @@ -929,7 +936,7 @@ and solve_obligations n tac = solve_prg_obligations prg tac and solve_all_obligations tac = - ProgMap.iter (fun k v -> ignore(solve_prg_obligations v tac)) !from_prg + ProgMap.iter (fun k v -> ignore(solve_prg_obligations (get_info v) tac)) !from_prg and try_solve_obligation n prg tac = let prg = get_prog prg in @@ -970,7 +977,7 @@ let show_obligations ?(msg=true) n = | Some n -> try [ProgMap.find n !from_prg] with Not_found -> raise (NoObligations (Some n)) - in List.iter (show_obligations_of_prg ~msg) progs + in List.iter (fun x -> show_obligations_of_prg ~msg (get_info x)) progs let show_term n = let prg = get_prog_err n in @@ -991,7 +998,7 @@ let add_definition n ?term t ctx ?(implicits=[]) ?(kind=Global,false,Definition) else ( let len = Array.length obls in let _ = Flags.if_verbose msg_info (info ++ str ", generating " ++ int len ++ str " obligation(s)") in - progmap_add n prg; + progmap_add n (Ephemeron.create prg); let res = auto_solve_obligations (Some n) tactic in match res with | Remain rem -> Flags.if_verbose (fun () -> show_obligations ~msg:false (Some n)) (); res @@ -1004,7 +1011,7 @@ let add_mutual_definitions l ctx ?tactic ?(kind=Global,false,Definition) ?(reduc (fun (n, b, t, imps, obls) -> let prg = init_prog_info ~opaque n (Some b) t ctx deps (Some fixkind) notations obls imps kind reduce hook - in progmap_add n prg) l; + in progmap_add n (Ephemeron.create prg)) l; let _defined = List.fold_left (fun finished x -> if finished then finished diff --git a/toplevel/obligations.mli b/toplevel/obligations.mli index 40f124ca..61a8ee52 100644 --- a/toplevel/obligations.mli +++ b/toplevel/obligations.mli @@ -17,11 +17,11 @@ open Decl_kinds (** Forward declaration. *) val declare_fix_ref : (?opaque:bool -> definition_kind -> Univ.universe_context -> Id.t -> - Entries.proof_output -> types -> Impargs.manual_implicits -> global_reference) ref + Safe_typing.private_constants Entries.proof_output -> types -> Impargs.manual_implicits -> global_reference) ref val declare_definition_ref : (Id.t -> definition_kind -> - Entries.definition_entry -> Impargs.manual_implicits + Safe_typing.private_constants Entries.definition_entry -> Impargs.manual_implicits -> global_reference Lemmas.declaration_hook -> global_reference) ref val check_evars : env -> evar_map -> unit diff --git a/toplevel/record.ml b/toplevel/record.ml index 737b7fb5..dc2c9264 100644 --- a/toplevel/record.ml +++ b/toplevel/record.ml @@ -90,9 +90,10 @@ let binder_of_decl = function let binders_of_decls = List.map binder_of_decl -let typecheck_params_and_fields def id t ps nots fs = +let typecheck_params_and_fields def id pl t ps nots fs = let env0 = Global.env () in - let evars = ref (Evd.from_env env0) in + let ctx = Evd.make_evar_universe_context env0 pl in + let evars = ref (Evd.from_ctx ctx) in let _ = let error bk (loc, name) = match bk, name with @@ -130,14 +131,21 @@ let typecheck_params_and_fields def id t ps nots fs = Pretyping.solve_remaining_evars Pretyping.all_and_fail_flags env_ar !evars (Evd.empty,!evars) in let evars, nf = Evarutil.nf_evars_and_universes sigma in let arity = nf t' in - let evars = + let arity, evars = let _, univ = compute_constructor_level evars env_ar newfs in let ctx, aritysort = Reduction.dest_arity env0 arity in assert(List.is_empty ctx); (* Ensured by above analysis *) if Sorts.is_prop aritysort || - (Sorts.is_set aritysort && engagement env0 = Some ImpredicativeSet) then - evars - else Evd.set_leq_sort env_ar evars (Type univ) aritysort + (Sorts.is_set aritysort && is_impredicative_set env0) then + arity, evars + else + let evars = Evd.set_leq_sort env_ar evars (Type univ) aritysort in + if Univ.is_small_univ univ then + (* We can assume that the level aritysort is not constrained + and clear it. *) + mkArity (ctx, Sorts.sort_of_univ univ), + Evd.set_eq_sort env_ar evars (Prop Pos) aritysort + else arity, evars in let evars, nf = Evarutil.nf_evars_and_universes evars in let newps = map_rel_context nf newps in @@ -145,15 +153,15 @@ let typecheck_params_and_fields def id t ps nots fs = let ce t = Evarutil.check_evars env0 Evd.empty evars t in List.iter (fun (n, b, t) -> Option.iter ce b; ce t) (List.rev newps); List.iter (fun (n, b, t) -> Option.iter ce b; ce t) (List.rev newfs); - Evd.universe_context evars, nf arity, template, imps, newps, impls, newfs + Evd.universe_context ?names:pl evars, nf arity, template, imps, newps, impls, newfs let degenerate_decl (na,b,t) = let id = match na with | Name id -> id | Anonymous -> anomaly (Pp.str "Unnamed record variable") in match b with - | None -> (id, Entries.LocalAssum t) - | Some b -> (id, Entries.LocalDef b) + | None -> (id, LocalAssum t) + | Some b -> (id, LocalDef b) type record_error = | MissingProj of Id.t * Id.t list @@ -232,7 +240,8 @@ let declare_projections indsp ?(kind=StructureComponent) binder_name coers field let (mib,mip) = Global.lookup_inductive indsp in let u = Declareops.inductive_instance mib in let paramdecls = Inductive.inductive_paramdecls (mib, u) in - let poly = mib.mind_polymorphic and ctx = Univ.instantiate_univ_context mib.mind_universes in + let poly = mib.mind_polymorphic in + let ctx = Univ.instantiate_univ_context mib.mind_universes in let indu = indsp, u in let r = mkIndU (indsp,u) in let rp = applist (r, Termops.extended_rel_list 0 paramdecls) in @@ -288,16 +297,17 @@ let declare_projections indsp ?(kind=StructureComponent) binder_name coers field try let entry = { const_entry_body = - Future.from_val (Term_typing.mk_pure_proof proj); + Future.from_val (Safe_typing.mk_pure_proof proj); const_entry_secctx = None; const_entry_type = Some projtyp; const_entry_polymorphic = poly; - const_entry_universes = ctx; + const_entry_universes = + if poly then ctx else Univ.UContext.empty; const_entry_opaque = false; const_entry_inline_code = false; const_entry_feedback = None } in let k = (DefinitionEntry entry,IsDefinition kind) in - let kn = declare_constant ~internal:KernelSilent fid k in + let kn = declare_constant ~internal:InternalTacticRequest fid k in let constr_fip = let proj_args = (*Rel 1 refers to "x"*) paramargs@[mkRel 1] in applist (mkConstU (kn,u),proj_args) @@ -366,7 +376,7 @@ let declare_structure finite poly ctx id idbuild paramimpls params arity templat mind_entry_polymorphic = poly; mind_entry_private = None; mind_entry_universes = ctx } in - let kn = Command.declare_mutual_inductive_with_eliminations mie [(paramimpls,[])] in + let kn = Command.declare_mutual_inductive_with_eliminations mie [] [(paramimpls,[])] in let rsp = (kn,0) in (* This is ind path of idstruc *) let cstr = (rsp,1) in let kinds,sp_projs = declare_projections rsp ~kind binder_name coers fieldimpls fields in @@ -396,44 +406,49 @@ let declare_class finite def poly ctx id idbuild paramimpls params arity let impl, projs = match fields with | [(Name proj_name, _, field)] when def -> - let class_body = it_mkLambda_or_LetIn field params in - let _class_type = it_mkProd_or_LetIn arity params in - let class_entry = - Declare.definition_entry (* ?types:class_type *) ~poly ~univs:ctx class_body in - let cst = Declare.declare_constant (snd id) - (DefinitionEntry class_entry, IsDefinition Definition) - in - let cstu = (cst, if poly then Univ.UContext.instance ctx else Univ.Instance.empty) in - let inst_type = appvectc (mkConstU cstu) (Termops.rel_vect 0 (List.length params)) in - let proj_type = - it_mkProd_or_LetIn (mkProd(Name binder_name, inst_type, lift 1 field)) params in - let proj_body = - it_mkLambda_or_LetIn (mkLambda (Name binder_name, inst_type, mkRel 1)) params in - let proj_entry = Declare.definition_entry ~types:proj_type ~poly ~univs:ctx proj_body in - let proj_cst = Declare.declare_constant proj_name - (DefinitionEntry proj_entry, IsDefinition Definition) - in - let cref = ConstRef cst in - Impargs.declare_manual_implicits false cref [paramimpls]; - Impargs.declare_manual_implicits false (ConstRef proj_cst) [List.hd fieldimpls]; - Classes.set_typeclass_transparency (EvalConstRef cst) false false; - let sub = match List.hd coers with - | Some b -> Some ((if b then Backward else Forward), List.hd priorities) - | None -> None - in - cref, [Name proj_name, sub, Some proj_cst] + let class_body = it_mkLambda_or_LetIn field params in + let _class_type = it_mkProd_or_LetIn arity params in + let class_entry = + Declare.definition_entry (* ?types:class_type *) ~poly ~univs:ctx class_body in + let cst = Declare.declare_constant (snd id) + (DefinitionEntry class_entry, IsDefinition Definition) + in + let cstu = (cst, if poly then Univ.UContext.instance ctx else Univ.Instance.empty) in + let inst_type = appvectc (mkConstU cstu) + (Termops.rel_vect 0 (List.length params)) in + let proj_type = + it_mkProd_or_LetIn (mkProd(Name binder_name, inst_type, lift 1 field)) params in + let proj_body = + it_mkLambda_or_LetIn (mkLambda (Name binder_name, inst_type, mkRel 1)) params in + let proj_entry = + Declare.definition_entry ~types:proj_type ~poly + ~univs:(if poly then ctx else Univ.UContext.empty) proj_body + in + let proj_cst = Declare.declare_constant proj_name + (DefinitionEntry proj_entry, IsDefinition Definition) + in + let cref = ConstRef cst in + Impargs.declare_manual_implicits false cref [paramimpls]; + Impargs.declare_manual_implicits false (ConstRef proj_cst) [List.hd fieldimpls]; + Classes.set_typeclass_transparency (EvalConstRef cst) false false; + let sub = match List.hd coers with + | Some b -> Some ((if b then Backward else Forward), List.hd priorities) + | None -> None + in + cref, [Name proj_name, sub, Some proj_cst] | _ -> - let ind = declare_structure BiFinite poly ctx (snd id) idbuild paramimpls + let ind = declare_structure BiFinite poly ctx (snd id) idbuild paramimpls params arity template fieldimpls fields ~kind:Method ~name:binder_name false (List.map (fun _ -> false) fields) sign - in - let coers = List.map2 (fun coe pri -> - Option.map (fun b -> - if b then Backward, pri else Forward, pri) coe) + in + let coers = List.map2 (fun coe pri -> + Option.map (fun b -> + if b then Backward, pri else Forward, pri) coe) coers priorities - in - IndRef ind, (List.map3 (fun (id, _, _) b y -> (id, b, y)) - (List.rev fields) coers (Recordops.lookup_projections ind)) + in + let l = List.map3 (fun (id, _, _) b y -> (id, b, y)) + (List.rev fields) coers (Recordops.lookup_projections ind) + in IndRef ind, l in let ctx_context = List.map (fun (na, b, t) -> @@ -502,7 +517,7 @@ open Vernacexpr (* [fs] corresponds to fields and [ps] to parameters; [coers] is a list telling if the corresponding fields must me declared as coercions or subinstances *) -let definition_structure (kind,poly,finite,(is_coe,(loc,idstruc)),ps,cfs,idbuild,s) = +let definition_structure (kind,poly,finite,(is_coe,((loc,idstruc),pl)),ps,cfs,idbuild,s) = let cfs,notations = List.split cfs in let cfs,priorities = List.split cfs in let coers,fs = List.split cfs in @@ -517,11 +532,11 @@ let definition_structure (kind,poly,finite,(is_coe,(loc,idstruc)),ps,cfs,idbuild if isnot_class && List.exists (fun opt -> not (Option.is_empty opt)) priorities then error "Priorities only allowed for type class substructures"; (* Now, younger decl in params and fields is on top *) - let ctx, arity, template, implpars, params, implfs, fields = + let (pl, ctx), arity, template, implpars, params, implfs, fields = States.with_state_protection (fun () -> - typecheck_params_and_fields (kind = Class true) idstruc s ps notations fs) () in + typecheck_params_and_fields (kind = Class true) idstruc pl s ps notations fs) () in let sign = structure_signature (fields@params) in - match kind with + let gr = match kind with | Class def -> let gr = declare_class finite def poly ctx (loc,idstruc) idbuild implpars params arity template implfs fields is_coe coers priorities sign in @@ -534,3 +549,6 @@ let definition_structure (kind,poly,finite,(is_coe,(loc,idstruc)),ps,cfs,idbuild idbuild implpars params arity template implfs fields is_coe (List.map (fun coe -> not (Option.is_empty coe)) coers) sign in IndRef ind + in + Universes.register_universe_binders gr pl; + gr diff --git a/toplevel/record.mli b/toplevel/record.mli index 91dccb96..eccb5d29 100644 --- a/toplevel/record.mli +++ b/toplevel/record.mli @@ -38,7 +38,7 @@ val declare_structure : Decl_kinds.recursivity_kind -> inductive val definition_structure : - inductive_kind * Decl_kinds.polymorphic * Decl_kinds.recursivity_kind * lident with_coercion * local_binder list * + inductive_kind * Decl_kinds.polymorphic * Decl_kinds.recursivity_kind * plident with_coercion * local_binder list * (local_decl_expr with_instance with_priority with_notation) list * Id.t * constr_expr option -> global_reference diff --git a/toplevel/search.ml b/toplevel/search.ml index 59283edf..9e67eef0 100644 --- a/toplevel/search.ml +++ b/toplevel/search.ml @@ -32,7 +32,7 @@ module SearchBlacklist = let key = ["Search";"Blacklist"] let title = "Current search blacklist : " let member_message s b = - str ("Search blacklist does "^(if b then "" else "not ")^"include "^s) + str "Search blacklist does " ++ (if b then mt () else str "not ") ++ str "include " ++ str s let synchronous = true end) @@ -253,7 +253,8 @@ let interface_search flags = let regexp = try Str.regexp s with e when Errors.noncritical e -> - Errors.error ("Invalid regexp: " ^ s) + Errors.errorlabstrm "Search.interface_search" + (str "Invalid regexp: " ++ str s) in extract_flags ((regexp, b) :: name) tpe subtpe mods blacklist l | (Type_Pattern s, b) :: l -> @@ -271,7 +272,8 @@ let interface_search flags = let id = try Nametab.full_name_module qid with Not_found -> - Errors.error ("Module " ^ path ^ " not found.") + Errors.errorlabstrm "Search.interface_search" + (str "Module " ++ str path ++ str " not found.") in extract_flags name tpe subtpe ((id, b) :: mods) blacklist l | (Include_Blacklist, b) :: l -> diff --git a/toplevel/toplevel.mllib b/toplevel/toplevel.mllib index bf0f305a..5aa7d428 100644 --- a/toplevel/toplevel.mllib +++ b/toplevel/toplevel.mllib @@ -10,6 +10,7 @@ Obligations Command Classes Record +Assumptions Vernacinterp Mltop Vernacentries diff --git a/toplevel/usage.ml b/toplevel/usage.ml index f053839c..472503ce 100644 --- a/toplevel/usage.ml +++ b/toplevel/usage.ml @@ -42,9 +42,9 @@ let print_usage_channel co command = \n -load-vernac-source-verbose f load Coq file f.v (Load Verbose f.)\ \n -lv f (idem)\ \n -load-vernac-object f load Coq object file f.vo\ -\n -require f load Coq object file f.vo and import it (Require f.)\ -\n -compile f compile Coq file f.v (implies -batch)\ -\n -compile-verbose f verbosely compile Coq file f.v (implies -batch)\ +\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 -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\ @@ -52,10 +52,14 @@ let print_usage_channel co command = \n proofs in each fi.vio\ \n\ \n -where print Coq's standard library location and exit\ -\n -config print Coq's configuration information and exit\ +\n -config, --config print Coq's configuration information and exit\ \n -v print Coq version and exit\ \n -list-tags print highlight color tags known by Coq and exit\ \n\ +\n -quiet unset display of extra information (implies -w none)\ +\n -w (all|none) configure display of warnings\ +\n -color (yes|no|auto) configure color output\ +\n\ \n -q skip loading of rcfile\ \n -init-file f set the rcfile to f\ \n -batch batch mode (exits just after arguments parsing)\ @@ -63,7 +67,6 @@ let print_usage_channel co command = \n -bt print backtraces (requires configure debug flag)\ \n -debug debug mode (implies -bt)\ \n -emacs tells Coq it is executed under Emacs\ -\n -color (on|off|auto) configure color output (only active through coqtop)\ \n -noglob do not dump globalizations\ \n -dump-glob f dump globalizations in file f (to be used by coqdoc)\ \n -with-geoproof (yes|no) to (de)activate special functions for Geoproof within Coqide (default is yes)\ @@ -71,8 +74,12 @@ let print_usage_channel co command = \n -indices-matter levels of indices (and nonuniform parameters) contribute to the level of inductives\ \n -type-in-type disable universe consistency checking\ \n -time display the time taken by each command\ -\n -no-native-compiler disable the native_compute reduction machinery\ -\n -h, -help print this list of options\ +\n -m, --memory display total heap size at program exit\ +\n (use environment variable\ +\n OCAML_GC_STATS=\"/tmp/gclog.txt\"\ +\n for full Gc stats dump) +\n -native-compiler precompile files for the native_compute machinery\ +\n -h, -help, --help print this list of options\ \n"; List.iter (fun (name, text) -> output_string co diff --git a/toplevel/vernac.ml b/toplevel/vernac.ml index 176a6c33..a0cd618e 100644 --- a/toplevel/vernac.ml +++ b/toplevel/vernac.ml @@ -27,7 +27,7 @@ let rec is_navigation_vernac = function | VernacBacktrack _ | VernacBackTo _ | VernacBack _ -> true - | VernacTime l -> + | VernacRedirect (_, l) | VernacTime l -> List.exists (fun (_,c) -> is_navigation_vernac c) l (* Time Back* is harmless *) | c -> is_deep_navigation_vernac c @@ -78,9 +78,13 @@ let get_exn_files e = Exninfo.get e files_of_exn let add_exn_files e f = Exninfo.add e files_of_exn f -let raise_with_file f (e, info) = - let inner_f = match get_exn_files info with None -> f | Some ff -> ff.inner in - iraise (e, add_exn_files info { outer = f; inner = inner_f }) +let enrich_with_file f (e, info) = + let inner = match get_exn_files info with None -> f | Some x -> x.inner in + (e, add_exn_files info { outer = f; inner }) + +let raise_with_file f e = iraise (enrich_with_file f e) + +let cur_file = ref None let disable_drop = function | Drop -> Errors.error "Drop is forbidden." @@ -88,28 +92,12 @@ let disable_drop = function let user_error loc s = Errors.user_err_loc (loc,"_",str s) -(* Open an utf-8 encoded file and skip the byte-order mark if any *) - -let open_utf8_file_in fname = - let is_bom s = - Int.equal (Char.code s.[0]) 0xEF && - Int.equal (Char.code s.[1]) 0xBB && - Int.equal (Char.code s.[2]) 0xBF - in - let in_chan = open_in fname in - let s = " " in - if input in_chan s 0 3 < 3 || not (is_bom s) then seek_in in_chan 0; - in_chan - (* Opening and closing a channel. Open it twice when verbose: the first channel is used to read the commands, and the second one to print them. Note: we could use only one thanks to seek_in, but seeking on and on in the file we parse seems a bit risky to me. B.B. *) -let open_file_twice_if verbosely fname = - let paths = Loadpath.get_paths () in - let _,longfname = - find_file_in_path ~warn:(Flags.is_verbose()) paths fname in +let open_file_twice_if verbosely longfname = let in_chan = open_utf8_file_in longfname in let verb_ch = if verbosely then Some (open_utf8_file_in longfname) else None in @@ -208,26 +196,24 @@ let display_cmd_header loc com = let cmd = noblank (shorten (string_of_ppcmds (safe_pr_vernac com))) in Pp.pp (str "Chars " ++ int start ++ str " - " ++ int stop ++ - str (" ["^cmd^"] ")); + str " [" ++ str cmd ++ str "] "); Pp.flush_all () -let rec vernac_com verbosely checknav (loc,com) = +let rec vernac_com verbose checknav (loc,com) = let interp = function | VernacLoad (verbosely, fname) -> let fname = Envars.expand_path_macros ~warn:(fun x -> msg_warning (str x)) fname in + let fname = CUnix.make_suffix fname ".v" in + let f = Loadpath.locate_file fname in let st = save_translator_coqdoc () in if !Flags.beautify_file then begin - let paths = Loadpath.get_paths () in - let _,f = find_file_in_path ~warn:(Flags.is_verbose()) - paths - (CUnix.make_suffix fname ".v") in chan_beautify := open_out (f^beautify_suffix); Pp.comments := [] end; begin try - read_vernac_file verbosely (CUnix.make_suffix fname ".v"); + read_vernac_file verbosely f; restore_translator_coqdoc st; with reraise -> let reraise = Errors.push reraise in @@ -237,7 +223,7 @@ let rec vernac_com verbosely checknav (loc,com) = | v when !just_parsing -> () - | v -> Stm.interp verbosely (loc,v) + | v -> Stm.interp verbose (loc,v) in try checknav loc com; @@ -253,13 +239,12 @@ let rec vernac_com verbosely checknav (loc,com) = else iraise (reraise, info) and read_vernac_file verbosely s = - Flags.make_warn verbosely; let checknav loc cmd = if is_navigation_vernac cmd && not (is_reset cmd) then user_error loc "Navigation commands forbidden in files" in - let (in_chan, fname, input) = - open_file_twice_if verbosely s in + let (in_chan, fname, input) = open_file_twice_if verbosely s in + cur_file := Some fname; try (* we go out of the following infinite loop when a End_of_input is * raised, which means that we raised the end of the file being loaded *) @@ -274,6 +259,7 @@ and read_vernac_file verbosely s = close_input in_chan input; (* we must close the file first *) match e with | End_of_input -> + cur_file := None; if do_beautify () then pr_new_syntax (Loc.make_loc (max_int,max_int)) None | _ -> raise_with_file fname (disable_drop e, info) @@ -296,14 +282,22 @@ let load_vernac verb file = chan_beautify := if !Flags.beautify_file then open_out (file^beautify_suffix) else stdout; try - read_vernac_file verb file; + Flags.silently (read_vernac_file verb) file; if !Flags.beautify_file then close_out !chan_beautify; with any -> let (e, info) = Errors.push any in if !Flags.beautify_file then close_out !chan_beautify; raise_with_file file (disable_drop e, info) -(* Compile a vernac file (f is assumed without .v suffix) *) +let ensure_v f = + if Filename.check_suffix f ".v" then f + else begin + msg_warning (str "File \"" ++ str f ++ strbrk "\" has been implicitly \ + expanded to \"" ++ str f ++ str ".v\""); + f ^ ".v" + end + +(* Compile a vernac file *) let compile verbosely f = let check_pending_proofs () = let pfs = Pfedit.get_all_proof_names () in @@ -311,7 +305,8 @@ let compile verbosely f = (msg_error (str "There are pending proofs"); flush_all (); exit 1) in match !Flags.compilation_mode with | BuildVo -> - let ldir,long_f_dot_v = Flags.verbosely Library.start_library f in + 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; Dumpglob.start_dump_glob long_f_dot_v; @@ -327,7 +322,8 @@ let compile verbosely f = Aux_file.stop_aux_file (); Dumpglob.end_dump_glob () | BuildVio -> - let ldir, long_f_dot_v = Flags.verbosely Library.start_library f in + let long_f_dot_v = ensure_v f in + let ldir = Flags.verbosely Library.start_library long_f_dot_v in Dumpglob.noglob (); Stm.set_compilation_hints long_f_dot_v; let _ = load_vernac verbosely long_f_dot_v in @@ -340,13 +336,18 @@ let compile verbosely f = let open Library in Dumpglob.noglob (); let f = if check_suffix f ".vio" then chop_extension f else f in - let lfdv, lib, univs, disch, tasks, proofs = load_library_todo f in + let lfdv, sum, lib, univs, disch, tasks, proofs = load_library_todo f in Stm.set_compilation_hints lfdv; let univs, proofs = Stm.finish_tasks lfdv univs disch proofs tasks in - Library.save_library_raw lfdv lib univs proofs + Library.save_library_raw lfdv sum lib univs proofs let compile v f = ignore(CoqworkmgrApi.get 1); compile v f; CoqworkmgrApi.giveback 1 +let () = Hook.set Stm.process_error_hook (fun e -> + match !cur_file with + | None -> Cerrors.process_vernac_interp_error e + | Some f -> enrich_with_file f (Cerrors.process_vernac_interp_error e) +) diff --git a/toplevel/vernacentries.ml b/toplevel/vernacentries.ml index cfa9bddc..b6a1a53f 100644 --- a/toplevel/vernacentries.ml +++ b/toplevel/vernacentries.ml @@ -76,9 +76,8 @@ let show_universes () = let gls = Proof.V82.subgoals pfts in let sigma = gls.Evd.sigma in let ctx = Evd.universe_context_set (Evd.nf_constraints sigma) in - let cstrs = Univ.merge_constraints (Univ.ContextSet.constraints ctx) Univ.empty_universes in msg_notice (Evd.pr_evar_universe_context (Evd.evar_universe_context sigma)); - msg_notice (str"Normalized constraints: " ++ Univ.pr_universes (Evd.pr_evd_level sigma) cstrs) + msg_notice (str"Normalized constraints: " ++ Univ.pr_universe_context_set (Evd.pr_evd_level sigma) ctx) let show_prooftree () = (* Spiwack: proof tree is currently not working *) @@ -102,17 +101,16 @@ let try_print_subgoals () = let show_intro all = let pf = get_pftreestate() in let {Evd.it=gls ; sigma=sigma; } = Proof.V82.subgoals pf in - let gl = {Evd.it=List.hd gls ; sigma = sigma; } in - let l,_= decompose_prod_assum (strip_outer_cast (pf_concl gl)) in - if all - then - let lid = Tactics.find_intro_names l gl in - msg_notice (hov 0 (prlist_with_sep spc pr_id lid)) - else - try + if not (List.is_empty gls) then begin + let gl = {Evd.it=List.hd gls ; sigma = sigma; } in + let l,_= decompose_prod_assum (strip_outer_cast (pf_concl gl)) in + if all then + let lid = Tactics.find_intro_names l gl in + msg_notice (hov 0 (prlist_with_sep spc pr_id lid)) + else if not (List.is_empty l) then let n = List.last l in msg_notice (pr_id (List.hd (Tactics.find_intro_names [n] gl))) - with Failure "List.last" -> () + end (** Prepare a "match" template for a given inductive type. For each branch of the match, we list the constructor name @@ -351,7 +349,7 @@ let dump_universes_gen g s = try Univ.dump_universes output_constraint g; close (); - msg_info (str ("Universes written to file \""^s^"\".")) + msg_info (str "Universes written to file \"" ++ str s ++ str "\".") with reraise -> let reraise = Errors.push reraise in close (); @@ -366,8 +364,7 @@ let dump_universes sorted s = (* "Locate" commands *) let locate_file f = - let paths = Loadpath.get_paths () in - let _, file = System.find_file_in_path ~warn:false paths f in + let file = Flags.silently Loadpath.locate_file f in str file let msg_found_library = function @@ -379,17 +376,27 @@ let msg_found_library = function msg_info (hov 0 (pr_dirpath fulldir ++ strbrk " is bound to file " ++ str file)) -let err_unmapped_library loc qid = +let err_unmapped_library loc ?from qid = let dir = fst (repr_qualid qid) in + let prefix = match from with + | None -> str "." + | Some from -> + str " and prefix " ++ pr_dirpath from ++ str "." + in user_err_loc (loc,"locate_library", - strbrk "Cannot find a physical path bound to logical path " ++ - pr_dirpath dir ++ str".") + strbrk "Cannot find a physical path bound to logical path matching suffix " ++ + pr_dirpath dir ++ prefix) -let err_notfound_library loc qid = +let err_notfound_library loc ?from qid = + let prefix = match from with + | None -> str "." + | Some from -> + str " with prefix " ++ pr_dirpath from ++ str "." + in user_err_loc (loc,"locate_library", - strbrk "Unable to locate library " ++ pr_qualid qid ++ str".") + strbrk "Unable to locate library " ++ pr_qualid qid ++ prefix) let print_located_library r = let (loc,qid) = qualid_of_reference r in @@ -415,7 +422,9 @@ let vernac_syntax_extension locality local = let local = enforce_module_locality locality local in Metasyntax.add_syntax_extension local -let vernac_delimiters = Metasyntax.add_delimiters +let vernac_delimiters sc = function + | Some lr -> Metasyntax.add_delimiters sc lr + | None -> Metasyntax.remove_delimiters sc let vernac_bind_scope sc cll = Metasyntax.add_class_scope sc (List.map scope_class_of_qualid cll) @@ -450,7 +459,7 @@ let vernac_definition_hook p = function | SubClass -> Class.add_subclass_hook p | _ -> no_hook -let vernac_definition locality p (local,k) (loc,id as lid) def = +let vernac_definition locality p (local,k) ((loc,id as lid),pl) def = let local = enforce_locality_exp locality local in let hook = vernac_definition_hook p k in let () = match local with @@ -460,26 +469,27 @@ let vernac_definition locality p (local,k) (loc,id as lid) def = (match def with | ProveBody (bl,t) -> (* local binders, typ *) start_proof_and_print (local,p,DefinitionBody Definition) - [Some lid, (bl,t,None)] no_hook + [Some (lid,pl), (bl,t,None)] no_hook | DefineBody (bl,red_option,c,typ_opt) -> let red_option = match red_option with | None -> None | Some r -> let (evc,env)= get_current_context () in Some (snd (interp_redexp env evc r)) in - do_definition id (local,p,k) bl red_option c typ_opt hook) + do_definition id (local,p,k) pl bl red_option c typ_opt hook) -let vernac_start_proof p kind l lettop = +let vernac_start_proof locality p kind l lettop = + let local = enforce_locality_exp locality None in if Dumpglob.dump () then List.iter (fun (id, _) -> match id with - | Some lid -> Dumpglob.dump_definition lid false "prf" + | Some (lid,_) -> Dumpglob.dump_definition lid false "prf" | None -> ()) l; if not(refining ()) then if lettop then errorlabstrm "Vernacentries.StartProof" (str "Let declarations can only be used in proof editing mode."); - start_proof_and_print (Global, p, Proof kind) l no_hook + start_proof_and_print (local, p, Proof kind) l no_hook let qed_display_script = ref true @@ -506,7 +516,7 @@ let vernac_assumption locality poly (local, kind) l nl = let kind = local, poly, kind in List.iter (fun (is_coe,(idl,c)) -> if Dumpglob.dump () then - List.iter (fun lid -> + List.iter (fun (lid, _) -> if global then Dumpglob.dump_definition lid false "ax" else Dumpglob.dump_definition lid true "var") idl) l; let status = do_assumptions kind nl l in @@ -514,11 +524,11 @@ let vernac_assumption locality poly (local, kind) l nl = let vernac_record k poly finite struc binders sort nameopt cfs = let const = match nameopt with - | None -> add_prefix "Build_" (snd (snd struc)) + | None -> add_prefix "Build_" (snd (fst (snd struc))) | Some (_,id as lid) -> Dumpglob.dump_definition lid false "constr"; id in if Dumpglob.dump () then ( - Dumpglob.dump_definition (snd struc) false "rec"; + Dumpglob.dump_definition (fst (snd struc)) false "rec"; List.iter (fun (((_, x), _), _) -> match x with | Vernacexpr.AssumExpr ((loc, Name id), _) -> Dumpglob.dump_definition (loc,id) false "proj" @@ -527,7 +537,7 @@ let vernac_record k poly finite struc binders sort nameopt cfs = let vernac_inductive poly lo finite indl = if Dumpglob.dump () then - List.iter (fun (((coe,lid), _, _, _, cstrs), _) -> + List.iter (fun (((coe,(lid,_)), _, _, _, cstrs), _) -> match cstrs with | Constructors cstrs -> Dumpglob.dump_definition lid false "ind"; @@ -542,12 +552,12 @@ let vernac_inductive poly lo finite indl = Errors.error "The Variant keyword cannot be used to define a record type. Use Record instead." | [ ( id , bl , c , b, RecordDecl (oc,fs) ), [] ] -> vernac_record (match b with Class true -> Class false | _ -> b) - poly finite id bl c oc fs + poly finite id bl c oc fs | [ ( id , bl , c , Class true, Constructors [l]), _ ] -> let f = let (coe, ((loc, id), ce)) = l in let coe' = if coe then Some true else None in - (((coe', AssumExpr ((loc, Name id), ce)), None), []) + (((coe', AssumExpr ((loc, Name id), ce)), None), []) in vernac_record (Class true) poly finite id bl c None [f] | [ ( id , bl , c , Class true, _), _ ] -> Errors.error "Definitional classes must have a single method" @@ -567,13 +577,13 @@ let vernac_inductive poly lo finite indl = let vernac_fixpoint locality poly local l = let local = enforce_locality_exp locality local in if Dumpglob.dump () then - List.iter (fun ((lid, _, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; + List.iter (fun (((lid,_), _, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; do_fixpoint local poly l let vernac_cofixpoint locality poly local l = let local = enforce_locality_exp locality local in if Dumpglob.dump () then - List.iter (fun ((lid, _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; + List.iter (fun (((lid,_), _, _, _), _) -> Dumpglob.dump_definition lid false "def") l; do_cofixpoint local poly l let vernac_scheme l = @@ -592,8 +602,19 @@ let vernac_combined_scheme lid l = List.iter (fun lid -> dump_global (Misctypes.AN (Ident lid))) l); Indschemes.do_combined_scheme lid l -let vernac_universe l = do_universe l -let vernac_constraint l = do_constraint l +let vernac_universe loc poly l = + if poly && not (Lib.sections_are_opened ()) then + user_err_loc (loc, "vernac_universe", + str"Polymorphic universes can only be declared inside sections, " ++ + str "use Monomorphic Universe instead"); + do_universe poly l + +let vernac_constraint loc poly l = + if poly && not (Lib.sections_are_opened ()) then + user_err_loc (loc, "vernac_constraint", + str"Polymorphic universe constraints can only be declared" + ++ str " inside sections, use Monomorphic Constraint instead"); + do_constraint poly l (**********************) (* Modules *) @@ -610,16 +631,14 @@ let vernac_declare_module export (loc, id) binders_ast mty_ast = let binders_ast = List.map (fun (export,idl,ty) -> if not (Option.is_empty export) then - error ("Arguments of a functor declaration cannot be exported. " ^ - "Remove the \"Export\" and \"Import\" keywords from every functor " ^ - "argument.") + error "Arguments of a functor declaration cannot be exported. Remove the \"Export\" and \"Import\" keywords from every functor argument." else (idl,ty)) binders_ast in let mp = Declaremods.declare_module Modintern.interp_module_ast id binders_ast (Enforce mty_ast) [] in Dumpglob.dump_moddef loc mp "mod"; - if_verbose msg_info (str ("Module "^ Id.to_string id ^" is declared")); + if_verbose msg_info (str "Module " ++ pr_id id ++ str " is declared"); Option.iter (fun export -> vernac_import export [Ident (Loc.ghost,id)]) export let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l = @@ -641,7 +660,7 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l = in Dumpglob.dump_moddef loc mp "mod"; if_verbose msg_info - (str ("Interactive Module "^ Id.to_string id ^" started")); + (str "Interactive Module " ++ pr_id id ++ str " started"); List.iter (fun (export,id) -> Option.iter @@ -651,9 +670,7 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l = let binders_ast = List.map (fun (export,idl,ty) -> if not (Option.is_empty export) then - error ("Arguments of a functor definition can be imported only if" ^ - " the definition is interactive. Remove the \"Export\" and " ^ - "\"Import\" keywords from every functor argument.") + error "Arguments of a functor definition can be imported only if the definition is interactive. Remove the \"Export\" and \"Import\" keywords from every functor argument." else (idl,ty)) binders_ast in let mp = Declaremods.declare_module Modintern.interp_module_ast @@ -661,14 +678,14 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l = in Dumpglob.dump_moddef loc mp "mod"; if_verbose msg_info - (str ("Module "^ Id.to_string id ^" is defined")); + (str "Module " ++ pr_id id ++ str " is defined"); Option.iter (fun export -> vernac_import export [Ident (Loc.ghost,id)]) export let vernac_end_module export (loc,id as lid) = let mp = Declaremods.end_module () in Dumpglob.dump_modref loc mp "mod"; - if_verbose msg_info (str ("Module "^ Id.to_string id ^" is defined")); + if_verbose msg_info (str "Module " ++ pr_id id ++ str " is defined"); Option.iter (fun export -> vernac_import export [Ident lid]) export let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l = @@ -690,7 +707,7 @@ let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l = in Dumpglob.dump_moddef loc mp "modtype"; if_verbose msg_info - (str ("Interactive Module Type "^ Id.to_string id ^" started")); + (str "Interactive Module Type " ++ pr_id id ++ str " started"); List.iter (fun (export,id) -> Option.iter @@ -701,9 +718,7 @@ let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l = let binders_ast = List.map (fun (export,idl,ty) -> if not (Option.is_empty export) then - error ("Arguments of a functor definition can be imported only if" ^ - " the definition is interactive. Remove the \"Export\" " ^ - "and \"Import\" keywords from every functor argument.") + error "Arguments of a functor definition can be imported only if the definition is interactive. Remove the \"Export\" and \"Import\" keywords from every functor argument." else (idl,ty)) binders_ast in let mp = Declaremods.declare_modtype Modintern.interp_module_ast @@ -711,12 +726,12 @@ let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l = in Dumpglob.dump_moddef loc mp "modtype"; if_verbose msg_info - (str ("Module Type "^ Id.to_string id ^" is defined")) + (str "Module Type " ++ pr_id id ++ str " is defined") let vernac_end_modtype (loc,id) = let mp = Declaremods.end_modtype () in Dumpglob.dump_modref loc mp "modtype"; - if_verbose msg_info (str ("Module Type "^ Id.to_string id ^" is defined")) + if_verbose msg_info (str "Module Type " ++ pr_id id ++ str " is defined") let vernac_include l = Declaremods.declare_include Modintern.interp_module_ast l @@ -765,8 +780,8 @@ let vernac_require from import qidl = let (_, dir, f) = Library.locate_qualified_library ?root ~warn qid in (dir, f) with - | Library.LibUnmappedDir -> err_unmapped_library loc qid - | Library.LibNotFound -> err_notfound_library loc qid + | Library.LibUnmappedDir -> err_unmapped_library loc ?from:root qid + | Library.LibNotFound -> err_notfound_library loc ?from:root qid in let modrefl = List.map locate qidl in if Dumpglob.dump () then @@ -868,20 +883,10 @@ let vernac_set_used_variables e = let vars = Environ.named_context env in List.iter (fun id -> if not (List.exists (fun (id',_,_) -> Id.equal id id') vars) then - error ("Unknown variable: " ^ Id.to_string id)) + errorlabstrm "vernac_set_used_variables" + (str "Unknown variable: " ++ pr_id id)) l; - let closure_l = List.map pi1 (set_used_variables l) in - let closure_l = List.fold_right Id.Set.add closure_l Id.Set.empty in - let vars_of = Environ.global_vars_set in - let aux env entry (all_safe,rest as orig) = - match entry with - | (x,None,_) -> - if Id.Set.mem x all_safe then orig else (all_safe, (Loc.ghost,x)::rest) - | (x,Some bo, ty) -> - let vars = Id.Set.union (vars_of env bo) (vars_of env ty) in - if Id.Set.subset vars all_safe then (Id.Set.add x all_safe, rest) - else (all_safe, (Loc.ghost,x) :: rest) in - let _,to_clear = Environ.fold_named_context aux env ~init:(closure_l,[]) in + let _, to_clear = set_used_variables l in vernac_solve SelectAll None Tacexpr.(TacAtom (Loc.ghost,TacClear(false,to_clear))) false @@ -914,7 +919,7 @@ let vernac_chdir = function | Some path -> begin try Sys.chdir (expand path) - with Sys_error err -> msg_warning (str ("Cd failed: " ^ err)) + with Sys_error err -> msg_warning (str "Cd failed: " ++ str err) end; if_verbose msg_info (str (Sys.getcwd())) @@ -924,10 +929,12 @@ let vernac_chdir = function let vernac_write_state file = Pfedit.delete_all_proofs (); + let file = CUnix.make_suffix file ".coq" in States.extern_state file let vernac_restore_state file = Pfedit.delete_all_proofs (); + let file = Loadpath.locate_file (CUnix.make_suffix file ".coq") in States.intern_state file (************) @@ -1051,15 +1058,16 @@ let vernac_declare_arguments locality r l nargs flags = let inf_names = let ty = Global.type_of_global_unsafe sr in Impargs.compute_implicits_names (Global.env ()) ty in - let string_of_name = function Anonymous -> "_" | Name id -> Id.to_string id in let rec check li ld ls = match li, ld, ls with | [], [], [] -> () | [], Anonymous::ld, (Some _)::ls when extra_scope_flag -> check li ld ls | [], _::_, (Some _)::ls when extra_scope_flag -> error "Extra notation scopes can be set on anonymous arguments only" - | [], x::_, _ -> error ("Extra argument " ^ string_of_name x ^ ".") - | l, [], _ -> error ("The following arguments are not declared: " ^ - (String.concat ", " (List.map string_of_name l)) ^ ".") + | [], x::_, _ -> errorlabstrm "vernac_declare_arguments" + (str "Extra argument " ++ pr_name x ++ str ".") + | l, [], _ -> errorlabstrm "vernac_declare_arguments" + (str "The following arguments are not declared: " ++ + prlist_with_sep pr_comma pr_name l ++ str ".") | _::li, _::ld, _::ls -> check li ld ls | _ -> assert false in let () = match l with @@ -1087,9 +1095,6 @@ let vernac_declare_arguments locality r l nargs flags = let renamed_arg = ref None in let set_renamed a b = if Option.is_empty !renamed_arg && not (Id.equal a b) then renamed_arg := Some(b,a) in - let pr_renamed_arg () = match !renamed_arg with None -> "" - | Some (o,n) -> - "\nArgument "^string_of_id o ^" renamed to "^string_of_id n^"." in let some_renaming_specified = try let names = Arguments_renaming.arguments_names sr in @@ -1103,7 +1108,8 @@ let vernac_declare_arguments locality r l nargs flags = let sr', impl = List.fold_map (fun b -> function | (Anonymous, _,_, true, max), Name id -> assert false | (Name x, _,_, true, _), Anonymous -> - error ("Argument "^Id.to_string x^" cannot be declared implicit.") + errorlabstrm "vernac_declare_arguments" + (str "Argument " ++ pr_id x ++ str " cannot be declared implicit.") | (Name iid, _,_, true, max), Name id -> set_renamed iid id; b || not (Id.equal iid id), Some (ExplByName id, max, false) @@ -1116,8 +1122,12 @@ let vernac_declare_arguments locality r l nargs flags = some_renaming_specified l in if some_renaming_specified then if not (List.mem `Rename flags) then - error ("To rename arguments the \"rename\" flag must be specified." - ^ pr_renamed_arg ()) + errorlabstrm "vernac_declare_arguments" + (str "To rename arguments the \"rename\" flag must be specified." ++ + match !renamed_arg with + | None -> mt () + | Some (o,n) -> + str "\nArgument " ++ pr_id o ++ str " renamed to " ++ pr_id n ++ str ".") else Arguments_renaming.rename_arguments (make_section_locality locality) sr names_decl; @@ -1175,8 +1185,9 @@ let default_env () = { let vernac_reserve bl = let sb_decl = (fun (idl,c) -> let env = Global.env() in - let t,ctx = Constrintern.interp_type env Evd.empty c in - let t = Detyping.detype false [] env Evd.empty t in + let sigma = Evd.from_env env in + let t,ctx = Constrintern.interp_type env sigma c in + let t = Detyping.detype false [] env (Evd.from_ctx ctx) t in let t = Notation_ops.notation_constr_of_glob_constr (default_env ()) t in Reserve.declare_reserved_type idl t) in List.iter sb_decl bl @@ -1348,19 +1359,10 @@ let _ = optwrite = Flags.make_universe_polymorphism } let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "use of virtual machine inside the kernel"; - optkey = ["Virtual";"Machine"]; - optread = (fun () -> Vconv.use_vm ()); - optwrite = (fun b -> Vconv.set_use_vm b) } - -let _ = declare_int_option { optsync = true; optdepr = false; - optname = "the level of inling duging functor application"; + optname = "the level of inlining during functor application"; optkey = ["Inline";"Level"]; optread = (fun () -> Some (Flags.get_inline_level ())); optwrite = (fun o -> @@ -1376,15 +1378,6 @@ let _ = optread = (fun () -> !Closure.share); optwrite = (fun b -> Closure.share := b) } -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "use of boxed values"; - optkey = ["Boxed";"Values"]; - optread = (fun _ -> not (Vm.transp_values ())); - optwrite = (fun b -> Vm.set_transp_values (not b)) } - (* No more undo limit in the new proof engine. The command still exists for compatibility (e.g. with ProofGeneral) *) @@ -1432,6 +1425,15 @@ let _ = optkey = ["Printing";"Universes"]; optread = (fun () -> !Constrextern.print_universes); optwrite = (fun b -> Constrextern.print_universes:=b) } + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "dumping bytecode after compilation"; + optkey = ["Dump";"Bytecode"]; + optread = Flags.get_dump_bytecode; + optwrite = Flags.set_dump_bytecode } let vernac_debug b = set_debug (if b then Tactic_debug.DebugOn 0 else Tactic_debug.DebugOff) @@ -1478,6 +1480,8 @@ let vernac_set_opacity locality (v,l) = let vernac_set_option locality key = function | StringValue s -> set_string_option_value_gen locality key s + | StringOptValue (Some s) -> set_string_option_value_gen locality key s + | StringOptValue None -> unset_option_value_gen locality key | IntValue n -> set_int_option_value_gen locality key n | BoolValue b -> set_bool_option_value_gen locality key b @@ -1523,7 +1527,7 @@ let vernac_check_may_eval redexp glopt rc = let sigma' = Evarconv.consider_remaining_unif_problems env sigma' in Evarconv.check_problems_are_solved env sigma'; let sigma',nf = Evarutil.nf_evars_and_universes sigma' in - let uctx = Evd.universe_context sigma' in + let pl, uctx = Evd.universe_context sigma' in let env = Environ.push_context uctx (Evarutil.nf_env_evar sigma' env) in let c = nf c in let j = @@ -1538,7 +1542,7 @@ let vernac_check_may_eval redexp glopt rc = let j = { j with Environ.uj_type = Reductionops.nf_betaiota sigma' j.Environ.uj_type } in msg_notice (print_judgment env sigma' j ++ pr_ne_evar_set (fnl () ++ str "where" ++ fnl ()) (mt ()) sigma' l ++ - Printer.pr_universe_ctx uctx) + Printer.pr_universe_ctx sigma uctx) | Some r -> Tacintern.dump_glob_red_expr r; let (sigma',r_interp) = interp_redexp env sigma' r in @@ -1555,7 +1559,7 @@ let vernac_global_check c = let sigma = Evd.from_env env in let c,ctx = interp_constr env sigma c in let senv = Global.safe_env() in - let cstrs = snd (Evd.evar_universe_context_set ctx) in + let cstrs = snd (Evd.evar_universe_context_set Univ.UContext.empty ctx) in let senv = Safe_typing.add_constraints cstrs senv in let j = Safe_typing.typing senv c in let env = Safe_typing.env_of_safe_env senv in @@ -1581,7 +1585,8 @@ let print_about_hyp_globs ref_or_by_not glnumopt = | Some n,AN (Ident (_loc,id)) -> (* goal number given, catch if wong *) (try get_nth_goal n,id with - Failure _ -> Errors.error ("No such goal: "^string_of_int n^".")) + Failure _ -> errorlabstrm "print_about_hyp_globs" + (str "No such goal: " ++ int n ++ str ".")) | _ , _ -> raise NoHyp in let hyps = pf_hyps gl in let (id,bdyopt,typ) = Context.lookup_named id hyps in @@ -1619,9 +1624,13 @@ let vernac_print = function msg_notice (Prettyp.print_path_between (cl_of_qualid cls) (cl_of_qualid clt)) | PrintCanonicalConversions -> msg_notice (Prettyp.print_canonical_projections ()) | PrintUniverses (b, None) -> - let univ = Global.universes () in - let univ = if b then Univ.sort_universes univ else univ in - msg_notice (Univ.pr_universes Universes.pr_with_global_universes univ) + let univ = Global.universes () in + let univ = if b then Univ.sort_universes univ else univ in + let pr_remaining = + if Global.is_joined_environment () then mt () + else str"There may remain asynchronous universe constraints" + in + msg_notice (Univ.pr_universes Universes.pr_with_global_universes univ ++ pr_remaining) | PrintUniverses (b, Some s) -> dump_universes b s | PrintHint r -> msg_notice (Hints.pr_hint_ref (smart_global r)) | PrintHintGoal -> msg_notice (Hints.pr_applicable_hint ()) @@ -1640,10 +1649,11 @@ let vernac_print = function dump_global qid; msg_notice (print_impargs qid) | PrintAssumptions (o,t,r) -> (* Prints all the axioms and section variables used by a term *) - let cstr = printable_constr_of_global (smart_global r) in + let gr = smart_global r in + let cstr = printable_constr_of_global gr in let st = Conv_oracle.get_transp_state (Environ.oracle (Global.env())) in let nassums = - Assumptions.assumptions st ~add_opaque:o ~add_transparent:t cstr in + Assumptions.assumptions st ~add_opaque:o ~add_transparent:t gr cstr in msg_notice (Printer.pr_assumptionset (Global.env ()) nassums) | PrintStrategy r -> print_strategy r @@ -1674,8 +1684,8 @@ let interp_search_about_item env = (fun _ -> true) s sc in GlobSearchSubPattern (Pattern.PRef ref) with UserError _ -> - error ("Unable to interp \""^s^"\" either as a reference or \ - as an identifier component") + errorlabstrm "interp_search_about_item" + (str "Unable to interp \"" ++ str s ++ str "\" either as a reference or as an identifier component") let vernac_search s gopt r = let r = interp_search_restriction r in @@ -1776,6 +1786,7 @@ let vernac_show = function | OpenSubgoals -> pr_open_subgoals () | NthGoal n -> pr_nth_open_subgoal n | GoalId id -> pr_goal_by_id id + | GoalUid id -> pr_goal_by_uid id in msg_notice info | ShowGoalImplicitly None -> @@ -1817,23 +1828,11 @@ let vernac_load interp fname = match Pcoq.Gram.entry_parse Pcoq.main_entry po with | Some x -> x | None -> raise End_of_input) in - let open_utf8_file_in fname = - let is_bom s = - Int.equal (Char.code s.[0]) 0xEF && - Int.equal (Char.code s.[1]) 0xBB && - Int.equal (Char.code s.[2]) 0xBF - in - let in_chan = open_in fname in - let s = " " in - if input in_chan s 0 3 < 3 || not (is_bom s) then seek_in in_chan 0; - in_chan in let fname = Envars.expand_path_macros ~warn:(fun x -> msg_warning (str x)) fname in let fname = CUnix.make_suffix fname ".v" in let input = - let paths = Loadpath.get_paths () in - let _,longfname = - System.find_file_in_path ~warn:(Flags.is_verbose()) paths fname in + let longfname = Loadpath.locate_file fname in let in_chan = open_utf8_file_in longfname in Pcoq.Gram.parsable (Stream.of_channel in_chan) in try while true do interp (snd (parse_sentence input)) done @@ -1842,14 +1841,16 @@ let vernac_load interp fname = (* "locality" is the prefix "Local" attribute, while the "local" component * is the outdated/deprecated "Local" attribute of some vernacular commands - * still parsed as the obsolete_locality grammar entry for retrocompatibility *) -let interp ?proof locality poly c = + * still parsed as the obsolete_locality grammar entry for retrocompatibility. + * loc is the Loc.t of the vernacular command being interpreted. *) +let interp ?proof ~loc locality poly c = prerr_endline ("interpreting: " ^ Pp.string_of_ppcmds (Ppvernac.pr_vernac c)); match c with (* Done later in this file *) | VernacLoad _ -> assert false | VernacFail _ -> assert false | VernacTime _ -> assert false + | VernacRedirect _ -> assert false | VernacTimeout _ -> assert false | VernacStm _ -> assert false @@ -1872,7 +1873,7 @@ let interp ?proof locality poly c = (* Gallina *) | VernacDefinition (k,lid,d) -> vernac_definition locality poly k lid d - | VernacStartTheoremProof (k,l,top) -> vernac_start_proof poly k l top + | VernacStartTheoremProof (k,l,top) -> vernac_start_proof locality poly k l top | VernacEndProof e -> vernac_end_proof ?proof e | VernacExactProof c -> vernac_exact_proof c | VernacAssumption (stre,nl,l) -> vernac_assumption locality poly stre l nl @@ -1881,8 +1882,8 @@ let interp ?proof locality poly c = | VernacCoFixpoint (local, l) -> vernac_cofixpoint locality poly local l | VernacScheme l -> vernac_scheme l | VernacCombinedScheme (id, l) -> vernac_combined_scheme id l - | VernacUniverse l -> vernac_universe l - | VernacConstraint l -> vernac_constraint l + | VernacUniverse l -> vernac_universe loc poly l + | VernacConstraint l -> vernac_constraint loc poly l (* Modules *) | VernacDeclareModule (export,lid,bl,mtyo) -> @@ -1977,7 +1978,7 @@ let interp ?proof locality poly c = | VernacBacktrack _ -> msg_warning (str "VernacBacktrack not handled by Stm") (* Proof management *) - | VernacGoal t -> vernac_start_proof poly Theorem [None,([],t,None)] false + | VernacGoal t -> vernac_start_proof locality poly Theorem [None,([],t,None)] false | VernacFocus n -> vernac_focus n | VernacUnfocus -> vernac_unfocus () | VernacUnfocused -> vernac_unfocused () @@ -1986,10 +1987,16 @@ let interp ?proof locality poly c = | VernacEndSubproof -> vernac_end_subproof () | VernacShow s -> vernac_show s | VernacCheckGuard -> vernac_check_guard () - | VernacProof (None, None) -> () - | VernacProof (Some tac, None) -> vernac_set_end_tac tac - | VernacProof (None, Some l) -> vernac_set_used_variables l + | VernacProof (None, None) -> + Aux_file.record_in_aux_at loc "VernacProof" "tac:no using:no" + | VernacProof (Some tac, None) -> + Aux_file.record_in_aux_at loc "VernacProof" "tac:yes using:no"; + vernac_set_end_tac tac + | VernacProof (None, Some l) -> + Aux_file.record_in_aux_at loc "VernacProof" "tac:no using:yes"; + vernac_set_used_variables l | VernacProof (Some tac, Some l) -> + Aux_file.record_in_aux_at loc "VernacProof" "tac:yes using:yes"; vernac_set_end_tac tac; vernac_set_used_variables l | VernacProofMode mn -> Proof_global.set_proof_mode mn (* Toplevel control *) @@ -2012,7 +2019,7 @@ let check_vernac_supports_locality c l = | VernacOpenCloseScope _ | VernacSyntaxExtension _ | VernacInfix _ | VernacNotation _ | VernacDefinition _ | VernacFixpoint _ | VernacCoFixpoint _ - | VernacAssumption _ + | VernacAssumption _ | VernacStartTheoremProof _ | VernacCoercion _ | VernacIdentityCoercion _ | VernacInstance _ | VernacDeclareInstances _ | VernacDeclareMLModule _ @@ -2039,7 +2046,7 @@ let check_vernac_supports_polymorphism c p = | VernacCoercion _ | VernacIdentityCoercion _ | VernacInstance _ | VernacDeclareInstances _ | VernacHints _ | VernacContext _ - | VernacExtend _ ) -> () + | VernacExtend _ | VernacUniverse _ | VernacConstraint _) -> () | Some _, _ -> Errors.error "This command does not support Polymorphism" let enforce_polymorphism = function @@ -2096,7 +2103,7 @@ let with_fail b f = | e -> let e = Errors.push e in raise (HasFailed (Errors.iprint - (Cerrors.process_vernac_interp_error ~with_header:false e)))) + (Cerrors.process_vernac_interp_error ~allow_uncaught:false ~with_header:false e)))) () with e when Errors.noncritical e -> let (e, _) = Errors.push e in @@ -2104,7 +2111,7 @@ let with_fail b f = | HasNotFailed -> errorlabstrm "Fail" (str "The command has not failed!") | HasFailed msg -> - if is_verbose () || !Flags.ide_slave then msg_info + if is_verbose () || !test_mode || !ide_slave then msg_info (str "The command has indeed failed with message:" ++ fnl () ++ msg) | _ -> assert false end @@ -2128,6 +2135,8 @@ let interp ?(verbosely=true) ?proof (loc,c) = | VernacTimeout (n,v) -> current_timeout := Some n; aux ?locality ?polymorphism isprogcmd v + | VernacRedirect (s, v) -> + Pp.with_output_to_file s (aux_list ?locality ?polymorphism isprogcmd) v; | VernacTime v -> System.with_time !Flags.time (aux_list ?locality ?polymorphism isprogcmd) v; @@ -2139,8 +2148,9 @@ let interp ?(verbosely=true) ?proof (loc,c) = Obligations.set_program_mode isprogcmd; try vernac_timeout begin fun () -> - if verbosely then Flags.verbosely (interp ?proof locality poly) c - else Flags.silently (interp ?proof locality poly) c; + if verbosely + then Flags.verbosely (interp ?proof ~loc locality poly) c + else Flags.silently (interp ?proof ~loc locality poly) c; if orig_program_mode || not !Flags.program_mode || isprogcmd then Flags.program_mode := orig_program_mode end @@ -2162,5 +2172,4 @@ let interp ?(verbosely=true) ?proof (loc,c) = else aux false c let () = Hook.set Stm.interp_hook interp -let () = Hook.set Stm.process_error_hook Cerrors.process_vernac_interp_error let () = Hook.set Stm.with_fail_hook with_fail diff --git a/toplevel/vernacentries.mli b/toplevel/vernacentries.mli index 4b1cd7a0..c6d87596 100644 --- a/toplevel/vernacentries.mli +++ b/toplevel/vernacentries.mli @@ -16,6 +16,9 @@ val show_prooftree : unit -> unit val show_node : unit -> unit +val vernac_require : + Libnames.reference option -> bool option -> Libnames.reference list -> unit + (** This function can be used by any command that want to observe terms in the context of the current goal *) val get_current_context_of_args : int option -> Evd.evar_map * Environ.env |